diff --git a/cloe/cloe-dc.lisp b/cloe/cloe-dc.lisp index 63e2c35b35985032c77b4fa38412ebb562b141d0..7e2b5d6b722c9a454eb1fc2c8673595807d2cc15 100644 --- a/cloe/cloe-dc.lisp +++ b/cloe/cloe-dc.lisp @@ -1,42 +1,26 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLOE-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-dc.lisp,v 1.1 92/10/01 10:03:56 cer Exp $ +;; $fiHeader: cloe-dc.lisp,v 1.1 92/10/28 09:24:09 cer Exp $ (in-package :cloe-clim) "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." - -(eval-when (compile load eval) -;; Define the new key chars for Cloe CLIM. Regular Cloe defines 0-127, we define -;; 128-139 as the F-keys (F1 thru F12), 140 for c-sh-A, and 141 as c-sh-V -(sys::define-character-name "F1" 128) -(sys::define-character-name "F2" 129) -(sys::define-character-name "F3" 130) -(sys::define-character-name "F4" 131) -(sys::define-character-name "F5" 132) -(sys::define-character-name "F6" 133) -(sys::define-character-name "F7" 134) -(sys::define-character-name "F8" 135) -(sys::define-character-name "F9" 136) -;; Note windows traps F10 as alt-space. Why? -(sys::define-character-name "F10" 137) -(sys::define-character-name "F11" 138) -(sys::define-character-name "F12" 139) -(sys::define-character-name "Arglist" 140) -(sys::define-character-name "ShowValue" 141) -) ;eval-when - -;;; - +(defvar *dummy-window*) (defvar *dc*) +(defvar *current-window*) (defvar *current-pen*) (defvar *current-brush*) (defvar *current-rop2*) (defvar *current-background-color*) (defvar *current-text-color*) (defvar *current-font*) +(defvar *current-region*) +(defvar *current-left*) +(defvar *current-top*) +(defvar *current-right*) +(defvar *current-bottom*) ;;; Stock objects (defvar *null-pen*) @@ -51,8 +35,8 @@ (defvar *color-to-image* (make-hash-table)) (defvar *black-image*) (defvar *white-image*) - (defvar *ink-to-image* (make-hash-table)) +(defvar *rectangle-to-region* (make-hash-table :test #'equal)) (defstruct (dc-image (:predicate nil)) @@ -68,7 +52,10 @@ (unless win::*windows-channel* (win::connect-to-winfe)) ;; Dummy window to represent class. - (setf *dc* (win::create-window "Vanilla" "CLIM" win::ws_popup 0 0 0 0 0 0 0 "arg")) + (setf *dummy-window* + (win::create-window "Vanilla" "CLIM" win::ws_popup 0 0 0 0 0 0 0 "arg")) + (setf *current-window* *dummy-window*) + (setf *dc* (win::get-dc *dummy-window*)) ;; Stock objects (setf *null-pen* (win::get-stock-object win::null_pen)) @@ -85,7 +72,15 @@ (setf *current-background-color* #xffffff) (setf *current-text-color* #x000000) (setf *current-font* nil) - + (setf *current-region* nil) + (setf *current-left* nil) + (setf *current-top* nil) + (setf *current-right* nil) + (setf *current-bottom* nil) + + (clrhash *color-to-image*) + (clrhash *ink-to-image*) + (clrhash *rectangle-to-region*) (setf *black-image* (make-dc-image :solid-1-pen *black-pen* :brush *black-brush* :text-color #x000000 :background-color nil)) @@ -98,6 +93,45 @@ ;;; +(defun select-window (window) + (unless (eql *current-window* window) + (win::release-dc *dc*) + (setf *dc* (win::get-dc window)) + (setf *current-window* window) + (setf *current-region* nil) ;??? + (setf *current-left* nil)) ;??? + *dc*) + +#|| +(defun select-clip-rectangle (left top right bottom) + (unless (and (eql *current-left* left) + (eql *current-top* top) + (eql *current-right* right) + (eql *current-bottom* bottom)) + #|| + (when *current-left* + (win::release-dc *dc*) + (setf *dc* (win::get-dc *current-window*))) + (win::intersect-clip-rect *dc* left top right bottom) + ||# + (setf *current-left* left) + (setf *current-top* top) + (setf *current-right* right) + (setf *current-bottom* bottom))) +||# + +(defun select-clip-rectangle (left top right bottom) + (select-region (with-stack-list (key left top right bottom) + (or (gethash key *rectangle-to-region*) + (setf (gethash (copy-list key) *rectangle-to-region*) + (win::create-rect-rgn left top right bottom)))))) + +(defun select-region (region) + (unless (eql *current-region* region) + (win::select-region *dc* region) + (setf *current-region* region)) + region) + (defun select-pen (pen) (unless (eql *current-pen* pen) (win::select-pen *dc* pen) diff --git a/cloe/cloe-frames.lisp b/cloe/cloe-frames.lisp index ae86cfdc0105f3533d23d4edfcbe7f4d32de1266..97e8b5d4bb9ccc5a70494ecb2def4c67aa100435 100644 --- a/cloe/cloe-frames.lisp +++ b/cloe/cloe-frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLOE-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-frames.lisp,v 1.1 92/10/01 10:03:49 cer Exp $ +;; $fiHeader: cloe-frames.lisp,v 1.2 92/10/28 11:32:23 cer Exp $ (in-package :cloe-clim) @@ -11,8 +11,8 @@ () (:default-initargs :dialog-view +textual-dialog-view+)) -(defmethod make-frame-manager ((port cloe-port) &key) - (make-instance 'cloe-frame-manager :port port)) +(defmethod make-frame-manager ((port cloe-port) &key palette) + (make-instance 'cloe-frame-manager :port port :palette palette)) (defmethod frame-wrapper ((framem cloe-frame-manager) (frame standard-application-frame) pane) diff --git a/cloe/cloe-medium.lisp b/cloe/cloe-medium.lisp index 10e1a6186b30db869564089ff7dbe77d5c56ffd5..11915efc91b5806668ac93a9ae281aee6b54afef 100644 --- a/cloe/cloe-medium.lisp +++ b/cloe/cloe-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLOE-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-medium.lisp,v 1.1 92/10/01 10:03:52 cer Exp $ +;; $fiHeader: cloe-medium.lisp,v 1.2 92/10/28 11:32:26 cer Exp $ (in-package :cloe-clim) @@ -8,31 +8,15 @@ (defclass cloe-medium (basic-medium) - ((window :initform nil :reader medium-drawable) - (background-dc-image) + ((background-dc-image) (foreground-dc-image))) -(defmethod make-medium ((port cloe-port) sheet) - (make-instance 'cloe-medium - :port port - :sheet sheet)) - -(defmethod deallocate-medium :after (port (medium cloe-medium)) +(defmethod engraft-medium :after ((medium cloe-medium) port sheet) (declare (ignore port)) - (with-slots (window) medium - (setf window nil))) - -(defmethod engraft-medium :after ((medium cloe-medium) (port cloe-port) sheet) - (with-slots (window background-dc-image foreground-dc-image) medium - (unless window - (setq window (sheet-mirror sheet))) + (with-slots (background-dc-image foreground-dc-image) medium (setf background-dc-image (dc-image-for-ink medium (medium-background medium))) (setf foreground-dc-image (dc-image-for-ink medium (medium-foreground medium))))) -(defmethod degraft-medium :after ((medium cloe-medium) (port cloe-port) sheet) - (declare (ignore sheet)) - nil) - (defmethod (setf medium-background) :after (new-background (medium cloe-medium)) (with-slots (background-dc-image) medium (setf background-dc-image (dc-image-for-ink medium new-background)))) @@ -41,6 +25,52 @@ (with-slots (foreground-dc-image) medium (setf foreground-dc-image (dc-image-for-ink medium new-foreground)))) +;;; + +(defclass cloe-window-medium (cloe-medium) + ((window :initform nil :reader medium-drawable))) + +(defmethod make-medium ((port cloe-port) sheet) + (make-instance 'cloe-window-medium + :port port + :sheet sheet)) + +(defmethod engraft-medium :after ((medium cloe-window-medium) port sheet) + (declare (ignore port)) + (with-slots (window) medium + (unless window + (setq window (sheet-mirror sheet))))) + +(defmethod degraft-medium :after ((medium cloe-window-medium) port sheet) + (declare (ignore port sheet)) + (with-slots (window) medium + (setf window nil)) + nil) + +(defmethod select-cloe-dc ((medium cloe-window-medium)) + (let* ((sheet (medium-sheet medium)) + (region (sheet-device-region sheet)) + (medium-region (medium-clipping-region medium)) + cleft ctop cright cbottom + (valid nil)) + (unless (eq region +nowhere+) + (multiple-value-setq (cleft ctop cright cbottom) (bounding-rectangle* region)) + (setf valid t) + (unless (eq medium-region +everywhere+) + (with-bounding-rectangle* (mleft mtop mright mbottom) medium-region + (multiple-value-setq (valid cleft ctop cright cbottom) + (multiple-value-call #'ltrb-overlaps-ltrb-p + cleft ctop cright cbottom + (transform-rectangle* + (sheet-device-transformation sheet) + mleft mtop mright mbottom)))))) + (when valid + (fix-coordinates cleft ctop cright cbottom) + (with-slots (window) medium + (select-window window)) + (select-clip-rectangle cleft ctop cright cbottom)) + valid)) + (defmethod dc-image-for-ink (medium (ink (eql +foreground-ink+))) @@ -154,83 +184,80 @@ (dc-image-for-ink medium (make-color-for-contrasting-ink ink))) -(defmethod invoke-with-clipping-region ((medium cloe-medium) continuation region) - (funcall continuation medium)) - (defmethod medium-draw-point* ((medium cloe-medium) x y) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (line-style (medium-line-style medium)) - (drawable (medium-drawable medium))) - (convert-to-device-coordinates transform x y) - (set-dc-for-ink medium ink line-style) - (win::rectangle drawable x y x y))) + (when (select-cloe-dc medium) + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet)) + (ink (medium-ink medium)) + (line-style (medium-line-style medium))) + (convert-to-device-coordinates transform x y) + (set-dc-for-ink medium ink line-style) + (win::rectangle *dc* x y x y)))) (defmethod medium-draw-points* ((medium cloe-medium) position-seq) (nyi)) (defmethod medium-draw-line* ((medium cloe-medium) x1 y1 x2 y2) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (line-style (medium-line-style medium)) - (drawable (medium-drawable medium))) - (convert-to-device-coordinates transform x1 y1 x2 y2) - (set-dc-for-ink medium ink line-style) - (win::move-to drawable x1 y2) - (win::line-to drawable x2 y2))) + (when (select-cloe-dc medium) + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet)) + (ink (medium-ink medium)) + (line-style (medium-line-style medium))) + (convert-to-device-coordinates transform x1 y1 x2 y2) + (set-dc-for-ink medium ink line-style) + (win::move-to *dc* x1 y2) + (win::line-to *dc* x2 y2)))) (defmethod medium-draw-lines* ((medium cloe-medium) position-seq) (nyi)) (defmethod medium-draw-rectangle* ((medium cloe-medium) left top right bottom filled) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (line-style (medium-line-style medium)) - (drawable (medium-drawable medium))) - (convert-to-device-coordinates transform - left top right bottom) - (when (< right left) (rotatef right left)) - (when (< bottom top) (rotatef bottom top)) - (set-dc-for-ink medium ink line-style) - (win::rectangle drawable left top right bottom))) + (when (select-cloe-dc medium) + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet)) + (ink (medium-ink medium)) + (line-style (and (not filled) (medium-line-style medium)))) + (convert-to-device-coordinates transform + left top right bottom) + (when (< right left) (rotatef right left)) + (when (< bottom top) (rotatef bottom top)) + (set-dc-for-ink medium ink line-style) + (win::rectangle *dc* left top right bottom)))) (defmethod medium-draw-rectangles* ((medium cloe-medium) position-seq filled) (nyi)) (defmethod medium-draw-polygon* ((medium cloe-medium) position-seq closed filled) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (line-style (medium-line-style medium)) - (drawable (medium-drawable medium)) - (minx most-positive-fixnum) - (miny most-positive-fixnum) - (length (length position-seq))) - ;; These really are fixnums, since we're fixing coordinates below - (declare (type fixnum minx miny)) - (with-stack-array (points (if (and closed line-style) (+ length 2) length)) - (declare (type simple-vector points)) - (replace points position-seq) ;set up the initial contents - (do ((i 0 (+ i 2))) - ((>= i length)) - (let ((x (svref points i)) - (y (svref points (1+ i)))) - (convert-to-device-coordinates transform x y) - (setf (svref points i) x) - (setf (svref points (1+ i)) y) - (minf minx x) - (minf miny y))) - (when (and closed line-style) ;kludge - (setf (svref points length) (svref points 0)) - (setf (svref points (+ length 1)) (svref points 1))) - (set-dc-for-ink medium ink line-style) - (if (null line-style) - (win::polygon drawable (coerce points 'list)) - (win::polyline drawable (coerce points 'list) closed))))) + (when (select-cloe-dc medium) + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet)) + (ink (medium-ink medium)) + (line-style (and (not filled) (medium-line-style medium))) + (minx most-positive-fixnum) + (miny most-positive-fixnum) + (length (length position-seq))) + ;; These really are fixnums, since we're fixing coordinates below + (declare (type fixnum minx miny)) + (with-stack-array (points (if (and closed line-style) (+ length 2) length)) + (declare (type simple-vector points)) + (replace points position-seq) ;set up the initial contents + (do ((i 0 (+ i 2))) + ((>= i length)) + (let ((x (svref points i)) + (y (svref points (1+ i)))) + (convert-to-device-coordinates transform x y) + (setf (svref points i) x) + (setf (svref points (1+ i)) y) + (minf minx x) + (minf miny y))) + (when (and closed line-style) ;kludge + (setf (svref points length) (svref points 0)) + (setf (svref points (+ length 1)) (svref points 1))) + (set-dc-for-ink medium ink line-style) + (if (null line-style) + (win::polygon *dc* (coerce points 'list)) + (win::polyline *dc* (coerce points 'list) closed)))))) (defconstant *ft* 0.0001) (defun-inline fl-= (x y) (< (abs (- x y)) *ft*)) @@ -239,79 +266,107 @@ center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (line-style (medium-line-style medium)) - (drawable (medium-drawable medium))) - (convert-to-device-coordinates transform center-x center-y) - (convert-to-device-distances transform - radius-1-dx radius-1-dy radius-2-dx radius-2-dy) - (when (null start-angle) - (setq start-angle 0.0 - end-angle 2pi)) - (set-dc-for-ink medium ink line-style) - (multiple-value-bind (x-radius y-radius) - (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) - (values (abs radius-2-dx) (abs radius-1-dy))) - ((and (= radius-2-dx 0) (= radius-1-dy 0)) - (values (abs radius-1-dx) (abs radius-2-dy))) - (t - (let ((s-1 (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy))) - (s-2 (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy)))) - (if (= s-1 s-2) - (let ((r (truncate (sqrt s-1)))) - (values r r)) - ;; Degrade to drawing a rectilinear ellipse - (values (truncate (sqrt s-1)) - (truncate (sqrt s-2))))))) - (let (left top right bottom) - (setq left (- center-x x-radius) - right (+ center-x x-radius) - top (- center-y y-radius) - bottom (+ center-y y-radius)) - (cond ((or (fl-= (- end-angle start-angle) 2pi) - (fl-= (- end-angle start-angle) 0)) - #+++ignore - (and (= start-angle 0) - (= end-angle 2pi)) - ;; drawing a full ellipse - (win::ellipse drawable left top right bottom)) - ((null line-style) - ;; drawing a pie slice - (win::pie drawable 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)))) - (t - ;; drawing an arc - (win::arc drawable 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))))))))) + (when (select-cloe-dc medium) + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet)) + (ink (medium-ink medium)) + (line-style (and (not filled) (medium-line-style medium)))) + (convert-to-device-coordinates transform center-x center-y) + (convert-to-device-distances transform + radius-1-dx radius-1-dy radius-2-dx radius-2-dy) + (when (null start-angle) + (setq start-angle 0.0 + end-angle 2pi)) + (set-dc-for-ink medium ink line-style) + (multiple-value-bind (x-radius y-radius) + (cond ((and (= radius-1-dx 0) (= radius-2-dy 0)) + (values (abs radius-2-dx) (abs radius-1-dy))) + ((and (= radius-2-dx 0) (= radius-1-dy 0)) + (values (abs radius-1-dx) (abs radius-2-dy))) + (t + (let ((s-1 (+ (* radius-1-dx radius-1-dx) (* radius-1-dy radius-1-dy))) + (s-2 (+ (* radius-2-dx radius-2-dx) (* radius-2-dy radius-2-dy)))) + (if (= s-1 s-2) + (let ((r (truncate (sqrt s-1)))) + (values r r)) + ;; Degrade to drawing a rectilinear ellipse + (values (truncate (sqrt s-1)) + (truncate (sqrt s-2))))))) + (let (left top right bottom) + (setq left (- center-x x-radius) + right (+ center-x x-radius) + top (- center-y y-radius) + bottom (+ center-y y-radius)) + (cond ((or (fl-= (- end-angle start-angle) 2pi) + (fl-= (- end-angle start-angle) 0)) + #+++ignore + (and (= start-angle 0) + (= end-angle 2pi)) + ;; drawing a full ellipse + (win::ellipse *dc* left top right bottom)) + ((null line-style) + ;; 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)))) + (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)))))))))) (defmethod medium-draw-string* ((medium cloe-medium) string x y start end align-x align-y towards-x towards-y transform-glyphs) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (text-style (medium-merged-text-style medium)) - (drawable (medium-drawable medium))) - (convert-to-device-coordinates transform x y) - (when towards-x - (convert-to-device-coordinates transform towards-x towards-y)) - (unless end - (setq end (length string))) - (with-temporary-substring (substring string start end) + (when (select-cloe-dc medium) + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet)) + (ink (medium-ink medium)) + (text-style (medium-merged-text-style medium))) + (convert-to-device-coordinates transform x y) + (when towards-x + (convert-to-device-coordinates transform towards-x towards-y)) + (unless end + (setq end (length string))) + (with-temporary-substring (substring string start end) + (let* ((font (text-style-mapping (port medium) text-style)) + (height (cloe-font-height font)) + (descent (cloe-font-descent font)) + (ascent (cloe-font-ascent font))) + (let ((x-adjust + (compute-text-x-adjustment align-x medium string text-style start end)) + (y-adjust + (compute-text-y-adjustment align-y descent ascent height))) + (incf x x-adjust) + (incf y y-adjust) + (when towards-x + (incf towards-x x-adjust) + (incf towards-y y-adjust))) + (decf y ascent) ;text is positioned by its top left on CLOE + (set-dc-for-text medium ink (cloe-font-index font)) + (win::text-out *dc* x y substring)))))) + +(defmethod medium-draw-character* ((medium cloe-medium) + character x y align-x align-y + towards-x towards-y transform-glyphs) + (when (select-cloe-dc medium) + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet)) + (ink (medium-ink medium)) + (text-style (medium-merged-text-style medium))) + (convert-to-device-coordinates transform x y) + (when towards-x + (convert-to-device-coordinates transform towards-x towards-y)) (let* ((font (text-style-mapping (port medium) text-style)) (height (cloe-font-height font)) (descent (cloe-font-descent font)) (ascent (cloe-font-ascent font))) (let ((x-adjust - (compute-text-x-adjustment align-x medium string text-style start end)) + (compute-text-x-adjustment align-x medium character text-style)) (y-adjust (compute-text-y-adjustment align-y descent ascent height))) (incf x x-adjust) @@ -321,37 +376,9 @@ (incf towards-y y-adjust))) (decf y ascent) ;text is positioned by its top left on CLOE (set-dc-for-text medium ink (cloe-font-index font)) - (win::text-out drawable x y substring))))) - -(defmethod medium-draw-character* ((medium cloe-medium) - character x y align-x align-y - towards-x towards-y transform-glyphs) - (let* ((sheet (medium-sheet medium)) - (transform (sheet-device-transformation sheet)) - (ink (medium-ink medium)) - (text-style (medium-merged-text-style medium)) - (drawable (medium-drawable medium))) - (convert-to-device-coordinates transform x y) - (when towards-x - (convert-to-device-coordinates transform towards-x towards-y)) - (let* ((font (text-style-mapping (port medium) text-style)) - (height (cloe-font-height font)) - (descent (cloe-font-descent font)) - (ascent (cloe-font-ascent font))) - (let ((x-adjust - (compute-text-x-adjustment align-x medium character text-style)) - (y-adjust - (compute-text-y-adjustment align-y descent ascent height))) - (incf x x-adjust) - (incf y y-adjust) - (when towards-x - (incf towards-x x-adjust) - (incf towards-y y-adjust))) - (decf y ascent) ;text is positioned by its top left on CLOE - (set-dc-for-text medium ink (cloe-font-index font)) - (with-temporary-string (string :length 1) - (vector-push character string) - (win::text-out drawable x y string))))) + (with-temporary-string (string :length 1) + (vector-push character string) + (win::text-out *dc* x y string)))))) (defmethod medium-draw-text* ((medium cloe-medium) string-or-char x y start end @@ -364,11 +391,19 @@ towards-x towards-y transform-glyphs))) (defmethod medium-clear-area ((medium cloe-medium) left top right bottom) - (with-slots (window background-dc-image) medium - (set-dc-for-filling background-dc-image) - (win::rectangle window left top right bottom))) + (when (select-cloe-dc medium) + (with-slots (background-dc-image) medium + (let* ((sheet (medium-sheet medium)) + (transform (sheet-device-transformation sheet))) + (convert-to-device-coordinates transform + left top right bottom) + (when (< right left) (rotatef right left)) + (when (< bottom top) (rotatef bottom top)) + (set-dc-for-filling background-dc-image) + (win::rectangle *dc* left top right bottom))))) + (defmethod text-style-width ((text-style standard-text-style) (medium cloe-medium)) (let ((font (text-style-mapping (port medium) text-style))) (cloe-font-average-character-width font))) @@ -392,17 +427,15 @@ (cloe-font-maximum-character-width font)))) + (defmethod medium-beep ((medium cloe-medium)) (win::message-beep)) (defmethod medium-force-output ((medium cloe-medium)) - (declare (ignore medium)) ) (defmethod medium-clear-output ((medium cloe-medium)) - (declare (ignore medium)) ) (defmethod medium-finish-output ((medium cloe-medium)) - (declare (ignore medium)) ) diff --git a/cloe/cloe-mirror.lisp b/cloe/cloe-mirror.lisp index 0ce59215306b23e4936f0b46c35dfe4f7d8aa978..ccc2705cbbfcb1f8e99be49339ed5216d5ec4322 100644 --- a/cloe/cloe-mirror.lisp +++ b/cloe/cloe-mirror.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLOE-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-mirror.lisp,v 1.1 92/10/01 10:03:54 cer Exp $ +;; $fiHeader: cloe-mirror.lisp,v 1.2 92/10/28 11:32:28 cer Exp $ (in-package :cloe-clim) @@ -14,8 +14,8 @@ silica::mm-width silica::mm-height silica::units) graft (multiple-value-bind (screen-width screen-height) (win::get-screen-size) - (let ((logpixelsx (win::get-device-caps *dc* 90)) - (logpixelsy (win::get-device-caps *dc* 90))) + (let ((logpixelsx (win::get-device-caps *dc* win::logpixelsx)) + (logpixelsy (win::get-device-caps *dc* win::logpixelsy))) (setf silica::pixel-width screen-width silica::pixel-height screen-height silica::mm-width (round (* screen-width 25.4s0) logpixelsx) @@ -31,7 +31,7 @@ 0 0 silica::pixel-width silica::pixel-height)))) (setf (sheet-native-transformation graft) +identity-transformation+) - (setf (sheet-direct-mirror graft) *dc*) + (setf (sheet-direct-mirror graft) 0) (update-mirror-transformation port graft))))) (defmethod realize-mirror ((port cloe-port) sheet) @@ -45,7 +45,7 @@ (win::create-window "Vanilla" "CLIM" (logior win::ws_clipchildren ;new, helps refresh - (cond ((not (eq parent *dc*)) + (cond ((not (eql parent 0)) (logior win::ws_child win::ws_clipsiblings)) (save-under @@ -60,7 +60,7 @@ win::ws_maximizebox))) ) left top (- right left) (- bottom top) - (if (eql parent *dc*) 0 parent) 0 0 "arg")))) + parent 0 0 "arg")))) (setf (sheet-native-transformation sheet) +identity-transformation+) window))) @@ -86,18 +86,14 @@ win::swp_nosize))) (defmethod mirror-visible-p ((port cloe-port) sheet) - ;;(win::is-window-visible (sheet-mirror sheet)) - t) - -(defmethod cloe-mirror-native-edges* ((port cloe-port) mirror) - (multiple-value-bind (wleft wtop wright wbottom) - (win::get-window-rectangle mirror) - (values (coordinate wleft) (coordinate wtop) - (coordinate wright) (coordinate wbottom)))) + (win::is-window-visible (sheet-mirror sheet))) ;; Returns left,top,right,bottom (defmethod mirror-region* ((port cloe-port) sheet) - (cloe-mirror-native-edges* port (sheet-mirror sheet))) + (multiple-value-bind (cleft ctop cright cbottom) + (win::get-client-rectangle (sheet-mirror window)) + (values (coordinate cleft) (coordinate ctop) + (coordinate cright) (coordinate cbottom)))) ;; Returns x,y,width,height (defmethod mirror-inside-region* ((port cloe-port) sheet) @@ -108,7 +104,10 @@ ;;--- Shouldn't this be the same as MIRROR-REGION*? (defmethod mirror-native-edges* ((port cloe-port) sheet) - (cloe-mirror-native-edges* port (sheet-direct-mirror sheet))) + (multiple-value-bind (cleft ctop cright cbottom) + (win::get-client-rectangle (sheet-direct-mirror sheet)) + (values (coordinate cleft) (coordinate ctop) + (coordinate cright) (coordinate cbottom)))) (defmethod mirror-inside-edges* ((port cloe-port) sheet) (multiple-value-bind (cleft ctop cright cbottom) @@ -120,198 +119,6 @@ (fix-coordinates left top right bottom) (win::set-window-position (sheet-mirror sheet) 0 left top (- right left) (- bottom top) - (logior win::swp_noactivate win::swp_nozorder))) - -;;; - -(defun-inline sign-extend-16 (n) - (dpb n (byte 15 0) (- (ldb (byte 1 15) n)))) - -(defmethod note-pointer-motion ((port cloe-port) sheet x y) - (with-slots (pointer-sheet pointer-x pointer-y) port - (setf pointer-sheet sheet) - (setf pointer-x x) - (setf pointer-y y))) - -(defmethod flush-pointer-motion ((port cloe-port)) - (with-slots (event-queue pointer-sheet pointer-x pointer-y) port - (when pointer-sheet - (let ((pointer (port-pointer port))) - (when pointer - (queue-put event-queue - (allocate-event 'pointer-motion-event - :native-x pointer-x - :native-y pointer-y - :modifier-state (port-modifier-state port) - :pointer pointer - :sheet pointer-sheet)))) - (setf pointer-sheet nil)))) - -;;; Convert a MS Windows shift mask into a CLIM modifier-state -(defun windows-mask->modifier-state (mask) - (if (logtest win::mk_shift mask) - (if (logtest win::mk_control mask) - (make-modifier-state :shift :control) - (make-modifier-state :shift)) - (if (logtest win::mk_control mask) - (make-modifier-state :control) - (make-modifier-state)))) - -(defmethod event-handler ((port cloe-port) args) - (with-slots (event-queue pointer-sheet pointer-x pointer-y) port - (let ((sheet (mirror->sheet port (win::get-16bit args 0))) - (message (win::get-16bit args 2))) - (declare (fixnum message)) - (when sheet - (cond ((eql message win::wm_mousemove) - (note-pointer-motion port sheet (win::get-16bit args 6) (win::get-16bit args 8))) - - ((eql message win::wm_paint) - (let ((ileft (win::get-16bit args 4)) - (itop (win::get-16bit args 6)) - (iright (win::get-16bit args 8)) - (ibottom (win::get-16bit args 10))) - (unless (or (= ileft iright) (= itop ibottom)) ;seems to happen alot - (queue-put event-queue - (allocate-event 'window-repaint-event - ;;--- Should this be (MIRROR-REGION PORT SHEET), as - ;;--- it is in the :CONFIGURE-NOTIFY case? - :native-region (sheet-native-region sheet) - :region (make-bounding-rectangle ileft itop iright ibottom) - :sheet sheet))))) - - #|| - ;; scrolling - ((or (eql message win::wm_hscroll) (eql message win::wm_vscroll)) - (let ((type (win::get-16bit args 4)) - (position (win::get-16bit args 6)) - (message (cond ((eql message win::wm_hscroll) :x) - ((eql message win::wm_vscroll) :y)))) - (declare (fixnum type position)) - (multiple-value-bind (type position) - (cond ((eql type win::sb_lineup) - (values :relative-jump -1)) - ((eql type win::sb_linedown) - (values :relative-jump +1)) - ((eql type win::sb_pageup) - (values :screenful -1)) - ((eql type win::sb_pagedown) - (values :screenful +1)) - ((eql type win::sb_thumbposition) - (values :percentage position)) - ((eql type win::sb_top) - (values :percentage 0)) - ((eql type win::sb_bottom) - (values :percentage 100))) - (when type - (queue-put pending-scrolls (list message type position)) - (pushnew stream *cloe-windows-with-deferred-events*))))) - ||# - - ;; resizing - ((or (eql message win::wm_move) - (eql message win::wm_size)) - (queue-put event-queue - (allocate-event 'window-configuration-event - :sheet sheet))) - - ;; character typed - ((eql message win::wm_char) - (let ((char (aref args 4))) - (flush-pointer-motion port) - (queue-put event-queue - (allocate-event 'key-press-event - :key-name nil - :character char - :modifier-state (port-modifier-state port) - :sheet sheet)))) - - #|| - ((or (eql message win::wm_keydown) - (eql message win::wm_keyup) - (eql message win::wm_syskeyup) - (eql message win::wm_syskeydown)) - (let ((vk (char-code (aref args 4)))) - (flush-pointer-motion port) - (queue-put event-queue - (allocate-event - (cond ((or (eql message win::wm_keydown) - (eql message win::wm_syskeydown)) - 'key-press-event) - ((or (eql message win::wm_keyup) - (eql message win::wm_syskeyup)) - 'key-release-event)) - :key-name (vk->keysym vk) - :character nil - :modifier-state (port-modifier-state port) - :sheet sheet)))) - ||# - - ;; button press or release - ((or (eql message win::wm_lbuttondown) - (eql message win::wm_rbuttondown) - (eql message win::wm_mbuttondown) - (eql message win::wm_lbuttonup) - (eql message win::wm_rbuttonup) - (eql message win::wm_mbuttonup)) - (let ((modifier-state (windows-mask->modifier-state (win::get-16bit args 4))) - (pointer (port-pointer port))) - (when pointer - (flush-pointer-motion port) - (setf (port-modifier-state port) modifier-state) - (multiple-value-bind (key button) - (cond ((eql message win::wm_lbuttondown) - (values 'pointer-button-press-event +pointer-left-button+)) - ((eql message win::wm_mbuttondown) - (values 'pointer-button-press-event +pointer-middle-button+)) - ((eql message win::wm_rbuttondown) - (values 'pointer-button-press-event +pointer-right-button+)) - ((eql message win::wm_lbuttonup) - (values 'pointer-button-release-event +pointer-left-button+)) - ((eql message win::wm_mbuttonup) - (values 'pointer-button-release-event +pointer-middle-button+)) - ((eql message win::wm_rbuttonup) - (values 'pointer-button-release-event +pointer-right-button+))) - (queue-put event-queue - (allocate-event key - :native-x (win::get-16bit args 6) - :native-y (win::get-16bit args 8) - :button button - :modifier-state modifier-state - :pointer pointer - :sheet sheet)))))) - ))))) - -(defun win::vanilla-event (code length args) - (declare (ignore code length)) ;because I don't know what they are! - (event-handler *cloe-port* args)) - -;;; - -(defmethod process-next-event ((port cloe-port) - &key (timeout nil) (wait-function nil) - (state "Windows Event")) - (with-slots (event-queue) port - (let ((end-time (and timeout (+ (get-internal-real-time) - (* internal-time-units-per-second timeout))))) - (win::await-response -1 nil nil) - (loop - (flush-pointer-motion port) - (let ((event (queue-get event-queue))) - (when event - (distribute-event port event) - (return t))) - (when (and end-time (> (get-internal-real-time) end-time)) - (return nil)) - (win::await-response -1 t t))))) - -(defmethod distribute-event :around ((port cloe-port) (event window-configuration-event)) - (let* ((sheet (event-sheet event)) - (mirror (sheet-mirror sheet))) - (unless (win::is-iconic mirror) - (let ((native-region (mirror-region port sheet))) - (setf (slot-value event 'pyrex::native-region) native-region) - (setf (slot-value event 'pyrex::region) - (untransform-region (sheet-native-transformation sheet) - native-region))) - (call-next-method)))) + (logior win::swp_nomove ;??? + win::swp_noactivate + win::swp_nozorder))) diff --git a/cloe/cloe-pixmaps.lisp b/cloe/cloe-pixmaps.lisp index 90ea4dc6da4f69494ff75a3ad2ccaa8a21eabbe8..e4b030fe3c30a28c1780ec66deb4782197c9719c 100644 --- a/cloe/cloe-pixmaps.lisp +++ b/cloe/cloe-pixmaps.lisp @@ -1,22 +1,25 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLOE-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-pixmaps.lisp,v 1.1 92/10/01 10:03:55 cer Exp $ +;; $fiHeader: cloe-pixmaps.lisp,v 1.2 92/10/28 11:32:30 cer Exp $ (in-package :cloe-clim) "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." -(defmethod medium-copy-area ((from-medium cloe-medium) from-x from-y width height - (to-medium cloe-medium) to-x to-y) +(defmethod medium-copy-area ((from-medium cloe-window-medium) from-x from-y width height + (to-medium cloe-window-medium) to-x to-y) (unless (eq from-medium to-medium) (error "Can't copy.")) + (when (select-cloe-dc from-medium) (let ((transform (sheet-device-transformation (medium-sheet from-medium)))) (convert-to-device-coordinates transform from-x from-y to-x to-y) (convert-to-device-distances transform width height) - (let ((x-delta (- to-x from-x)) ;can be negative - (y-delta (- to-y from-y))) ;can be negative - (win::scroll-dc (medium-drawable from-medium) - x-delta y-delta - from-x from-y (+ from-x width) (+ from-y height) - 0 0 width height)))) + (let ((left (min from-x to-x)) + (top (min from-y to-y)) + (right (+ (max from-x to-x) width)) + (bottom (+ (max from-y to-y) height))) + (win::scroll-dc *dc* + (- to-x from-x) (- to-y from-y) + left top right bottom + left top right bottom))))) diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp index ca6de4fe4ed51050f67f27aeb181f61da707c96f..0b1baccb271d6c62edb16497898ea483c2d51e34 100644 --- a/clx/clx-port.lisp +++ b/clx/clx-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-port.lisp,v 1.16 92/10/02 15:19:06 cer Exp $ +;; $fiHeader: clx-port.lisp,v 1.17 92/10/28 11:31:16 cer Exp $ (in-package :clx-clim) @@ -46,11 +46,11 @@ ;;--- Eventually do better than this (defclass clx-palette (basic-palette) ()) -(defmethod make-palette ((port clx-port) &key color-p mutable-p) +(defmethod make-palette ((port clx-port) &key color-p dynamic-p) (make-instance 'clx-palette :port port :color-p color-p - :mutable-p mutable-p)) + :dynamic-p dynamic-p)) (defmethod initialize-instance :after ((port clx-port) &key server-path) @@ -86,7 +86,7 @@ :background (xlib:screen-white-pixel screen))) (setf (slot-value port 'silica::default-palette) (make-palette port :color-p color-p - :mutable-p (and (member vic '(:gray-scale + :dynamic-p (and (member vic '(:gray-scale :pseudo-color :direct-color)) t)))) diff --git a/clx/clx-prefill.lisp b/clx/clx-prefill.lisp index bdc4eb7e8e0dc9fce43cf817a5f8665eb996ddc7..c14f82d724ce6e4b680af8634f1edb13a1f7c5d1 100644 --- a/clx/clx-prefill.lisp +++ b/clx/clx-prefill.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-prefill.lisp,v 1.5 92/09/08 15:17:17 cer Exp $ +;; $fiHeader: clx-prefill.lisp,v 1.6 92/10/28 11:31:17 cer Exp $ (in-package :clim-internals) @@ -207,7 +207,7 @@ (clx-clim::initialize-clx-port (clx-clim::clx-port)) (initialize-menu - (clx-clim::clx-port clim-stream-pane t)) + (clx-clim::clx-port clim-stream-pane)) (make-frame-manager (clx-clim::clx-port)) (make-medium diff --git a/demo/color-editor.lisp b/demo/color-editor.lisp index d707f0e3012d9b5cf638f2b2b26cbed278e547f2..60c771ea9400cb0fa86161289c7e8b717393230b 100644 --- a/demo/color-editor.lisp +++ b/demo/color-editor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: color-editor.lisp,v 1.8 92/10/28 11:32:53 cer Exp $ +;; $fiHeader: color-editor.lisp,v 1.9 92/10/29 16:55:25 cer Exp $ (in-package :clim-demo) @@ -83,7 +83,7 @@ (setf dynamic-p (palette-dynamic-p (frame-palette frame)) color (if dynamic-p (make-dynamic-color +black+) - +black+)))) + +black+)))) (defmethod color ((frame color-chooser)) (with-slots (color dynamic-p) frame diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp index 320a19b0da2d3a430331e2f106a8323ef9e6ab02..55247071e8b0052891b0f9475c0a8a1390524c44 100644 --- a/demo/puzzle.lisp +++ b/demo/puzzle.lisp @@ -1,25 +1,25 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: puzzle.lisp,v 1.20 92/10/28 11:33:08 cer Exp Locker: cer $ +;; $fiHeader: puzzle.lisp,v 1.21 92/10/29 16:55:36 cer Exp $ (in-package :clim-demo) "Copyright (c) 1989, 1990, 1991, 1992 Symbolics, Inc. All rights reserved." (define-application-frame puzzle () - ((puzzle :initform (make-array '(4 4)) - :accessor puzzle-puzzle)) + ((puzzle :initform (make-array '(4 4)) + :accessor puzzle-puzzle)) (:panes - (display :application - :display-function 'draw-puzzle - :text-style '(:fix :bold :very-large) - :incremental-redisplay t - :text-cursor nil - :width :compute :height :compute - :end-of-page-action :allow - :end-of-line-action :allow)) + (display :application + :display-function 'draw-puzzle + :text-style '(:fix :bold :very-large) + :incremental-redisplay t + :text-cursor nil + :width :compute :height :compute + :end-of-page-action :allow + :end-of-line-action :allow)) (:layouts - (:default display))) + (:default display))) (defmethod frame-standard-input ((puzzle puzzle)) (get-frame-pane puzzle 'display)) @@ -70,18 +70,18 @@ (declare (ignore max-width max-height)) (let ((puzzle-array (puzzle-puzzle puzzle))) (formatting-table (stream) - (dotimes (row 4) - (formatting-row (stream) - (dotimes (column 4) - (let* ((value (aref puzzle-array row column)) - (cell-id (encode-puzzle-cell row column))) - (updating-output (stream :unique-id cell-id - :cache-value value) - (formatting-cell (stream :align-x :right) - (unless (zerop value) - (with-output-as-presentation - (stream cell-id 'puzzle-cell) - (format stream "~2D" value)))))))))))) + (dotimes (row 4) + (formatting-row (stream) + (dotimes (column 4) + (let* ((value (aref puzzle-array row column)) + (cell-id (encode-puzzle-cell row column))) + (updating-output (stream :unique-id cell-id + :cache-value value) + (formatting-cell (stream :align-x :right) + (unless (zerop value) + (with-output-as-presentation + (stream cell-id 'puzzle-cell) + (format stream "~2D" value)))))))))))) (defun find-open-cell (puzzle) (dotimes (row 4) diff --git a/genera/genera-port.lisp b/genera/genera-port.lisp index 5996d788155bb169620646b9444147866be6a732..ef086ad2d084dca4022e9dfa4642527eefeeb007 100644 --- a/genera/genera-port.lisp +++ b/genera/genera-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-port.lisp,v 1.15 92/10/28 11:32:43 cer Exp Locker: cer $ +;; $fiHeader: genera-port.lisp,v 1.16 92/11/05 17:15:46 cer Exp $ (in-package :genera-clim) @@ -38,11 +38,11 @@ ;;--- Eventually do better than this (defclass genera-palette (basic-palette) ()) -(defmethod make-palette ((port genera-port) &key color-p mutable-p) +(defmethod make-palette ((port genera-port) &key color-p dynamic-p) (make-instance 'genera-palette :port port :color-p color-p - :mutable-p mutable-p)) + :dynamic-p dynamic-p)) (defmethod initialize-instance :after ((port genera-port) &key server-path) diff --git a/genera/genera-prefill.lisp b/genera/genera-prefill.lisp index 55836cab2a8461f4cc739be0cb452a24f9ee1c91..bca5f4bba17eea92594f50cb0b4491308b3c654d 100644 --- a/genera/genera-prefill.lisp +++ b/genera/genera-prefill.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-prefill.lisp,v 1.5 92/09/08 15:18:56 cer Exp $ +;; $fiHeader: genera-prefill.lisp,v 1.6 92/10/28 11:32:44 cer Exp $ (in-package :clim-internals) @@ -216,7 +216,7 @@ (genera-clim::initialize-genera-port (genera-clim::genera-port)) (initialize-menu - (genera-clim::genera-port clim-stream-pane t)) + (genera-clim::genera-port clim-stream-pane)) (make-frame-manager (genera-clim::genera-port)) (make-medium diff --git a/utils/clim-streams.lisp b/utils/clim-streams.lisp index 4a3488ca3d9d306d27af4a0d8637d75466981529..ef8703053e5ee2f6fb765caef4c0731a5f5c2b40 100644 --- a/utils/clim-streams.lisp +++ b/utils/clim-streams.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clim-streams.lisp,v 1.6 92/09/08 15:16:57 cer Exp $ +;; $fiHeader: clim-streams.lisp,v 1.7 92/10/02 15:18:40 cer Exp $ (in-package :clim-utils) @@ -21,6 +21,12 @@ :reader encapsulating-stream-stream)) #+Allegro (:default-initargs :element-type 'character)) +;; Return the encapsulated stream corresponding to STREAM. +;; If you change GENERATE-STREAM-PROTOCOL-TRAMPOLINES to maintain a more complex +;; mapping than a simple binding of *ORIGINAL-STREAM*, change this too. +(defmacro encapsulated-stream (stream &optional (encapsulated-stream '*original-stream*)) + `(or ,encapsulated-stream ,stream)) + ;;; Shadow this for all Lisp implementations diff --git a/utils/extended-regions.lisp b/utils/extended-regions.lisp index 0f2a77ad52528e5ebb2be8818984a09039f4b968..8e45de0ee7afe4583ecb03ffe34cf00b227672a5 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 -*- -;; $fiHeader: extended-regions.lisp,v 1.3 92/05/07 13:11:37 cer Exp $ +;; $fiHeader: extended-regions.lisp,v 1.4 92/10/02 15:18:48 cer Exp $ (in-package :clim-utils) @@ -18,7 +18,7 @@ (points :type simple-vector :initarg :points :reader polygon-points))) (define-constructor make-line-1 standard-line (start-x start-y end-x end-y points) - :start-x start-x :start-y start-y :end-x end-x :end-y end-y :points points) + :start-x start-x :start-y start-y :end-x end-x :end-y end-y :points points) (defun make-line (start-point end-point) (make-line-1 (point-x start-point) (point-y start-point) @@ -26,7 +26,7 @@ (vector start-point end-point))) (define-constructor make-line*-1 standard-line (start-x start-y end-x end-y) - :start-x start-x :start-y start-y :end-x end-x :end-y end-y) + :start-x start-x :start-y start-y :end-x end-x :end-y end-y) (defun make-line* (start-x start-y end-x end-y) (declare (type real start-x start-y end-x end-y)) @@ -219,10 +219,10 @@ ((closed :initarg :closed :reader polyline-closed))) (define-constructor make-polyline standard-polyline (point-seq &key closed) - :points (coerce point-seq 'vector) :closed closed) + :points (coerce point-seq 'vector) :closed closed) (define-constructor make-polyline* standard-polyline (coord-seq &key closed) - :coords (coerce coord-seq 'vector) :closed closed) + :coords (coerce coord-seq 'vector) :closed closed) (defmethod make-load-form ((polyline standard-polyline)) (with-slots (closed) polyline @@ -243,10 +243,10 @@ (defclass standard-polygon (polygon-mixin polygon) ()) (define-constructor make-polygon standard-polygon (point-seq) - :points (coerce point-seq 'vector)) + :points (coerce point-seq 'vector)) (define-constructor make-polygon* standard-polygon (coord-seq) - :coords (coerce coord-seq 'vector)) + :coords (coerce coord-seq 'vector)) (defmethod make-load-form ((polygon standard-polygon)) `(make-polygon ',(polygon-points polygon))) @@ -296,8 +296,8 @@ (defclass standard-elliptical-arc (ellipse-mixin elliptical-arc) ()) (define-constructor make-elliptical-arc standard-elliptical-arc - (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy - &key start-angle end-angle) + (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy + &key start-angle end-angle) :center-point center-point :center-x (point-x center-point) :center-y (point-y center-point) :radius-1-dx (coordinate radius-1-dx) :radius-1-dy (coordinate radius-1-dy) :radius-2-dx (coordinate radius-2-dx) :radius-2-dy (coordinate radius-2-dy) @@ -309,8 +309,8 @@ (t nil))) (define-constructor make-elliptical-arc* standard-elliptical-arc - (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy - &key start-angle end-angle) + (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy + &key start-angle end-angle) :center-x center-x :center-y center-y :radius-1-dx (coordinate radius-1-dx) :radius-1-dy (coordinate radius-1-dy) :radius-2-dx (coordinate radius-2-dx) :radius-2-dy (coordinate radius-2-dy) @@ -352,8 +352,8 @@ (defclass standard-ellipse (ellipse-mixin ellipse) ()) (define-constructor make-ellipse standard-ellipse - (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy - &key start-angle end-angle) + (center-point radius-1-dx radius-1-dy radius-2-dx radius-2-dy + &key start-angle end-angle) :center-point center-point :center-x (point-x center-point) :center-y (point-y center-point) :radius-1-dx (coordinate radius-1-dx) :radius-1-dy (coordinate radius-1-dy) :radius-2-dx (coordinate radius-2-dx) :radius-2-dy (coordinate radius-2-dy) @@ -365,8 +365,8 @@ (t nil))) (define-constructor make-ellipse* standard-ellipse - (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy - &key start-angle end-angle) + (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy + &key start-angle end-angle) :center-x center-x :center-y center-y :radius-1-dx (coordinate radius-1-dx) :radius-1-dy (coordinate radius-1-dy) :radius-2-dx (coordinate radius-2-dx) :radius-2-dy (coordinate radius-2-dy) diff --git a/utils/regions.lisp b/utils/regions.lisp index d21f541870733688edbc02a12b36589c09964b82..1071fa3ff93089b1c2343ec99832fb40879154dd 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 -*- -;; $fiHeader: regions.lisp,v 1.13 92/07/20 15:59:45 cer Exp $ +;; $fiHeader: regions.lisp,v 1.14 92/08/18 17:24:15 cer Exp $ (in-package :clim-utils) @@ -193,7 +193,7 @@ (y :initarg :y :accessor point-y :type coordinate))) (define-constructor make-point-1 standard-point (x y) - :x x :y y) + :x x :y y) (defun make-point (x y) (declare (type real x y)) @@ -304,7 +304,8 @@ (max-y :initarg :max-y :reader rectangle-max-y :type coordinate) (points :initarg :points :type simple-vector :reader polygon-points))) -(define-constructor make-rectangle-1 standard-rectangle (min-x min-y max-x max-y points) +(define-constructor make-rectangle-1 standard-rectangle + (min-x min-y max-x max-y points) :min-x min-x :min-y min-y :max-x max-x :max-y max-y :points points) (defun make-rectangle (min-point max-point) @@ -318,7 +319,8 @@ (vector min-point (make-point min-x max-y) max-point (make-point max-x min-y)))))) -(define-constructor make-rectangle*-1 standard-rectangle (x1 y1 x2 y2) +(define-constructor make-rectangle*-1 standard-rectangle + (x1 y1 x2 y2) :min-x x1 :min-y y1 :max-x x2 :max-y y2) (defun make-rectangle* (x1 y1 x2 y2) diff --git a/utils/transformations.lisp b/utils/transformations.lisp index 6c5c3ca778575725d51c852e0fa597a945938484..cb19f8b91caa0b8eeea58e71f2771315a8eb7f50 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 -*- -;; $fiHeader: transformations.lisp,v 1.8 92/07/08 16:29:37 cer Exp $ +;; $fiHeader: transformations.lisp,v 1.9 92/08/18 17:24:17 cer Exp $ (in-package :clim-utils) @@ -64,7 +64,7 @@ (ty :type single-float :initarg :ty))) (define-constructor make-translation-transformation-1 translation-transformation - (tx ty) + (tx ty) :tx tx :ty ty) (defmethod print-object ((transform translation-transformation) stream) @@ -91,7 +91,7 @@ (ty :type single-float :initarg :ty))) (define-constructor make-standard-transformation-1 standard-transformation - (mxx mxy myx myy tx ty) + (mxx mxy myx myy tx ty) :mxx mxx :mxy mxy :myx myx :myy myy :tx tx :ty ty) (defmethod make-load-form ((transform standard-transformation))