diff --git a/Makefile b/Makefile index 16195c02a649f188260b284c3dd5cb3eeee311ce..a5ddcd346ca74e062aad9a22ab3de74a6df39228 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.68 92/11/20 08:44:11 cer Exp $ +# $fiHeader: Makefile,v 1.69 92/12/01 09:44:55 cer Exp $ # # Makefile for CLIM 2.0 # @@ -14,9 +14,11 @@ TRAIN_TIMES=2 # view, file, print PSVIEW=file +FRAME_TESTS=t + TRAIN_LISP= \ (load \"misc/train.lisp\") \ - (train-clim :train-times $(TRAIN_TIMES) :psview :$(PSVIEW)) \ + (train-clim :frame-tests $(FRAME_TESTS) :train-times $(TRAIN_TIMES) :psview :$(PSVIEW)) \ (exit 0) TRAIN_TEXT = \ @@ -37,12 +39,19 @@ SAFETY = 1 # This next should be set to 1 for distribution DEBUG = 2 +COMPILE_PRINT=nil +# Name of dumped lisp +CLIM = ./slim +CLIMOL= $(CLIM) +CLIMXM= $(CLIM) + make = make SPEED=${SPEED} SAFETY=${SAFETY} DEBUG=${DEBUG} \ LOAD_SOURCE_FILE_INFO=${LOAD_SOURCE_FILE_INFO} \ RECORD_SOURCE_FILE_INFO=${RECORD_SOURCE_FILE_INFO} \ LOAD_XREF_INFO=${LOAD_XREF_INFO} \ - RECORD_XREF_INFO=${RECORD_XREF_INFO} - + RECORD_XREF_INFO=${RECORD_XREF_INFO} \ + CLIM=${CLIM} CLIMOL=${CLIMOL} CLIMXM=${CLIMXM} \ + COMPILE_PRINT=${COMPILE_PRINT} CFLAGS = -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD -I/x11/motif-1.1/lib @@ -50,11 +59,6 @@ OLDSPACE = 15000000 NEWSPACE = 5000000 PREMALLOCS = '-m 401408' -# Name of dumped lisp -CLIM = ./slim -CLIMOL= $(CLIM) -CLIMXM= $(CLIM) - CLIM-SMALL = ./slim-small PUBDIRS = sys utils silica clim demo test genera clx pre-silica postscript compatibility @@ -174,7 +178,6 @@ CLIM-UTILS-OBJS = utils/excl-verification.fasl \ utils/queue.fasl \ utils/timers.fasl \ utils/protocols.fasl \ - utils/autoconstructor.fasl \ utils/clim-streams.fasl \ utils/excl-streams.fasl \ utils/clim-macros.fasl \ @@ -265,7 +268,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/stream-trampolines.fasl GENERIC-GADGETS = clim/db-menu.fasl clim/db-list.fasl clim/db-text.fasl silica/db-button.fasl \ - silica/db-slider.fasl + silica/db-slider.fasl silica/scroll-pane.fasl XLIB-CLIM-OBJS = xlib/pkg.fasl xlib/load-xlib.fasl @@ -354,7 +357,6 @@ ALL_SRC = utils/excl-verification.lisp \ utils/processes.lisp \ utils/queue.lisp \ utils/protocols.lisp \ - utils/autoconstructor.lisp \ utils/clim-streams.lisp \ utils/excl-streams.lisp \ utils/clim-macros.lisp \ @@ -521,10 +523,12 @@ compile-xm: $(CLIMOBJS) FORCE (si::system-compile-wrapper \ (function \ (lambda () \ + (setq *compile-print* $(COMPILE_PRINT)) \ (setq sys::*libxt-pathname* \"$(XTLIB)\") \ (setq sys::*libx11-pathname* \"$(XLIB)\") \ (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \ - (load \"misc/compile-xm.lisp\"))) \ + (load \"misc/compile-1.lisp\") \ + (compile-it 'motif-clim))) \ :speed $(SPEED) :debug $(DEBUG) :safety $(SAFETY) \ :record-source-file-info $(RECORD_SOURCE_FILE_INFO) \ :record-xref-info $(RECORD_XREF_INFO) \ @@ -536,13 +540,15 @@ compile-ol: $(CLIMOBJS) FORCE (si::system-compile-wrapper \ (function \ (lambda () \ + (setq *compile-print* $(COMPILE_PRINT)) \ (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \ (setq sys::*libxt-pathname* \"$(XTLIB)\") \ (setq sys::*libx11-pathname* \"$(XLIB)\") \ (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \ (setq *ignore-package-name-case* t) \ (set-case-mode :case-insensitive-lower) \ - (load \"misc/compile-ol.lisp\"))) \ + (load \"misc/compile-1.lisp\") \ + (compile-it 'openlook-clim))) \ :speed $(SPEED) :debug $(DEBUG) :safety $(SAFETY) \ :record-source-file-info $(RECORD_SOURCE_FILE_INFO) \ :record-xref-info $(RECORD_XREF_INFO) \ @@ -629,7 +635,8 @@ clim-xm: FORCE $(CLIMOBJS) (setq sys::*libxt-pathname* \"$(XTLIB)\") \ (setq sys::*libx11-pathname* \"$(XLIB)\") \ (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \ - (load \"misc/dev-load-xm.lisp\") \ + (load \"misc/dev-load-1.lisp\") \ + (load-it 'motif-clim) \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIMXM) ls -lLt $(CLIMXM) >> Clim-sizes.n @@ -643,7 +650,8 @@ clim-ol: FORCE $(CLIMOBJS) (setq sys::*libxt-pathname* \"$(XTLIB)\") \ (setq sys::*libx11-pathname* \"$(XLIB)\") \ (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \ - (load \"misc/dev-load-ol.lisp\") \ + (load \"misc/dev-load-1.lisp\") \ + (load-it 'openlook-clim) \ (load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch $(MV) $(TMP)/clim.temp_`whoami` $(CLIMOL) ls -lLt $(CLIMOL) >> Clim-sizes.n diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index e9d6deb6450257c6b3a8d894eefc6c032c09a13c..f5ac303761bafcfe85e26c08705b57d75bd5b19e 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept-values.lisp,v 1.47 92/11/20 08:44:18 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.48 92/12/03 10:25:53 cer Exp $ (in-package :clim-internals) @@ -539,6 +539,19 @@ (move-cursor-beyond-output-record (encapsulating-stream-stream stream) avv))))))))) +(defmethod invoke-with-aligned-prompts ((stream accept-values-stream) continuation &key (align-prompts t)) + (setq align-prompts (ecase align-prompts + ((t :right) :right) + ((:left) :left) + ((nil) nil))) + (letf-globally (((slot-value stream 'align-prompts) align-prompts)) + (formatting-table (stream) + (funcall continuation stream)))) + +(defmethod invoke-with-aligned-prompts ((stream t) continuation &key align-prompts) + (declare (ignore align-prompts)) + (funcall continuation stream)) + (defmethod frame-manager-display-input-editor-error ((framem standard-frame-manager) (frame accept-values) stream error) ;;--- Resignal the error so the user can handle it diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp index a23d3869dc5f4c96491a59761ce3c1190b32ec87..f57b12da73ab1549496742739994bbbeb9634109 100644 --- a/clim/basic-translators.lisp +++ b/clim/basic-translators.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: basic-translators.lisp,v 1.11 92/11/19 14:17:04 cer Exp $ +;; $fiHeader: basic-translators.lisp,v 1.12 92/12/03 10:26:03 cer Exp $ (in-package :clim-internals) @@ -22,13 +22,15 @@ (object presentation) (values object (presentation-type presentation))) + (defun identity-translator-applicable-p (presentation context-type) (let* ((type (presentation-type presentation)) (type-name (presentation-type-name type)) (object (presentation-object presentation))) (with-presentation-type-decoded (context-name context-parameters) context-type (if (eq type-name 'blank-area) - (orD,#TD1PsT[Begin using 006 escapes](1 0 (NIL 0) (NIL :BOLD NIL) "CPTFONTCB") 0(eq context-name 'blank-area) + (or ;; D,#TD1PsT[Begin using 006 escapes](1 0 (NIL 0) (NIL :BOLD NIL) "CPTFONTCB") 0 + (eq context-name 'blank-area) (presentation-subtypep-1 type context-type)) ;; Let MENU-ITEM-IDENTITY take care of pure menu items (unless (and (eq type-name 'menu-item) diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp index 69e3b7c2e6682c719d41d7e1433c7341a685aeb9..d66db0607451e3b3856f9725149b2af72df5dbbb 100644 --- a/clim/clim-defs.lisp +++ b/clim/clim-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clim-defs.lisp,v 1.19 92/12/01 09:45:05 cer Exp $ +;; $fiHeader: clim-defs.lisp,v 1.20 92/12/03 10:26:06 cer Exp $ (in-package :clim-internals) @@ -309,6 +309,11 @@ (declare (dynamic-extent #'accepting-values-body)) (invoke-accepting-values ,stream #'accepting-values-body ,@args))) +(defmacro with-aligned-prompts ((stream &rest args) &body body) + (default-input-stream stream accepting-values) + `(flet ((with-aligned-prompts-body (,stream) ,@body)) + (declare (dynamic-extent #'accepting-values-body)) + (invoke-with-aligned-prompts ,stream #'with-aligned-prompts-body ,@args))) ;; Establish a first quadrant coordinate system, execute the body, and then ;; place the output in such a way that the upper left corner of it is where diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 0bd754c359a5ac5f9875f8031f4c10e69066b17c..f47ae11466abfa056f1749f83fdf1decfd82174f 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.38 92/12/01 09:45:08 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.39 92/12/03 10:26:23 cer Exp $ (in-package :clim-internals) @@ -355,7 +355,7 @@ (:top (setq pane `(vertically () ,label ,pane)))))) (when borders - (setq pane (outlining (:thickness 1) + (setq pane `(outlining (:thickness 1) #+allegro ,pane #-allegro diff --git a/clim/frames.lisp b/clim/frames.lisp index db8309758a0a9a9b1dcc8f29c260f51b7e48fbcb..41d3433478a9e2ad328112b2033d701fb7e9e280 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.52 92/12/01 09:45:11 cer Exp $ +;; $fiHeader: frames.lisp,v 1.53 92/12/03 10:26:35 cer Exp $ (in-package :clim-internals) @@ -1500,3 +1500,11 @@ (values left left-presentation left-context middle middle-presentation middle-context right right-presentation right-context))) + +(defmethod handle-event ((stream input-protocol-mixin) (event port-terminated)) + (if (pane-frame stream) + (frame-terminated (pane-frame stream) event) + (error "Port has died ~A" event))) + +(defmethod frame-terminated ((frame standard-application-frame) event) + (error "Port for frame ~A has died ~A" frame event)) diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index 2c58ad9e1566cc74f5931b891418a3487b62c64e..c2cb7c9d52de0be307db6b4c83e16e75ef52a2d2 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,79 +1,12 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; Allegro Common Lisp -;; -[Thu Nov 19 18:52:10 1992 by smh]- -;; -;; 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: graph-formatting.lisp,v 1.18 92/11/06 18:59:45 cer Exp $ - - -"Copyright (c) 1990, 1991, 1992 Symbolics Inc. All rights reserved." - - -(In-package :clim-internals) -#| - -This file is smh's quick hacked version for improved digraph layout. - -The basic strategy is that each node appearing more than once in the -graph is reliably assigned the maximum generation (ply) to which it -belongs, instead of depending on which occurence was encountered -first. Then `filler' output records are inserted to fill in missing -generations in any link. These fillers then participate in regular -node layout. This results in some unnecessarily squiggley lines, but -generally the behavior is reasonable. - -In graphs where a node with large "depth" is adjacent to a small depth -node with large fanout connections there is still the possibly that a -connector will overwrite a node. This could be fixed with one of -several strategies: Pad the short node's depth somehow, which moves a -lot of complexity onto the arc-drawing functions; or add a whole -generation of additional filler nodes, which would be laid out to -constrain the set of children of each parent to lie within that -parents breadth. I'd draw a picture of it weren't so tedious... - -The unnecessary squiggles could be fixed without too much work by -postprocessing the links, successively moving filler nodes when there -is room to line them up with one of it's connections in the adjacent -generation. - -Useful rfe: Enforce some limit on the maximum absolute value slope on -a connection. Extra inter-generation spacing would be adde to limit -the slope, since high-slope lines are the most visually confusion, -especially when many occur together. +;; $fiHeader: graph-formatting.lisp,v 1.20 92/12/01 17:49:59 cer Exp $ -As an additional hack, the digraph grapher handles circularities by -creating a pair of `offpage' connectors. This isn't as elegant as -plotting circular paths backwards, but the current hack results in a -clear visual diagram with little effort. The new -offpage-connector-out-printer and offpage-connector-in-printer args to -format-graph-from-roots are something of a crock -- perhaps we can -avoid documenting them until better treatment of cyclic graphs is -devised. BTW, before this hack, a circular graph with no roots (i.e. -all nodes have at least one parent) would blow the stack, so don't -undertake a more ambitious fix for circular graphs without accounting -for this case. +(in-package :clim-internals) -|# +"Copyright (c) 1990, 1991, 1992 Symbolics Inc. All rights reserved. + Portions copyright (c) 1992 Franz, Inc. All rights reserved." - (defvar *graph-type-record-type-alist* nil) (defmacro define-graph-type (graph-type class) @@ -157,15 +90,12 @@ for this case. ;; The basic graph output record class (defclass basic-graph-output-record (standard-sequence-output-record graph-output-record) - ((orientation :initarg :orientation) - (center-nodes :initarg :center-nodes) - (cutoff-depth :initarg :cutoff-depth) - (merge-duplicates :initarg :merge-duplicates) - (generation-separation :initarg :generation-separation) - (within-generation-separation :initarg :within-generation-separation) + ((graph-type :initarg :graph-type) ;; The output records corresponding to the root nodes (root-nodes :initform nil :accessor graph-root-nodes) - (hash-table :initform nil :initarg :hash-table)) + (hash-table :initform nil :initarg :hash-table) + ;; Stores things like :ORIENTATION, :MERGE-DUPLICATES, etc. + (properties :initarg :properties)) (:default-initargs :size 30)) ;;--- Not correct, since edges can overlap nodes. @@ -187,12 +117,13 @@ for this case. ((generation :accessor graph-node-generation :initform 0) ;; The output records corresponding to this node's parents and children (node-children :accessor graph-node-children :initform nil) - (node-parents :accessor graph-node-parents :initform nil)) + (node-parents :accessor graph-node-parents :initform nil) + (object :accessor graph-node-object :initarg :object)) (:default-initargs :size 5)) (define-output-record-constructor standard-graph-node-output-record - (&key x-position y-position (size 25)) - :x-position x-position :y-position y-position :size size) + (&key object x-position y-position (size 25)) + :object object :x-position x-position :y-position y-position :size size) (defmethod tree-recompute-extent-1 ((record standard-graph-node-output-record)) (bounding-rectangle* record)) @@ -221,9 +152,9 @@ for this case. *default-generation-separation*) (within-generation-separation *default-within-generation-separation*) - (move-cursor t)) + (store-objects nil) (move-cursor t)) (declare (dynamic-extent keys object-printer inferior-producer) - (ignore stream key orientation cutoff-depth + (ignore stream key orientation cutoff-depth store-objects generation-separation within-generation-separation move-cursor)) (with-keywords-removed (keys keys '(:key)) (apply #'format-graph-from-roots @@ -243,15 +174,16 @@ for this case. *default-generation-separation*) (within-generation-separation *default-within-generation-separation*) - (move-cursor t) + (maximize-generations #+Allegro t #-Allegro nil) + (store-objects nil) (move-cursor t) ;; These `offpage' connector print functions ;; should receive more useful id in addition ;; to an identification number, such as the ;; from and to nodes. (offpage-connector-out-printer - #'(lambda (s n) (format s ">~d" n))) + #'(lambda (s n) (format s ">~D" n))) (offpage-connector-in-printer - #'(lambda (s n) (format s "~d>" n)))) + #'(lambda (s n) (format s "~D>" n)))) (declare (dynamic-extent object-printer inferior-producer)) (check-type cutoff-depth (or null integer)) (check-type generation-separation real) @@ -272,22 +204,25 @@ for this case. (with-end-of-line-action (stream :allow) (with-new-output-record (stream record-type graph-record - :orientation orientation - :center-nodes center-nodes - :cutoff-depth cutoff-depth - :merge-duplicates merge-duplicates - :generation-separation - (coordinate generation-separation) - :within-generation-separation - (coordinate within-generation-separation) + :graph-type graph-type + :properties `(:orientation ,orientation + :center-nodes ,center-nodes + :cutoff-depth ,cutoff-depth + :merge-duplicates ,merge-duplicates + :maximize-generations ,maximize-generations + :generation-separation + ,(coordinate generation-separation) + :within-generation-separation + ,(coordinate within-generation-separation)) :hash-table hash-table) (generate-graph-nodes - graph-record stream - root-objects object-printer inferior-producer - :duplicate-key duplicate-key - :duplicate-test duplicate-test - :offpage-connector-out-printer offpage-connector-out-printer - :offpage-connector-in-printer offpage-connector-in-printer) + graph-record stream + root-objects object-printer inferior-producer + :duplicate-key duplicate-key + :duplicate-test duplicate-test + :store-objects store-objects + :offpage-connector-out-printer offpage-connector-out-printer + :offpage-connector-in-printer offpage-connector-in-printer) graph-record)))))) (unwind-protect (progn @@ -302,31 +237,31 @@ for this case. (move-cursor-beyond-output-record stream graph-record)) graph-record))) -(defun draw-linear-arc (stream from-node to-node x1 y1 x2 y2 &rest drawing-options) +(defun draw-linear-arc (stream from-object to-object x1 y1 x2 y2 &rest drawing-options) (declare (dynamic-extent drawing-options)) - (declare (ignore from-node to-node)) + (declare (ignore from-object to-object)) (apply #'draw-line* stream x1 y1 x2 y2 drawing-options)) -(defun-inline call-arc-drawer (stream arc-drawer from-node to-node +(defun-inline call-arc-drawer (stream arc-drawer parent-object child-object parent parent-x parent-y child child-x child-y arc-drawing-options) (declare (dynamic-extent arc-drawer)) (if (or (stream-redisplaying-p stream) (stream-current-redisplay-record stream)) - (call-arc-drawer-1 stream arc-drawer from-node to-node + (call-arc-drawer-1 stream arc-drawer parent-object child-object parent parent-x parent-y child child-x child-y arc-drawing-options) - (apply arc-drawer stream from-node to-node + (apply arc-drawer stream parent-object child-object parent-x parent-y child-x child-y arc-drawing-options))) ;; Split out to avoid consing a closure environment -(defun call-arc-drawer-1 (stream arc-drawer from-node to-node +(defun call-arc-drawer-1 (stream arc-drawer parent-object child-object parent parent-x parent-y child child-x child-y arc-drawing-options) (declare (dynamic-extent arc-drawer)) #---ignore ;--- this is the wrong thing... - (apply arc-drawer stream from-node to-node + (apply arc-drawer stream parent-object child-object parent-x parent-y child-x child-y arc-drawing-options) #+++ignore ;--- ...but the right thing doesn't work either @@ -335,7 +270,7 @@ for this case. :cache-value (list parent-x parent-y child-x child-y) :cache-test #'equal) - (apply arc-drawer stream from-node to-node + (apply arc-drawer stream parent-object child-object parent-x parent-y child-x child-y arc-drawing-options))) @@ -348,13 +283,13 @@ for this case. (defmethod generate-graph-nodes ((graph tree-graph-output-record) stream root-objects object-printer inferior-producer - &key duplicate-key duplicate-test - offpage-connector-out-printer - offpage-connector-in-printer) + &key duplicate-key duplicate-test store-objects + offpage-connector-out-printer + offpage-connector-in-printer) (declare (ignore duplicate-key duplicate-test - offpage-connector-out-printer - offpage-connector-in-printer)) - (let ((cutoff-depth (slot-value graph 'cutoff-depth))) + offpage-connector-out-printer offpage-connector-in-printer)) + (let* ((properties (slot-value graph 'properties)) + (cutoff-depth (getf properties :cutoff-depth))) (labels ((format-node (object &optional (depth 1)) (when (and cutoff-depth (> depth cutoff-depth)) (return-from format-node nil)) @@ -367,7 +302,9 @@ for this case. (setq children (nconc children (list node)))))) (let ((this-node (with-stream-cursor-position-saved (stream) - (with-new-output-record (stream 'standard-graph-node-output-record) + (with-new-output-record + (stream 'standard-graph-node-output-record nil + :object (and store-objects object)) (funcall object-printer object stream))))) (setf (graph-node-children this-node) children) (dolist (child (graph-node-children this-node)) @@ -377,13 +314,16 @@ for this case. (map 'list #'format-node root-objects)))) graph) -(defmethod layout-graph-nodes ((graph tree-graph-output-record) - stream arc-drawer arc-drawing-options) +(defmethod layout-graph-nodes ((graph tree-graph-output-record) stream + arc-drawer arc-drawing-options) (declare (ignore stream arc-drawer arc-drawing-options)) - (with-slots (root-nodes orientation center-nodes - generation-separation within-generation-separation) graph - (let ((start-x (coordinate 0)) - (start-y (coordinate 0))) + (with-slots (root-nodes) graph + (let* ((properties (slot-value graph 'properties)) + (orientation (getf properties :orientation)) + (generation-separation (getf properties :generation-separation)) + (within-generation-separation (getf properties :within-generation-separation)) + (start-x (coordinate 0)) + (start-y (coordinate 0))) (dolist (root-node root-nodes) (macrolet ((layout-body (driver-function-name @@ -446,191 +386,254 @@ for this case. (layout-graph root-node start-x start-y (node-depth root-node)))))))))))) -(defmethod layout-graph-edges ((graph tree-graph-output-record) - stream arc-drawer arc-drawing-options) - (with-slots (orientation root-nodes) graph - (dolist (root-node root-nodes) - (flet ((parent-attachment-position (node) - (with-bounding-rectangle* (left top right bottom) node - (case orientation - ((:horizontal :right) - (values (1+ right) (+ top (floor (- bottom top) 2)))) - ((:vertical :down) - (values (+ left (floor (- right left) 2)) (1+ bottom)))))) - (child-attachment-position (node) - (with-bounding-rectangle* (left top right bottom) node - (case orientation - ((:horizontal :right) - (values (1- left) (+ top (floor (- bottom top) 2)))) - ((:vertical :down) - (values (+ left (floor (- right left) 2)) (1- top))))))) - (declare (dynamic-extent #'parent-attachment-position #'child-attachment-position)) - (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates - stream (output-record-parent graph)) - (with-identity-transformation (stream) - (with-output-recording-options (stream :draw nil :record t) - (with-new-output-record (stream 'standard-sequence-output-record nil - :parent graph) - (labels ((draw-edges (parent) - (dolist (child (graph-node-children parent)) - (when (graph-node-children child) - (draw-edges child)) - (multiple-value-bind (parent-x parent-y) - (parent-attachment-position parent) - (multiple-value-bind (child-x child-y) - (child-attachment-position child) - (translate-coordinates xoff yoff - parent-x parent-y child-x child-y) - (call-arc-drawer stream arc-drawer - ;;--- Should be from- and to-node - nil nil - parent parent-x parent-y - child child-x child-y - arc-drawing-options)))))) - (declare (dynamic-extent #'draw-edges)) - (draw-edges root-node)))))))))) +(defmethod layout-graph-edges ((graph tree-graph-output-record) stream + arc-drawer arc-drawing-options) + (with-slots (root-nodes properties) graph + (let ((orientation (getf properties :orientation))) + (dolist (root-node root-nodes) + (flet ((parent-attachment-position (node) + (with-bounding-rectangle* (left top right bottom) node + (case orientation + ((:horizontal :right) + (values (1+ right) (+ top (floor (- bottom top) 2)))) + ((:vertical :down) + (values (+ left (floor (- right left) 2)) (1+ bottom)))))) + (child-attachment-position (node) + (with-bounding-rectangle* (left top right bottom) node + (case orientation + ((:horizontal :right) + (values (1- left) (+ top (floor (- bottom top) 2)))) + ((:vertical :down) + (values (+ left (floor (- right left) 2)) (1- top))))))) + (declare (dynamic-extent #'parent-attachment-position #'child-attachment-position)) + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent graph)) + (with-identity-transformation (stream) + (with-output-recording-options (stream :draw nil :record t) + (with-new-output-record (stream 'standard-sequence-output-record nil + :parent graph) + (labels ((draw-edges (parent) + (dolist (child (graph-node-children parent)) + (when (graph-node-children child) + (draw-edges child)) + (multiple-value-bind (parent-x parent-y) + (parent-attachment-position parent) + (multiple-value-bind (child-x child-y) + (child-attachment-position child) + (translate-coordinates xoff yoff + parent-x parent-y child-x child-y) + (call-arc-drawer stream arc-drawer + (graph-node-object parent) + (graph-node-object child) + parent parent-x parent-y + child child-x child-y + arc-drawing-options)))))) + (declare (dynamic-extent #'draw-edges)) + (draw-edges root-node))))))))))) ;;; Directed graphs, both acyclic and cyclic +#| + +The basic strategy is that each node appearing more than once in the +graph is reliably assigned the maximum generation (ply) to which it +belongs, instead of depending on which occurence was encountered +first. Then `filler' output records are inserted to fill in missing +generations in any link. These fillers then participate in regular +node layout. This results in some unnecessarily squiggley lines, but +generally the behavior is reasonable. + +In graphs where a node with large "depth" is adjacent to a small depth +node with large fanout connections there is still the possibly that a +connector will overwrite a node. This could be fixed with one of +several strategies: Pad the short node's depth somehow, which moves a +lot of complexity onto the arc-drawing functions; or add a whole +generation of additional filler nodes, which would be laid out to +constrain the set of children of each parent to lie within that +parents breadth. I'd draw a picture of it weren't so tedious... + +The unnecessary squiggles could be fixed without too much work by +postprocessing the links, successively moving filler nodes when there +is room to line them up with one of it's connections in the adjacent +generation. + +Useful rfe: Enforce some limit on the maximum absolute value slope on +a connection. Extra inter-generation spacing would be added to limit +the slope, since high-slope lines are the most visually confusing, +especially when many occur together. + +As an additional hack, the digraph grapher handles circularities by +creating a pair of `offpage' connectors. This isn't as elegant as +plotting circular paths backwards, but the current hack results in a +clear visual diagram with little effort. The offpage-connector-out-printer +and offpage-connector-in-printer args to format-graph-from-roots are +something of a crock -- perhaps we can avoid documenting them until +better treatment of cyclic graphs is devised. BTW, before this hack, +a circular graph with no roots (i.e. all nodes have at least one parent) +would blow the stack, so don't undertake a more ambitious fix for +circular graphs without accounting for this case. + +|# + (defclass directed-graph-output-record (basic-graph-output-record) ((n-generations :initform 0))) ;; For now, treat digraphs and DAGs the same way... -;; -;; With smh's hacks, cyclic digraphs get converted to dags automatically -;; with the insertion of `offpage' connectors. -;; This should be conditionalized, with options for also trying to thread -;; the cycle path neatly backwards -- but it's too tricky for right now. -;; Contact me for my thoughts on the matter. 19Nov92 -smh - (define-graph-type :directed-graph directed-graph-output-record) (define-graph-type :digraph directed-graph-output-record) (define-graph-type :directed-acyclic-graph directed-graph-output-record) (define-graph-type :dag directed-graph-output-record) -;; These implement the dummy nodes inserted when an arc must span -;; more than one generation. -(defclass graph-node-filler-output-record (standard-graph-node-output-record) ()) +;; These implement the dummy nodes inserted when an arc must span more +;; than one generation. +(defclass graph-node-filler-output-record (standard-graph-node-output-record) ()) (defclass graph-node-filler-output-record-1 (standard-graph-node-output-record) ()) ;; These implement the `offpage' connectors for cyclic graphs. (defclass graph-node-connector-output-record - (standard-graph-node-output-record) + (standard-graph-node-output-record) ((id :accessor connector-id :initarg :connector-id))) -(defclass graph-node-connector-in-output-record (graph-node-connector-output-record) ()) -(defclass graph-node-connector-out-output-record (graph-node-connector-output-record) ()) - -(defmethod generate-graph-nodes ((graph directed-graph-output-record) - stream +(defclass graph-node-connector-in-output-record (graph-node-connector-output-record) + () + (:default-initargs :object nil)) +(defclass graph-node-connector-out-output-record (graph-node-connector-output-record) + () + (:default-initargs :object nil)) + +(defmethod generate-graph-nodes ((graph directed-graph-output-record) stream root-objects object-printer inferior-producer - &key duplicate-key duplicate-test - offpage-connector-out-printer - offpage-connector-in-printer) + &key duplicate-key duplicate-test store-objects + offpage-connector-out-printer + offpage-connector-in-printer) (declare (dynamic-extent object-printer inferior-producer)) (declare (ignore duplicate-test)) - (let ((hash-table (slot-value graph 'hash-table)) - (cutoff-depth (slot-value graph 'cutoff-depth)) - (root-nodes '()) - (connectors-in '())) - (labels ((inferior-mapper (function node) - (map nil function (funcall inferior-producer node))) - (new-node-function (parent-object parent-record child-object) - (let ((child-record - (with-stream-cursor-position-saved (stream) - (with-new-output-record - (stream 'standard-graph-node-output-record) - (funcall object-printer child-object stream))))) - ;; This guarantees that the next phase will have at least one node - ;; from which to start. Otherwise the entire graph gets lost. - ;; If the first node isn't really a root, it will be deleted from - ;; the set of roots when the cycle is detected. - (when (null root-nodes) - (push child-record root-nodes)) - (old-node-function parent-object parent-record child-object child-record))) - (old-node-function (parent-object parent-record child-object child-record) - (declare (ignore parent-object child-object)) - ;; Preserve the ordering of the nodes - ;; Generation numbers are now computed later -smh. - (when parent-record - (unless (member parent-record (graph-node-parents child-record)) - (setf (graph-node-parents child-record) - (nconc (graph-node-parents child-record) - (list parent-record)))) - (unless (member child-record (graph-node-children parent-record)) - (setf (graph-node-children parent-record) - (nconc (graph-node-children parent-record) - (list child-record))))) - child-record)) - (declare (dynamic-extent #'inferior-mapper #'new-node-function #'old-node-function)) - (traverse-graph root-objects #'inferior-mapper - hash-table duplicate-key - #'new-node-function #'old-node-function - cutoff-depth)) - (map-node-table #'(lambda (key node) - (declare (ignore key)) - (when (and (typep node 'graph-node-output-record) - (null (graph-node-parents node))) - (pushnew node root-nodes))) - hash-table) - (labels ((break-cycles (node &optional path) - (do ((c (graph-node-children node) (cdr c))) - ((null c)) - (let ((child (car c))) - (if (member child path) - (let* ((id (connector-id - (or (find child connectors-in - :key #'(lambda (x) - (car (graph-node-children x)))) - (let* ((id (1+ (length connectors-in))) - (rec (with-new-output-record - (stream - 'graph-node-connector-in-output-record - nil :connector-id id) - (funcall offpage-connector-in-printer - stream id)))) - (push rec connectors-in) - (setf (graph-node-children rec) (list child)) - ;; What about ordering? - (push rec (graph-node-parents child)) - (setf root-nodes (delete child root-nodes)) - rec))))) - (setf (car c) + (with-slots (n-generations) graph + (let* ((hash-table (slot-value graph 'hash-table)) + (graph-type (slot-value graph 'graph-type)) + (properties (slot-value graph 'properties)) + (cutoff-depth (getf properties :cutoff-depth)) + (maximize-generations (getf properties :maximize-generations)) + (root-nodes nil) + (connectors-in nil)) + (labels ((inferior-mapper (function node) + (map nil function (funcall inferior-producer node))) + (new-node-function (parent-object parent-record child-object) + (let ((child-record + (with-stream-cursor-position-saved (stream) (with-new-output-record - (stream 'graph-node-connector-out-output-record nil - :connector-id id) - (funcall offpage-connector-out-printer stream id)))) + (stream 'standard-graph-node-output-record nil + :object (and store-objects child-object)) + (funcall object-printer child-object stream))))) + ;; This guarantees that the next phase will have at least one + ;; node from which to start. Otherwise the entire graph gets + ;; lost. If the first node isn't really a root, it will be + ;; deleted from the set of roots when the cycle is detected. + (when (null root-nodes) + (push child-record root-nodes)) + (old-node-function parent-object parent-record child-object child-record))) + (old-node-function (parent-object parent-record child-object child-record) + (declare (ignore parent-object child-object)) + (unless maximize-generations + (let ((old-generation (graph-node-generation child-record))) + ;; Set the generation of this node to 1 greater than the parent, + ;; and keep track of the highest generation encountered. + (maxf n-generations + (maxf (graph-node-generation child-record) + (if parent-record + (1+ (graph-node-generation parent-record)) + 0))) + ;; If the child-record got its generation adjusted, then we must + ;; adjust the generation-number of already-processed children, + ;; and their children, etc. + (unless (eql (graph-node-generation child-record) old-generation) + (increment-generation child-record)))) + ;; Preserve the ordering of the nodes. Generation numbers are + ;; computed later in the case when MAXIMIZE-GENERATIONS is T. + (when parent-record + (unless (member parent-record (graph-node-parents child-record)) + (setf (graph-node-parents child-record) + (nconc (graph-node-parents child-record) + (list parent-record)))) + (unless (member child-record (graph-node-children parent-record)) + (setf (graph-node-children parent-record) + (nconc (graph-node-children parent-record) + (list child-record))))) + child-record) + (increment-generation (record) + (let ((new-generation (1+ (graph-node-generation record)))) + (dolist (child (graph-node-children record)) + ;; Remember which generation the child belonged to. + (let ((old-generation (graph-node-generation child))) + (maxf n-generations + (maxf (graph-node-generation child) new-generation)) + ;; If it has changed, fix up the next generation recursively. + (unless (eql (graph-node-generation child) old-generation) + (increment-generation child))))))) + (declare (dynamic-extent #'inferior-mapper #'increment-generation + #'new-node-function #'old-node-function)) + (traverse-graph root-objects #'inferior-mapper + hash-table duplicate-key + #'new-node-function #'old-node-function + cutoff-depth)) + (map-node-table #'(lambda (key node) + (declare (ignore key)) + (when (and (typep node 'graph-node-output-record) + (null (graph-node-parents node))) + (pushnew node root-nodes))) + hash-table) + (when (and (member graph-type '(:directed-graph :digraph)) + offpage-connector-in-printer offpage-connector-out-printer) + (labels + ((break-cycles (node &optional path) + (do ((c (graph-node-children node) (cdr c))) + ((null c)) + (let ((child (car c))) + (if (member child path) + (let* ((id (connector-id + (or (find child connectors-in + :key #'(lambda (x) + (car (graph-node-children x)))) + (let* ((id (1+ (length connectors-in))) + (rec (with-new-output-record + (stream 'graph-node-connector-in-output-record nil + :connector-id id) + (funcall offpage-connector-in-printer + stream id)))) + (push rec connectors-in) + (setf (graph-node-children rec) (list child)) + ;;--- What about ordering? + (push rec (graph-node-parents child)) + (setf root-nodes (delete child root-nodes)) + rec))))) + (setf (car c) + (with-new-output-record + (stream 'graph-node-connector-out-output-record nil + :connector-id id) + (funcall offpage-connector-out-printer stream id)))) (break-cycles child (cons node path))))))) - (declare (dynamic-extent #'break-cycles)) - (map nil #'break-cycles (copy-list root-nodes))) - (setf (slot-value graph 'root-nodes) (nconc (nreverse connectors-in) - (nreverse root-nodes))) - #+never - (let ((root-nodes nil)) - (flet ((find-roots (key node) - (declare (ignore key)) - (when (and (graph-node-output-record-p node) - (null (graph-node-parents node))) - (push node root-nodes)))) - (declare (dynamic-extent #'find-roots)) - (map-node-table #'find-roots hash-table)) - (setf (graph-root-nodes graph) (nreverse root-nodes)))) - (compute-graph-effective-generations graph) - (add-graph-filler-output-records graph stream) + (declare (dynamic-extent #'break-cycles)) + (map nil #'break-cycles (copy-list root-nodes)))) + (setf (slot-value graph 'root-nodes) + (nconc (nreverse connectors-in) (nreverse root-nodes))) + (when maximize-generations + (compute-graph-effective-generations graph) + (add-graph-filler-output-records graph stream)))) graph) (defmethod compute-graph-effective-generations ((graph directed-graph-output-record)) - (with-slots (n-generations root-nodes) graph + (with-slots (root-nodes n-generations) graph (labels ((traverse (node ply) (with-slots (generation) node (maxf generation ply) (let ((children (graph-node-children node)) (gen1 (1+ generation))) - (if children ;Save time -- do one or the other. + (if children ;save time -- do one or the other (dolist (child children) (traverse child gen1)) - (maxf n-generations generation)))))) + (maxf n-generations generation)))))) + (declare (dynamic-extent #'traverse)) (dolist (root root-nodes) (traverse root 0))))) @@ -644,16 +647,17 @@ for this case. ((null c)) (let ((child (car c))) (if (> (graph-node-generation child) gen1) - (progn - (let ((filler (with-new-output-record - (stream 'graph-node-filler-output-record) - nil))) - (setf (graph-node-children filler) (list child) - (graph-node-parents filler) (list node) - (car c) filler - (graph-node-generation filler) gen1) - (traverse filler))) - (traverse child))))))) + (let ((filler (with-new-output-record + (stream 'graph-node-filler-output-record) + nil))) + (setf (graph-node-children filler) (list child) + (graph-node-parents filler) (list node) + (graph-node-object filler) (graph-node-object node) + (car c) filler + (graph-node-generation filler) gen1) + (traverse filler)) + (traverse child))))))) + (declare (dynamic-extent #'traverse)) (dolist (root root-nodes) (traverse root))))) @@ -669,14 +673,18 @@ for this case. (edge-breadth-separation nil) ;margin whitespace (touched nil)) ;if T, use inner breadth separation -(defmethod layout-graph-nodes ((graph directed-graph-output-record) - stream arc-drawer arc-drawing-options) - (with-slots (orientation center-nodes - generation-separation within-generation-separation n-generations - root-nodes hash-table) graph +(defmethod layout-graph-nodes ((graph directed-graph-output-record) stream + arc-drawer arc-drawing-options) + (with-slots (root-nodes hash-table n-generations) graph (when root-nodes - (let ((start-x (coordinate 0)) - (start-y (coordinate 0))) + (let* ((properties (slot-value graph 'properties)) + (orientation (getf properties :orientation)) + (center-nodes (getf properties :center-nodes)) + (generation-separation (getf properties :generation-separation)) + (within-generation-separation (getf properties :within-generation-separation)) + (maximize-generations (getf properties :maximize-generations)) + (start-x (coordinate 0)) + (start-y (coordinate 0))) (flet ((inferior-mapper (function node) (map nil function (graph-node-children node))) (yx-output-record-set-position (record y x) @@ -717,38 +725,38 @@ for this case. (maxf (generation-depth descr) (depth child-node))))) (declare (dynamic-extent #'collect-node-size)) (traverse #'collect-node-size)) - - ;; Replace all filler nodes, giving them the max depth in their generation. - (labels - ((replace-filler-nodes (parent) - (let ((children (graph-node-children parent))) - (do ((c children (cdr c))) - ((null c)) - (let ((node (car c))) - (when (typep node 'graph-node-filler-output-record) - (delete-output-record node graph) - (let* ((depth (generation-depth - (assoc (graph-node-generation node) - generation-descriptors))) - (new (with-output-to-output-record - (stream 'graph-node-filler-output-record-1) - (call-arc-drawer stream arc-drawer - ;;--- Should be from- and to-node - nil nil - parent 0 0 - node depth 0 - arc-drawing-options))) - (child (car (graph-node-children node)))) - (setf (graph-node-generation new) (graph-node-generation node) - (graph-node-children new) (graph-node-children node) - (graph-node-parents new) (graph-node-parents node) - (graph-node-parents child) (list new) - (car c) new) - (add-output-record new graph))))) - (map nil #'replace-filler-nodes children)))) - (declare (dynamic-extent #'replace-filler-nodes)) - (map nil #'replace-filler-nodes root-nodes)) - + ;; Replace all filler nodes, giving them the max depth in their generation. + (when maximize-generations + (labels + ((replace-filler-nodes (parent) + (let ((children (graph-node-children parent))) + (do ((c children (cdr c))) + ((null c)) + (let ((node (car c))) + (when (typep node 'graph-node-filler-output-record) + (delete-output-record node graph) + (let* ((depth (generation-depth + (assoc (graph-node-generation node) + generation-descriptors))) + (new (with-new-output-record + (stream 'graph-node-filler-output-record-1 nil + :parent graph) + (call-arc-drawer stream arc-drawer + (graph-node-object parent) + (graph-node-object node) + parent 0 0 + node depth 0 + arc-drawing-options))) + (child (car (graph-node-children node)))) + (setf (graph-node-generation new) (graph-node-generation node) + (graph-node-children new) (graph-node-children node) + (graph-node-parents new) (graph-node-parents node) + (graph-node-parents child) (list new) + (graph-node-object new) (graph-node-object node) + (car c) new))))) + (map nil #'replace-filler-nodes children)))) + (declare (dynamic-extent #'replace-filler-nodes)) + (map nil #'replace-filler-nodes root-nodes))) ;; Determine max-breadth and starting-depth (loop with depth-so-far = start-depth for descr in generation-descriptors do @@ -788,61 +796,62 @@ for this case. (declare (dynamic-extent #'place-node)) (traverse #'place-node)))))))))) -(defmethod layout-graph-edges ((graph directed-graph-output-record) - stream arc-drawer arc-drawing-options) - (with-slots (orientation root-nodes hash-table) graph - (when root-nodes - (flet ((inferior-mapper (function node) - (map nil function (graph-node-children node))) - (north (node) - (with-bounding-rectangle* (left top right bottom) node - (declare (ignore bottom)) - (values (floor (+ right left) 2) (1- top)))) - (south (node) - (with-bounding-rectangle* (left top right bottom) node - (declare (ignore top)) - (values (floor (+ right left) 2) (1+ bottom)))) - (west (node) - (with-bounding-rectangle* (left top right bottom) node - (declare (ignore right)) - (values (1- left) (floor (+ top bottom) 2)))) - (east (node) - (with-bounding-rectangle* (left top right bottom) node - (declare (ignore left)) - (values (1+ right) (floor (+ top bottom) 2))))) - (declare (dynamic-extent #'inferior-mapper #'north #'south #'west #'east)) - (multiple-value-bind (parent-attach child-attach) - (ecase orientation - ((:vertical :down) (values #'south #'north)) - ((:up) (values #'north #'south)) - ((:horizontal :right) (values #'east #'west)) - ((:left) (values #'west #'east))) - (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates - stream (output-record-parent graph)) - (with-identity-transformation (stream) - (with-output-recording-options (stream :draw nil :record t) - (with-new-output-record (stream 'standard-sequence-output-record nil - :parent graph) - (labels ((draw-edge (parent ph child &optional ch) - (declare (ignore ph ch)) - (when parent - (multiple-value-bind (parent-x parent-y) - (funcall parent-attach parent) - (multiple-value-bind (child-x child-y) - (funcall child-attach child) - (translate-coordinates xoff yoff - parent-x parent-y child-x child-y) - (call-arc-drawer stream arc-drawer - ;;--- Should be from- and to-node - nil nil - parent parent-x parent-y - child child-x child-y - arc-drawing-options)))))) - (declare (dynamic-extent #'draw-edge)) - (traverse-graph root-nodes #'inferior-mapper - hash-table #'identity - #'draw-edge #'draw-edge))))))))))) +(defmethod layout-graph-edges ((graph directed-graph-output-record) stream + arc-drawer arc-drawing-options) + (with-slots (root-nodes hash-table properties) graph + (let ((orientation (getf properties :orientation))) + (when root-nodes + (flet ((inferior-mapper (function node) + (map nil function (graph-node-children node))) + (north (node) + (with-bounding-rectangle* (left top right bottom) node + (declare (ignore bottom)) + (values (floor (+ right left) 2) (1- top)))) + (south (node) + (with-bounding-rectangle* (left top right bottom) node + (declare (ignore top)) + (values (floor (+ right left) 2) (1+ bottom)))) + (west (node) + (with-bounding-rectangle* (left top right bottom) node + (declare (ignore right)) + (values (1- left) (floor (+ top bottom) 2)))) + (east (node) + (with-bounding-rectangle* (left top right bottom) node + (declare (ignore left)) + (values (1+ right) (floor (+ top bottom) 2))))) + (declare (dynamic-extent #'inferior-mapper #'north #'south #'west #'east)) + (multiple-value-bind (parent-attach child-attach) + (ecase orientation + ((:vertical :down) (values #'south #'north)) + ((:up) (values #'north #'south)) + ((:horizontal :right) (values #'east #'west)) + ((:left) (values #'west #'east))) + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent graph)) + (with-identity-transformation (stream) + (with-output-recording-options (stream :draw nil :record t) + (with-new-output-record (stream 'standard-sequence-output-record nil + :parent graph) + (labels ((draw-edge (parent ph child &optional ch) + (declare (ignore ph ch)) + (when parent + (multiple-value-bind (parent-x parent-y) + (funcall parent-attach parent) + (multiple-value-bind (child-x child-y) + (funcall child-attach child) + (translate-coordinates xoff yoff + parent-x parent-y child-x child-y) + (call-arc-drawer stream arc-drawer + (graph-node-object parent) + (graph-node-object child) + parent parent-x parent-y + child child-x child-y + arc-drawing-options)))))) + (declare (dynamic-extent #'draw-edge)) + (traverse-graph root-nodes #'inferior-mapper + hash-table #'identity + #'draw-edge #'draw-edge)))))))))))) ;; ROOT-OBJECTS is a sequence of the roots of the graph. ;; INFERIOR-MAPPER is a function of two arguments, a function and an object @@ -874,7 +883,7 @@ for this case. (funcall new-node-function parent-object parent-hashval object))) (setf (get-node-table (funcall key object) hash-table) object-hashval) (when max-depth (decf max-depth)) - (unless (eql max-depth 0) + (unless (eq max-depth 0) (flet ((traverse1 (child-object) (let ((child-key (funcall key child-object))) (multiple-value-bind (child-hashval found) @@ -889,3 +898,4 @@ for this case. (map nil #'(lambda (root) (traverse nil nil root max-depth)) root-objects))) + diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index d6a9b5417c1ec486c3b13ac1856a9cdd0dc01018..dcaba5b617e12b73e262aeb58f77f92f8903dc04 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-protocol.lisp,v 1.34 92/12/01 09:45:20 cer Exp $ +;; $fiHeader: input-protocol.lisp,v 1.35 92/12/03 10:26:58 cer Exp $ (in-package :clim-internals) @@ -379,6 +379,7 @@ (process-abort-or-accelerator-gesture stream gesture) gesture) + (defun process-abort-or-accelerator-gesture (stream gesture) (cond ((member gesture *accelerator-gestures* :test #'keyboard-event-matches-gesture-name-p) @@ -416,6 +417,8 @@ (force-output stream)))))) (error 'abort-gesture :event gesture)))) + + ;;; This function is just a convenience for the programmer, defaulting the ;;; keyword :STREAM argument to *standard-input*. The application can call ;;; stream-read-gesture directly. diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 06fc4ff528879576baf287aac5220b88197550f5..f8df0b69330faec3eed7cd6923da87bb3343b116 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: standard-types.lisp,v 1.21 92/11/20 08:44:58 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.22 92/12/03 10:27:49 cer Exp $ (in-package :clim-internals) @@ -1468,7 +1468,7 @@ (subseq string index)))) expression)))) -r(define-presentation-method present (object (type expression) stream (view textual-view) +(define-presentation-method present (object (type expression) stream (view textual-view) &key (acceptably *print-readably*)) (print-recursive object stream :make-presentation nil :readably acceptably)) @@ -1481,18 +1481,23 @@ r(define-presentation-method present (object (type expression) stream (view text ;;--- Maybe this should have WRITE options (define-presentation-type form () :options ((auto-activate nil boolean)) - :inherit-from `((expression) :auto-activate ,auto-activate)) + ;; Handling of AUTO-ACTIVATE is done below... + :inherit-from `expression) (define-presentation-method presentation-type-history ((type form)) ;; Share history with EXPRESSION (presentation-type-history-for-frame 'expression *application-frame*)) (define-presentation-method map-over-presentation-type-supertypes ((type form) function) - (map-over-presentation-type-supertypes-augmented type function - ;; Include COMMAND-OR-FORM in the supertypes - (with-stack-list (new-type 'command-or-form + (with-presentation-type-decoded (name) type + (funcall function name type) + (with-stack-list (new-name 'command-or-form :command-table (frame-command-table *application-frame*)) - (funcall function 'command-or-form new-type)))) + (with-stack-list (new-type new-name :auto-activate auto-activate) + (funcall function 'command-or-form new-type)) + (with-stack-list (new-name 'expression) + (with-stack-list (new-type new-name :auto-activate auto-activate) + (map-over-presentation-type-supertypes new-type function)))))) (defvar *char-associations* '((#\( . #\)) (#\" . #\") diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index 469ff4505524d5165ebf5c32ebb94d39209dd8dd..14da7dc2db626ab059fdc9005a9f7df74dc7edc8 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.15 92/11/06 19:03:27 cer Exp $ +;; $fiHeader: compile-1.lisp,v 1.16 92/11/09 10:55:28 cer Exp $ (in-package :user) @@ -40,8 +40,6 @@ (setf (sys:gsgc-switch :print) t) (setf (sys:gsgc-switch :stats) t)) -(setq *compile-print* nil) - (setq comp:generate-call-count-code-switch (named-function |(> debug 1)| (lambda (safety size speed debug) diff --git a/misc/train.lisp b/misc/train.lisp index 895da43c8a1410811330d76afc6901b1f6dd3bbb..ddafff5ac70869f7543e14007ec2e6d20cf18c9b 100644 --- a/misc/train.lisp +++ b/misc/train.lisp @@ -20,12 +20,13 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: train.lisp,v 1.1 92/12/01 09:46:08 cer Exp $ -(defun train-clim (&key (train-times 2) (psview nil)) +(defun train-clim (&key (train-times 2) (psview nil) (frame-tests t)) (load "test/test.lisp") - (clim-user::train-clim-2 train-times) - (clim-user::do-frame-tests) + (when frame-tests + (clim-user::train-clim-2 train-times) + (clim-user::do-frame-tests)) (when psview (load "test/postscript-tests.lisp") (clim-user::run-postscript-tests :output psview)) diff --git a/silica/classes.lisp b/silica/classes.lisp index 8e556380b541893ebef5a785833c5116afb10511..592f7a4ffd6985e713cca1b75db3cb9d6286f4e8 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: classes.lisp,v 1.25 92/12/01 09:46:13 cer Exp $ +;; $fiHeader: classes.lisp,v 1.26 92/12/03 10:29:12 cer Exp $ (in-package :silica) @@ -129,7 +129,6 @@ ((timestamp :reader event-timestamp :initform (atomic-incf *event-timestamp*) :initarg :timestamp))) - (define-event-class device-event (event) ((sheet :reader event-sheet :initarg :sheet) (modifier-state :reader event-modifier-state diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index d479933c7abe561b1c07bc61556acd0ffd5107cf..77fb5d5c234b358509d258686a90f332fb5a5b55 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.36 92/12/01 09:46:20 cer Exp $ +;; $fiHeader: db-scroll.lisp,v 1.37 92/12/03 10:29:18 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -24,17 +24,6 @@ :accessor scroller-pane-gadget-supplies-scrolling-p)) (:default-initargs :scroll-bars :both)) -;; An implementation of a scroller pane -(defclass generic-scroller-pane (scroller-pane - client-space-requirement-mixin - wrapping-space-mixin - permanent-medium-sheet-output-mixin - pane-repaint-background-mixin - layout-pane) - ()) - -(defmethod handle-event :after ((pane generic-scroller-pane) (event pointer-motion-event)) - (deallocate-event event)) ;; Returns the viewport of the pane, if there is one (defmethod pane-viewport ((sheet sheet)) @@ -69,97 +58,6 @@ (declare (ignore frame-manager frame ignore contents)) nil) -(defmethod allocate-space :before ((scroller generic-scroller-pane) width height) - (declare (ignore width height)) - ;; Adjust the status of the scrollbars - (multiple-value-bind (changedp - hscroll-bar hscroll-bar-enabled-p - vscroll-bar vscroll-bar-enabled-p) - (compute-dynamic-scroll-bar-values scroller) - (when changedp - (update-dynamic-scroll-bars scroller changedp - hscroll-bar hscroll-bar-enabled-p - vscroll-bar vscroll-bar-enabled-p)))) - -(defmethod compose-space ((scroller generic-scroller-pane) &key width height) - (declare (ignore width height)) - (let ((sr (call-next-method))) - (multiple-value-bind (width min-width max-width - height min-height max-height) - (space-requirement-components sr) - (if (or (< width 50) (< height 50)) - ;; Make sure the scroller pane is big enough to hold something - (make-space-requirement - :width (max width 50) - :min-width (max min-width 50) - :max-width (max max-width 50) - :height (max height 50) - :min-height (max min-height 50) - :max-height (max max-height 50)) - sr)))) - -;;--- Ideally we should use a toolkit scrolling window. This will look -;;--- exactly right and will deal with user specified placement of scroll-bars. -;;--- However the geometry management problems are quite huge. -(defmethod initialize-instance :after ((pane generic-scroller-pane) - &key contents frame-manager frame - scroll-bars) - (let ((scroller (gadget-supplied-scrolling frame-manager frame contents - :scroll-bars scroll-bars))) - (if scroller - (progn - (sheet-adopt-child pane scroller) - (setf (slot-value pane 'scrolling-supplied-by-gadget) t) - scroller) - (progn - (check-type scroll-bars - (member t :both :dynamic :vertical :horizontal)) - (with-slots (vertical-scroll-bar horizontal-scroll-bar - (c contents) viewport foreground background) pane - (with-look-and-feel-realization (frame-manager frame) - (let ((verticalp - (member scroll-bars '(t :both :dynamic :vertical))) - (horizontalp - (member scroll-bars '(t :both :dynamic :horizontal)))) - (setf vertical-scroll-bar - (and verticalp - (make-pane 'scroll-bar - :orientation :vertical - :id :vertical - :client pane - :background background - :foreground foreground - :shared-medium-sheet pane)) - horizontal-scroll-bar - (and horizontalp - (make-pane 'scroll-bar - :orientation :horizontal - :id :horizontal - :background background - :foreground foreground - :client pane - :shared-medium-sheet pane)) - c contents - viewport (make-pane 'viewport :scroller-pane pane)) - (sheet-adopt-child - pane - (cond ((and horizontalp verticalp) - (tabling () - (viewport vertical-scroll-bar) - (horizontal-scroll-bar nil))) - (verticalp - (horizontally () - viewport - vertical-scroll-bar)) - (horizontalp - (vertically () - viewport - horizontal-scroll-bar)) - (t (error "Internal error laying out scroll bars")))) - (sheet-adopt-child viewport c) - ;;--- Add callbacks - ))))))) - (defvar *inhibit-updating-scroll-bars* nil) (defmacro inhibit-updating-scroll-bars ((stream) &body body) `(unwind-protect @@ -359,440 +257,9 @@ (note-viewport-position-changed frame sheet)))))))) (defmethod note-viewport-position-changed (frame pane) + (declare (ignore frame pane)) nil) - -;;; Home-grown scroll bars - -(defparameter *scroll-shaft-thickness-ink* 12) - -;;--- unit-increment, page-increment. -(defclass scroll-bar-pane - (scroll-bar - sheet-permanently-enabled-mixin - wrapping-space-mixin - immediate-sheet-input-mixin - sheet-multiple-child-mixin - space-requirement-mixin - shared-medium-sheet-output-mixin - basic-pane) - ((shaft-thickness :initarg :shaft-thickness) - (min-target-pane :initform nil) - (max-target-pane :initform nil) - (shaft-pane :initform nil)) - (:default-initargs :value 0 - :shaft-thickness *scroll-shaft-thickness-ink*)) - -(defmethod initialize-instance :after ((pane scroll-bar-pane) - &key orientation shaft-thickness - frame-manager frame) - (with-slots (min-target-pane max-target-pane shaft-pane - shared-medium-sheet foreground background) pane - (with-look-and-feel-realization (frame-manager frame) - (let ((inferiors - (ecase orientation - (:vertical - (spacing (:thickness 1) - (vertically () - (setq min-target-pane - (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :less-than - :width shaft-thickness - :height shaft-thickness - :background background - :foreground foreground - :shared-medium-sheet shared-medium-sheet)) - (setq shaft-pane - (make-pane 'scroll-bar-shaft-pane - :scroll-bar pane - :width shaft-thickness - :height 0 - :max-height +fill+ - :background background - :foreground foreground - :shared-medium-sheet shared-medium-sheet)) - (setq max-target-pane - (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :greater-than - :width shaft-thickness - :height shaft-thickness - :background background - :foreground foreground - :shared-medium-sheet shared-medium-sheet))))) - (:horizontal - (spacing (:thickness 1) - (horizontally () - (setq min-target-pane - (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :less-than - :width shaft-thickness - :height shaft-thickness - :background background - :foreground foreground - :shared-medium-sheet shared-medium-sheet)) - (setq shaft-pane - (make-pane 'scroll-bar-shaft-pane - :scroll-bar pane - :width 0 - :max-width +fill+ - :height shaft-thickness - :background background - :foreground foreground - :shared-medium-sheet shared-medium-sheet)) - (setq max-target-pane - (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :greater-than - :width shaft-thickness - :height shaft-thickness - :background background - :foreground foreground - :shared-medium-sheet shared-medium-sheet)))))))) - (sheet-adopt-child pane inferiors))))) - -(defmethod handle-event :after ((pane scroll-bar-pane) (event pointer-event)) - (deallocate-event event)) - - -(defmethod contents-range ((scroller scroller-pane) orientation) - (with-slots (viewport) scroller - (with-bounding-rectangle* (left top right bottom) - (viewport-contents-extent viewport) - (ecase orientation - (:horizontal (- right left)) - (:vertical (- bottom top)))))) - -(defmethod viewport-range ((scroller scroller-pane) orientation) - (with-slots (viewport) scroller - (with-bounding-rectangle* (left top right bottom) - (viewport-viewport-region viewport) - (ecase orientation - (:horizontal (- right left)) - (:vertical (- bottom top)))))) - -(defmethod line-scroll-amount ((pane scroller-pane) orientation direction) - (declare (ignore direction)) - (with-slots (contents) pane - (let ((style (medium-text-style contents))) - ;; --- These are the stubs for user specified line scroll amounts - ;; req by graphic panes. I haven't enabled them because I want to - ;; check with SWM for the MAKE-PANE protocol for these. Davo 6/30/92 - (ecase orientation - (:horizontal (or #+++ignore horizontal-line-scroll-amount - (text-style-width style contents))) - (:vertical (or #+++ignore vertical-line-scroll-amount - ;; --- This should check the top or bottom line - ;; of the viewport for its line height to - ;; determine the scroll amount - this is the - ;; reason for the direction arg. Davo 6/30/92 - (+ (text-style-height style contents) - (if (extended-output-stream-p contents) - (stream-vertical-spacing contents) - 0)))))))) - -(defmethod scroll-up-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) - (with-slots (current-size current-value port) scroll-bar - (with-slots (viewport contents) scroller-pane - (let* ((contents-range (contents-range scroller-pane orientation)) - (line-value (if (= contents-range 0) - 0 - (the single-float - (/ (line-scroll-amount scroller-pane orientation :up) - (float contents-range 0.0s0))))) - (new-value (max 0.0 (- current-value line-value)))) - (scroll-bar-value-changed-callback - scroll-bar scroller-pane orientation new-value current-size))))) - -(defmethod scroll-down-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) - (with-slots (current-size current-value port) scroll-bar - (with-slots (viewport contents) scroller-pane - (let* ((contents-range (contents-range scroller-pane orientation)) - (line-value (if (= contents-range 0) - 0 - (the single-float - (/ (line-scroll-amount scroller-pane orientation :down) - (float contents-range 0.0s0))))) - (new-value (min (- 1.0 current-size) (+ current-value line-value)))) - (scroll-bar-value-changed-callback - scroll-bar scroller-pane orientation new-value current-size))))) - -(defmethod scroll-up-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) - (with-slots (current-size current-value) scroll-bar - (with-slots (viewport contents) scroller-pane - (let* ((contents-range (contents-range scroller-pane orientation)) - (viewport-range (bounding-rectangle-max-y viewport)) - new-value) - (if (zerop contents-range) - (setq new-value current-value) - (let ((page-value (the single-float - (/ viewport-range (float contents-range 0.0s0))))) - (setq new-value (max 0.0 (- current-value page-value))))) - (scroll-bar-value-changed-callback - scroll-bar scroller-pane orientation new-value current-size))))) - -(defmethod scroll-down-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) - (with-slots (current-size current-value) scroll-bar - (with-slots (viewport contents) scroller-pane - (let* ((contents-range (contents-range scroller-pane orientation)) - (viewport-range (bounding-rectangle-max-y viewport)) - new-value) - (if (zerop contents-range) - (setq new-value current-value) - (let ((page-value (the single-float - (/ viewport-range (float contents-range 0.0s0))))) - (setq new-value (min (- 1.0 current-size) (+ current-value page-value))))) - (scroll-bar-value-changed-callback - scroll-bar scroller-pane orientation new-value current-size))))) - -(defmethod scroll-to-top-callback ((scroll-bar scroll-bar-pane) client id) - (with-slots (current-size current-value) scroll-bar - (scroll-bar-value-changed-callback scroll-bar client id 0 current-size))) - -(defmethod scroll-to-bottom-callback ((scroll-bar scroll-bar-pane) client id) - (with-slots (current-size current-value) scroll-bar - (scroll-bar-value-changed-callback - scroll-bar client id (- 1.0 current-size) current-size))) - -(defmethod scroll-line-to-top-callback ((scroll-bar scroll-bar-pane) - scroller-pane id orientation x y) - (with-slots (current-size current-value) scroll-bar - (with-slots (viewport contents) scroller-pane - ;; --- scroll-bar may not be the right thing if it's not the same - ;; size as the contents pane - Davo 6/30/92. - (with-bounding-rectangle* (left top right bottom) - (sheet-region scroll-bar) - (with-bounding-rectangle* (vleft vtop vright vbottom) - (viewport-viewport-region viewport) - (declare (ignore vright vbottom)) - (with-bounding-rectangle* (cleft ctop cright cbottom) - (viewport-contents-extent viewport) - (declare (ignore cright cbottom)) - (let ((contents-range (contents-range scroller-pane orientation))) - (unless (zerop contents-range) - (let* ((viewport-range (viewport-range scroller-pane orientation)) - (contents-min - (ecase orientation (:horizontal cleft) (:vertical ctop))) - (viewport-min - (ecase orientation (:horizontal vleft) (:vertical vtop))) - (mouse-offset - (ecase orientation - (:vertical (/ (- y top) (float (- bottom top) 0.0s0))) - (:horizontal (/ (- x left) (float (- right left) 0.0s0))))) - (pos (/ (- (+ viewport-min (* viewport-range mouse-offset)) - contents-min) - contents-range))) - (scroll-bar-value-changed-callback - scroll-bar scroller-pane id - (min (- 1.0 current-size) pos) current-size)))))))))) - -(defmethod scroll-line-to-bottom-callback ((scroll-bar scroll-bar-pane) - scroller-pane id orientation x y) - (with-slots (current-size current-value) scroll-bar - (with-slots (viewport contents) scroller-pane - ;; --- scroll-bar may not be the right thing if its not the same - ;; size as the contents pane - Davo 6/30/92. - (with-bounding-rectangle* (left top right bottom) - (sheet-region scroll-bar) - (with-bounding-rectangle* (vleft vtop vright vbottom) - (viewport-viewport-region viewport) - (declare (ignore vright vbottom)) - (with-bounding-rectangle* (cleft ctop cright cbottom) - (viewport-contents-extent viewport) - (declare (ignore cright cbottom)) - (let ((contents-range (contents-range scroller-pane orientation))) - (unless (zerop contents-range) - (let* ((viewport-range (viewport-range scroller-pane orientation)) - (contents-min - (ecase orientation (:horizontal cleft) (:vertical ctop))) - (viewport-min - (ecase orientation (:horizontal vleft) (:vertical vtop))) - (mouse-offset - (ecase orientation - (:vertical (/ (- y top) (float (- bottom top) 0.0s0))) - (:horizontal (/ (- x left) (float (- right left) 0.0s0))))) - (pos (/ (- (+ viewport-min (* viewport-range mouse-offset)) - viewport-range contents-min) - contents-range))) - (scroll-bar-value-changed-callback - scroll-bar scroller-pane id (max 0 pos) current-size)))))))))) - -(defmethod scroll-elevator-callback ((scroll-bar scroll-bar-pane) - scroller-pane id orientation x y) - (with-slots (current-size current-value) scroll-bar - (with-slots (viewport contents) scroller-pane - ;; --- scroll-bar may not be the right thing if its not the same - ;; size as the contents pane - Davo 6/30/92. - (with-bounding-rectangle* (left top right bottom) - (sheet-region scroll-bar) - (let* ((mouse-offset - (- (ecase orientation - (:vertical (/ (- y top) (float (- bottom top) 0.0s0))) - (:horizontal (/ (- x left) (float (- right left) 0.0s0)))) - (/ current-size 2.0s0)))) - (scroll-bar-value-changed-callback - scroll-bar scroller-pane id (min 1.0s0 (max 0.0s0 mouse-offset)) current-size)))))) - -;;; Set the indicator to the proper size and location (size and value are between 0 and 1) -(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane) - &key slider-size value) - (setf (gadget-value scroll-bar) value) - (setf (scroll-bar-current-size scroll-bar) slider-size)) - - -(defclass scroll-bar-target-pane - (immediate-sheet-input-mixin - space-requirement-mixin - sheet-single-child-mixin - shared-medium-sheet-output-mixin - foreground-background-and-text-style-mixin - pane-repaint-background-mixin - leaf-pane) - ((end :initarg :end) - (scroll-bar :initarg :scroll-bar) - (coord-cache :initform nil))) - -(defmethod initialize-instance :after ((pane scroll-bar-target-pane) &key end) - (let* ((scroll-bar (slot-value pane 'scroll-bar)) - (orientation (gadget-orientation scroll-bar))) - (setf (slot-value pane 'pointer-cursor) - (ecase end - (:less-than - (ecase orientation - (:horizontal :scroll-left) - (:vertical :scroll-up))) - (:greater-than - (ecase orientation - (:horizontal :scroll-right) - (:vertical :scroll-down))))))) - -(defmethod note-sheet-region-changed :after ((pane scroll-bar-target-pane) - &key &allow-other-keys) - (setf (slot-value pane 'coord-cache) nil)) - -(defmethod handle-repaint ((pane scroll-bar-target-pane) region) - (declare (ignore region)) - (with-sheet-medium (medium pane) - (with-bounding-rectangle* (left top right bottom) (sheet-region pane) - (draw-rectangle* medium left top (1- right) (1- bottom) - :filled nil :ink (medium-foreground medium))) - (draw-target pane medium))) - -;;; You can pass :FILLED T to this in order to highlight the target when clicked on... -(defmethod draw-target ((pane scroll-bar-target-pane) medium - &key filled (ink +foreground-ink+)) - (let ((coord-cache (slot-value pane 'coord-cache))) - (unless coord-cache - (let ((identity (sheet-pointer-cursor pane))) - (setq coord-cache - (setf (slot-value pane 'coord-cache) - (with-bounding-rectangle* (left top right bottom) (sheet-region pane) - ;; This seems to be a kludge to deal with roundoff? - (decf right) (decf bottom) - ;; Indent the target arrows a little for aesthetic purposes - (incf left 2) (decf right 2) - (incf top 2) (decf bottom 2) - (ecase identity - (:scroll-up - (list left bottom - (+ left (/ (- right left) 2)) top - right bottom)) - (:scroll-down - (list left top - (+ left (/ (- right left) 2)) bottom - right top)) - (:scroll-left - (list right top - left (/ (+ top bottom) 2) - right bottom)) - (:scroll-right - (list left top - right (/ (+ top bottom) 2) - left bottom)))))))) - (draw-polygon* medium coord-cache :filled filled :ink ink))) - -(defclass scroll-bar-shaft-pane - (immediate-sheet-input-mixin - space-requirement-mixin - sheet-single-child-mixin - shared-medium-sheet-output-mixin - foreground-background-and-text-style-mixin - pane-repaint-background-mixin - leaf-pane) - ((scroll-bar :initarg :scroll-bar) - (needs-erase :initform nil))) - -(defmethod initialize-instance :after ((pane scroll-bar-shaft-pane) &key) - (let* ((scroll-bar (slot-value pane 'scroll-bar)) - (orientation (gadget-orientation scroll-bar))) - (setf (slot-value pane 'pointer-cursor) - (ecase orientation - (:horizontal :horizontal-scroll) - (:vertical :vertical-scroll))))) - -(defmethod handle-repaint ((pane scroll-bar-shaft-pane) region) - (declare (ignore region)) - (with-sheet-medium (medium pane) - (with-bounding-rectangle* (left top right bottom) (sheet-region pane) - (draw-rectangle* medium left top (1- right) (1- bottom) - :filled nil :ink (medium-foreground medium))) - (draw-thumb pane medium))) - -(defparameter *scroll-bar-thumb-ink* (make-gray-color 2/3)) - -(defmethod draw-thumb ((pane scroll-bar-shaft-pane) medium - &key (ink +foreground-ink+)) - (let ((needs-erase (slot-value pane 'needs-erase))) - (setf (slot-value pane 'needs-erase) (not (eq ink +background-ink+))) - (when (and (not needs-erase) - (eq ink +background-ink+)) - (return-from draw-thumb (values)))) - (let* ((scroll-bar (slot-value pane 'scroll-bar)) - (scroll-value (gadget-value scroll-bar)) - (min-value (gadget-min-value scroll-bar)) - (max-value (gadget-max-value scroll-bar)) - (gadget-size (or (scroll-bar-current-size scroll-bar) 0)) - (gadget-range (abs (- max-value min-value))) - (identity (sheet-pointer-cursor pane))) - (flet ((draw-car (medium left top right bottom which) - (decf right) (decf bottom) - (draw-rectangle* medium left top right bottom - :filled t - :ink (if (eq ink +foreground-ink+) *scroll-bar-thumb-ink* ink)) - (case which - (:vertical-scroll - (draw-line* medium left top right top :ink ink) - (draw-line* medium left bottom right bottom :ink ink)) - (:horizontal-scroll - (draw-line* medium left bottom left top :ink ink) - (draw-line* medium right bottom right top :ink ink))))) - (declare (dynamic-extent #'draw-car)) - (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) - (let* ((height (- y2 y1)) - (width (- x2 x1)) - (scroll-range (ecase identity - (:vertical-scroll height) - (:horizontal-scroll width))) - (car-size (max 10 (* scroll-range (/ gadget-size gadget-range)))) - (elevator-top (compute-symmetric-value - min-value max-value scroll-value 0 - scroll-range)) - (elevator-bottom (+ elevator-top car-size))) - (ecase identity - (:vertical-scroll - (draw-car medium - (+ x1 1) (+ y1 elevator-top) - (+ x1 width -1) (+ y1 elevator-bottom) - identity)) - (:horizontal-scroll - (draw-car medium - elevator-top (+ y1 1) - elevator-bottom (+ y1 height -1) - identity)))))))) - - ;;; Given min1, max1 and value1 which is between them it will return ;;; value2 which would be proportionally between min2 and max2. (defun compute-symmetric-value (min1 max1 value1 min2 max2) @@ -801,122 +268,3 @@ (fraction1 (if (zerop distance1) 0 (/ (- value1 min1) distance1)))) (let ((x (+ min2 (* (- max2 min2) fraction1)))) (if (integerp x) x (float x))))) - -(defmethod handle-event :around ((pane scroll-bar-target-pane) - (event pointer-button-press-event)) - (with-sheet-medium (medium pane) - (draw-target pane medium :filled t :ink +foreground-ink+) - (call-next-method) - (draw-target pane medium :filled t :ink +background-ink+) - (draw-target pane medium :filled nil))) - - -;;; This implements genera style scroll bars. -;;; Vertical Scroll bars -;;; Top Target -;;; Left: Next Line Middle: First Page Right: Previous Line -;;; Bottom Target -;;; Left: Next Page Middle: Last Page Right: Previous Page -(defmethod handle-event ((pane scroll-bar-target-pane) - (event pointer-button-press-event)) - (let* ((scroll-bar (slot-value pane 'scroll-bar)) - (client (gadget-client scroll-bar)) - (id (gadget-id scroll-bar))) - (case (pointer-event-button event) - (#.+pointer-left-button+ - (ecase (slot-value pane 'end) - (:greater-than - (scroll-down-page-callback scroll-bar client id)) - (:less-than - (scroll-down-line-callback scroll-bar client id)))) - (#.+pointer-middle-button+ - (ecase (slot-value pane 'end) - (:greater-than - (scroll-to-bottom-callback scroll-bar client id)) - (:less-than - (scroll-to-top-callback scroll-bar client id)))) - (#.+pointer-right-button+ - (ecase (slot-value pane 'end) - (:greater-than - (scroll-up-page-callback scroll-bar client id)) - (:less-than - (scroll-up-line-callback scroll-bar client id))))))) - -(defmethod handle-event ((pane scroll-bar-shaft-pane) - (event pointer-button-press-event)) - (let* ((x (pointer-event-x event)) - (y (pointer-event-y event)) - (scroll-bar (slot-value pane 'scroll-bar)) - (client (gadget-client scroll-bar)) - (id (gadget-id scroll-bar)) - (orientation (gadget-orientation scroll-bar))) - (case (pointer-event-button event) - (#.+pointer-left-button+ - (scroll-line-to-top-callback - scroll-bar client id orientation x y)) - (#.+pointer-right-button+ - (scroll-line-to-bottom-callback - scroll-bar client id orientation x (- (bounding-rectangle-height scroll-bar) y))) - (#.+pointer-middle-button+ - (scroll-elevator-callback - scroll-bar client id orientation x y))))) - -(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-enter-event)) - (frame-manager-display-pointer-documentation-string - (frame-manager pane) *pointer-documentation-output* - (ecase (gadget-orientation (slot-value pane 'scroll-bar)) - (:vertical - "L: This line to top; M: Proportional scrolling; R: Top line to here.") - (:horizontal - "L: This column to left edge; M: Proportional scrolling; R: Left edge to here.")))) - -(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-enter-event)) - (frame-manager-display-pointer-documentation-string - (frame-manager pane) *pointer-documentation-output* - (ecase (gadget-orientation (slot-value pane 'scroll-bar)) - (:vertical - (ecase (slot-value pane 'end) - (:greater-than - "L: Next screenful; M: Last screenful; R: previous screenful.") - (:less-than - "L: Next line; M: First screenful; R: Previous line."))) - (:horizontal - (ecase (slot-value pane 'end) - (:greater-than - "L: Next screenful; M: Last screenful; R: previous screenful.") - (:less-than - "L: Next column; M: First screenful; R: Previous column.")))))) - -(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-exit-event)) - (frame-manager-display-pointer-documentation-string - (frame-manager pane) *pointer-documentation-output* nil)) - -(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-exit-event)) - (frame-manager-display-pointer-documentation-string - (frame-manager pane) *pointer-documentation-output* nil)) - -(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-event)) - (deallocate-event event)) - -(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-event)) - (deallocate-event event)) - -(defmethod update-scroll-bar-value ((pane scroll-bar-shaft-pane) scroll-bar coord min max) - (let* ((min-value (gadget-min-value scroll-bar)) - (max-value (gadget-max-value scroll-bar)) - (value (compute-symmetric-value min max coord min-value max-value))) - (setf (gadget-value scroll-bar) value))) - -(defmethod (setf gadget-value) (value (pane scroll-bar-pane) &key invoke-callback) - (declare (ignore invoke-callback)) - (setf (slot-value pane 'value) value)) - -(defmethod (setf gadget-value) :around (value (pane scroll-bar-pane) &key invoke-callback) - (declare (ignore value invoke-callback)) - (if (port pane) - (let ((shaft-pane (slot-value pane 'shaft-pane))) - (with-sheet-medium (medium shaft-pane) - (draw-thumb shaft-pane medium :ink +background-ink+) - (call-next-method) - (draw-thumb shaft-pane medium :ink +foreground-ink+))) - (call-next-method))) diff --git a/silica/port.lisp b/silica/port.lisp index a288041dcd103de5000f7c99a2b4fdee8e2b2218..743856ab23d4bd8f37258acfa78b403c60baa67d 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: port.lisp,v 1.25 92/11/19 14:25:03 cer Exp $ +;; $fiHeader: port.lisp,v 1.26 92/12/01 09:46:29 cer Exp $ (in-package :silica) @@ -136,6 +136,17 @@ (defgeneric remove-watcher (port watcher)) (defgeneric reset-watcher (watcher how)) +(define-event-class port-terminated (window-manager-event) + ((condition :initarg :condition :reader port-terminated-condition))) + +(defmethod port-terminated ((port basic-port) condition) + ;;--- Should mark it as dead + (setq *ports* (delete port *ports*)) + (dolist (graft (port-grafts port)) + (dolist (sheet (sheet-children graft)) + (queue-event sheet (make-instance 'port-terminated + :condition condition + :sheet sheet))))) ;;;;;;;;;;;;;;;; diff --git a/silica/scroll-pane.lisp b/silica/scroll-pane.lisp new file mode 100644 index 0000000000000000000000000000000000000000..83f9c71092cb308f08d73fbc733fd3a6cf9372c7 --- /dev/null +++ b/silica/scroll-pane.lisp @@ -0,0 +1,666 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- + +;; $fiHeader: db-scroll.lisp,v 1.36 92/12/01 09:46:20 cer Exp $ + +"Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. + Portions copyright(c) 1991, 1992 International Lisp Associates. + Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." + +(in-package :silica) + +;; An implementation of a scroller pane +(defclass generic-scroller-pane (scroller-pane + client-space-requirement-mixin + wrapping-space-mixin + permanent-medium-sheet-output-mixin + pane-repaint-background-mixin + layout-pane) + ()) + +(defmethod handle-event :after ((pane generic-scroller-pane) (event pointer-motion-event)) + (deallocate-event event)) + +(defmethod allocate-space :before ((scroller generic-scroller-pane) width height) + (declare (ignore width height)) + ;; Adjust the status of the scrollbars + (multiple-value-bind (changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p) + (compute-dynamic-scroll-bar-values scroller) + (when changedp + (update-dynamic-scroll-bars scroller changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p)))) + +(defmethod compose-space ((scroller generic-scroller-pane) &key width height) + (declare (ignore width height)) + (let ((sr (call-next-method))) + (multiple-value-bind (width min-width max-width + height min-height max-height) + (space-requirement-components sr) + (if (or (< width 50) (< height 50)) + ;; Make sure the scroller pane is big enough to hold something + (make-space-requirement + :width (max width 50) + :min-width (max min-width 50) + :max-width (max max-width 50) + :height (max height 50) + :min-height (max min-height 50) + :max-height (max max-height 50)) + sr)))) + +;;--- Ideally we should use a toolkit scrolling window. This will look +;;--- exactly right and will deal with user specified placement of scroll-bars. +;;--- However the geometry management problems are quite huge. +(defmethod initialize-instance :after ((pane generic-scroller-pane) + &key contents frame-manager frame + scroll-bars) + (let ((scroller (gadget-supplied-scrolling frame-manager frame contents + :scroll-bars scroll-bars))) + (if scroller + (progn + (sheet-adopt-child pane scroller) + (setf (slot-value pane 'scrolling-supplied-by-gadget) t) + scroller) + (progn + (check-type scroll-bars + (member t :both :dynamic :vertical :horizontal)) + (with-slots (vertical-scroll-bar horizontal-scroll-bar + (c contents) viewport foreground background) pane + (with-look-and-feel-realization (frame-manager frame) + (let ((verticalp + (member scroll-bars '(t :both :dynamic :vertical))) + (horizontalp + (member scroll-bars '(t :both :dynamic :horizontal)))) + (setf vertical-scroll-bar + (and verticalp + (make-pane 'scroll-bar + :orientation :vertical + :id :vertical + :client pane + :background background + :foreground foreground + :shared-medium-sheet pane)) + horizontal-scroll-bar + (and horizontalp + (make-pane 'scroll-bar + :orientation :horizontal + :id :horizontal + :background background + :foreground foreground + :client pane + :shared-medium-sheet pane)) + c contents + viewport (make-pane 'viewport :scroller-pane pane)) + (sheet-adopt-child + pane + (cond ((and horizontalp verticalp) + (tabling () + (viewport vertical-scroll-bar) + (horizontal-scroll-bar nil))) + (verticalp + (horizontally () + viewport + vertical-scroll-bar)) + (horizontalp + (vertically () + viewport + horizontal-scroll-bar)) + (t (error "Internal error laying out scroll bars")))) + (sheet-adopt-child viewport c) + ;;--- Add callbacks + ))))))) + +;;; Home-grown scroll bars + +(defparameter *scroll-shaft-thickness-ink* 12) + +;;--- unit-increment, page-increment. +(defclass scroll-bar-pane + (scroll-bar + sheet-permanently-enabled-mixin + wrapping-space-mixin + immediate-sheet-input-mixin + sheet-multiple-child-mixin + space-requirement-mixin + shared-medium-sheet-output-mixin + basic-pane) + ((shaft-thickness :initarg :shaft-thickness) + (min-target-pane :initform nil) + (max-target-pane :initform nil) + (shaft-pane :initform nil)) + (:default-initargs :value 0 + :shaft-thickness *scroll-shaft-thickness-ink*)) + +(defmethod initialize-instance :after ((pane scroll-bar-pane) + &key orientation shaft-thickness + frame-manager frame) + (with-slots (min-target-pane max-target-pane shaft-pane + shared-medium-sheet foreground background) pane + (with-look-and-feel-realization (frame-manager frame) + (let ((inferiors + (ecase orientation + (:vertical + (spacing (:thickness 1) + (vertically () + (setq min-target-pane + (make-pane 'scroll-bar-target-pane + :scroll-bar pane + :end :less-than + :width shaft-thickness + :height shaft-thickness + :background background + :foreground foreground + :shared-medium-sheet shared-medium-sheet)) + (setq shaft-pane + (make-pane 'scroll-bar-shaft-pane + :scroll-bar pane + :width shaft-thickness + :height 0 + :max-height +fill+ + :background background + :foreground foreground + :shared-medium-sheet shared-medium-sheet)) + (setq max-target-pane + (make-pane 'scroll-bar-target-pane + :scroll-bar pane + :end :greater-than + :width shaft-thickness + :height shaft-thickness + :background background + :foreground foreground + :shared-medium-sheet shared-medium-sheet))))) + (:horizontal + (spacing (:thickness 1) + (horizontally () + (setq min-target-pane + (make-pane 'scroll-bar-target-pane + :scroll-bar pane + :end :less-than + :width shaft-thickness + :height shaft-thickness + :background background + :foreground foreground + :shared-medium-sheet shared-medium-sheet)) + (setq shaft-pane + (make-pane 'scroll-bar-shaft-pane + :scroll-bar pane + :width 0 + :max-width +fill+ + :height shaft-thickness + :background background + :foreground foreground + :shared-medium-sheet shared-medium-sheet)) + (setq max-target-pane + (make-pane 'scroll-bar-target-pane + :scroll-bar pane + :end :greater-than + :width shaft-thickness + :height shaft-thickness + :background background + :foreground foreground + :shared-medium-sheet shared-medium-sheet)))))))) + (sheet-adopt-child pane inferiors))))) + +(defmethod handle-event :after ((pane scroll-bar-pane) (event pointer-event)) + (deallocate-event event)) + + +(defmethod contents-range ((scroller generic-scroller-pane) orientation) + (with-slots (viewport) scroller + (with-bounding-rectangle* (left top right bottom) + (viewport-contents-extent viewport) + (ecase orientation + (:horizontal (- right left)) + (:vertical (- bottom top)))))) + +(defmethod viewport-range ((scroller generic-scroller-pane) orientation) + (with-slots (viewport) scroller + (with-bounding-rectangle* (left top right bottom) + (viewport-viewport-region viewport) + (ecase orientation + (:horizontal (- right left)) + (:vertical (- bottom top)))))) + +(defmethod line-scroll-amount ((pane scroller-pane) orientation direction) + (declare (ignore direction)) + (with-slots (contents) pane + (let ((style (medium-text-style contents))) + ;; --- These are the stubs for user specified line scroll amounts + ;; req by graphic panes. I haven't enabled them because I want to + ;; check with SWM for the MAKE-PANE protocol for these. Davo 6/30/92 + (ecase orientation + (:horizontal (or #+++ignore horizontal-line-scroll-amount + (text-style-width style contents))) + (:vertical (or #+++ignore vertical-line-scroll-amount + ;; --- This should check the top or bottom line + ;; of the viewport for its line height to + ;; determine the scroll amount - this is the + ;; reason for the direction arg. Davo 6/30/92 + (+ (text-style-height style contents) + (if (extended-output-stream-p contents) + (stream-vertical-spacing contents) + 0)))))))) + +(defmethod scroll-up-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) + (with-slots (current-size current-value port) scroll-bar + (with-slots (viewport contents) scroller-pane + (let* ((contents-range (contents-range scroller-pane orientation)) + (line-value (if (= contents-range 0) + 0 + (the single-float + (/ (line-scroll-amount scroller-pane orientation :up) + (float contents-range 0.0s0))))) + (new-value (max 0.0 (- current-value line-value)))) + (scroll-bar-value-changed-callback + scroll-bar scroller-pane orientation new-value current-size))))) + +(defmethod scroll-down-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) + (with-slots (current-size current-value port) scroll-bar + (with-slots (viewport contents) scroller-pane + (let* ((contents-range (contents-range scroller-pane orientation)) + (line-value (if (= contents-range 0) + 0 + (the single-float + (/ (line-scroll-amount scroller-pane orientation :down) + (float contents-range 0.0s0))))) + (new-value (min (- 1.0 current-size) (+ current-value line-value)))) + (scroll-bar-value-changed-callback + scroll-bar scroller-pane orientation new-value current-size))))) + +(defmethod scroll-up-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) + (with-slots (current-size current-value) scroll-bar + (with-slots (viewport contents) scroller-pane + (let* ((contents-range (contents-range scroller-pane orientation)) + (viewport-range (bounding-rectangle-max-y viewport)) + new-value) + (if (zerop contents-range) + (setq new-value current-value) + (let ((page-value (the single-float + (/ viewport-range (float contents-range 0.0s0))))) + (setq new-value (max 0.0 (- current-value page-value))))) + (scroll-bar-value-changed-callback + scroll-bar scroller-pane orientation new-value current-size))))) + +(defmethod scroll-down-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation) + (with-slots (current-size current-value) scroll-bar + (with-slots (viewport contents) scroller-pane + (let* ((contents-range (contents-range scroller-pane orientation)) + (viewport-range (bounding-rectangle-max-y viewport)) + new-value) + (if (zerop contents-range) + (setq new-value current-value) + (let ((page-value (the single-float + (/ viewport-range (float contents-range 0.0s0))))) + (setq new-value (min (- 1.0 current-size) (+ current-value page-value))))) + (scroll-bar-value-changed-callback + scroll-bar scroller-pane orientation new-value current-size))))) + +(defmethod scroll-to-top-callback ((scroll-bar scroll-bar-pane) client id) + (with-slots (current-size current-value) scroll-bar + (scroll-bar-value-changed-callback scroll-bar client id 0 current-size))) + +(defmethod scroll-to-bottom-callback ((scroll-bar scroll-bar-pane) client id) + (with-slots (current-size current-value) scroll-bar + (scroll-bar-value-changed-callback + scroll-bar client id (- 1.0 current-size) current-size))) + +(defmethod scroll-line-to-top-callback ((scroll-bar scroll-bar-pane) + scroller-pane id orientation x y) + (with-slots (current-size current-value) scroll-bar + (with-slots (viewport contents) scroller-pane + ;; --- scroll-bar may not be the right thing if it's not the same + ;; size as the contents pane - Davo 6/30/92. + (with-bounding-rectangle* (left top right bottom) + (sheet-region scroll-bar) + (with-bounding-rectangle* (vleft vtop vright vbottom) + (viewport-viewport-region viewport) + (declare (ignore vright vbottom)) + (with-bounding-rectangle* (cleft ctop cright cbottom) + (viewport-contents-extent viewport) + (declare (ignore cright cbottom)) + (let ((contents-range (contents-range scroller-pane orientation))) + (unless (zerop contents-range) + (let* ((viewport-range (viewport-range scroller-pane orientation)) + (contents-min + (ecase orientation (:horizontal cleft) (:vertical ctop))) + (viewport-min + (ecase orientation (:horizontal vleft) (:vertical vtop))) + (mouse-offset + (ecase orientation + (:vertical (/ (- y top) (float (- bottom top) 0.0s0))) + (:horizontal (/ (- x left) (float (- right left) 0.0s0))))) + (pos (/ (- (+ viewport-min (* viewport-range mouse-offset)) + contents-min) + contents-range))) + (scroll-bar-value-changed-callback + scroll-bar scroller-pane id + (min (- 1.0 current-size) pos) current-size)))))))))) + +(defmethod scroll-line-to-bottom-callback ((scroll-bar scroll-bar-pane) + scroller-pane id orientation x y) + (with-slots (current-size current-value) scroll-bar + (with-slots (viewport contents) scroller-pane + ;; --- scroll-bar may not be the right thing if its not the same + ;; size as the contents pane - Davo 6/30/92. + (with-bounding-rectangle* (left top right bottom) + (sheet-region scroll-bar) + (with-bounding-rectangle* (vleft vtop vright vbottom) + (viewport-viewport-region viewport) + (declare (ignore vright vbottom)) + (with-bounding-rectangle* (cleft ctop cright cbottom) + (viewport-contents-extent viewport) + (declare (ignore cright cbottom)) + (let ((contents-range (contents-range scroller-pane orientation))) + (unless (zerop contents-range) + (let* ((viewport-range (viewport-range scroller-pane orientation)) + (contents-min + (ecase orientation (:horizontal cleft) (:vertical ctop))) + (viewport-min + (ecase orientation (:horizontal vleft) (:vertical vtop))) + (mouse-offset + (ecase orientation + (:vertical (/ (- y top) (float (- bottom top) 0.0s0))) + (:horizontal (/ (- x left) (float (- right left) 0.0s0))))) + (pos (/ (- (+ viewport-min (* viewport-range mouse-offset)) + viewport-range contents-min) + contents-range))) + (scroll-bar-value-changed-callback + scroll-bar scroller-pane id (max 0 pos) current-size)))))))))) + +(defmethod scroll-elevator-callback ((scroll-bar scroll-bar-pane) + scroller-pane id orientation x y) + (with-slots (current-size current-value) scroll-bar + (with-slots (viewport contents) scroller-pane + ;; --- scroll-bar may not be the right thing if its not the same + ;; size as the contents pane - Davo 6/30/92. + (with-bounding-rectangle* (left top right bottom) + (sheet-region scroll-bar) + (let* ((mouse-offset + (- (ecase orientation + (:vertical (/ (- y top) (float (- bottom top) 0.0s0))) + (:horizontal (/ (- x left) (float (- right left) 0.0s0)))) + (/ current-size 2.0s0)))) + (scroll-bar-value-changed-callback + scroll-bar scroller-pane id (min 1.0s0 (max 0.0s0 mouse-offset)) current-size)))))) + + +;;; Set the indicator to the proper size and location (size and value are between 0 and 1) +(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane) + &key slider-size value) + (setf (gadget-value scroll-bar) value) + (setf (scroll-bar-current-size scroll-bar) slider-size)) + + + +(defclass scroll-bar-target-pane + (immediate-sheet-input-mixin + space-requirement-mixin + sheet-single-child-mixin + shared-medium-sheet-output-mixin + foreground-background-and-text-style-mixin + pane-repaint-background-mixin + leaf-pane) + ((end :initarg :end) + (scroll-bar :initarg :scroll-bar) + (coord-cache :initform nil))) + +(defmethod initialize-instance :after ((pane scroll-bar-target-pane) &key end) + (let* ((scroll-bar (slot-value pane 'scroll-bar)) + (orientation (gadget-orientation scroll-bar))) + (setf (slot-value pane 'pointer-cursor) + (ecase end + (:less-than + (ecase orientation + (:horizontal :scroll-left) + (:vertical :scroll-up))) + (:greater-than + (ecase orientation + (:horizontal :scroll-right) + (:vertical :scroll-down))))))) + +(defmethod note-sheet-region-changed :after ((pane scroll-bar-target-pane) + &key &allow-other-keys) + (setf (slot-value pane 'coord-cache) nil)) + +(defmethod handle-repaint ((pane scroll-bar-target-pane) region) + (declare (ignore region)) + (with-sheet-medium (medium pane) + (with-bounding-rectangle* (left top right bottom) (sheet-region pane) + (draw-rectangle* medium left top (1- right) (1- bottom) + :filled nil :ink (medium-foreground medium))) + (draw-target pane medium))) + +;;; You can pass :FILLED T to this in order to highlight the target when clicked on... +(defmethod draw-target ((pane scroll-bar-target-pane) medium + &key filled (ink +foreground-ink+)) + (let ((coord-cache (slot-value pane 'coord-cache))) + (unless coord-cache + (let ((identity (sheet-pointer-cursor pane))) + (setq coord-cache + (setf (slot-value pane 'coord-cache) + (with-bounding-rectangle* (left top right bottom) (sheet-region pane) + ;; This seems to be a kludge to deal with roundoff? + (decf right) (decf bottom) + ;; Indent the target arrows a little for aesthetic purposes + (incf left 2) (decf right 2) + (incf top 2) (decf bottom 2) + (ecase identity + (:scroll-up + (list left bottom + (+ left (/ (- right left) 2)) top + right bottom)) + (:scroll-down + (list left top + (+ left (/ (- right left) 2)) bottom + right top)) + (:scroll-left + (list right top + left (/ (+ top bottom) 2) + right bottom)) + (:scroll-right + (list left top + right (/ (+ top bottom) 2) + left bottom)))))))) + (draw-polygon* medium coord-cache :filled filled :ink ink))) + +(defclass scroll-bar-shaft-pane + (immediate-sheet-input-mixin + space-requirement-mixin + sheet-single-child-mixin + shared-medium-sheet-output-mixin + foreground-background-and-text-style-mixin + pane-repaint-background-mixin + leaf-pane) + ((scroll-bar :initarg :scroll-bar) + (needs-erase :initform nil))) + +(defmethod initialize-instance :after ((pane scroll-bar-shaft-pane) &key) + (let* ((scroll-bar (slot-value pane 'scroll-bar)) + (orientation (gadget-orientation scroll-bar))) + (setf (slot-value pane 'pointer-cursor) + (ecase orientation + (:horizontal :horizontal-scroll) + (:vertical :vertical-scroll))))) + +(defmethod handle-repaint ((pane scroll-bar-shaft-pane) region) + (declare (ignore region)) + (with-sheet-medium (medium pane) + (with-bounding-rectangle* (left top right bottom) (sheet-region pane) + (draw-rectangle* medium left top (1- right) (1- bottom) + :filled nil :ink (medium-foreground medium))) + (draw-thumb pane medium))) + +(defparameter *scroll-bar-thumb-ink* (make-gray-color 2/3)) + +(defmethod draw-thumb ((pane scroll-bar-shaft-pane) medium + &key (ink +foreground-ink+)) + (let ((needs-erase (slot-value pane 'needs-erase))) + (setf (slot-value pane 'needs-erase) (not (eq ink +background-ink+))) + (when (and (not needs-erase) + (eq ink +background-ink+)) + (return-from draw-thumb (values)))) + (let* ((scroll-bar (slot-value pane 'scroll-bar)) + (scroll-value (gadget-value scroll-bar)) + (min-value (gadget-min-value scroll-bar)) + (max-value (gadget-max-value scroll-bar)) + (gadget-size (or (scroll-bar-current-size scroll-bar) 0)) + (gadget-range (abs (- max-value min-value))) + (identity (sheet-pointer-cursor pane))) + (flet ((draw-car (medium left top right bottom which) + (decf right) (decf bottom) + (draw-rectangle* medium left top right bottom + :filled t + :ink (if (eq ink +foreground-ink+) *scroll-bar-thumb-ink* ink)) + (case which + (:vertical-scroll + (draw-line* medium left top right top :ink ink) + (draw-line* medium left bottom right bottom :ink ink)) + (:horizontal-scroll + (draw-line* medium left bottom left top :ink ink) + (draw-line* medium right bottom right top :ink ink))))) + (declare (dynamic-extent #'draw-car)) + (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) + (let* ((height (- y2 y1)) + (width (- x2 x1)) + (scroll-range (ecase identity + (:vertical-scroll height) + (:horizontal-scroll width))) + (car-size (max 10 (* scroll-range (/ gadget-size gadget-range)))) + (elevator-top (compute-symmetric-value + min-value max-value scroll-value 0 + scroll-range)) + (elevator-bottom (+ elevator-top car-size))) + (ecase identity + (:vertical-scroll + (draw-car medium + (+ x1 1) (+ y1 elevator-top) + (+ x1 width -1) (+ y1 elevator-bottom) + identity)) + (:horizontal-scroll + (draw-car medium + elevator-top (+ y1 1) + elevator-bottom (+ y1 height -1) + identity)))))))) + + + +(defmethod handle-event :around ((pane scroll-bar-target-pane) + (event pointer-button-press-event)) + (with-sheet-medium (medium pane) + (draw-target pane medium :filled t :ink +foreground-ink+) + (call-next-method) + (draw-target pane medium :filled t :ink +background-ink+) + (draw-target pane medium :filled nil))) + + +;;; This implements genera style scroll bars. +;;; Vertical Scroll bars +;;; Top Target +;;; Left: Next Line Middle: First Page Right: Previous Line +;;; Bottom Target +;;; Left: Next Page Middle: Last Page Right: Previous Page +(defmethod handle-event ((pane scroll-bar-target-pane) + (event pointer-button-press-event)) + (let* ((scroll-bar (slot-value pane 'scroll-bar)) + (client (gadget-client scroll-bar)) + (id (gadget-id scroll-bar))) + (case (pointer-event-button event) + (#.+pointer-left-button+ + (ecase (slot-value pane 'end) + (:greater-than + (scroll-down-page-callback scroll-bar client id)) + (:less-than + (scroll-down-line-callback scroll-bar client id)))) + (#.+pointer-middle-button+ + (ecase (slot-value pane 'end) + (:greater-than + (scroll-to-bottom-callback scroll-bar client id)) + (:less-than + (scroll-to-top-callback scroll-bar client id)))) + (#.+pointer-right-button+ + (ecase (slot-value pane 'end) + (:greater-than + (scroll-up-page-callback scroll-bar client id)) + (:less-than + (scroll-up-line-callback scroll-bar client id))))))) + +(defmethod handle-event ((pane scroll-bar-shaft-pane) + (event pointer-button-press-event)) + (let* ((x (pointer-event-x event)) + (y (pointer-event-y event)) + (scroll-bar (slot-value pane 'scroll-bar)) + (client (gadget-client scroll-bar)) + (id (gadget-id scroll-bar)) + (orientation (gadget-orientation scroll-bar))) + (case (pointer-event-button event) + (#.+pointer-left-button+ + (scroll-line-to-top-callback + scroll-bar client id orientation x y)) + (#.+pointer-right-button+ + (scroll-line-to-bottom-callback + scroll-bar client id orientation x (- (bounding-rectangle-height scroll-bar) y))) + (#.+pointer-middle-button+ + (scroll-elevator-callback + scroll-bar client id orientation x y))))) + +(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-enter-event)) + (frame-manager-display-pointer-documentation-string + (frame-manager pane) *pointer-documentation-output* + (ecase (gadget-orientation (slot-value pane 'scroll-bar)) + (:vertical + "L: This line to top; M: Proportional scrolling; R: Top line to here.") + (:horizontal + "L: This column to left edge; M: Proportional scrolling; R: Left edge to here.")))) + +(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-enter-event)) + (frame-manager-display-pointer-documentation-string + (frame-manager pane) *pointer-documentation-output* + (ecase (gadget-orientation (slot-value pane 'scroll-bar)) + (:vertical + (ecase (slot-value pane 'end) + (:greater-than + "L: Next screenful; M: Last screenful; R: previous screenful.") + (:less-than + "L: Next line; M: First screenful; R: Previous line."))) + (:horizontal + (ecase (slot-value pane 'end) + (:greater-than + "L: Next screenful; M: Last screenful; R: previous screenful.") + (:less-than + "L: Next column; M: First screenful; R: Previous column.")))))) + +(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-exit-event)) + (frame-manager-display-pointer-documentation-string + (frame-manager pane) *pointer-documentation-output* nil)) + +(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-exit-event)) + (frame-manager-display-pointer-documentation-string + (frame-manager pane) *pointer-documentation-output* nil)) + +(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-event)) + (deallocate-event event)) + +(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-event)) + (deallocate-event event)) + +(defmethod update-scroll-bar-value ((pane scroll-bar-shaft-pane) scroll-bar coord min max) + (let* ((min-value (gadget-min-value scroll-bar)) + (max-value (gadget-max-value scroll-bar)) + (value (compute-symmetric-value min max coord min-value max-value))) + (setf (gadget-value scroll-bar) value))) + +(defmethod (setf gadget-value) (value (pane scroll-bar-pane) &key invoke-callback) + (declare (ignore invoke-callback)) + (setf (slot-value pane 'value) value)) + +(defmethod (setf gadget-value) :around (value (pane scroll-bar-pane) &key invoke-callback) + (declare (ignore value invoke-callback)) + (if (port pane) + (let ((shaft-pane (slot-value pane 'shaft-pane))) + (with-sheet-medium (medium shaft-pane) + (draw-thumb shaft-pane medium :ink +background-ink+) + (call-next-method) + (draw-thumb shaft-pane medium :ink +foreground-ink+))) + (call-next-method))) + diff --git a/silica/text-style.lisp b/silica/text-style.lisp index 7f1a22aa11067c27132fe850e41e5494e6233fa2..241b6d8c324abcbdf705667d2fb8d2f3f650a263 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-style.lisp,v 1.15 92/11/06 19:04:02 cer Exp $ +;; $fiHeader: text-style.lisp,v 1.16 92/11/19 14:25:06 cer Exp $ (in-package :silica) @@ -659,7 +659,7 @@ (let ((tuples (gethash key mapping-table)) (last-tuple nil) (last-size nil)) - (dolist (tuple tuples (if tuples (cadr (last tuples)))) + (dolist (tuple tuples (if (and tuples (not exact-size-required)) (cadar (last tuples)))) (let ((font-size (text-style-size (car tuple)))) (if exact-size-required (when (= size font-size) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 5818a1748f81dba8084255bdca4d89d966f7fb9b..f5d5c2d5a9fcb7ac0b614c245881eecebb72d169 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.31 92/11/19 14:25:12 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.32 92/12/03 10:29:40 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -137,8 +137,6 @@ ("queue") ("timers" :load-before-compile ("queue" "processes")) ("protocols") - ("autoconstructor") - ;; Establish a uniform stream model ("clim-streams") ("cl-stream-classes" :features (not clim-uses-lisp-stream-classes)) @@ -190,6 +188,7 @@ ("gadgets") ("db-border") ("db-scroll") + ("scroll-pane") ("db-button") ("db-slider")) @@ -344,77 +343,59 @@ ("x11-keysyms" :load-before-compile ("ffi")) ("last" :load-before-compile ("load-xlib" "xlib-funs"))) -#+Allegro -(clim-defsys:defsystem xt-tk - (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;" - #-Genera (frob-pathname "tk") - :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" - #-Genera (frob-pathname "tk") - :needed-systems (xlib) - :load-before-compile (xlib)) - ;; Motif and Openlook specific foreign loading. - ;; Must be done early so defforeigns can be opencoded. - ("load-xm" :features clim-motif) - ("load-ol" :features clim-openlook) - ;; General stuff - ("pkg") - ("macros") - ("xt-defs") ; Used to be 'xtk'. - ("xt-funs") - ("foreign-obj") - ;; Xlib stuff - ("xlib") - ("font") - ("gcontext") - ("graphics") +(macrolet ((define-xt-system (name file &rest modules) + `(clim-defsys:defsystem ,name + (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;" + #-Genera (frob-pathname "tk") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" + #-Genera (frob-pathname "tk") + :needed-systems (xlib) + :load-before-compile (xlib)) + (,file) + ("pkg") + ("macros") + ("xt-defs") ; Used to be 'xtk'. + ("xt-funs") + ("foreign-obj") + ;; Xlib stuff + ("xlib") + ("font") + ("gcontext") + ("graphics") - ;; Toolkit stuff - ("meta-tk") - ("make-classes") - ("foreign") - ("widget") - ("resources") - ("event") - ("callbacks") - ("xt-classes") - ("xt-init")) - -#+Allegro -(clim-defsys:defsystem xm-tk - (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;" - #-Genera (frob-pathname "tk") - :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" - #-Genera (frob-pathname "tk") - :needed-systems (xt-tk) - :load-before-compile (xt-tk)) - ;; Motif specific stuff - ("xm-defs") - ("xm-funs") - ("xm-classes") - ("xm-callbacks") - ("xm-init") - ("xm-widgets") - ("xm-font-list") - ("xm-protocols") - ("convenience") - ("make-widget")) + ;; Toolkit stuff + ("meta-tk") + ("make-classes") + ("foreign") + ("widget") + ("resources") + ("event") + ("callbacks") + ("xt-classes") + ("xt-init") + ,@modules))) + + (define-xt-system xm-tk "load-xm" + ("xm-defs") + ("xm-funs") + ("xm-classes") + ("xm-callbacks") + ("xm-init") + ("xm-widgets") + ("xm-font-list") + ("xm-protocols") + ("convenience") + ("make-widget")) + + (define-xt-system ol-tk "load-ol" + ("ol-defs") + ("ol-funs") + ("ol-classes") + ("ol-init") + ("ol-widgets") + ("ol-callbacks") + ("make-widget"))) -#+Allegro -(clim-defsys:defsystem ol-tk - (:default-pathname #+Genera "SYS:CLIM;REL-2;TK;" - #-Genera (frob-pathname "tk") - :default-binary-pathname #+Genera "SYS:CLIM;REL-2;TK;" - #-Genera (frob-pathname "tk") - :needed-systems (xt-tk) - :load-before-compile (xt-tk)) - ;; OpenLook specific stuff - ("ol-defs") - ("ol-funs") - ("ol-classes") - ("ol-init") - ("ol-widgets") - ("ol-callbacks") - ("make-widget")) #+Allegro (clim-defsys:defsystem motif-clim diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 55524db9a8a2e9d5ef5ab7fcba3989596fb31a33..839bd5205d7854dc5ecab59ea13dc4724075280c 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.47 92/12/01 09:46:42 cer Exp $ +;; $fiHeader: test-suite.lisp,v 1.48 92/12/03 10:29:48 cer Exp $ (in-package :clim-user) @@ -767,7 +767,7 @@ people, shall not perish from the earth. (draw-rectangle* stream 0 0 (pattern-width pattern) (pattern-height pattern) :ink pattern)) (write-string "not found" stream)))))))) -#+Allegro + (define-test (draw-some-bezier-curves graphics) (stream) "Draw bezier curve" (let ((points (list 0 0 100 300 300 300 400 0 200 200 150 30 0 0))) @@ -775,7 +775,7 @@ people, shall not perish from the earth. (dolist (filled '(nil t)) (formatting-cell (stream) (with-scaling (stream 0.5) - (draw-bezier-polygon* stream points :filled filled) + (draw-bezier-curve* stream points :filled filled) (do ((points points (cddr points))) ((null points)) (draw-point* stream (car points) (cadr points) :line-thickness 2 @@ -1251,6 +1251,37 @@ people, shall not perish from the earth. (sleep 2) (window-refresh stream))) +(define-test (hairy-graph-formatting formatted-output) (stream) + "Some hairy re-entrant and circular graphs" + (formatting-item-list (stream) + (dolist (test '((nil (a (bbbb (ccc (dd eee) (fff ggg (hh (ii jj) kkk))) (lll (mmm nnn) (ooo ppp qqq))) r (s t))) + (t (a #1=(b (c #2= (d e #3=(f g)) (hhhhhhhhhh (i j k) l (m n o))))) + (p (q (r (s t #3# u)))) + (w (x #2# #1#))) + (t (a #11=(bbb (ccc (dd eee) (ffff g hhhhhhhh))) + (mm (nnn ooo #11#) (p #12=(q r (s t)))) + (u (v (w (x #12#)))))) + (t (a #21= (b (c (d #21# e)) (f #22= (g (h i) j) k) #22#) (m n))) + (t #34=(a #31= (b (c (d #31# e)) (f #32= (g (h i #31#) j) k) #32#) (m #34# n))) + (t #51=(a #51#)) + (t #41=(aaa (bbb (ccc #41#)))) + )) + (formatting-cell (stream) + (destructuring-bind (merge . data) test + (flet ((printer-function (node stream) + (format stream "~A" (if (consp node) (car node) node))) + (child-function (node) + (and (consp node) (cdr node)))) + (format-graph-from-roots + data + #'printer-function + #'child-function + :stream stream + :cutoff-depth 8 + :merge-duplicates merge + ))))))) + + (define-test (filled-output formatted-output) (stream) "Some simple tests of filled output. The thing labelled <Click Here> should be sensitive." (filling-output (stream :fill-width '(30 :character)) @@ -1742,7 +1773,11 @@ Luke Luck licks the lakes Luke's duck likes.")) :label "Select an activity")) (doit (menu-choose '("akjdfkjdf" "bdfkj" "cdfkj") - :label "foo" :text-style '(:fix :roman :huge))))) + :label "foo" :text-style '(:fix :roman :huge))) + (doit + (menu-choose '("akjdfkjdf" "bdfkj" "cdfkj") + :label '("Foo" :text-style (:serif :bold :huge)) + :text-style '(:fix :roman :huge))))) (define-test (graphical-menu menus-and-dialogs) (stream) "A menu that contains graphics." @@ -1950,44 +1985,53 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-test (readonly-gadget-dialog menus-and-dialogs) (stream) "Create a bunch of readonly gadgets" (accepting-values (stream :own-window nil :label "Gadgets dialog" - :align-prompts t) - (macrolet ((do-presents (view &rest p) - `(progn - ,@(mapcar #'(lambda (x) - `(progn - (present ',(car x) ',(cadr x) - ,@(and view `(:view ,view)) - :prompt (format nil "~A,~A" - ',(cadr x) - ,(if (constantp view) - (if (eval view) `',(type-of (eval view)) :default) - `(if ,view (type-of ,view) :default))) - :stream stream) - (terpri stream))) - p)))) - (do-presents - nil - (5.0 real) - ("xxx" string) - (#P"/tmp/foo" pathname) - (:a (member :a :b)) - ((:a :b) (subset :a :b)) - (( 3 4) (sequence integer)) - ;; sequence-enumerated - (t boolean)) - (do-presents - +text-field-view+ - (5.0 real) - ("xxx" string) - (#P"/tmp/foo" pathname) - (:a (member :a :b)) - ((:a :b) (subset :a :b)) - (( 3 4) (sequence integer)) - ;; sequence-enumerated - (t boolean)) - (do-presents - '(text-editor-view :nlines 5 :ncolumns 30) - (" (do-presents + :align-prompts nil) + (macrolet ((do-presents (view &rest p) + `(progn + ,@(mapcar #'(lambda (x) + `(progn + (present ',(car x) ',(cadr x) + ,@(and view `(:view ,view)) + :prompt (format nil "~A,~A" + ',(cadr x) + ,(if (constantp view) + (if (eval view) `',(type-of (eval view)) :default) + `(if ,view (type-of ,view) :default))) + :stream stream) + (terpri stream))) + p)))) + + (formatting-item-list (stream :n-columns 2) + (formatting-cell (stream) + (with-aligned-prompts (stream) + (do-presents + nil + (5.0 real) + ("xxx" string) + (#P"/tmp/fooo" pathname) + (:a (member :a :b)) + ((:a :b) (subset :a :b)) + (( 3 4) (sequence integer)) + ;; sequence-enumerated + (t boolean)))) + (formatting-cell (stream) + (with-aligned-prompts (stream) + (do-presents + +text-field-view+ + (5.0 real) + ("xxx" string) + (#P"/tmp/fooo" pathname) + (:a (member :a :b)) + ((:a :b) (subset :a :b)) + (( 3 4) (sequence integer)) + ;; sequence-enumerated + (t boolean)))) + + (formatting-cell (stream) + (with-aligned-prompts (stream) + (do-presents + '(text-editor-view :nlines 5 :ncolumns 30) + (" (do-presents +text-field-view+ (5.0 real) (xxx string) @@ -1997,11 +2041,15 @@ Luke Luck licks the lakes Luke's duck likes.")) (( 3 4) (sequence integer)) ;; sequence-enumerated (t boolean)) " - string)) - (do-presents - +slider-view+ - (5.0 float) - (1 integer))))) + string)))) + + (formatting-cell (stream) + (with-aligned-prompts (stream) + (do-presents + +slider-view+ + (5.0 float) + (1 integer)))))))) + (defun gadgets-dialog-internal (stream &optional own-window) (macrolet ((accepts (&rest accepts) @@ -2078,29 +2126,35 @@ Luke Luck licks the lakes Luke's duck likes.")) (defun time-continuation (name iterations continuation &key (careful t)) (with-display-pane (stream) - (let ((results nil) - (vresults nil)) + (let ((results nil) + (vresults nil)) (when careful (funcall continuation stream)) - (repeat (* *multiply-factor* (if (not careful) 1 5)) - (window-clear stream) - #+Genera (si:%gc-scavenge) - #+Cloe-Runtime (gc-immediately) - #+Lucid (lucid-common-lisp:ephemeral-gc) - #+excl (excl::gc) - #+ccl (ccl:gc) - (let ((start-time (get-internal-real-time)) - (vstart-time (get-internal-run-time))) - (repeat iterations - (#+Genera mi:with-metering-enabled #-Genera progn - (funcall continuation stream)) - (force-output stream)) - (push (/ (float (- (get-internal-real-time) start-time)) - internal-time-units-per-second) - results) - (push (/ (float (- (get-internal-run-time) vstart-time)) - internal-time-units-per-second) - vresults))) + (let ((initial-scale-iterations 1)) + (repeat (* *multiply-factor* (if (not careful) 1 5)) + (window-clear stream) + #+Genera (si:%gc-scavenge) + #+Cloe-Runtime (gc-immediately) + #+Lucid (lucid-common-lisp:ephemeral-gc) + #+excl (excl::gc) + #+ccl (ccl:gc) + (do ((scale-iterations initial-scale-iterations (* scale-iterations 2))) + (nil) + (let ((start-time (get-internal-real-time)) + (vstart-time (get-internal-run-time))) + (repeat (* iterations scale-iterations) + (#+Genera mi:with-metering-enabled #-Genera progn + (funcall continuation stream)) + (force-output stream)) + (let ((vtime (/ (float (- (get-internal-run-time) vstart-time)) + internal-time-units-per-second)) + (rtime (/ (float (- (get-internal-real-time) start-time)) + internal-time-units-per-second))) + (when (or (> vtime 1) (> rtime 1)) + (setq initial-scale-iterations scale-iterations) + (push (/ rtime scale-iterations) results) + (push (/ vtime scale-iterations) vresults) + (return nil))))))) (let ((time (if (not careful) (first results) @@ -2112,11 +2166,11 @@ Luke Luck licks the lakes Luke's duck likes.")) (let ((results (rest (butlast (sort vresults #'<))))) (/ (apply #'+ results) (length results)))))) (format (get-frame-pane *application-frame* 'caption-pane) - "~%Each run of ~A took about ~3$ real, ~3$ virtual, ~3$ v/r seconds" - name - time - vtime - (float (/ vtime time))) + "~%Each run of ~A took about ~3$ real, ~3$ virtual, ~3$ v/r seconds" + name + time + vtime + (float (/ vtime time))) time)))) ;;; To distill the results down to something more easily interpretable by the @@ -2953,7 +3007,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (without-clim-input (if #+allegro (typep (port stream) 'xm-silica::xt-port) #-allegro nil - (sleep 1) ;; Avoid division by zero! + (sleep 0.1) ;; Avoid division by zero! (menu-choose '(("Red" :value +red+) ("Green" :value +green+) ("Blue" :value +blue+) @@ -2971,7 +3025,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (without-clim-input (if #+allegro (typep (port stream) 'xm-silica::xt-port) #-allegro nil - (sleep 1) ;; Avoid division by zero! + (sleep 0.1) ;; Avoid division by zero! (menu-choose '(("Red" :value +red+) ("Green" :value +green+) ("Blue" :value +blue+) diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp index e123da7ac0dbe197e8cb38d474b4531943730277..a9342609f1438a17c57368fa412327c1424a582d 100644 --- a/tk-silica/ol-frames.lisp +++ b/tk-silica/ol-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-frames.lisp,v 1.18 92/11/10 08:56:55 cer Exp $ +;; $fiHeader: ol-frames.lisp,v 1.19 92/12/03 10:30:10 cer Exp $ (in-package :xm-silica) @@ -74,8 +74,11 @@ (font (and text-style (text-style-mapping (port framem) text-style))) (font-args (and font (list :font font)))) - (tk::set-values menu-shell :title (or label "Choose")) - + (let ((title (cond ((null label) "Choose") + ((atom label) label) + (t (car label))))) + (check-type title string) + (tk::set-values menu-shell :title title)) ;;-- Does not have a font resource ;; (when font (tk::set-values menu-shell :font font)) @@ -184,6 +187,6 @@ (tk::ol_menu_popdown menu 1)) (defmethod framem-menu-active-p ((framem openlook-frame-manager) menu) - (declare (ignore t)) + (declare (ignore menu)) t) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index fc8403e13ac16ec6a78d65b1325abd31b2bee395..e8f5cf24ee7cc6fab65deb5aea7a1c0854370c3e 100644 --- a/tk-silica/ol-gadgets.lisp +++ b/tk-silica/ol-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-gadgets.lisp,v 1.32 92/11/20 08:46:35 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.33 92/12/03 10:30:13 cer Exp $ (in-package :xm-silica) @@ -101,6 +101,7 @@ mmin mmax size smin smax))))) (defmethod compose-space ((m openlook-scroll-bar) &key width height) + (declare (ignore width height)) (let ((x 16)) (ecase (gadget-orientation m) (:vertical @@ -260,9 +261,9 @@ (declare (ignore ignore-x igore-y)) (maxf height h) (incf width w))) - (multiple-value-bind (h-pad v-pad h-space v-space) + (multiple-value-bind (h-pad v-pad h-space) (tk::get-values (sheet-direct-mirror mb) - :h-pad :v-pad :h-space :v-space) + :h-pad :v-pad :h-space) (incf width (+ (* 2 h-pad) (* (1- (length children)) h-space))) (incf height (* 2 v-pad))) (make-space-requirement :width width :height height))) @@ -273,7 +274,7 @@ ;; This code fills the menu-bar. If top level items do not have ;; submenus then it creates one with a menu of its own - (let ((mirror (call-next-method)) + (let* ((mirror (call-next-method)) (text-style (menu-bar-text-style sheet)) (font-list (and text-style (list :font (text-style-mapping port text-style)))) @@ -611,8 +612,12 @@ (nv (gadget openlook-toggle-button) &key invoke-callback) (declare (ignore invoke-callback)) (when (sheet-direct-mirror gadget) - (with-no-value-changed-callbacks - (tk::set-values (sheet-mirror gadget) :set nv)))) + (handler-bind + ;;-- Nasty hack alert for + ((simple-warning #'(lambda (condition) + (muffle-warning condition)))) + (with-no-value-changed-callbacks + (tk::set-values (sheet-mirror gadget) :set nv))))) ;; @@ -738,7 +743,7 @@ (with-accessors ((label gadget-label) (show-value-p gadget-show-value-p) (value gadget-value) - (editable gadget-editable-p)) sheet + (editablep gadget-editable-p)) sheet (multiple-value-bind (smin smax) (gadget-range* sheet) (let ((mmin 0) @@ -794,10 +799,11 @@ (defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-slider) (widget t)) - ;;--- Do we need to do this? - #+ignore - (tk::add-callback widget :drag-callback 'queue-drag-event sheet) - (tk::add-callback widget :slider-moved 'slider-changed-callback-1 sheet)) + (when (gadget-editable-p sheet) + ;;--- Do we need to do this? + #+ignore + (tk::add-callback widget :drag-callback 'queue-drag-event sheet) + (tk::add-callback widget :slider-moved 'slider-changed-callback-1 sheet))) (defmethod slider-changed-callback-1 ((widget t) (sheet openlook-slider)) (queue-value-changed-event widget sheet)) @@ -949,6 +955,7 @@ (defmethod initialize-instance :after ((sp openlook-scrolling-window) &key scroll-bars contents frame-manager frame) + #-bad-hack (declare (ignore scroll-bars)) (if (setf (scroller-pane-gadget-supplies-scrolling-p sp) (gadget-supplies-scrolling-p contents)) (sheet-adopt-child sp contents) @@ -1261,6 +1268,7 @@ :string "xxxxxxxxxxxxxxxxxxxxxxxx" :parent control)) (menu-pane (tk::get-values widget :menu-pane))) + (declare (ignore label)) (setf (option-menu-buttons sheet) (mapcar #'(lambda (item) (let* ((currentp (funcall @@ -1316,7 +1324,7 @@ :accelerator accel :accelerator-text accel-text)))) -(defmethod discard-accelerator-event-p ((port openlook-port) event) +(defmethod discard-accelerator-event-p ((port openlook-port) (event t)) ;;-- There are a whole bunch of other keysyms that need to be ignored. ;;-- Perhaps in OLIT there is a way of getting the actual keysym. ;;-- Perhaps we need a way of representing them in the clim world diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index f1460e7ddb707647bc98a5318ba3b9de9096145a..8d6b1bab597ab1f1a58f75e6db86b7eb903dae34 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.41 92/11/20 08:46:41 cer Exp $ +;; $fiHeader: xm-frames.lisp,v 1.42 92/12/03 10:30:17 cer Exp $ (in-package :xm-silica) @@ -321,11 +321,16 @@ (font (and text-style (text-style-mapping (port framem) text-style))) (font-list (and (or label simplep) font (list :font-list (list font))))) (when label - (apply #'make-instance 'xt::xm-label - :parent menu - :managed nil - :label-string label - font-list) + (let ((title (if (atom label) label (car label)))) + (check-type title string) + (destructuring-bind (&key text-style) (and (listp label) (cdr label)) + (apply #'make-instance 'xt::xm-label + :parent menu + :managed nil + :label-string title + (if text-style + (list :font-list (list (text-style-mapping (port framem) text-style))) + font-list)))) (make-instance 'xt::xm-separator :managed nil :separator-type :double-line diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 7c59bfa135545f7f9fbc6a94ba31811b5bdeaf91..e0efab0c211ce0f8dd04bf58b6b2295947353a22 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.61 92/12/01 09:47:21 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.62 92/12/02 13:31:36 colin Exp $ (in-package :xm-silica) @@ -91,50 +91,50 @@ (setf (getf (mp:process-property-list process) ':survive-dumplisp) #'cleanup-port-after-dumplisp) (setf (port-process port) process)))) -(defmacro destructure-x-server-path ((&key display) path &body body) - ;;-- Of course the port ends up with an unspecified server-path. - ;;-- Perhaps this is OK or perhaps we have to default the components before - ;;-- putting it in the port??? - (let ((ignore (gensym))) - `(destructuring-bind - (,ignore &key ((:display ,display) - (or (sys::getenv "DISPLAY") - "localhost:0"))) - ,path - (declare (ignore ,ignore)) - ,@body))) - +(defmethod port-event-loop :around ((port xt-port)) + (handler-case (call-next-method) + (tk::x-connection-lost (condition) + (port-terminated port condition) + (mp:process-kill mp:*current-process*)))) + (defparameter *use-color* t) ; For debugging monochrome +(defvar *unreliable-server-vendors* + '("Solbourne Computer, Inc" "Network Computing Devices" + "Tektronix")) + (defmethod initialize-instance :after ((port xt-port) &key server-path) - (destructuring-bind - (&key (display nil display-p) - (application-name nil application-name-p) - (application-class nil application-class-p)) - (cdr server-path) - (let ((args nil)) - (when display-p (setf (getf args :host) display)) - (when application-name-p (setf (getf args :application-name) application-name)) - (when application-class-p (setf (getf args :application-class) application-class)) - (multiple-value-bind (context display application-shell) - (apply #'tk::initialize-toolkit args) - (setf (slot-value port 'application-shell) application-shell - (slot-value port 'context) context - (slot-value port 'display) display - (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display)) - (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display)) - (slot-value port 'silica::default-palette) - (make-xt-palette port (tk::default-colormap (port-display port)))) - (let* ((screen (x11:xdefaultscreenofdisplay display)) - (bs-p (not (zerop (x11::screen-backing-store screen)))) - (su-p (not (zerop (x11::screen-save-unders screen)))) - (vendor (ff:char*-to-string (x11::display-vendor display)))) - (if (and bs-p su-p - ;; An amazing crock. XXX - (not (search "Network Computing Devices" vendor)) - (not (search "Tektronix" vendor))) - (setf (slot-value port 'safe-backing-store) t))) - (initialize-xlib-port port display))))) + (handler-case + (destructuring-bind + (&key (display nil display-p) + (application-name nil application-name-p) + (application-class nil application-class-p)) + (cdr server-path) + (let ((args nil)) + (when display-p (setf (getf args :host) display)) + (when application-name-p (setf (getf args :application-name) application-name)) + (when application-class-p (setf (getf args :application-class) application-class)) + (multiple-value-bind (context display application-shell) + (apply #'tk::initialize-toolkit args) + (setf (slot-value port 'application-shell) application-shell + (slot-value port 'context) context + (slot-value port 'display) display + (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display)) + (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display)) + (slot-value port 'silica::default-palette) + (make-xt-palette port (tk::default-colormap (port-display port)))) + (let* ((screen (x11:xdefaultscreenofdisplay display)) + (bs-p (not (zerop (x11::screen-backing-store screen)))) + (su-p (not (zerop (x11::screen-save-unders screen)))) + (vendor (ff:char*-to-string (x11::display-vendor display)))) + (if (and bs-p su-p + ;; An amazing crock. XXX + (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*)) + (setf (slot-value port 'safe-backing-store) t))) + (initialize-xlib-port port display)))) + (tk::x-connection-lost (condition) + (port-terminated port condition)))) + (defmethod port-color-p ((port xt-port)) (and *use-color* diff --git a/tk/xlib.lisp b/tk/xlib.lisp index c72075b02e8d9126ff2250cc312dab27978be3f1..8884a2490f659c22bf3dbe0e07d26ed0a2bb111a 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.34 92/11/18 15:54:57 colin Exp $ +;; $fiHeader: xlib.lisp,v 1.35 92/12/02 13:31:21 colin Exp $ (in-package :tk) @@ -194,6 +194,15 @@ (asynchronous :reader x-error-asynchronous :initarg :asynchronous)) (:report report-x-error)) +(define-condition x-connection-lost (error) + ((display :reader x-error-display :initarg :display)) + (:report report-x-connection-lost)) + +(defun report-x-connection-lost (condition stream) + (let ((display (x-error-display condition))) + (format stream "Xlib: Connection to X11 server '~a' lost" + (ff:char*-to-string (x11:display-display-name display))))) + (defun report-x-error (condition stream) (let ((display (x-error-display condition)) (error-code (x-error-error-code condition)) @@ -229,8 +238,8 @@ (defun-c-callable x-io-error-handler ((display :unsigned-long)) (let ((*error-output* excl:*initial-terminal-io*)) - (error "Xlib: Connection to X11 server '~a' lost" - (ff:char*-to-string (x11:display-display-name display))))) + (error 'x-connection-lost :display display))) + (defun get-error-text (code display-handle) diff --git a/utils/packages.lisp b/utils/packages.lisp index 307cff0ed49af6b7a89d10fc94d338e75fb824ef..bffe654243d6180260d6bb2b66c07c73ea6893ab 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.41 92/12/01 09:47:32 cer Exp $ +;; $fiHeader: packages.lisp,v 1.42 92/12/03 10:30:45 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2557,6 +2557,7 @@ display-exit-boxes frame-manager-dialog-view invoke-accept-values-command-button + with-aligned-prompts ;; Command processor *command-argument-delimiters* @@ -3497,6 +3498,7 @@ port-set-pointer-position port-set-sheet-pointer-cursor port-set-sheet-grabbed-pointer-cursor + port-terminated port-trace-thing port-undefined-text-style process-event-locally