Skip to content
Snippets Groups Projects
Commit ae07aa5f authored by cer's avatar cer
Browse files

Makefile.generic removed loads of climtoys since

			 	it is already loaded.
clim/accept-values.lisp		Support Align-prompts for
			 	own-window nil dialogs
				When its t added updating-outpt
			 	to identify the prompt/value pair.
clim/frames.lisp		Defaulted calling-frame to NIL.
			 	Alternative space-requirements
			 	work for allpanes.

clim/incremental-redisplay.lisp	Added some commented out diagnostics
clim/menus.lisp			Worked on
			 	menu-choose-from-drawer. Label
			 	is optional
clim/recording-protocol.lisp	In invoke-with-new-output-record
			 	find-child-output-record is
			 	called instead of
			 	find-child-output-record-1. This
			 	forces it to use output-record-old-children
demo/plot.lisp			Fixed dialog. replaced redisplay
			 	command now calls redisplay-frame-panes
hpgl/hpgl-tests.lisp		hpgl-tests now uses the
			 	postscript tests

misc/dev-load-1.lisp		Load in compiled version of test-driver/demos
misc/olsupport.c		Added support for ol_appl_delete_item
postscript/laserwriter-metrics.lisp	Reddid the font metrics
postscript/postscript-medium.lisp	Hacked the text style
			 	and pattern drawing stuff.
postscript/postscript-port.lisp		Hacked the text style
			 	and pattern drawing stuff.
postscript/sysdcl.lisp		Added read-afm.lisp
silica/db-box.lisp		redid the topdown fractional
			 	layout stuff.
silica/db-layout.lisp		Added the
			 	normalize-space-requirement
			 	stuff and hacked
			 	allocate-space-to-items to
			 	handle the fractional stuff better.
silica/event.lisp		distribute pointer events to
			 	grabbed sheet.
silica/gadgets.lisp		Hacked radio-boxes and
			 	check-boxes and added with-radio-box
test/postscript-tests.lisp	Now usable by the hpgl tests.
test/test-clim.lisp		Added some more tests
test/test-driver.lisp		error handling can now be
			 	completely disabled so you get
			 	into the debugger.

test/test.lisp		Added tests
tk/ol-funs.lisp		Added ol_appl_delete_item
tk/resources.lisp	Enhanced enumerated type to support
			 	explicit numbers
tk-silica/ol-frames.lisp	menu items now use the text-style
tk-silica/ol-gadgets.lisp		Added multiple
			 	row/columns for check/radio-boxes
tk-silica/xm-frames.lisp		menu items now use the
			 	text-style. Added frame for menu-choose-from-drawer
tk-silica/xm-gadgets.lisp
			 	normalize-space-requirement for
			 	text-fields etc.
				multiple row/columns for
			 	radio/check boxes. changing set-item-gadget-items

tk-silica/xt-frames.lisp  	Disable menu-caching in motif port
tk-silica/xt-gadgets.lisp 	normalize-space-requirement for
			 	text fields

tk-silica/xt-graphics.lisp	changing foreground/background repaints sheet
tk-silica/xt-silica.lisp	Using calling-frame shell if
			 	there is one
utils/region-arithmetic.lisp		fixed the ltrb-union code
parent 3bb86c45
No related branches found
No related tags found
No related merge requests found
;; -*- mode: common-lisp; package: clim-internals -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
(in-package :clim-internals)
(defmethod default-frame-top-level ((frame standard-application-frame)
&key command-parser command-unparser
partial-command-parser
(prompt "Command: "))
;; Enable the frame now
(unless (eq (frame-state frame) :enabled)
(enable-frame frame))
(loop
(let* ((*standard-output*
(or (frame-standard-output frame) *standard-output*))
(*standard-input*
(or (frame-standard-input frame) *standard-output*))
(*query-io*
(or (frame-query-io frame) *standard-input*))
(*error-output*
(or (frame-error-output frame) *standard-output*))
(*pointer-documentation-output*
(frame-pointer-documentation-output frame))
(interactor
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(*command-parser*
(or command-parser
(if interactor
#'command-line-command-parser
#'menu-command-parser)))
(*command-unparser*
(or command-unparser
#'command-line-command-unparser))
(*partial-command-parser*
(or partial-command-parser
(if interactor
#'command-line-read-remaining-arguments-for-partial-command
#'menu-read-remaining-arguments-for-partial-command)))
(command-stream
;;--- We have to ask the frame since we do not want to
;;--- just pick up a stream from the dynamic environment
(let ((si (or (frame-standard-input frame)
(frame-standard-output frame))))
(typecase si
(output-protocol-mixin si)
(t (frame-top-level-sheet frame))))))
;; The read-eval-print loop for applications...
(loop
;; Redisplay all the panes
(catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
(redisplay-frame-panes frame)
(when interactor
(fresh-line *standard-input*)
(if (stringp prompt)
(write-string prompt *standard-input*)
(funcall prompt *standard-input* frame)))
(let ((command (read-frame-command frame :stream command-stream)))
(when interactor
(terpri *standard-input*))
;; Need this check in case the user aborted out of a command menu
(when command
(execute-frame-command frame command))))))))
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable. ;; applicable.
;; ;;
;; $fiHeader: plot.lisp,v 1.21 92/12/14 15:02:44 cer Exp $ ;; $fiHeader: plot.lisp,v 1.22 93/03/19 09:44:14 cer Exp $
(in-package :clim-demo) (in-package :clim-demo)
...@@ -523,30 +523,25 @@ ...@@ -523,30 +523,25 @@
:default graph-type :default graph-type
:stream stream :stream stream
:prompt "Graph type")) :prompt "Graph type"))
(terpri stream)
(unless (eq graph-type :pie) (unless (eq graph-type :pie)
(unless (eq graph-type :bar) (unless (eq graph-type :bar)
(setf x-min (accept '(null-or-type number) (setf x-min (accept '(null-or-type number)
:default x-min :default x-min
:stream stream :stream stream
:prompt "Min X")) :prompt "Min X")))
(terpri stream))
(setf y-min (accept '(null-or-type number) (setf y-min (accept '(null-or-type number)
:default y-min :default y-min
:stream stream :stream stream
:prompt "Min Y")) :prompt "Min Y"))
(terpri stream)
(unless (eq graph-type :bar) (unless (eq graph-type :bar)
(setf x-max (accept '(null-or-type number) (setf x-max (accept '(null-or-type number)
:default x-max :default x-max
:stream stream :stream stream
:prompt "Max X")) :prompt "Max X")))
(terpri stream))
(setf y-max (accept '(null-or-type number) (setf y-max (accept '(null-or-type number)
:default y-max :default y-max
:stream stream :stream stream
:prompt "Max Y")) :prompt "Max Y")))))
(terpri stream))))
(defmethod frame-standard-output ((fr plot-demo)) (defmethod frame-standard-output ((fr plot-demo))
(get-frame-pane fr 'command)) (get-frame-pane fr 'command))
...@@ -728,12 +723,8 @@ ...@@ -728,12 +723,8 @@
(describe region)) (describe region))
(define-plot-demo-command (com-redisplay :name t) () (define-plot-demo-command (com-redisplay :name t) ()
(redisplay-frame-pane *application-frame* (redisplay-frame-panes *application-frame* :force-p t))
(get-frame-pane *application-frame* 'graph-window)
:force-p t)
(redisplay-frame-pane *application-frame*
(get-frame-pane *application-frame* 'data-window)
:force-p t))
(define-plot-demo-command (com-add-new-column :name t) () (define-plot-demo-command (com-add-new-column :name t) ()
(with-slots (plot-data y-labels) *application-frame* (with-slots (plot-data y-labels) *application-frame*
......
...@@ -17,7 +17,7 @@ ...@@ -17,7 +17,7 @@
* 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as * 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as
* applicable. * applicable.
* *
* $fiHeader: support.c,v 1.1 92/05/13 08:52:50 cer Exp $ * $fiHeader: olsupport.c,v 1.1 92/06/23 08:27:32 cer Exp $
*/ */
/************************************************************************/ /************************************************************************/
...@@ -46,3 +46,13 @@ int token; ...@@ -46,3 +46,13 @@ int token;
(*fn)(widget, token); (*fn)(widget, token);
} }
void ol_appl_delete_item (fn, widget, token)
int (*fn)();
char *widget;
int token;
{
(*fn)(widget, token);
}
This diff is collapsed.
;; -*- mode: common-lisp; package: postscript-clim -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(in-package :postscript-clim)
(defun read-afm-file (file)
(labels ((afm-whitespace-char-p (char)
(or (eq char #\tab)
(eq char #\space)
(eq char #\newline)))
(read-keyname ()
(let ((chars (make-array 0 :element-type 'string-char :fill-pointer 0 :adjustable t)))
(loop
(let ((char (read-char)))
(when (afm-whitespace-char-p char)
(unread-char char)
(return-from read-keyname (intern chars :keyword)))
(vector-push-extend char chars))))))
(with-open-file (*standard-input* file :direction :input)
(let (font-name
font-bbox
character-metrics
fixed-pitch)
(loop
(case (read-keyname)
(:|FontName|
(peek-char t)
(setq font-name (read-keyname))
(read-line))
(:|IsFixedPitch|
(peek-char t)
(setq fixed-pitch
(ecase (read-keyname)
(:|true| t)
(:|false| nil))))
(:|CharWidth|
(setq fixed-pitch (read))
(read))
(:|FontBBox|
(setq font-bbox
(list (read) (read) (read) (read))))
(:|StartCharMetrics|
(loop
(read-line)
(let ((key (read-keyname))
code wx name bounding-box)
(when (eq key :|EndCharMetrics|) (return nil))
(loop
(peek-char t)
(ecase key
(:|L|
(read-keyname) (peek-char t) (read-keyname))
(:|C| (setq code (read)))
(:|WX| (setq wx (read)))
(:|N| (peek-char t)
(setq name (read-keyname)))
(:|B|
(setq bounding-box (list (read) (read) (read) (read)))))
(assert (eq (peek-char t) #\;))
(read-char)
(when (eq (peek-char) #\newline)
(push (list code wx name bounding-box)
character-metrics)
(return))
(peek-char t)
(setq key (read-keyname)))))
(return))
(t (read-line))))
(values font-name font-bbox fixed-pitch (nreverse character-metrics))))))
(defun load-metrics-from-afm-file (file)
(setup-laserwriter-metrics
(load-metrics-from-afm-file-1 file)))
(defun load-metrics-from-afm-file-1 (file)
(multiple-value-bind (name bounding-box fixed-pitch character-metrics) (read-afm-file file)
(let ((height (- (fourth bounding-box) (second bounding-box))))
`((,(symbol-name name) 1000 ,bounding-box)
,@(cond ((null fixed-pitch)
(mapcan #'(lambda (X)
(destructuring-bind (code width name . ignore) x
(declare (ignore ignore))
(and (plusp code)
`((,code ,(round (* 1000 (/ width height))) ,(symbol-name name))))))
character-metrics))
((numberp fixed-pitch)
(round (* 1000 (/ fixed-pitch height))))
(t
(round (* 1000 (/ (second (car character-metrics)) height)))))))))
(defmacro load-metrics-from-afm-file-macro (file)
`(setup-laserwriter-metrics
',(load-metrics-from-afm-file-1 file)))
(defmacro load-font-metrics-from-files (&rest files)
`(progn
,@(mapcar #'(lambda (file)
`(load-metrics-from-afm-file-macro
,(format nil "/src_fi/tran/sun4/sparc/lib/~A.afm" file)))
files)))
#+ignore
(load-font-metrics-from-files
"Times-Roman"
"Times-Italic"
"Times-Bold"
"Times-BoldItalic"
"Helvetica"
"Helvetica-Oblique"
"Helvetica-Bold"
"Helvetica-BoldOblique"
"Courier"
"Courier-Oblique"
"Courier-Bold"
"Courier-BoldOblique"
"Symbol")
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
;; $fiHeader: sysdcl.lisp,v 1.6 92/11/20 08:45:42 cer Exp $ ;; $fiHeader: sysdcl.lisp,v 1.7 92/12/03 10:29:08 cer Exp $
(in-package #-ANSI-90 :user #+ANSI-90 :cl-user) (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
...@@ -16,6 +16,7 @@ ...@@ -16,6 +16,7 @@
#+Allegro ("postscript-s") #+Allegro ("postscript-s")
("postscript-port") ("postscript-port")
("postscript-medium") ("postscript-medium")
("read-afm")
("laserwriter-metrics")) ("laserwriter-metrics"))
#+Genera #+Genera
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;; $fiHeader: db-box.lisp,v 1.23 93/02/08 15:57:26 cer Exp $ ;; $fiHeader: db-box.lisp,v 1.24 93/03/19 09:44:31 cer Exp $
(in-package :silica) (in-package :silica)
...@@ -66,11 +66,17 @@ ...@@ -66,11 +66,17 @@
(if (and (numberp scale) (< x +fill+)) (/ x scale) x))) (if (and (numberp scale) (< x +fill+)) (/ x scale) x)))
(declare (dynamic-extent #'scale)) (declare (dynamic-extent #'scale))
(cond ((eq scale :fill) (cond ((eq scale :fill)
(incf major+ +fill+)) (incf major+ +fill+)
(t (incf major (scale (funcall fn-major space-req)))
(incf major- (scale (funcall fn-major- space-req))))
((= scale 1.0)
(incf major+ (scale (funcall fn-major+ space-req)))
(incf major (scale (funcall fn-major space-req))) (incf major (scale (funcall fn-major space-req)))
(incf major+ (scale (funcall fn-major+ space-req))))) (incf major- (scale (funcall fn-major- space-req))))
(incf major- (scale (funcall fn-major- space-req))) (t
(maxf major+ (scale (funcall fn-major+ space-req)))
(maxf major (scale (funcall fn-major space-req)))
(maxf major- (scale (funcall fn-major- space-req)))))
(setq minor (max minor (funcall fn-minor space-req))) (setq minor (max minor (funcall fn-minor space-req)))
(maxf minor-min (funcall fn-minor- space-req)) (maxf minor-min (funcall fn-minor- space-req))
(minf minor-max (funcall fn-minor+ space-req))))))) (minf minor-max (funcall fn-minor+ space-req)))))))
...@@ -109,7 +115,7 @@ ...@@ -109,7 +115,7 @@
(flet ((compose (x) (flet ((compose (x)
(cond ((atom x) (compose-space x :height height)) (cond ((atom x) (compose-space x :height height))
((eq (car x) :fill) :fill) ((eq (car x) :fill) :fill)
(t (make-space-requirement :height 0 :width (* (car x) width)))))) (t (car x) #+ignore (make-space-requirement :height 0 :width (* (car x) width))))))
(declare (dynamic-extent #'compose)) (declare (dynamic-extent #'compose))
(let* ((adjust (* spacing (1- (length (sheet-children box-pane))))) (let* ((adjust (* spacing (1- (length (sheet-children box-pane)))))
(sizes (sizes
...@@ -155,7 +161,7 @@ ...@@ -155,7 +161,7 @@
(flet ((compose (x) (flet ((compose (x)
(cond ((atom x) (compose-space x :width width)) (cond ((atom x) (compose-space x :width width))
((eq (car x) :fill) :fill) ((eq (car x) :fill) :fill)
(t (make-space-requirement :width 0 :height (* (car x) height)))))) (t (car x) #+ignore (make-space-requirement :width 0 :height (* (car x) height))))))
(declare (dynamic-extent #'compose)) (declare (dynamic-extent #'compose))
(let* ((adjust (* spacing (1- (length (sheet-children box-pane))))) (let* ((adjust (* spacing (1- (length (sheet-children box-pane)))))
(sizes (sizes
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;; $fiHeader: event.lisp,v 1.32 92/12/16 16:49:23 cer Exp $ ;; $fiHeader: event.lisp,v 1.33 93/01/21 14:59:00 cer Exp $
(in-package :silica) (in-package :silica)
...@@ -503,55 +503,63 @@ ...@@ -503,55 +503,63 @@
(generate-deeply-mirrored-crossing-events port event) (generate-deeply-mirrored-crossing-events port event)
(generate-crossing-events port event))) (generate-crossing-events port event)))
(defmethod distribute-event-1 :around ((port basic-port) (event pointer-event))
(let ((sheet (port-grabbing-sheet port)))
(if sheet (dispatch-pointer-event-to-sheet port event sheet)
(call-next-method))))
(defmethod distribute-event-1 ((port basic-port) (event pointer-event)) (defmethod distribute-event-1 ((port basic-port) (event pointer-event))
(declare (optimize (speed 3))) (declare (optimize (speed 3)))
(let ((sheet (let ((v (port-trace-thing port)))
(and (not (zerop (fill-pointer v)))
(aref v (1- (fill-pointer v)))))))
(dispatch-pointer-event-to-sheet port event sheet)))
(defun dispatch-pointer-event-to-sheet (port event sheet)
(declare (ignore port))
(let ((event-type (class-name (class-of event))) (let ((event-type (class-name (class-of event)))
(x (pointer-event-native-x event)) (x (pointer-event-native-x event))
(y (pointer-event-native-y event)) (y (pointer-event-native-y event))
(modifiers (event-modifier-state event)) (modifiers (event-modifier-state event))
(pointer (pointer-event-pointer event))) (pointer (pointer-event-pointer event)))
;; Dispatch event to the innermost sheet ;; Dispatch event to the innermost sheet
(let ((sheet (let ((v (port-trace-thing port))) (when (and sheet (port sheet))
(and (not (zerop (fill-pointer v))) (multiple-value-bind (tx ty)
(aref v (1- (fill-pointer v))))))) (untransform-position (sheet-device-transformation sheet) x y)
;;--- This is not quite right. We need to transform the ;; Update the pointer object
;;--- coordinates better. Also it should probably override ;;--- It might make a lot more sense for methods on
;;--- the sheet in the trace-thing. ;;--- dispatch-event to update the pointer
(unless sheet ;;--- This would enable exit events to do the right thing
(setq sheet (port-grabbing-sheet port))) ;;--- Hence if we exit then we set the sheet to NIL??
(when (and sheet (port sheet)) (setf (pointer-sheet pointer) sheet
(multiple-value-bind (tx ty) (pointer-x-position pointer) tx
(untransform-position (sheet-device-transformation sheet) x y) (pointer-y-position pointer) ty
;; Update the pointer object (pointer-native-x-position pointer) x
(setf (pointer-sheet pointer) sheet (pointer-native-y-position pointer) y)
(pointer-x-position pointer) tx (setf (pointer-cursor pointer)
(pointer-y-position pointer) ty (or (sheet-pointer-cursor sheet) :default))
(pointer-native-x-position pointer) x (typecase event
(pointer-native-y-position pointer) y) (pointer-button-event
(setf (pointer-cursor pointer) (dispatch-event
(or (sheet-pointer-cursor sheet) :default)) sheet
(typecase event (allocate-event event-type
(pointer-button-event :sheet sheet
(dispatch-event :native-x x :native-y y
sheet :x tx :y ty
(allocate-event event-type :modifier-state modifiers
:sheet sheet :button (pointer-event-button event)
:native-x x :native-y y :pointer pointer)))
:x tx :y ty (pointer-motion-event
:modifier-state modifiers (dispatch-event
:button (pointer-event-button event) sheet
:pointer pointer))) (allocate-event event-type
(pointer-motion-event :sheet sheet
(dispatch-event :native-x x :native-y y
sheet :x tx :y ty
(allocate-event event-type :modifier-state modifiers
:sheet sheet :pointer pointer)))
:native-x x :native-y y ;; Pointer exit and enter events are handled by GENERATE-CROSSING-EVENTS
:x tx :y ty ))))
:modifier-state modifiers
:pointer pointer)))
;; Pointer exit and enter events are handled by GENERATE-CROSSING-EVENTS
)))))
(deallocate-event event)) (deallocate-event event))
......
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable. ;; applicable.
;; ;;
;; $fiHeader: xm-widgets.lisp,v 1.11 92/12/01 09:46:56 cer Exp $ ;; $fiHeader: xm-widgets.lisp,v 1.12 92/12/14 15:04:12 cer Exp $
(in-package :tk) (in-package :tk)
...@@ -131,3 +131,11 @@ ...@@ -131,3 +131,11 @@
:original-name :original-name
(string-to-char* (string-to-char*
"scrollVertical"))) "scrollVertical")))
(tk::add-resource-to-class (find-class 'xm-text)
(make-instance 'resource
:name :word-wrap
:type 'tk::boolean
:original-name
(string-to-char*
"wordWrap")))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment