diff --git a/ChangeLog.n b/ChangeLog.n index baf56ffc69be95da426ebf3fb02b8db76073c124..55b2cdb183810e9a0f8fdf43f32d1239386218c8 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -10,6 +10,54 @@ Tests for new features: <`no new features', `no tests for new features', or <standard changelog date stamp> * <changes go here...> +******************************************************************************* +Fri May 30 17:49:18 PDT 1997 Tom McClure <tomj@romeo> + + * aclpc/acl-medium.lisp + - ellipse drawing fixes + * clim/accept-values.lisp + - made default action (when you hit enter) work better + * clim/db-stream.lisp + - pointer-documentation pane now defaults to menu font + * clim/drag-and-drop.lisp + - returned multiple-window drag-and-drop functionality + * clim/input-editor-commands.lisp, clim/menus.lisp, + silica/port.lisp, test/test-suite.lisp, + utils/defun-utilities.lisp, utils/defun.lisp, + utils/designs.lisp + - removed references to obsolete feature microsoft-32 + * clim/menus.lisp, xm/xm-frames.lisp + - fixed *default-menu-text-style* + * clim/output-protocol.lisp + - fixed aclpc char v. character bug + * clim/output-protocol.lisp, clim/text-recording.lisp + - fixed text baseline calculations + * silica/db-scroll.lisp + - most recent text output wasn't resizing extent + * sys/compile.lisp, sys/load.lisp + - major housecleaning + * tk/gcontext.lisp, tk-silica/xt-graphics.lisp, + utils/transformations.lisp + - optimized transform-position + * tk/image.lisp + - xpm pixmaps were being written out with huge chars + * xm/xm-gadgets.lisp + - added option abort-on-cancel-p to notify-user + * tk-silica/xt-silica.lisp + - gave clim fonts explicit iso8859-1 encoding + * utils/base-designs.lisp + - removed aclpc ink constant weirdness from nt + * utils/extended-regions.lisp + - added many missing region methods + - fixed bugs in map-over-polygon-xxx and + region-intersection for lines + * utils/region-arithmetic.lisp + - made path/area stuff agree with spec + - small optimization in make-region-difference + * utils/regions.lisp + - bounding-rectangles of partial ellipses fixed + + ******************************************************************************* Documentation changes: none Tests for new features: no new features diff --git a/Makefile.sun4-svr4 b/Makefile.sun4-svr4 index 481c6cee93d71db62cb876159e947805bcd65f72..13c1070ae80b9849f977fefe0ade716a9bb4684d 100644 --- a/Makefile.sun4-svr4 +++ b/Makefile.sun4-svr4 @@ -1,9 +1,12 @@ -# $Header: /repo/cvs.copy/clim2/Makefile.sun4-svr4,v 1.13 1997/02/05 01:42:08 tomj Exp $ +# $Header: /repo/cvs.copy/clim2/Makefile.sun4-svr4,v 1.14 1997/05/31 01:00:23 tomj Exp $ # # Makefile.sun4-svr4 for CLIM 2.0 # include Makefile.defs +#CL_HOME=/fi/scm/4.3/sunos5/src +CL=$(CL_HOME)/dcl +CLIM_HOME=$(CL_HOME) Makefile=Makefile.sun4-svr4 diff --git a/aclpc/acl-medium.lisp b/aclpc/acl-medium.lisp index 2db9113d9c508e61fdc0555ba24a63cc38c723ea..e5645c001e43fd74dd462c67903ceed85b81ac4d 100644 --- a/aclpc/acl-medium.lisp +++ b/aclpc/acl-medium.lisp @@ -625,18 +625,18 @@ stipples are not supported yet.")) ;; drawing a pie slice (win::pie dc left top right bottom - (round (+ (* (cos end-angle) x-radius) center-x)) - (round (+ (* (sin end-angle) y-radius) center-y)) - (round (+ (* (cos start-angle) x-radius) center-x)) - (round (+ (* (sin start-angle) y-radius) center-y)))) + (round (+ center-x (* (cos start-angle) x-radius))) + (round (- center-y (* (sin start-angle) y-radius))) + (round (+ center-x (* (cos end-angle) x-radius))) + (round (- center-y (* (sin end-angle) y-radius))))) (t ;; drawing an arc (win::arc dc left top right bottom - (round (+ (* (cos end-angle) x-radius) center-x)) - (round (+ (* (sin end-angle) y-radius) center-y)) - (round (+ (* (cos start-angle) x-radius) center-x)) - (round (+ (* (sin start-angle) y-radius) center-y))))) + (round (+ center-x (* (cos start-angle) x-radius))) + (round (- center-y (* (sin start-angle) y-radius))) + (round (+ center-x (* (cos end-angle) x-radius))) + (round (- center-y (* (sin end-angle) y-radius)))))) ))))))) (defmethod medium-draw-string* ((medium acl-medium) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index ae349acc2e8fb9f26f43fac0851b5309fec7ccb8..648aa0a845e2ed446d7826ab078791e4ae2fc8bc 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 -*- -;; $Header: /repo/cvs.copy/clim2/clim/accept-values.lisp,v 1.80 1997/02/05 01:42:38 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/accept-values.lisp,v 1.81 1997/05/31 01:00:29 tomj Exp $ (in-package :clim-internals) @@ -861,7 +861,7 @@ (defmethod accept-values-query-edit-value ((query accept-values-query) stream &key modify) (with-slots (presentation-type value changed-p prompt presentation) query (let ((stream (encapsulating-stream-stream stream)) - (*editting-field-p* t)) + (*editting-field-p* stream)) (with-stream-cursor-position-saved (stream) (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates @@ -970,10 +970,25 @@ changed-p t)))) (define-gesture-name :exit-dialog :keyboard (:end)) -#+allegro -(define-gesture-name :exit-dialog :keyboard (:newline) :unique nil) (define-gesture-name :abort-dialog :keyboard (:abort)) +(define-gesture-name :default-dialog :keyboard (:newline)) + +;; com-default-avv gets run when the "default" gesture is activated. On +;; Motif this is when the user hits "return". In most cases we don't need +;; to do anything because the :default-button mechanism should cause the +;; correct command to be run - but to maintain compatibility with +;; non-gadget style dialogs we check for +textual-dialog-view+ and then "do +;; the Symbolics thing". (cim/tomj 5/21/97) + +(define-accept-values-command (com-default-avv :keystroke :default-dialog) () + (let ((frame *application-frame*)) + (with-slots (stream) frame + (when (eq (stream-default-view stream) + +textual-dialog-view+) + (com-exit-avv))))) + + (define-accept-values-command (com-exit-avv :keystroke :exit-dialog) () (let ((frame *application-frame*)) (with-slots (stream) frame @@ -1514,7 +1529,7 @@ (defun handle-exit-box-callback (gadget) (if *editting-field-p* - (beep) + (beep *editting-field-p*) (let ((id (gadget-id gadget))) (case id (:exit (com-exit-avv)) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 3e329fb179ef94eab21ff7cb91f3eabacd7c59e7..6c09298c14c443d70706ec7facc1cc5b763c4043 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 -*- -;; $Header: /repo/cvs.copy/clim2/clim/db-stream.lisp,v 1.64 1997/02/14 23:57:01 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/db-stream.lisp,v 1.65 1997/05/31 01:00:29 tomj Exp $ (in-package :clim-internals) @@ -372,11 +372,13 @@ (defclass application-pane (clim-stream-pane) ()) #-aclpc -;; apparently aclpc needs to do this in silica/framem.lisp since it refers -;; to the class in a note-frame-enabled method -tjm 12Feb97 +;; apparently aclpc needs to do this in silica/framem.lisp instead since it +;; refers to the class in a note-frame-enabled method -tjm 12Feb97 (defclass accept-values-pane (clim-stream-pane) ()) -(defclass pointer-documentation-pane (clim-stream-pane) ()) +(defclass pointer-documentation-pane (clim-stream-pane) () + (:default-initargs + :text-style *default-menu-text-style*)) (defclass title-pane (clim-stream-pane) ((display-string :initform nil :initarg :display-string))) diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp index 2375e3ee2dbc57af272d7a13f7392ee332892e10..9ec58a4d7aed9bf9e31d1bac43b1dadbce13c314 100644 --- a/clim/drag-and-drop.lisp +++ b/clim/drag-and-drop.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/drag-and-drop.lisp,v 1.15 1997/02/07 00:20:51 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/drag-and-drop.lisp,v 1.16 1997/05/31 01:00:29 tomj Exp $ (in-package :clim-internals) @@ -154,9 +154,9 @@ :move)) (finish-on-release (and translators (presentation-translator-finish-on-release (first translators)))) - ;;--- needed this when we were calling (setf pointer-cursor) + ;;--- spr15619: needed this when we were calling (setf pointer-cursor) ;;--- to change the mouse pointer to :move during the drag; - ;;--- now we use sheet-pointer-cursor + ;;--- now we use sheet-pointer-cursor. #+ignore (pointer (port-pointer (port window))) #+ignore (old-pointer-cursor (pointer-cursor pointer)) (initial-x x) @@ -195,17 +195,18 @@ ;;--- when drop initiated an accepting-values, (setf pointer-cursor) ;;--- was losing, ie changing the cursor back to default on the wrong frame (letf-globally ((#+ignore (pointer-cursor-override pointer) - ;; why doesn't this work? - #+ignore (sheet-pointer-cursor window) - ;; calling sheet-pointer-cursor on the - ;; top-level sheet is not quite right, - ;; since we only want to change this for - ;; the appropriate pane, not the whole - ;; frame, but this is better than before - ;; 1-24-97 tjm (w/colin) for spr15619 - #-ignore (sheet-pointer-cursor - (frame-top-level-sheet frame)) - pointer-cursor)) + ;; why doesn't this work? + #+ignore (sheet-pointer-cursor window) + ;; calling sheet-pointer-cursor on the top-level + ;; sheet is not quite right, since we only want to + ;; change this for the appropriate pane, not the + ;; whole frame, but this at least ensures that the + ;; pointer cursor will always revert to its + ;; previous shape. + ;; 1-24-97 tjm (w/colin) for spr15619 + #-ignore (sheet-pointer-cursor + (frame-top-level-sheet frame)) + pointer-cursor)) #+ignore (setf (pointer-cursor pointer) pointer-cursor) (macrolet ((feedback (window x y state) `(funcall feedback frame from-presentation ,window @@ -215,8 +216,13 @@ (output-recording-stream-p ,window)) (funcall highlighting frame ,presentation ,window ,state)))) (block drag-presentation + ;; :multiple-window t below was changed by colin (to nil) in + ;; post-4.3 sources, since he had promised this to a customer + ;; as a fix for something (spr?) but this breaks + ;; functionality which is needed by other customers. + ;; cf spr15818 7feb97 --tjm (tracking-pointer (window :context-type `((or ,@destination-types)) - :multiple-window nil :highlight nil) + :multiple-window t :highlight nil) (:presentation-button-press (presentation event) (unless finish-on-release (setq destination-event event @@ -275,7 +281,7 @@ (highlight destination last-window :unhighlight) (when last-x (feedback last-window last-x last-y :unhighlight))) - ;; see above + ;; see above "now we use ..." #+ignore (setf (pointer-cursor pointer) old-pointer-cursor)) ;; The user has put down the presentation, figure out what to do ;;--- What if there is more than one translator? diff --git a/clim/frames.lisp b/clim/frames.lisp index 61b2c7774c404deb2c173c82967b0580e6780f9a..3415bd9b622f5de42d973eb2e0bc83fc917929af 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 -*- -;; $Header: /repo/cvs.copy/clim2/clim/frames.lisp,v 1.84 1997/02/05 01:43:30 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/frames.lisp,v 1.85 1997/05/31 01:00:30 tomj Exp $ (in-package :clim-internals) @@ -1037,6 +1037,7 @@ ;; First display all the :accept-values panes, then display the rest. ;; We do this to ensure that all side-effects from :accept-values panes ;; have taken place. + (when *frame-layout-changing-p* (setq force-p t)) (map-over-sheets #'(lambda (sheet) (when (typep sheet 'accept-values-pane) (redisplay-frame-pane frame sheet :force-p force-p))) @@ -1063,8 +1064,6 @@ (with-simple-restart (skip-pane-redisplay "Skip redisplaying pane ~S" pane) (loop (with-simple-restart (retry-pane-redisplay "Retry displaying pane ~S" pane) - (when *frame-layout-changing-p* - (setq force-p t)) (unless *sizing-application-frame* (unless (member pane (slot-value frame 'initialized-panes)) (setq force-p t) diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp index 4ace0168d55fa909d6efcb366b7d703b61b5499b..e7866f0dda5ca916691afb094a8920d5f6c1e29e 100644 --- a/clim/input-editor-commands.lisp +++ b/clim/input-editor-commands.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/input-editor-commands.lisp,v 1.33 1997/02/07 00:20:53 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/input-editor-commands.lisp,v 1.34 1997/05/31 01:00:31 tomj Exp $ (in-package :clim-internals) @@ -1278,13 +1278,13 @@ This may confused the input editor" gestures)) (:ie-scroll-right :scroll :super :meta) (:ie-input-editor-help :help :control)) -#-(or (and (not microsoft-32) Allegro) Lucid) +#-(or (and (not acl86win32) Allegro) Lucid) (define-input-editor-gestures (:ie-show-arglist :a :control :shift) (:ie-show-value :v :control :shift) (:ie-show-documentation :d :control :shift)) -#+(or (and (not microsoft-32) Allegro) Lucid) +#+(or (and (not acl86win32) Allegro) Lucid) (define-input-editor-gestures (:ie-show-arglist :a :meta :shift) (:ie-show-value :v :meta :shift) @@ -1391,7 +1391,7 @@ This may confused the input editor" gestures)) (assign-input-editor-key-bindings (com-ie-swap-point-and-mark (:ie-prefix-2 (:x :control)))) -#+(or (and Allegro (not microsoft-32)) Lucid) +#+(or (and Allegro (not acl86win32)) Lucid) (assign-input-editor-key-bindings com-ie-forward-word (:ie-prefix-1 :f) com-ie-backward-word (:ie-prefix-1 :b) @@ -1469,7 +1469,7 @@ This may confused the input editor" gestures)) ) ;#+Genera -#+(and Allegro (not microsoft-32)) +#+(and Allegro (not acl86win32)) (progn (define-input-editor-gestures (:left-arrow :left-arrow) diff --git a/clim/menus.lisp b/clim/menus.lisp index 60b87fd61c70a4c9b4639103d130d36e7b6f6064..5e4711b79f26c69f9881998f7187bf202440d879 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/menus.lisp,v 1.50 1997/02/05 01:44:15 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/menus.lisp,v 1.51 1997/05/31 01:00:31 tomj Exp $ (in-package :clim-internals) @@ -9,8 +9,10 @@ (defvar *abort-menus-when-buried* t) -(defparameter *default-menu-text-style* (make-text-style :fix :roman :normal)) -(defparameter *default-menu-label-text-style* (make-text-style :fix :italic :normal)) +(defparameter *default-menu-text-style* (make-text-style :sans-serif :roman :small)) +(defparameter *default-menu-label-text-style* + (merge-text-styles (make-text-style nil :italic nil) + *default-menu-text-style*)) (define-application-frame menu-frame () (menu @@ -309,7 +311,7 @@ (medium-background associated-window)) (medium-foreground menu) (or foreground (medium-foreground associated-window))) - (with-text-style (menu text-style) + (with-text-style (menu (or text-style *default-menu-text-style*)) (with-end-of-line-action (menu :allow) (loop (multiple-value-bind (item gesture) @@ -462,13 +464,13 @@ ;; on nt there is no server round trip so ;; it's safe to check window-visibility ;; (cim 9/16/96) - (or #-(and Allegro (not microsoft-32)) + (or #-(and Allegro (not acl86win32)) (and *abort-menus-when-buried* (not (window-visibility menu))) (pointer-motion-pending menu))) (input-wait-handler (menu) ;; Abort if the menu becomes buried - #-(and Allegro (not microsoft-32)) + #-(and Allegro (not acl86win32)) (when (and *abort-menus-when-buried* (not (window-visibility menu))) (return-from menu-choose-from-drawer nil)) diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index aea7c11e904194b04ec8ba81cd272e4a62bb839d..78839555554e23f010ba18cfae731f3a82d94118 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/output-protocol.lisp,v 1.44 1997/02/05 01:44:19 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/output-protocol.lisp,v 1.45 1997/05/31 01:00:31 tomj Exp $ (in-package :clim-internals) @@ -433,7 +433,7 @@ (let ((text-style (merge-text-styles '(nil nil :very-small) *default-text-style*)) (ink (medium-ink stream)) - (name (char-name character))) + (name (char-name #-aclpc character #+aclpc char))) (setq name (if name (string-upcase name) #+Genera (format nil "~O" (char-code character)) @@ -516,7 +516,8 @@ (declare (type coordinate cursor-x cursor-y baseline height max-x)) (unless (or draw-p record-p) (return-from stream-write-string string)) ;No deeds to do - (let* ((medium (sheet-medium stream))) + (let* ((medium (sheet-medium stream)) + (baseline-diff nil)) (with-cursor-state (stream nil) (loop (multiple-value-bind (write-char next-char-index @@ -525,26 +526,26 @@ stream medium string start end style cursor-x max-x glyph-buffer) (declare (type coordinate new-cursor-x new-baseline new-height)) (declare (ignore font)) + (setf baseline-diff (max 0 (- baseline new-baseline))) (when record-p (stream-add-string-output stream string start next-char-index style (- new-cursor-x cursor-x) new-height new-baseline)) (when draw-p (when (< baseline new-baseline) - (stream-note-line-height-change stream baseline new-baseline height - cursor-x cursor-y) - (setf baseline new-baseline)) + (stream-note-line-height-change stream baseline new-baseline height + cursor-x cursor-y)) (let ((amount (the fixnum (- next-char-index start)))) (unless (zerop amount) ;;--- Need DRAW-GLYPHS, which will take a port-specific font ;;--- object, as well as the :INK option. (with-identity-transformation (medium) (draw-text* medium string - cursor-x (+ cursor-y (- baseline new-baseline)) + cursor-x (+ cursor-y baseline-diff) :text-style style :start start :end next-char-index :align-x :left :align-y :top))))) - (setf baseline (max baseline new-baseline) + (setf baseline (if (zerop baseline) new-baseline baseline) height (max height new-height) cursor-x new-cursor-x) (when (>= next-char-index end) diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp index 4e18bca3ed51778ccdc972f332b0ae235dcf8486..55a46607bf7ad573b7109ecfac4dd20b221df885 100644 --- a/clim/text-recording.lisp +++ b/clim/text-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/clim/text-recording.lisp,v 1.21 1997/02/05 01:45:12 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/clim/text-recording.lisp,v 1.22 1997/05/31 01:00:32 tomj Exp $ (in-package :clim-internals) @@ -404,20 +404,22 @@ (return-from get-text-output-record record))) (let* ((string (make-array 16 :element-type #+ANSI-90 'character #-ANSI-90 'string-char :fill-pointer 0 :adjustable t)) - (record (if (not (eq style default-style)) - (make-styled-text-output-record - string (medium-ink stream) (medium-clipping-region stream)) - (make-standard-text-output-record - string (medium-ink stream) (medium-clipping-region stream))))) + (record (if (eq style default-style) + (make-standard-text-output-record + string (medium-ink stream) (medium-clipping-region stream)) + (make-styled-text-output-record + string (medium-ink stream) (medium-clipping-region stream))))) (setf (stream-text-output-record stream) record) - (multiple-value-bind (abs-x abs-y) - (point-position - (stream-output-history-position stream)) - (declare (type coordinate abs-x abs-y)) - (multiple-value-bind (cx cy) (stream-cursor-position stream) - (declare (type coordinate cx cy)) - (output-record-set-start-cursor-position - record (- cx abs-x) (- cy abs-y)))) + (let ((baseline-diff (min 0 (- (text-style-ascent style (sheet-medium stream)) + (stream-baseline stream))))) + (multiple-value-bind (abs-x abs-y) + (point-position + (stream-output-history-position stream)) + (declare (type coordinate abs-x abs-y)) + (multiple-value-bind (cx cy) (stream-cursor-position stream) + (declare (type coordinate cx cy)) + (output-record-set-start-cursor-position + record (- cx abs-x) (- cy abs-y baseline-diff))))) ;; Moved to STREAM-CLOSE-TEXT-OUTPUT-RECORD, since we don't need this thing ;; in the history until then. This should save an extra recompute-extent call ;; (one in here, one when the string is added). diff --git a/make-symbolic-links.sh b/make-symbolic-links.sh index a987722449bcd5c3877bddb7b309bced80e2cec8..22a6bd5a3177557684d46e39818c3ee8febe7da0 100644 --- a/make-symbolic-links.sh +++ b/make-symbolic-links.sh @@ -1,6 +1,6 @@ #!/bin/sh # -# $Header: /repo/cvs.copy/clim2/Attic/make-symbolic-links.sh,v 1.5 1997/05/24 03:52:34 tomj Exp $ +# $Header: /repo/cvs.copy/clim2/Attic/make-symbolic-links.sh,v 1.6 1997/05/31 01:00:23 tomj Exp $ # # make a tree of links # @@ -8,7 +8,7 @@ # 'original' must be changed whenever the source tree is moved # It must be a pathname accessible from any machine on the net -original=/net/romeo/home1/tomj/clim2-nt/clim2 +original=/net/romeo/home1/tomj/clim2 linkdir=$1 if test -z "$linkdir"; then diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 13e6ec800f0cb151328eb18d630866b6bee5655c..3617e7c3827820adcce79eb364436f6ac2c22fa8 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 -*- -;; $Header: /repo/cvs.copy/clim2/silica/db-scroll.lisp,v 1.54 1997/02/05 01:50:50 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/silica/db-scroll.lisp,v 1.55 1997/05/31 01:00:34 tomj Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -106,6 +106,9 @@ hscroll-bar hscroll-bar-enabled-p vscroll-bar vscroll-bar-enabled-p t)) + ;; tjm 15Mar97 otherwise most recent text-output-record not + ;; considered (spr15933) + (stream-force-output (sheet-child viewport)) (with-bounding-rectangle* (left top right bottom) (viewport-contents-extent viewport) (with-bounding-rectangle* (vleft vtop vright vbottom) diff --git a/silica/port.lisp b/silica/port.lisp index 01d5b809518ed18e2fe28ec3c4c5e4eb8965af5f..48ac735c0d75abc7be3232e21dbf8aa0c312d50c 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 -*- -;; $Header: /repo/cvs.copy/clim2/silica/port.lisp,v 1.37 1997/02/05 01:51:15 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/silica/port.lisp,v 1.38 1997/05/31 01:00:36 tomj Exp $ (in-package :silica) @@ -10,7 +10,7 @@ ;; Ports and grafts -(defvar *default-server-path* #+(and Allegro (not microsoft-32)) '(:motif) +(defvar *default-server-path* #+(and Allegro (not acl86win32)) '(:motif) #+Lucid '(:clx) #+Genera `(:genera) #+Cloe-Runtime `(:cloe) diff --git a/sys/compile.lisp b/sys/compile.lisp index 3e51dc116fc75d023f20b64602f62e25d48fc9d0..951dc85b17b7304b0680f8a3200edcb128f38332 100644 --- a/sys/compile.lisp +++ b/sys/compile.lisp @@ -1,6 +1,6 @@ (in-package :user) -#+(and Allegro microsoft-32) +#+(and Allegro (or microsoft-32 mswindows)) (eval-when (compile load eval) (push :acl86win32 *features*)) #+acl86win32 diff --git a/sys/load.lisp b/sys/load.lisp index 8ceff085b47587d3070093aca948eb7b322045c1..f0e330d55a3e9f650f9bdc71716f5f824075b01e 100644 --- a/sys/load.lisp +++ b/sys/load.lisp @@ -1,6 +1,6 @@ (in-package :user) -#+(and Allegro microsoft-32) +#+(and Allegro (or microsoft-32 mswindows)) (eval-when (compile load eval) (push :acl86win32 *features*)) #+acl86win32 @@ -42,23 +42,22 @@ (let (#+acl86win32 (excl::*enable-package-locked-errors* nil)) +(load (climpath "aclpc\\sysdcl.lisp")) + #+aclpc (clim-defsystem:load-system "aclpc-clim") #+acl86win32 (load-system 'aclnt-clim) -;;; to make a non-demo-loaded version, comment the following -#+aclpc (load (climpath "test\\test-suite.fsl")) -#+acl86win32 (load (climpath "test\\test-suite.fasl")) - -#+aclpc (load (climpath "demo\\sysdcl-pc.lisp")) -#+acl86win32 (load (climpath "demo\\sysdcl.lisp")) +(unless (and (boundp *no-clim-demos*) *no-clim-demos*) + #+aclpc (load (climpath "test\\test-suite.fsl")) + #+acl86win32 (load (climpath "test\\test-suite.fasl")) + #+aclpc (load (climpath "demo\\sysdcl-pc.lisp")) + #+acl86win32 (load (climpath "demo\\sysdcl.lisp")) + #+aclpc (clim-defsystem:load-system "clim-demo") + #+acl86win32 (load-system 'clim-demo)) ) ;; end let #+acl86win32 (excl::*enable-package-locked-errors* nil) -#-acl86win32 -(clim-defsystem:load-system "clim-demo") - ;;; Remove this feature for the final world. - #+acl86win32-uses-clim-defsystem (setq *features* (delete :defsystem *features*)) diff --git a/sys/sysdcl-pc.lisp b/sys/sysdcl-pc.lisp index 973fbef450b8452988c3338259fe343116712c6b..6975f2b888f55f6b60c6a27e6d58a398b1c79922 100644 --- a/sys/sysdcl-pc.lisp +++ b/sys/sysdcl-pc.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/sys/sysdcl-pc.lisp,v 1.3 1997/05/24 03:52:47 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/sys/sysdcl-pc.lisp,v 1.4 1997/05/31 01:00:38 tomj Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -208,12 +208,9 @@ ("formatted-output-defs") ("recording-protocol" ; :short-name "rprotoco" :load-before-compile ("recording-defs")) - ("text-recording" - :load-before-compile ("recording-protocol")) - ("graphics-recording" - :load-before-compile ("recording-protocol")) - ("design-recording" - :load-before-compile ("graphics-recording")) + ("text-recording" :load-before-compile ("recording-protocol")) + ("graphics-recording" :load-before-compile ("recording-protocol")) + ("design-recording" :load-before-compile ("graphics-recording")) ;; Input editing ("interactive-protocol" ; :short-name "iprotoco" @@ -231,75 +228,46 @@ ("pixmap-streams") ;; Presentation types - ("ptypes1" - :load-before-compile ("clim-defs")) - ("completer" - :load-before-compile ("ptypes1")) - ("presentations" - :load-before-compile ("ptypes1")) - ("translators" - :load-before-compile ("presentations")) - ("histories" - :load-before-compile ("presentations")) - ("ptypes2" - :load-before-compile ("translators")) - ("standard-types" - :load-before-compile ("ptypes2")) - ("excl-presentations" - :load-before-compile ("presentations") - :features Allegro) + ("ptypes1" :load-before-compile ("clim-defs")) + ("completer" :load-before-compile ("ptypes1")) + ("presentations" :load-before-compile ("ptypes1")) + ("translators" :load-before-compile ("presentations")) + ("histories" :load-before-compile ("presentations")) + ("ptypes2" :load-before-compile ("translators")) + ("standard-types" :load-before-compile ("ptypes2")) + ("excl-presentations" :load-before-compile ("presentations") :features Allegro) ;; Formatted output - ("table-formatting" - :load-before-compile ("clim-defs" "incremental-redisplay")) - ("graph-formatting" - :load-before-compile ("clim-defs" "incremental-redisplay")) - ("surround-output" - :load-before-compile ("clim-defs" "incremental-redisplay")) - ("text-formatting" - :load-before-compile ("clim-defs" "incremental-redisplay")) + ("table-formatting" :load-before-compile ("clim-defs" "incremental-redisplay")) + ("graph-formatting" :load-before-compile ("clim-defs" "incremental-redisplay")) + ("surround-output" :load-before-compile ("clim-defs" "incremental-redisplay")) + ("text-formatting" :load-before-compile ("clim-defs" "incremental-redisplay")) ;; Pointer tracking ("tracking-pointer") - ("dragging-output" - :load-before-compile ("tracking-pointer")) + ("dragging-output" :load-before-compile ("tracking-pointer")) ;; Gadgets ("db-stream") ("gadget-output") ;; Application building substrate - ("accept" - :load-before-compile ("clim-defs" "ptypes2")) - ("present" - :load-before-compile ("clim-defs" "ptypes2")) - ("command" - :load-before-compile ("clim-defs" "ptypes2")) - ("command-processor" - :load-before-compile ("clim-defs" "command")) - ("basic-translators" - :load-before-compile ("ptypes2" "command")) - ("frames" - :load-before-compile ("clim-defs" "command-processor")) + ("accept" :load-before-compile ("clim-defs" "ptypes2")) + ("present" :load-before-compile ("clim-defs" "ptypes2")) + ("command" :load-before-compile ("clim-defs" "ptypes2")) + ("command-processor" :load-before-compile ("clim-defs" "command")) + ("basic-translators" :load-before-compile ("ptypes2" "command")) + ("frames" :load-before-compile ("clim-defs" "command-processor")) ("panes" :load-before-compile ("frames")) - ("default-frame" - :load-before-compile ("frames")) - ("activities" - :load-before-compile ("frames")) - ("db-menu" - :load-before-compile ("frames")) - ("db-list" - :load-before-compile ("db-menu")) - ("db-text" - :load-before-compile ("frames")) - ("noting-progress" - :load-before-compile ("frames")) - ("menus" - :load-before-compile ("defresource" "clim-defs")) - ("accept-values" - :load-before-compile ("clim-defs" "incremental-redisplay" "frames")) - ("drag-and-drop" - :load-before-compile ("frames")) + ("default-frame" :load-before-compile ("frames")) + ("activities" :load-before-compile ("frames")) + ("db-menu" :load-before-compile ("frames")) + ("db-list" :load-before-compile ("db-menu")) + ("db-text" :load-before-compile ("frames")) + ("noting-progress" :load-before-compile ("frames")) + ("menus" :load-before-compile ("defresource" "clim-defs")) + ("accept-values" :load-before-compile ("clim-defs" "incremental-redisplay" "frames")) + ("drag-and-drop" :load-before-compile ("frames")) ("item-list-manager") ;; Bootstrap everything diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index af8fbe84a146fdb2a62abb5fd1d61f74cbe30aee..9cdf688a9385a3eae7f9be522752b29971deb334 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 -*- -;; $Header: /repo/cvs.copy/clim2/sys/sysdcl.lisp,v 1.54 1997/05/24 03:52:47 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/sys/sysdcl.lisp,v 1.55 1997/05/31 01:00:39 tomj Exp $ (in-package :cl-user) @@ -182,6 +182,10 @@ "gadgets" "db-border" "db-scroll" + #+acl86win32 "scroll-pane" + #+acl86win32 "db-button" + #+acl86win32 "db-label" + #+acl86win32 ("db-slider" (:load-before-compile "db-border")) )) (defsystem clim-standalone diff --git a/test/test-suite.lisp b/test/test-suite.lisp index c6f3aacff202409366db43c18529a247a19a5887..b13fdd8c4eec5e0f1e82d5c825c38e514c774a64 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 -*- -;; $Header: /repo/cvs.copy/clim2/test/test-suite.lisp,v 1.80 1997/02/05 01:52:20 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/test/test-suite.lisp,v 1.81 1997/05/31 01:00:40 tomj Exp $ (in-package :clim-user) @@ -1941,10 +1941,11 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-drag-and-drop-translator test-suite-dnd-blank - (drag-source string drop-target presentations - :drag-documentation "Don't drop now" + (integer string blank-area presentations + :drag-documentation ((object destination-object stream) + (format stream "Hello ~s on ~s" object destination-object)) :pointer-documentation "bar bar" - :documentation "Documentatoin") + :documentation "Documentation") () (format nil "Dragged to blank area")) @@ -2206,7 +2207,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-test (gadgets-dialog menus-and-dialogs) (stream) - "An own-window ACCEPTING-VALUES dialog that has lots of gadgets inside of it." + "An ACCEPTING-VALUES dialog that has lots of gadgets inside of it." (gadgets-dialog-internal stream nil)) (define-test (ozone-dialog menus-and-dialogs) (stream) @@ -3400,9 +3401,8 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-benchmark (simple-menu-choose :iterations 10) (stream) "Pop up a simple menu of colors" (without-clim-input - (if #+(allegro (not microsoft-32)) - (typep (port stream) 'xm-silica::xt-port) - #-(allegro (not microsoft-32)) nil + (if #-(or aclpc acl86win32) (typep (port stream) 'xm-silica::xt-port) + #+(or aclpc acl86win32) nil (sleep 0.1) ;; Avoid division by zero! (menu-choose '(("Red" :value +red+) ("Green" :value +green+) @@ -3419,9 +3419,8 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-benchmark (cached-menu-choose :iterations 10) (stream) "Pop up a cached menu of colors" (without-clim-input - (if #+(and allegro (not microsoft-32)) - (typep (port stream) 'xm-silica::xt-port) - #-(and allegro (not microsoft-32)) nil + (if #-(or aclpc acl86win32) (typep (port stream) 'xm-silica::xt-port) + #+(or aclpc acl86win32) nil (sleep 0.1) ;; Avoid division by zero! (menu-choose '(("Red" :value +red+) ("Green" :value +green+) @@ -3528,7 +3527,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-application-frame clim-tests () ((history-class :initarg :history-class - :initform 'standard-tree-output-history + :initform 'standard-sequence-output-history :reader clim-tests-history-class)) (:command-table (clim-tests :inherit-from (graphics diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp index 0097bc431eab60008a3cd09a627e686cbd816f84..6f43e8818b6146bcc65ea31af3d31cb993f67734 100644 --- a/tk-silica/image.lisp +++ b/tk-silica/image.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/tk-silica/image.lisp,v 1.21 1997/02/05 01:53:47 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/tk-silica/image.lisp,v 1.22 1997/05/31 01:00:45 tomj Exp $ (in-package :xm-silica) @@ -267,7 +267,11 @@ (if palette (find-named-color x palette) x))) - (let* ((codes (make-array (expt char-code-limit chars-per-pixel))) + ;;--- char-code-limit is 2^16, but the chars in xpm palettes will + ;;--- always be printable ascii. use of char-code-limit here was + ;;--- creating prohibitively large arrays. -tjm 3Mar97 + (let* ((xpm-char-code-limit 256) + (codes (make-array (expt xpm-char-code-limit chars-per-pixel))) (designs (do ((color-specs (read-strings) (cddr color-specs)) (designs nil) @@ -278,7 +282,7 @@ (key 0)) (dotimes (i chars-per-pixel) (setq key (+ (char-code (schar code i)) - (* key char-code-limit)))) + (* key xpm-char-code-limit)))) (setf (svref codes key) index) (push color designs)))) (array (make-array (list height width))) @@ -293,7 +297,7 @@ (let ((key 0)) (dotimes (i chars-per-pixel) (setq key (+ (char-code (schar row index)) - (* key char-code-limit))) + (* key xpm-char-code-limit))) (incf index)) (setf (aref array i j) (svref codes key))))) (incf i))) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index ecc2b9c5b60a8905ee7e884db51a4347b9656401..98ca7868e79c434cb88db11411bf22cc0e6fe0fc 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-frames.lisp,v 1.74 1997/02/05 01:54:00 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-frames.lisp,v 1.75 1997/05/31 01:00:45 tomj Exp $ (in-package :xm-silica) @@ -144,7 +144,9 @@ #+ignore (remove-keywords (find-widget-resource-initargs-for-sheet port sheet) '(:font-list))) - (menu-text-style (pane-text-style sheet)) + ;; menu-text-style used to be (pane-text-style sheet) + ;; changed 28May97 -tjm + (menu-text-style clim-internals::*default-menu-text-style*) (frame (pane-frame sheet)) (top-command-table (or (menu-bar-command-table sheet) (frame-command-table frame))) @@ -377,7 +379,9 @@ port associated-window :foreground foreground :background background) '(:font-list))) - (default-text-style (sheet-text-style port associated-window)) + ;; default-text-style used to be (sheet-text-style port associated-window) + ;; changed 28May97 -tjm + (default-text-style clim-internals::*default-menu-text-style*) (menu-text-style (if text-style (merge-text-styles text-style default-text-style) @@ -409,7 +413,8 @@ initargs))) (when label - (let ((title (if (atom label) label (car label)))) + (let ((title (if (atom label) label (car label))) + (menu-text-style clim-internals::*default-menu-label-text-style*)) (check-type title string) (destructuring-bind (&key text-style) (and (listp label) (cdr label)) (apply #'make-instance 'xt::xm-label diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 5f8915be495fab405116a788a34a766485dcdb9b..319f0410b1a8acb2aa523f426b3d19c111425228 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-gadgets.lisp,v 1.95 1997/02/05 01:54:03 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/tk-silica/xm-gadgets.lisp,v 1.96 1997/05/31 01:00:46 tomj Exp $ (in-package :xm-silica) @@ -1562,7 +1562,8 @@ :help)) (name :notify-user) x-position - y-position) + y-position + (abort-on-cancel-p nil)) (let* ((initargs (find-widget-resource-initargs-for-sheet (port framem) associated-window :foreground foreground :background background @@ -1620,7 +1621,9 @@ #'(lambda () (or result (not (tk::is-managed-p dialog)))) "Waiting for dialog"))) (tk::destroy-widget dialog)) - (car result)))))) + (or (car result) + (and abort-on-cancel-p + (abort)))))))) (defun process-exit-boxes (framem associated-window diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index ab9cf299976c975cbd88f19ddded9f469db7ef86..693266225b75440b1d3f835d8ffc088dc776e11e 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-graphics.lisp,v 1.93 1997/02/05 01:54:14 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-graphics.lisp,v 1.94 1997/05/31 01:00:46 tomj Exp $ (in-package :tk-silica) @@ -504,22 +504,11 @@ device-clip-region-tick) (null ink-clip-region)) (setf (tk::gcontext-clip-mask gc) - (macrolet ((region-rectangle (region) - `(with-bounding-rectangle* (left top right bottom) ,region - (list (fix-coordinate left) (fix-coordinate top) - (fix-coordinate (- right left)) - (fix-coordinate (- bottom top)))))) - (etypecase device-clip-region - (everywhere :none) - (nowhere nil) - (standard-rectangle-set - (let ((regions (region-set-regions device-clip-region)) - (rectangles nil)) - (dolist (region regions) - (push (region-rectangle region) rectangles)) - rectangles)) - (standard-bounding-rectangle - (list (region-rectangle device-clip-region)))))) + (etypecase device-clip-region + (everywhere :none) + (nowhere nil) + (standard-rectangle-set device-clip-region) + (standard-bounding-rectangle device-clip-region))) (setf (ink-gcontext-last-clip-region-tick gc) device-clip-region-tick)))) ;; tile and stipple origin diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 88c3311d04e212b1df112b3186a0019b7fcd2989..fa0dda01e81c97921d1cc8e9623163c18b95a0d2 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-silica.lisp,v 1.106 1997/02/07 00:21:04 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/tk-silica/xt-silica.lisp,v 1.107 1997/05/31 01:00:47 tomj Exp $ (in-package :xm-silica) @@ -163,10 +163,10 @@ `( ;; ascii (0 "fixed" - (:fix "-*-courier-*-*-*-*-*-*-*-*-*-*-*-*") - (:sans-serif "-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*") - (:serif "-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-*-*" - "-*-times-*-*-*-*-*-*-*-*-*-*-*-*")) + (:fix "-*-courier-*-*-*-*-*-*-*-*-*-*-iso8859-1") + (:sans-serif "-*-helvetica-*-*-*-*-*-*-*-*-*-*-iso8859-1") + (:serif "-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-iso8859-1" + "-*-times-*-*-*-*-*-*-*-*-*-*-iso8859-1")) ,@(excl:ics-target-case (:+ics diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index 696ec2214f7e61a484206322247f4e4ac7dbab36..fa07d6970315761db1db73aa0366117483d72a9c 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/tk/gcontext.lisp,v 1.31 1997/02/05 01:52:44 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/tk/gcontext.lisp,v 1.32 1997/05/31 01:00:42 tomj Exp $ (in-package :tk) @@ -350,6 +350,44 @@ gc nv)) +;; granted, this isn't the right thing to do, but it saves us from some +;; nasty consing -tjm 11Apr97 +(defmethod (setf gcontext-clip-mask) ((nv clim-utils::standard-bounding-rectangle) (gc gcontext)) + (let ((rs (x11:make-xrectangle-array :number 1))) + (clim-utils::with-bounding-rectangle* (left top right bottom) nv + (setf (x11:xrectangle-array-x rs 0) (clim-utils::fix-coordinate left) + (x11:xrectangle-array-y rs 0) (clim-utils::fix-coordinate top) + (x11:xrectangle-array-width rs 0) (clim-utils::fix-coordinate (- right left)) + (x11:xrectangle-array-height rs 0) (clim-utils::fix-coordinate (- bottom top)))) + (x11:xsetcliprectangles + (object-display gc) + gc + 0 + 0 + rs + 1 + x11:unsorted))) + +(defmethod (setf gcontext-clip-mask) ((nv clim-utils::standard-rectangle-set) (gc gcontext)) + (let* ((rectangles (clim-utils::region-set-regions nv)) + (n (length rectangles)) + (rs (x11:make-xrectangle-array :number n))) + (dotimes (i n) + (let ((r (nth i rectangles))) + (clim-utils::with-bounding-rectangle* (left top right bottom) r + (setf (x11:xrectangle-array-x rs i) (clim-utils::fix-coordinate left) + (x11:xrectangle-array-y rs i) (clim-utils::fix-coordinate top) + (x11:xrectangle-array-width rs i) (clim-utils::fix-coordinate (- right left)) + (x11:xrectangle-array-height rs i) (clim-utils::fix-coordinate (- bottom top)))))) + (x11:xsetcliprectangles + (object-display gc) + gc + 0 + 0 + rs + n + x11:unsorted))) + (defmethod (setf gcontext-clip-mask) ((nv list) (gc gcontext)) (let* ((n (length nv)) (rs (x11:make-xrectangle-array :number n))) diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp index 392416a15b06d745b2eed442a2fe91c0509beda4..e05a3e2c1b0721c0c2023523c57cd4dd4c9106f6 100644 --- a/utils/base-designs.lisp +++ b/utils/base-designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/base-designs.lisp,v 1.11 1997/02/05 01:54:29 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/base-designs.lisp,v 1.12 1997/05/31 01:00:47 tomj Exp $ (in-package :clim-utils) @@ -171,14 +171,14 @@ (defmethod make-load-form ((design (eql (symbol-value '+foreground-ink+))) #-aclpc &optional #-aclpc environment) #-aclpc (declare (ignore environment)) - #-(or aclpc acl86win32) '+foreground-ink+ #+(or aclpc acl86win32) '(symbol-value '+foreground-ink+)) + #-aclpc '+foreground-ink+ #+aclpc '(symbol-value '+foreground-ink+)) (defconstant +background-ink+ (make-instance 'design)) (defmethod make-load-form ((design (eql (symbol-value '+background-ink+))) #-aclpc &optional #-aclpc environment) #-aclpc (declare (ignore environment)) - #-(or aclpc acl86win32) '+background-ink+ #+(or aclpc acl86win32) '(symbol-value '+background-ink+)) + #-aclpc '+background-ink+ #+aclpc '(symbol-value '+background-ink+)) ;;; Flipping inks diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp index 5614506932dadea2a8fc664c6a11b4c9d641e780..9f66811287a5c4e0c804f0e6f4af103b1125ff01 100644 --- a/utils/defun-utilities.lisp +++ b/utils/defun-utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;;; $Header: /repo/cvs.copy/clim2/utils/defun-utilities.lisp,v 1.11 1997/02/05 01:54:47 tomj Exp $ +;;; $Header: /repo/cvs.copy/clim2/utils/defun-utilities.lisp,v 1.12 1997/05/31 01:00:48 tomj Exp $ (in-package :clim-utils) @@ -64,7 +64,7 @@ (defmacro define-group (name type &body body) `(sys:multiple-definition ,name ,type ,@body)) -#+(and Allegro (not microsoft-32) (version>= 4 1)) +#+(and Allegro (not acl86win32) (version>= 4 1)) (defmacro define-group (name type &body body) `(progn (excl::record-source-file ',name :type ',type) diff --git a/utils/defun.lisp b/utils/defun.lisp index 6113024625ff4defc73de6471254bbdf944077ca..1ee320bf8bde4dc65a882e89401320c0fbdc4530 100644 --- a/utils/defun.lisp +++ b/utils/defun.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/defun.lisp,v 1.11 1997/02/14 23:57:18 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/defun.lisp,v 1.12 1997/05/31 01:00:49 tomj Exp $ (in-package :clim-utils) @@ -356,9 +356,9 @@ #+PCL `(pcl::method ,function-name ,@qualifiers ,specifier-list) #-PCL `(#-aclpc clos:method #+aclpc cl:method ,function-name ,specifier-list ,@qualifiers))) -#+(and Allegro (not microsoft-32) (version>= 4 1)) +#+(and Allegro (not acl86win32) (version>= 4 1)) (eval-when (compile load eval) (cltl1::require :scm)) -#+(and Allegro (not microsoft-32) (version>= 4 1)) +#+(and Allegro (not acl86win32) (version>= 4 1)) (scm::define-simple-parser defmethod scm::defmethod-parser) #+Genera diff --git a/utils/designs.lisp b/utils/designs.lisp index 7cf0512c215b2f0fff88f95febd924ba333dc3ec..e2ae5aa482bc69d069e26cddb40282d8256bf2d1 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/designs.lisp,v 1.22 1997/02/05 01:54:50 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/designs.lisp,v 1.23 1997/05/31 01:00:51 tomj Exp $ (in-package :clim-utils) @@ -360,7 +360,7 @@ (values best-color best-distance)))) -#-(or aclpc (and allegro microsoft-32)) +#-(or aclpc acl86win32) (defmethod add-colors-to-palette ((palette basic-palette) &rest colors) (declare (dynamic-extent colors)) (let ((colors-done nil) @@ -375,10 +375,10 @@ (deallocate-color color palette)) (error condition)))))) -#+(or aclpc (and allegro microsoft-32)) +#+(or aclpc acl86win32) (defgeneric add-colors-to-palette (palette &rest colors)) -#+(or aclpc (and allegro microsoft-32)) +#+(or aclpc acl86win32) (defmethod add-colors-to-palette ((palette basic-palette) &rest colors) (declare (dynamic-extent colors)) (let ((colors-done nil)) @@ -392,7 +392,7 @@ (deallocate-color color palette)) (error condition)))))) -#+(or aclpc (and allegro microsoft-32)) +#+(or aclpc acl86win32) (defgeneric remove-colors-from-palette (palette &rest colors)) (defmethod remove-colors-from-palette ((palette basic-palette) &rest colors) @@ -478,7 +478,7 @@ (make-dynamic-color +black+))) set)) -#+(or aclpc (and allegro microsoft-32)) (defgeneric layered-color (set &rest layers)) +#+aclpc (defgeneric layered-color (set &rest layers)) (defmethod layered-color ((set layered-color-set) &rest layers) (declare (dynamic-extent layers)) @@ -690,7 +690,7 @@ ;;; Compatibility with the old stipple feature, perhaps temporary until ;;; rendering of tiles and patterns is fully implemented ;;; This could be done with methods, but there is very little point to that -#-(or aclpc (and allegro microsoft-32)) +#-(or aclpc acl86win32) (defun decode-tile-as-stipple (rectangular-tile) (declare (values array width height)) (multiple-value-bind (pattern width height) @@ -705,7 +705,7 @@ (eq (aref designs 1) +foreground-ink+)) (values array width height)))))) -#+(or aclpc (and allegro microsoft-32)) +#+(or aclpc acl86win32) (defun decode-tile-as-stipple (rectangular-tile) (declare (values array width height)) (multiple-value-bind (pattern width height) diff --git a/utils/extended-regions.lisp b/utils/extended-regions.lisp index 1264712ad9ce008d3dc3805665f5e137e424ee97..94abad6737fd7f3a814779ca42f4e9b240aa302f 100644 --- a/utils/extended-regions.lisp +++ b/utils/extended-regions.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/extended-regions.lisp,v 1.8 1997/02/05 01:54:54 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/extended-regions.lisp,v 1.9 1997/05/31 01:00:51 tomj Exp $ (in-package :clim-utils) @@ -98,6 +98,34 @@ (and (region-contains-position-p line1 start-x start-y) (region-contains-position-p line1 end-x end-y)))) +;; spec says only coincidence satisfies region-intersects-region-p for lines +;; this is often more useful since it returns true if they touch *anywhere* +(defun segments-intersect-p (line1 line2) + (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1 + (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2 + (let ((sx1 sx1) (sy1 sy1) (ex1 ex1) (ey1 ey1) + (sx2 sx2) (sy2 sy2) (ex2 ex2) (ey2 ey2)) + (declare (type coordinate sx1 sy1 ex1 ey1 + sx2 sy2 ex2 ey2)) + ;; do the lines' x-components and y-components even overlap? + (and (>= (max sx2 ex2) (min sx1 ex1)) + (>= (max sx1 ex1) (min sx2 ex2)) + (>= (max sy2 ey2) (min sy1 ey1)) + (>= (max sy1 ey1) (min sy2 ey2)) + (let* ((dx1 (- ex1 sx1)) (dy1 (- ey1 sy1)) + (dx2 (- ex2 sx2)) (dy2 (- ey2 sy2)) + (dsx (- sx1 sx2)) (dsy (- sy1 sy2)) + (slope-diff (- (* dx1 dy2) (* dx2 dy1)))) + (if (= slope-diff 0) ; parallel + (= (* dsy dx1) (* dsx dy1)) ; coincident + (let ((r (/ (- (* dsy dx2) (* dsx dy2)) slope-diff)) + (s (/ (- (* dsy dx1) (* dsx dy1)) slope-diff))) + (and (<= 0 r 1) (<= 0 s 1)))))))))) ; intersecting + +;; as per the dimensionality rules in the spec (why?) +;; this only returns true if the segments coincide; +;; use segments-intersect-p above to find out if they cross +;; and point-of-intersection to get the p-o-i (defmethod region-intersects-region-p ((line1 standard-line) (line2 standard-line)) (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1 (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2 @@ -118,8 +146,29 @@ (declare (type coordinate sx1 sy1 ex1 ey1)) (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2 (declare (type coordinate sx2 sy2 ex2 ey2)) - (make-line* (max sx1 sx2) (max sy1 sy2) (min ex1 ex2) (min ey1 ey2)))) - +nowhere+)) + (flet ((between-p (x1 y1 x2 y2 x y) + (and (or (<= x1 x x2) (<= x2 x x1)) + (or (<= y1 y y2) (<= y2 y y1))))) + (let ((sx nil) (sy nil) (ex nil) (ey nil)) + ;; A B C D + ;; line1: ___ _____ ____ ____ + ;; line2: ----- --- ---- ---- + (if (between-p sx1 sy1 ex1 ey1 sx2 sy2) + ;; cases B/D + (setf sx sx2 sy sy2)) + (if (between-p sx1 sy1 ex1 ey1 ex2 ey2) + ;; cases B/C + (if sx (setf ex ex2 ey ey2) ;; case B + (setf sx ex2 sy ey2))) ;; case C + (if (between-p sx2 sy2 ex2 ey2 sx1 sy1) + ;; cases A/C + (if sx (setf ex sx1 ey sy1) ;; case C + (setf sx sx1 sy sy1))) ;; case A + (if (between-p sx2 sy2 ex2 ey2 ex1 ey1) + ;; cases A/D + (setf ex ex1 ey ey1)) + (make-line* sx sy ex ey))))) + +nowhere+)) (defmethod transform-region (transformation (line standard-line)) (with-slots (start-x start-y end-x end-y) line @@ -188,7 +237,7 @@ (i 1)) (loop (funcall function x y - (setf x (aref coords (incf i))) (setf x (aref coords (incf i)))) + (setf x (aref coords (incf i))) (setf y (aref coords (incf i)))) (when (= i ncoords) (return))) (when (polyline-closed polygon) (funcall function x y x1 y1))) @@ -268,6 +317,521 @@ (map-over-polygon-coordinates #'transform-coord polygon)) (make-polygon* (nreverse coords)))) +;;; from patch3519, various missing region methods on polygons, polylines, etc. +;;; note that these work in the hairy cases too, eg: +;;; _ +;;; |\ /| / \ |\ /| +;;; | X | | | | \/ | +;;; |/ \| \_/ |____| + +(defmethod region-contains-position-p ((polyline standard-polyline) x y) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (when (region-contains-position-p (make-line* x1 y1 x2 y2) x y) + (return-from region-contains-position-p t))) + polyline)) + +(define-symmetric-region-method region-intersects-region-p ((polyline standard-polyline) (other-region region)) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (when (region-intersects-region-p (make-line* x1 y1 x2 y2) other-region) + (return-from region-intersects-region-p t))) + polyline)) + +(defmethod region-contains-region-p ((polyline standard-polyline) (line standard-line)) + (let ((x nil) (y nil)) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((this-segment (make-line* x1 y1 x2 y2))) + (when (region-contains-region-p this-segment line) + (return-from region-contains-region-p t)) + ;; also check for this case: \__.__/ + ;; imagine parallel lines are --- superimposed. + (unless (and x + (let ((last-n-segments (make-line* x y x2 y2))) + ;; if the last few segments form a straight line... + (and (region-contains-region-p last-n-segments this-segment) + (if (region-contains-region-p last-n-segments line) + (return-from region-contains-region-p t) + ;; else-- no dice, but keep x and y + ;; because maybe there's an even longer + ;; straight line in the polyline + t)))) + (setf x x1 y y1)))) + polyline))) + +(defmethod region-contains-region-p ((polyline1 standard-polyline) (polyline2 standard-polyline)) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (unless (region-contains-region-p polyline1 (make-line* x1 y1 x2 y2)) + (return-from region-contains-region-p nil))) + polyline2) + t) + +(defmethod region-contains-position-p ((polygon polygon) x y) + (with-bounding-rectangle* (left top right bottom) polygon + (and (<= left x right) + (<= top y bottom) + (let ((line-to-infinity (make-line* x y (+ 10 right) (+ 10 bottom))) + (intersections 0)) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (if (region-contains-position-p line-to-infinity x1 y1) + (when (and (= x x1) (= y y1)) + ;; position is a vertex of the polygon [if not, + ;; line-to-infinity crosses a vertex of the poly, but we + ;; still don't incf this time since the same intersection + ;; will have shown up in the previous segment and we don't + ;; want to count it twice] + (return-from region-contains-position-p t)) + (let ((segment (make-line* x1 y1 x2 y2))) + (when (segments-intersect-p line-to-infinity segment) + (when (region-contains-position-p segment x y) + ;; position sits on a line of the polygon + (return-from region-contains-position-p t)) + (incf intersections))))) + polygon) + ;; position is bounded by polygon if line from position to infinity + ;; crosses polygon boundaries an odd number of times + (oddp intersections))))) + +(defmethod region-intersects-region-p ((polygon1 polygon) (polygon2 polygon)) + (or (region-contains-region-p polygon1 polygon2) + (region-contains-region-p polygon2 polygon1) + (map-over-polygon-segments + #'(lambda (sx sy ex ey) + (let ((segment-of-p1 (make-line* sx sy ex ey))) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (when (segments-intersect-p segment-of-p1 + (make-line* x1 y1 x2 y2)) + (return-from region-intersects-region-p t))) + polygon2))) + polygon1))) + +;; just-touches-p is useful in many situations when we know two things +;; intersect but would like to determine whether they just touch or +;; actually cross, ie the lines in T or V just touch but in X they cross. + +;; default to nil +(defmethod just-touches-p ((region1 region) (region2 region))) + +(defmethod just-touches-p ((line1 standard-line) (line2 standard-line)) + (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1 + (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2 + ;; if any segment endpoint is *on* the other segment, they don't cross + (or (region-contains-position-p line2 sx1 sy1) + (region-contains-position-p line2 ex1 ey1) + (region-contains-position-p line1 sx2 sy2) + (region-contains-position-p line1 ex2 ey2))))) + +(define-symmetric-region-method just-touches-p ((polygon polygon) (line standard-line)) + (and (not (region-contains-region-p polygon line)) + ;; relies on map-over-polygon-segments returning nil on completion + (not (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((segment (make-line* x1 y1 x2 y2))) + (unless (or (not (segments-intersect-p segment line)) + (just-touches-p segment line)) + (return-from just-touches-p nil)))) + polygon)))) + +(defmethod just-touches-p ((polygon1 polygon) (polygon2 polygon)) + (and (not (map-over-polygon-segments + #'(lambda (a b c d) + (let ((segment-of-1 (make-line* a b c d))) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((segment-of-2 (make-line* x1 y1 x2 y2))) + (unless (or (not (segments-intersect-p segment-of-1 segment-of-2)) + (and (just-touches-p segment-of-1 polygon2) + (just-touches-p segment-of-2 polygon1))) + (return-from just-touches-p nil)))) + polygon2))) + polygon1)))) + +;; does-not-overlap-p might seem redundant but is a distinction which needs +;; to be made in the case where a line meets an region on the border of a +;; region-difference. + +(defmethod does-not-overlap-p ((region1 region) (region2 region)) + (just-touches-p region1 region2)) + +(defmethod does-not-overlap-p ((line1 standard-line) (line2 standard-line)) + (not (region-intersects-region-p line1 line2))) + +;; if poly first, just-touches-p is called +(defmethod does-not-overlap-p ((line standard-line) (poly polygon)) + (not (region-intersects-region-p line poly))) + + +(defmethod region-contains-region-p ((polygon polygon) (line standard-line)) + (with-slots ((sx start-x) (sy start-y) (ex end-x) (ey end-y)) line + (declare (type coordinate sx sy ex ey)) + (and (region-contains-position-p polygon sx sy) + (region-contains-position-p polygon ex ey) + (not (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((segment (make-line* x1 y1 x2 y2))) + (when (segments-intersect-p line segment) + (unless (and (just-touches-p line segment) + ;; make sure the midpoint is bounded-- + ;; remember, polygons can be concave + (region-contains-position-p + polygon + (+ sx (/ (- ex sx) 2)) + (+ sy (/ (- ey sy) 2)))) + ;; line crosses out + (return-from region-contains-region-p nil))))) + polygon))))) + +(defmethod region-contains-region-p ((polygon1 polygon) (polygon2 polygon)) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (unless (region-contains-region-p polygon1 (make-line* x1 y1 x2 y2)) + (return-from region-contains-region-p nil))) + polygon2) + t) + +(defmethod region-equal ((polygon1 polygon) (polygon2 polygon)) + ;; inefficient? + (and (region-contains-region-p polygon1 polygon2) + (region-contains-region-p polygon2 polygon1))) + +(define-symmetric-region-method region-intersects-region-p ((polygon polygon) (line standard-line)) + (or (region-contains-region-p polygon line) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (when (segments-intersect-p line (make-line* x1 y1 x2 y2)) + (return-from region-intersects-region-p t))) + polygon))) + +;; previously missing region-set methods -- region-set is essentially equivalent to +;; region-union since there are no specialized region-union methods + +(defmethod region-intersects-region-p ((set1 region-set) (set2 region-set)) + (map-over-region-set-regions + #'(lambda (region-of-set1) + (map-over-region-set-regions + #'(lambda (region-of-set2) + (when (region-intersects-region-p region-of-set1 region-of-set2) + (return-from region-intersects-region-p t))) + set2)) + set1) + nil) + +(defmethod region-equal ((set1 region-set) (set2 region-set)) + ;; inefficient? bah. consider making this the primary method. + (and (region-contains-region-p set1 set2) + (region-contains-region-p set2 set1))) + +(define-symmetric-region-method region-intersects-region-p ((set region-set) (other-region region)) + (map-over-region-set-regions + #'(lambda (set-region) + (when (region-intersects-region-p set-region other-region) + (return-from region-intersects-region-p t))) + set)) + +(defun point-of-intersection (sx1 sy1 ex1 ey1 sx2 sy2 ex2 ey2) + ;; do the lines' x-components and y-components even overlap? + (when (and (>= (max sx2 ex2) (min sx1 ex1)) + (>= (max sx1 ex1) (min sx2 ex2)) + (>= (max sy2 ey2) (min sy1 ey1)) + (>= (max sy1 ey1) (min sy2 ey2))) + (let* ((dx1 (- ex1 sx1)) (dy1 (- ey1 sy1)) + (dx2 (- ex2 sx2)) (dy2 (- ey2 sy2)) + (dsx (- sx1 sx2)) (dsy (- sy1 sy2)) + (slope-diff (- (* dx1 dy2) (* dx2 dy1)))) + (unless (= slope-diff 0) ; parallel or coincident + (let ((r (/ (- (* dsy dx2) (* dsx dy2)) slope-diff)) + (s (/ (- (* dsy dx1) (* dsx dy1)) slope-diff))) + (when (and (<= 0 r 1) (<= 0 s 1)) ; intersecting + (values (+ sx1 (* r (- ex1 sx1))) ; xy of intersection + (+ sy1 (* r (- ey1 sy1)))))))))) + +(defmethod break-line-across-poly ((line standard-line) (poly polygon)) + (with-slots ((sx start-x) (sy start-y) (ex end-x) (ey end-y)) line + (let ((poi nil)) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (multiple-value-bind (poi-x poi-y) + (point-of-intersection x1 y1 x2 y2 sx sy ex ey) + (when poi-x + ;; index on distance from start point + (let ((d (+ (abs (- sx poi-x)) + (abs (- sy poi-y))))) + (push (list d poi-x poi-y) poi))))) + poly) + (let ((sorted-poi (apply #'append (mapcar #'cdr (sort poi #'< :key #'car))))) + (make-polyline* (append (list sx sy) sorted-poi (list ex ey))))))) + +(defmethod break-line-across-poly ((line1 standard-line) (line2 standard-line)) + (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1 + (with-slots ((sx2 start-x) (sy2 start-y) (ex2 end-x) (ey2 end-y)) line2 + (flet ((between (x y) + (if (and (or (<= sx1 x ex1) (<= ex1 x sx1)) + (or (<= sy1 y ey1) (<= ey1 y sy1))) + (+ (abs (- sx1 x)) (abs (- sy1 y)))))) + (let* ((ds (between sx2 sy2)) + (de (between ex2 ey2)) + (mid (if (and ds de) + (if (> de ds) + (list sx2 sy2 ex2 ey2) + (list ex2 ey2 sx2 sy2)) + (if ds (list sx2 sy2) + (if de (list ex2 ey2)))))) + (make-polyline* (append (list sx1 sy1) mid (list ex1 ey1)))))))) + +(defmethod region-contains-region-p ((region-set region-set) (line standard-line)) + (let ((possibly-uncontained-parts (list line))) + (map-over-region-set-regions + #'(lambda (this-region) + (let ((still-uncontained nil)) + (dolist (smaller-part possibly-uncontained-parts) + (unless (region-contains-region-p this-region smaller-part) + (if (region-intersects-region-p smaller-part this-region) + (let ((broken-line (break-line-across-poly line this-region))) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((this-part (make-line* x1 y1 x2 y2))) + (unless (region-contains-region-p this-region this-part) + (push this-part still-uncontained)))) + broken-line)) + ;; else + (push smaller-part still-uncontained)))) + (setf possibly-uncontained-parts + (or still-uncontained + (return-from region-contains-region-p t))))) + region-set))) + +(defmethod region-contains-region-p ((other-region region) (region-set region-set)) + (map-over-region-set-regions + #'(lambda (this-region) + (unless (region-contains-region-p other-region this-region) + (return-from region-contains-region-p nil))) + region-set) + t) + +(defmethod region-contains-region-p ((region-set region-set) (polygon polygon)) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (unless (region-contains-region-p region-set (make-line* x1 y1 x2 y2)) + (return-from region-contains-region-p nil))) + polygon) + t) + + +;; standard-region-intersection comparisons + +(defmethod region-contains-position-p ((set standard-region-intersection) x y) + (map-over-region-set-regions + #'(lambda (region) + (unless (region-contains-position-p region x y) + (return-from region-contains-position-p nil))) + set) + t) + +;; this fails on the following case: it gives a false positive on an +;; other-region which *does* intersect all regions in the set but not at +;; their intersection eg the region-intersection of any two regions below +;; with the third. +;; +;; poly A poly B +;; +--+ +--+ +;; | \ / | +;;--+----\---/----+-- line C +;; | \ / | +;; | X | +;; | / \ | +;; +----/---+ | +;; / | +;; +----------+ +;; but not to worry, we catch most of these cases with the specializations +;; on lines/polys below +(define-symmetric-region-method region-intersects-region-p ((set standard-region-intersection) (other-region region)) + (map-over-region-set-regions + #'(lambda (set-region) + (unless (region-intersects-region-p set-region other-region) + (return-from region-intersects-region-p nil))) + set) + t) + +(define-symmetric-region-method region-intersects-region-p ((set standard-region-intersection) (line standard-line)) + (let ((possibly-intersecting-parts (list line))) + (map-over-region-set-regions + #'(lambda (this-region) + (let ((intersects-so-far nil)) + (dolist (this-part possibly-intersecting-parts) + (when (and (region-intersects-region-p this-region this-part) + (not (just-touches-p this-region this-part))) + (let ((broken-line (break-line-across-poly line this-region))) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((this-subsegment (make-line* x1 y1 x2 y2))) + (when (region-contains-region-p this-region this-subsegment) + (push this-subsegment intersects-so-far)))) + broken-line)))) + (setf possibly-intersecting-parts + (or intersects-so-far + (return-from region-intersects-region-p nil))))) + set)) + t) + +(define-symmetric-region-method region-intersects-region-p ((set standard-region-intersection) (poly polygon)) + (or (region-contains-region-p poly set) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (when (region-intersects-region-p set (make-line* x1 y1 x2 y2)) + (return-from region-intersects-region-p t))) + poly))) + +(defmethod region-contains-region-p ((set standard-region-intersection) (other-region region)) + (map-over-region-set-regions + #'(lambda (set-region) + (unless (region-contains-region-p set-region other-region) + (return-from region-contains-region-p nil))) + set) + t) + +;; this fails too often - works for union but not intersection... but we +;; catch many such cases with poly specialization below +(defmethod region-contains-region-p ((other-region region) (set standard-region-intersection)) + (map-over-region-set-regions + #'(lambda (set-region) + (unless (region-contains-region-p other-region set-region) + (return-from region-contains-region-p nil))) + set) + t) + +;; what a headache... this checks through each side of each region in the +;; set against all other regions in the set and hacks each side down into +;; the part (if any) which is actually *in* all of them (ie bounding or +;; inside the intersection). As it goes it checks to make sure each such +;; segment is contained by the poly in question. +(defmethod region-contains-region-p ((poly polygon) (set standard-region-intersection)) + (let ((current-region 0)) + (map-over-region-set-regions + #'(lambda (this-region) + ;; should check if polygon first + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((parts-of-this-side (list (make-line* x1 y1 x2 y2))) + (counter 0)) + (dolist (that-region (region-set-regions set)) + (unless parts-of-this-side (return)) + (let ((smaller-parts nil)) + (unless (= counter current-region) + (dolist (this-segment parts-of-this-side) + (if (region-intersects-region-p this-segment that-region) + (let ((broken-line (break-line-across-poly this-segment that-region))) + (map-over-polygon-segments + #'(lambda (sx sy ex ey) + (let ((subseg (make-line* sx sy ex ey))) + (if (region-contains-region-p + that-region subseg) + (push subseg smaller-parts)))) + broken-line)))) + (setf parts-of-this-side smaller-parts))) + (incf counter)) + (dolist (segment-bounding-intersection parts-of-this-side) + (unless (region-contains-region-p poly segment-bounding-intersection) + (return-from region-contains-region-p nil))))) + this-region) + (incf current-region)) + set)) + t) + + +;; standard-region-difference comparisons + +(defmethod region-contains-position-p ((diff standard-region-difference) x y) + (with-slots (region1 region2) diff + (and (region-contains-position-p region1 x y) + (not (region-contains-position-p region2 x y))))) + +(defmethod region-contains-region-p ((diff standard-region-difference) (other-region region)) + (with-slots (region1 region2) diff + (and (region-contains-region-p region1 other-region) + (or (not (region-intersects-region-p region2 other-region)) + ;; okay to touch? + (does-not-overlap-p region2 other-region))))) + +(defmethod region-contains-region-p ((other-region region) (diff standard-region-difference)) + (with-slots (region1 region2) diff + (or (region-contains-region-p other-region region1) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((this-side (make-line* x1 y1 x2 y2))) + (if (and (region-intersects-region-p this-side region2) + (not (does-not-overlap-p this-side region2))) + ;; what if region2 not poly? + (let ((broken-line (break-line-across-poly this-side region2))) + (map-over-polygon-segments + #'(lambda (sx sy ex ey) + (let ((subseg (make-line* sx sy ex ey))) + (unless (or (region-contains-region-p region2 subseg) + (region-contains-region-p other-region subseg)) + (return-from region-contains-region-p nil)))) + broken-line)) + (unless (region-contains-region-p other-region this-side) + (return-from region-contains-region-p nil))))) + region1) + t))) + +(define-symmetric-region-method region-intersects-region-p ((diff standard-region-difference) (other-region region)) + (with-slots (region1 region2) diff + (and (region-intersects-region-p region1 other-region) + (or (not (region-intersects-region-p region2 other-region)) + (just-touches-p region2 other-region))))) + +(define-symmetric-region-method region-intersects-region-p ((diff standard-region-difference) (poly polygon)) + (or (region-contains-region-p poly diff) + (region-contains-region-p diff poly) + (with-slots (region1 region2) diff + (and (region-intersects-region-p region1 poly) + (or (not (region-intersects-region-p region2 poly)) + (and (region-contains-region-p poly region1) + (not (region-contains-region-p region2 region1))) + (does-not-overlap-p region2 poly) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (when (region-intersects-region-p diff (make-line* x1 y1 x2 y2)) + (return-from region-intersects-region-p t))) + poly)))))) + +(define-symmetric-region-method region-intersects-region-p ((diff standard-region-difference) (line standard-line)) + (with-slots (region1 region2) diff + (and (region-intersects-region-p line region1) + (or (not (region-intersects-region-p line region2)) + (does-not-overlap-p region2 line) + (and (not (region-contains-region-p region2 line)) + (let ((broken-line (break-line-across-poly line region2))) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((this-subsegment (make-line* x1 y1 x2 y2))) + (when (and (region-intersects-region-p this-subsegment region1) + (not (region-contains-region-p region2 this-subsegment))) + (return-from region-intersects-region-p t)))) + broken-line))))))) + + +;; line-poly-intersection assumes region-intersects-region-p is true. +;; produces line(s) clipped to stay inside poly. +;; we don't use this yet-- but spec says region-intersection and +;; region-difference of paths and areas (eg lines and polys) should produce +;; clipped lines... how to do this? +#+ignore-for-now +(defun line-poly-intersection (line poly) + (let ((segments nil) + (broken-line (break-line-across-poly line poly))) + (map-over-polygon-segments + #'(lambda (x1 y1 x2 y2) + (let ((this-segment (make-line* x1 y1 x2 y2))) + (when (region-contains-region-p poly this-segment) + (push this-segment segments)))) + broken-line) + (apply #'make-region-union segments))) + ;;; Ellipses and elliptical arcs diff --git a/utils/region-arithmetic.lisp b/utils/region-arithmetic.lisp index b885431ecff9bdee14a49639e583bc6a02654e57..bf174e4c60c8538099f108330df7d8dc48cf3318 100644 --- a/utils/region-arithmetic.lisp +++ b/utils/region-arithmetic.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/region-arithmetic.lisp,v 1.16 1997/02/05 01:55:18 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/region-arithmetic.lisp,v 1.17 1997/05/31 01:00:52 tomj Exp $ (in-package :clim-utils) @@ -100,6 +100,13 @@ (if (region-intersects-region-p point path) point +nowhere+)) (define-symmetric-region-method region-intersection ((point point) (area area)) (if (region-intersects-region-p point area) point +nowhere+)) +;; this looks fishy to me-- what if the path and area are like so: +;; +-----+ +;; | --+----- +;; | | +;; +-----+ then the path is *not* the intersection! +;; and in fact the spec backs me up on this +#+ignore ;; tjm 17Mar97 (define-symmetric-region-method region-intersection ((path path) (area area)) (if (region-intersects-region-p path area) path +nowhere+)) @@ -166,7 +173,9 @@ (defmethod region-difference ((area area) (path path)) area) (defmethod region-difference ((region1 region) (region2 region)) - (make-region-difference region1 region2)) + (if (region-intersects-region-p region1 region2) + (make-region-difference region1 region2) + region1)) ;;; Simple rectangle (LTRB) arithmetic diff --git a/utils/regions.lisp b/utils/regions.lisp index f67a6d992cb6c0edc72ff422aa3ef5f477e6e61f..fd9e0d4f8873ffe70ce8a33ccef89a5ead4f32cf 100644 --- a/utils/regions.lisp +++ b/utils/regions.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/regions.lisp,v 1.20 1997/02/07 00:21:08 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/regions.lisp,v 1.21 1997/05/31 01:00:52 tomj Exp $ (in-package :clim-utils) @@ -838,6 +838,8 @@ (map-over-region-set-regions #'contains-position-p region-set)) nil) +;; what if none of the chunks contain the other-region but they do as a whole? +;; can we cover that case with strategic use of region-difference? -tjm 17Mar97 (defmethod region-contains-region-p ((region-set region-set) (other-region region)) (flet ((contains-region-p (region) (when (region-contains-region-p region other-region) @@ -989,11 +991,11 @@ (bottom (max y1 y2))) (when (angle-between-angles-p pi-single-float theta-1 theta-2) (minf left (- x-radius))) - (when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2) + (when (angle-between-angles-p pi/2 theta-1 theta-2) (minf top (- y-radius))) (when (angle-between-angles-p 0 theta-1 theta-2) (maxf right x-radius)) - (when (angle-between-angles-p pi/2 theta-1 theta-2) + (when (angle-between-angles-p (* pi-single-float 3/2) theta-1 theta-2) (maxf bottom y-radius)) (when filled (minf left 0) diff --git a/utils/transformations.lisp b/utils/transformations.lisp index b61d755a55accd1baea7c8667f3faff2823f999b..a69d99e10665e2995452f1d0338360e25f84ff3c 100644 --- a/utils/transformations.lisp +++ b/utils/transformations.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $Header: /repo/cvs.copy/clim2/utils/transformations.lisp,v 1.13 1997/02/05 01:55:24 tomj Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/transformations.lisp,v 1.14 1997/05/31 01:00:53 tomj Exp $ (in-package :clim-utils) @@ -696,16 +696,18 @@ (declare (type single-float tx ty)) (values (coordinate (+ x tx)) (coordinate (+ y ty)))))) +;; coordinates *would* be single floats if we compiled with feature use-float-coordinates +;; ... why *don't* we? (defmethod transform-position ((transform standard-transformation) x y) +;; (declare (optimize (speed 3) (safety 1) (debug 0))) (declare (type real x y)) - (let ((x (coordinate x)) - (y (coordinate y))) - (declare (type coordinate x y)) + (let ((x #-ignore (float x 0f0) #+ignore (coordinate x)) + (y #-ignore (float y 0f0) #+ignore (coordinate y))) + (declare (type #-ignore single-float #+ignore coordinate x y)) (with-slots (mxx mxy myx myy tx ty) transform (declare (type single-float mxx mxy myx myy tx ty)) - (values (coordinate (+ (* x mxx) (* y mxy) tx)) - (coordinate (+ (* x myx) (* y myy) ty)))))) - + (values (the #-ignore single-float #+ignore coordinate (+ (* x mxx) (* y mxy) tx)) + (the #-ignore single-float #+ignore coordinate (+ (* x myx) (* y myy) ty)))))) (defmethod untransform-position ((transform identity-transformation) x y) (declare (type real x y))