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

The usual swm hack attack. Lots of random changes wherever you look.

swm changes.
parent 85ec0e40
No related branches found
No related tags found
No related merge requests found
;;; -*- 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)
......
;;; -*- 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)
......
;;; -*- 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))
)
;;; -*- 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)))
;;; -*- 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)))))
;;; -*- 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))))
......
;;; -*- 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
......
;;; -*- 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
......
;;; -*- 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)
......
;;; -*- 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)
......
;;; -*- 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
......
;;; -*- 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
......
;;; -*- 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)
......
;;; -*- 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)
......
;;; -*- 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))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment