From c42a3f6d89e8174a5416c19da55cbbcbbd14acf4 Mon Sep 17 00:00:00 2001 From: colin <colin> Date: Tue, 7 Sep 1993 21:47:44 +0000 Subject: [PATCH] see changelog for Tue Sep 7 14:42:57 PDT 1993 --- ChangeLog.n | 60 +++++++++ Makefile.defs | 4 +- clim/frames.lisp | 33 ++--- clim/gadget-output.lisp | 4 +- clim/graphics-recording.lisp | 5 +- clim/output-protocol.lisp | 4 +- demo/plot.lisp | 8 +- silica/gadgets.lisp | 10 +- silica/medium.lisp | 9 +- silica/port.lisp | 4 +- test/test.lisp | 12 +- tk-silica/image.lisp | 7 +- tk-silica/xm-gadgets.lisp | 5 +- tk-silica/xt-frames.lisp | 28 +++-- tk-silica/xt-gadgets.lisp | 15 +-- tk-silica/xt-graphics.lisp | 228 +++++++++++++++++++---------------- tk-silica/xt-silica.lisp | 31 +++-- utils/designs.lisp | 8 +- utils/packages.lisp | 3 +- 19 files changed, 282 insertions(+), 196 deletions(-) diff --git a/ChangeLog.n b/ChangeLog.n index 462412e5..5ee9e768 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,63 @@ +from colin: Tue Sep 7 14:42:57 PDT 1993 + +Makefile.defs now using devel.17 + +clim/output-recording-defs.lisp removed +clim/standard-sequence.lisp removed +clim/standard-tree.lisp removed +clim/text-output-recording.lisp removed + +clim/frames.lisp added function limit-size-to-graft + +clim/graphics-recording.lisp bounding rectangle for text-output-records + changed to use medium-merged-text-style + rather than medium-text-style + +clim/output-protocol.lisp silica::scrolled-pane-line-scroll-amount + uses medium-merged-text-style rather than + medium-text-style + +demo/plot.lisp use medium-merged-text-style... + +silica/medium.lisp engraft-medium sets text-style of new + medium to nil (not medium-default-text-style) + added setf medium-text-style :before method + which invalidates medium-merged-text-style + +silica/port.lisp added defgeneric port-type, port-name + +test/test.lisp use pattern for icon pixmap + +tk-silica/image.lisp added truename for files passed to pbm + filters in read-bitmap-file + +tk-silica/xm-gadgets.lisp hack to make setf (gadget-alignment) work + +tk-silica/xt-frames.lisp made update-frame-settings use + pixmap-from-pattern with bitmap format + limit size of top level shell to size of + graft + +tk-silica/xt-gadgets.lisp decode-gadget-background handles patterns + properly + +tk-silica/xt-graphics.lisp engraft-medium doesn't set indirect-inks to + nil anymore (only degraft-medium does) and + doesn't call invalidate-indirect-inks + added gf deallocate-ink + decode-pattern-ink split into + decode-pattern-ink and pixmap-from-pattern + +tk-silica/xt-silica.lisp added port-name + made get-xt-resources more robust to + invalid resource specifications + +utils/designs.lisp fixed bug in (method color-rgb (ihs-color)) + +utils/packages.lisp export port-name from clim package + +------------------------------------------------------------------------------- + Thu Aug 12 12:01:08 1993 Kevin Layer (layer@sole) * Makefile.cobjs-svr4: make sure setup_LLP exists before using it. diff --git a/Makefile.defs b/Makefile.defs index a969f056..bb9db1f1 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,9 +1,9 @@ -# $fiHeader: Makefile.defs,v 1.16 1993/07/29 20:51:15 layer Exp $ +# $fiHeader: Makefile.defs,v 1.18 1993/08/31 04:53:51 layer Exp $ # # Makefile.defs for CLIM 2.0 # -CL = /usr/fi/dcl-4.2.devel.15 +CL = /usr/fi/dcl-4.2.devel.17 PWD = /usr/tech/cer/stuff/clim-2.0 DUMP-CL = $(CL) diff --git a/clim/frames.lisp b/clim/frames.lisp index 5eadafd9..9d5085d5 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.70 1993/07/22 15:37:51 cer Exp $ +;; $fiHeader: frames.lisp,v 1.71 1993/07/27 01:39:24 colin Exp $ (in-package :clim-internals) @@ -521,32 +521,33 @@ ;; Maintain ALL-PANES in the order the panes are created (setq all-panes (nconc all-panes (list new-pane))) new-pane))))) - + +(defmacro limit-size-to-graft (width height graft) + `(multiple-value-bind (graft-width graft-height) + (bounding-rectangle-size ,graft) + ;;--- This fudge factor stuff looks dubious --SWM + (let ((fudge-factor #+Allegro 0.9 #-Allegro 1)) + (minf-or ,width (* graft-width fudge-factor)) + (minf-or ,height (* graft-height fudge-factor))))) + (defmethod layout-frame ((frame standard-application-frame) &optional width height) (let ((panes (frame-panes frame)) (*application-frame* frame)) (when panes (clear-space-requirement-caches-in-tree panes) - (multiple-value-bind (graft-width graft-height) - (bounding-rectangle-size (graft frame)) - (cond ((and width height) - (minf width graft-width) - (minf height graft-height)) - (t - (let ((sr (compose-space panes))) - (setq width (or width (space-requirement-width sr)) - height (or height (space-requirement-height sr))) - ;;--- This fudge factor stuff looks dubious --SWM - (let ((fudge-factor #+Allegro 0.9 #-Allegro 1)) - (minf-or width (* graft-width fudge-factor)) - (minf-or height (* graft-height fudge-factor))))))) + (unless (and width height) + (let ((sr (compose-space panes))) + (setq width (or width (space-requirement-width sr)) + height (or height (space-requirement-height sr))))) + (limit-size-to-graft width height (graft frame)) + ;;--- Don't bother with this if the size didn't change? (let ((top-sheet (or (frame-top-level-sheet frame) panes))) (if (and (sheet-enabled-p top-sheet) (not (frame-resizable frame))) (multiple-value-call #'allocate-space top-sheet (bounding-rectangle-size top-sheet)) - (resize-sheet top-sheet width height)))))) + (resize-sheet top-sheet width height)))))) (defvar *frame-layout-changing-p* nil) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 83a4fa5b..0b0ecbdd 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.51 1993/05/25 20:40:49 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.52 1993/07/27 01:39:32 colin Exp $ (in-package :clim-internals) @@ -703,8 +703,6 @@ (multiple-value-bind (object type index) (accept-from-string (accept-values-query-type query) new-value) (declare (ignore type)) - ;; we can put this back in when we handle ol text-fields - ;; correctly (see tk-silica/ol-gadgets) (assert (= index (length new-value))) object) (error (c) diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp index 5fb370e4..3876e5fd 100644 --- a/clim/graphics-recording.lisp +++ b/clim/graphics-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-recording.lisp,v 1.22 93/04/07 09:06:40 cer Exp $ +;; $fiHeader: graphics-recording.lisp,v 1.23 1993/07/27 01:39:42 colin Exp $ (in-package :clim-internals) @@ -517,7 +517,8 @@ (define-graphics-recording draw-text (ink text-style clipping-region) :bounding-rectangle (medium-text-bounding-box medium string-or-char x y - start end align-x align-y text-style + start end align-x align-y + (medium-merged-text-style medium) towards-x towards-y transform-glyphs transformation)) (defmethod medium-text-bounding-box ((sheet standard-sheet-output-mixin) string x y diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 532edb37..c2344715 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: output-protocol.lisp,v 1.37 1993/05/05 01:38:48 cer Exp $ +;; $fiHeader: output-protocol.lisp,v 1.38 1993/06/04 16:06:23 cer Exp $ (in-package :clim-internals) @@ -1095,7 +1095,7 @@ orientation direction) (declare (ignore direction)) - (let ((style (medium-text-style pane))) + (let ((style (medium-merged-text-style pane))) (ecase orientation (:horizontal (text-style-width style pane)) (:vertical (+ (text-style-height style pane) diff --git a/demo/plot.lisp b/demo/plot.lisp index a8022818..85ed7ace 100644 --- a/demo/plot.lisp +++ b/demo/plot.lisp @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- ;; -;; -[Thu Jul 22 17:14:40 1993 by colin]- +;; -[Mon Aug 23 14:13:24 1993 by colin]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: plot.lisp,v 1.25 1993/07/27 01:45:58 colin Exp $ +;; $fiHeader: plot.lisp,v 1.26 1993/08/12 16:03:37 cer Exp $ (in-package :clim-demo) @@ -200,8 +200,8 @@ :cache-value (cons type (copy-list y-labels)) :cache-test #'equalp) (let ((n-lines (length y-labels)) - (ascent (text-style-ascent (medium-text-style stream) stream)) - (descent (text-style-descent (medium-text-style stream) stream)) + (ascent (text-style-ascent (medium-merged-text-style stream) stream)) + (descent (text-style-descent (medium-merged-text-style stream) stream)) (i 0)) (surrounding-output-with-border (stream) (formatting-table (stream) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index d7eccea8..42794ca0 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.55 1993/07/22 15:38:53 cer Exp $ +;; $fiHeader: gadgets.lisp,v 1.56 1993/08/12 16:04:16 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -374,7 +374,7 @@ (when (eq value t) (setf (radio-box-current-selection client) selection) (value-changed-callback - client (gadget-client client) (gadget-id client) selection)) + client (gadget-client client) (gadget-id client) selection)) (call-next-method)) @@ -433,10 +433,10 @@ (declare (ignore gadget-id)) (if (eq value t) (pushnew selection (check-box-current-selection client)) - (setf (check-box-current-selection client) - (delete selection (check-box-current-selection client)))) + (setf (check-box-current-selection client) + (delete selection (check-box-current-selection client)))) (value-changed-callback - client (gadget-client client) (gadget-id client) (check-box-current-selection client)) + client (gadget-client client) (gadget-id client) (check-box-current-selection client)) (call-next-method)) diff --git a/silica/medium.lisp b/silica/medium.lisp index 4f1ae338..45227352 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: medium.lisp,v 1.35 1993/06/02 18:41:56 cer Exp $ +;; $fiHeader: medium.lisp,v 1.37 1993/08/19 20:10:13 smh Exp $ (in-package :silica) @@ -159,6 +159,7 @@ (defmethod engraft-medium :after ((medium basic-medium) port (sheet sheet-with-resources-mixin)) + (declare (ignore port)) ;; We set the slots directly in order to avoid running any per-port ;; :AFTER methods (or whatever). That work should be done by similar ;; per-port methods on ENGRAFT-MEDIUM. @@ -168,7 +169,7 @@ (setf foreground (pane-foreground sheet) background (pane-background sheet) default-text-style (parse-text-style (pane-text-style sheet)) - text-style default-text-style + text-style nil merged-text-style-valid nil))) @@ -393,6 +394,10 @@ (declare (ignore new)) (setf (medium-merged-text-style-valid medium) nil)) +(defmethod (setf medium-text-style) :before (new (medium basic-medium)) + (declare (ignore new)) + (setf (medium-merged-text-style-valid medium) nil)) + (defmethod medium-merged-text-style ((medium basic-medium)) (with-slots (text-style default-text-style merged-text-style merged-text-style-valid) medium diff --git a/silica/port.lisp b/silica/port.lisp index ce0d41a9..ff916f0a 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: port.lisp,v 1.30 93/02/08 15:57:38 cer Exp $ +;; $fiHeader: port.lisp,v 1.31 1993/07/22 15:38:59 cer Exp $ (in-package :silica) @@ -66,6 +66,8 @@ (defmethod find-port-type (x) (error "Cannot find port type: ~S" x)) +(defgeneric port-type (port)) +(defgeneric port-name (port)) (defmethod initialize-instance :around ((port basic-port) &key server-path) (setf (slot-value port 'server-path) (copy-list server-path)) diff --git a/test/test.lisp b/test/test.lisp index c98b7ff9..349dc8c0 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.50 1993/06/21 20:51:31 cer Exp $ +;; $fiHeader: test.lisp,v 1.51 1993/08/12 16:04:35 cer Exp $ (in-package :clim-user) @@ -84,13 +84,9 @@ (:command-table test-frame) (:pane (make-clim-interactor-pane)) (:icon :name "foo" - :pixmap (make-pattern - (let ((x (make-array '(48 48)))) - (dotimes (i 48) - (dotimes (j 48) - (setf (aref x i j) (random 2)))) - x) - (list +red+ +green+))) + :pixmap (make-pattern-from-bitmap-file + "/usr/include/X11/bitmaps/terminal" + :designs (list +red+ +green+))) (:pointer-documentation t) (:geometry :width 800 :height 800)) diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp index d9598866..cb6cbd21 100644 --- a/tk-silica/image.lisp +++ b/tk-silica/image.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: xm-silica -*- ;; -;; -[Mon Jul 12 14:47:08 1993 by colin]- +;; -[Mon Aug 2 10:00:30 1993 by colin]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: image.lisp,v 1.13 1993/07/22 15:39:27 cer Exp $ +;; $fiHeader: image.lisp,v 1.14 1993/07/27 01:54:53 colin Exp $ (in-package :xm-silica) @@ -58,7 +58,8 @@ (format filter) (compute-filter-for-bitmap-format format) (with-open-stream (fstream (excl:run-shell-command - (format nil "cat ~A | ~A" pathname filter) + (format nil "cat ~A | ~A" + (truename pathname) filter) :wait nil :error-output :stream :output :stream)) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 6f36f17a..080d78dc 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.79 1993/07/27 01:55:28 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.80 1993/08/12 16:05:07 cer Exp $ (in-package :xm-silica) @@ -131,7 +131,8 @@ :alignment (ecase nv ((:left nil) :beginning) (:center :center) - (:right :end))))) + (:right :end)) + :label-string (or (gadget-label sheet) "")))) ;;; Motif widgets that support the activate callback diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index ff4106d9..d492280d 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: xm-silica -*- ;; -;; -[Mon Jul 19 18:52:07 1993 by colin]- +;; -[Thu Aug 26 18:34:07 1993 by colin]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.lisp,v 1.37 1993/07/27 01:55:36 colin Exp $ +;; $fiHeader: xt-frames.lisp,v 1.38 1993/08/12 16:05:10 cer Exp $ (in-package :xm-silica) @@ -248,17 +248,22 @@ (defmethod update-frame-settings ((framem xt-frame-manager) (frame t)) ;;--- Lets see how this works out - (let ((shell (sheet-shell (frame-top-level-sheet frame)))) - (let ((sr (compose-space (frame-top-level-sheet frame)))) + (let ((graft (graft framem)) + (shell (sheet-shell (frame-top-level-sheet frame)))) + (let* ((sr (compose-space (frame-top-level-sheet frame))) + (width (fix-coordinate (space-requirement-min-width sr))) + (height (fix-coordinate (space-requirement-min-height sr)))) + (clim-internals::limit-size-to-graft width height graft) (tk::set-values shell - :min-width (fix-coordinate (space-requirement-min-width sr)) - :min-height (fix-coordinate (space-requirement-min-height sr)))) + :min-width width + :min-height height)) (let ((geo (clim-internals::frame-geometry frame))) (destructuring-bind (&key left top width height &allow-other-keys) geo ;;-- what about width and height (when (and width height) + (clim-internals::limit-size-to-graft width height graft) (tk::set-values shell :width (fix-coordinate width) :height (fix-coordinate height))) (when (and left top) @@ -268,24 +273,21 @@ (tk::set-values shell :title (frame-pretty-name frame)) (let ((icon (clim-internals::frame-icon frame))) - (flet ((decode-pixmap (x) + (flet ((decode-bitmap (x) (etypecase x (string x) (pattern (let ((sheet (frame-top-level-sheet frame))) (with-sheet-medium (medium sheet) - (destructuring-bind (&key background-pixmap) - (decode-gadget-background medium sheet x) - background-pixmap))))))) + (pixmap-from-pattern x medium :bitmap))))))) (destructuring-bind (&key (name (frame-pretty-name frame)) pixmap clipping-mask) icon ;;-- Dialog shells do not have :icon-name resource (when (typep shell 'tk::top-level-shell) (tk::set-values shell :icon-name name)) (when pixmap - (tk::set-values shell :icon-pixmap (decode-pixmap pixmap))) - (when clipping-mask - (tk::set-values shell :clip-mask (decode-pixmap clipping-mask)))))))) + (tk::set-values shell :icon-pixmap (decode-bitmap pixmap))) + (when clipping-mask (tk::set-values shell :clip-mask (decode-bitmap clipping-mask)))))))) (defmethod frame-manager-note-pretty-name-changed ((framem xt-frame-manager) (frame standard-application-frame)) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index 4e39f989..4aff18ec 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: xm-silica -*- ;; -;; -[Fri Jul 30 15:12:38 1993 by colin]- +;; -[Thu Aug 19 15:39:02 1993 by colin]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.36 1993/07/27 01:55:40 colin Exp $ +;; $fiHeader: xt-gadgets.lisp,v 1.37 1993/07/30 23:58:39 colin Exp $ (in-package :xm-silica) @@ -87,15 +87,13 @@ (defmethod decode-gadget-background (medium sheet ink) (declare (ignore sheet)) - (let ((gc (decode-ink ink medium))) - (if (tk::gcontext-stipple gc) - (list :background-pixmap (tk::gcontext-stipple gc)) - (list :background (tk::gcontext-foreground gc))))) + (let ((pixel (decode-color ink medium))) + (list :background pixel))) (defmethod decode-gadget-background (medium sheet (ink pattern)) (declare (ignore sheet)) - (let ((gc (decode-ink ink medium))) - (list :background-pixmap (tk::gcontext-stipple gc)))) + (let ((pixmap (pixmap-from-pattern ink medium :pixmap))) + (list :background-pixmap pixmap))) (defmethod decode-gadget-foreground (medium sheet ink) (declare (ignore sheet)) @@ -113,7 +111,6 @@ (apply #'tk::set-values m (decode-gadget-background medium pane ink))))) - (defclass xt-pane (basic-pane) ;;--- Is this useful a hack enabling things to be passed through ;;--- to the mirror diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index e1db2bda..16414dea 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: tk-silica -*- ;; -;; -[Thu Jul 22 18:06:19 1993 by colin]- +;; -[Thu Aug 19 18:38:51 1993 by colin]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.76 1993/06/23 00:13:59 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.77 1993/07/27 01:55:47 colin Exp $ (in-package :tk-silica) @@ -309,14 +309,12 @@ (let ((palette (medium-palette medium))) (with-slots (white-pixel black-pixel) palette - (setf indirect-inks nil - device-clip-region nil) + (setf device-clip-region nil) (setf (medium-sheet medium) sheet) (when (and drawable (not (eq (port-display port) (tk::object-display drawable)))) - (error "drawable and display do not match")) - (invalidate-indirect-inks medium))))) + (error "drawable and display do not match")))))) (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet) (declare (ignore sheet)) @@ -325,12 +323,8 @@ (setf drawable nil (medium-sheet medium) nil) (maphash #'(lambda (ink gc) - (declare (ignore ink)) - (let ((pixmap (or (tk::gcontext-stipple gc) - (tk::gcontext-tile gc)))) - (when pixmap - (tk::destroy-pixmap pixmap)) - (tk::free-gcontext gc))) + (declare (ignore gc)) + (deallocate-ink ink medium)) ink-table) (clrhash ink-table) (setf indirect-inks nil))) @@ -339,15 +333,15 @@ (with-slots (ink-table indirect-inks) medium (dolist (ink indirect-inks) - (let* ((gc (gethash ink ink-table)) - (pixmap (or (tk::gcontext-stipple gc) - (tk::gcontext-tile gc)))) - (when pixmap - (tk::destroy-pixmap pixmap)) - (tk::free-gcontext gc)) + (deallocate-ink ink medium) (remhash ink ink-table)) (setf indirect-inks nil))) +(defmethod deallocate-ink ((ink design) (medium xt-medium)) + (with-slots (ink-table) medium + (let ((gc (gethash ink ink-table))) + (tk::free-gcontext gc)))) + (defmethod (setf medium-background) :after (ink (medium xt-medium)) (declare (ignore ink)) (invalidate-indirect-inks medium) @@ -477,15 +471,6 @@ (defgeneric decode-ink (ink medium)) -;;; we provide this around method which implement a cache of already -;;; decoded inks - -;;; if the decode method for an ink calculates the gcontext by calling -;;; decode-ink it should also return t as it's second value. (eg for -;;; contrasting inks) This prevent problems with having multiple -;;; entries for the same gc in the table which causes problems when -;;; they need to be freed - (defmethod decode-ink ((ink design) (medium xt-medium)) (with-slots (ink-table indirect-inks) medium (or (gethash ink ink-table) @@ -513,9 +498,11 @@ (setf (tk::gcontext-plane-mask new-gc) mask))) new-gc))) +#+ignore (defmethod decode-ink-1 ((x (eql +foreground-ink+)) (medium xt-medium)) (decode-ink-1 (medium-foreground medium) medium)) +#+ignore (defmethod decode-ink-1 ((x (eql +background-ink+)) (medium xt-medium)) (decode-ink-1 (medium-background medium) medium)) @@ -597,84 +584,111 @@ (decode-rectangular-tile ink) (declare (ignore width height)) (decode-pattern-ink pattern medium t))) - -(defun decode-pattern-ink (pattern medium &optional tile-p) + +(defmethod deallocate-ink :before ((ink pattern) (medium xt-medium)) + (deallocate-pattern-ink ink medium)) + +(defmethod deallocate-ink :before ((ink rectangular-tile) (medium xt-medium)) + (deallocate-pattern-ink ink medium)) + +(defun deallocate-pattern-ink (ink medium) + (with-slots (ink-table) medium + (let* ((gc (gethash ink ink-table)) + (pixmap (or (tk::gcontext-stipple gc) + (tk::gcontext-tile gc)))) + (when pixmap + (tk::destroy-pixmap pixmap))))) + +(defun pixmap-from-pattern (pattern medium &optional format) (multiple-value-bind (array designs) (decode-pattern pattern) - (let* ((height (array-dimension array 0)) + (let* ((n-designs (length designs)) + (height (array-dimension array 0)) (width (array-dimension array 1)) - (image-data (make-array (list height width))) - (design-pixels (make-array (length designs))) - (two-color-p (eql (length designs) 2)) - two-color-fg - two-color-bg) - (declare (simple-vector design-pixels)) - - ;; Cache the decoded designs from the pattern - (dotimes (n (length designs)) - (let ((design (elt designs n))) - (if (eql design +nowhere+) - (unless two-color-p - (error "Transparent pattern ~S has more than two designs" pattern)) - (setf (svref design-pixels n) - (decode-color design medium))))) - - (when two-color-p - (setq two-color-bg (svref design-pixels 0) - two-color-fg (svref design-pixels 1)) - ;; make sure that any transparent design is the bg - (when (null (svref design-pixels 1)) - (rotatef two-color-bg two-color-fg))) - - (dotimes (w width) - (dotimes (h height) - (let ((pixel (svref design-pixels (aref array h w)))) - (setf (aref image-data h w) - (if two-color-p - (if (eq pixel two-color-bg) - 0 - 1) - pixel))))) - - (let* ((port (port (medium-sheet medium))) - (drawable (or (slot-value medium 'drawable) - (tk::display-root-window - (port-display port)))) - (depth (if two-color-p - 1 - (tk::drawable-depth drawable))) - (image (make-instance 'tk::image - :width width - :height height - :data image-data - :depth depth)) - (gc (make-instance 'ink-gcontext :drawable drawable)) - (pixmap - (make-instance 'tk::pixmap - :drawable drawable - :width width - :height height - :depth depth))) - (tk::put-image pixmap - (if two-color-p - (port-copy-gc-depth-1 port) - gc) - image) - (tk::destroy-image image) - (if two-color-p + (pixels (make-array n-designs)) + (image-data (make-array (list height width)))) + (declare (simple-vector pixels)) + + (unless format + (setq format (if (eql n-designs 2) :bitmap :pixmap))) + + (let ((bitmap + (case format + (:bitmap (or (eql n-designs 2) + (error "Can't make a bitmap from pattern with more than two designs"))) + (:pixmap (and (member +nowhere+ designs) + (error "Can't make a pixmap from a transparent pattern")))))) + + (dotimes (n (length designs)) + (let ((design (elt designs n))) + (setf (svref pixels n) + (and (not (eql design +nowhere+)) + (decode-color design medium))))) + + (let ((bitmap-bg (and bitmap + (svref pixels 1) (svref pixels 0)))) + (dotimes (w width) + (dotimes (h height) + (let ((pixel (svref pixels (aref array h w)))) + (setf (aref image-data h w) + (if bitmap + (if (eq pixel bitmap-bg) 0 1) + pixel)))))) + + (when bitmap + (when (null (svref pixels 1)) + (rotatef (svref pixels 0) (svref pixels 1)))) + + (let* ((port (port (medium-sheet medium))) + (drawable (or (slot-value medium 'drawable) + (tk::display-root-window (port-display port)))) + (depth (if bitmap + 1 + (tk::drawable-depth drawable))) + (image (make-instance 'tk::image + :width width + :height height + :data image-data + :depth depth)) + (pixmap (make-instance 'tk::pixmap + :drawable drawable + :width width + :height height + :depth depth))) + (tk::put-image pixmap + (if bitmap + (port-copy-gc-depth-1 port) + (port-copy-gc port)) + image) + (tk::destroy-image image) + (values pixmap format pixels)))))) + + +(defun decode-pattern-ink (pattern medium &optional tile-p) + (multiple-value-bind (pixmap format pixels) + (pixmap-from-pattern pattern medium) + (let* ((drawable (or (slot-value medium 'drawable) + (tk::display-root-window + (port-display (port (medium-sheet medium)))))) + (gc (make-instance 'ink-gcontext :drawable drawable))) + (if (eq format :bitmap) + (let ((bg (svref pixels 0)) + (fg (svref pixels 1))) (setf (tk::gcontext-stipple gc) pixmap - (tk::gcontext-fill-style gc) (if two-color-bg + (tk::gcontext-fill-style gc) (if bg :opaque-stippled :stippled) - (tk::gcontext-foreground gc) (or two-color-fg 0) - (tk::gcontext-background gc) (or two-color-bg 0)) - (setf (tk::gcontext-tile gc) pixmap - (tk::gcontext-fill-style gc) :tiled)) - (unless tile-p - (setf (ink-gcontext-shift-tile-origin gc) t - (ink-gcontext-ink-clip-region gc) - (make-bounding-rectangle 0 0 width height))) - gc)))) + (tk::gcontext-foreground gc) (or fg 0) + (tk::gcontext-background gc) (or bg 0))) + (setf (tk::gcontext-tile gc) pixmap + (tk::gcontext-fill-style gc) :tiled)) + (unless tile-p + (setf (ink-gcontext-shift-tile-origin gc) t + (ink-gcontext-ink-clip-region gc) + (make-bounding-rectangle 0 0 + (pattern-width pattern) + (pattern-height pattern)))) + gc))) ;;; decode color @@ -695,7 +709,7 @@ (defmethod decode-color ((ink standard-opacity) (medium xt-medium)) (if (> (opacity-value ink) 0.5) (decode-color +foreground-ink+ medium) - (decode-color +background-ink+ medium))) + (decode-color +background-ink+ medium))) (defmethod decode-color ((ink contrasting-ink) (medium xt-medium)) (decode-color (decode-contrasting-ink ink medium) medium)) @@ -1308,7 +1322,8 @@ (let* ((port (port medium)) (sheet (medium-sheet medium)) (transform (sheet-device-transformation sheet)) - (font (text-style-mapping port (medium-text-style medium))) + (text-style (medium-merged-text-style medium)) + (font (text-style-mapping port text-style)) (ascent (tk::font-ascent font))) (convert-to-device-coordinates transform x y) (discard-illegal-coordinates medium-draw-text* x y) @@ -1318,26 +1333,25 @@ (setq string-or-char (string string-or-char))) (ecase align-x (:right - (let ((dx (text-size sheet string-or-char - :text-style (medium-text-style medium) + (let ((dx (text-size sheet string-or-char :text-style text-style :start start :end end))) (when towards-x (decf towards-x dx)) (decf x dx))) (:center (let ((dx (floor (text-size sheet string-or-char - :text-style (medium-text-style medium) + :text-style text-style :start start :end end) 2))) (when towards-x (decf towards-x dx)) (decf x dx))) (:left nil)) (ecase align-y (:bottom - (let ((dy (text-style-descent (medium-text-style medium) medium))) + (let ((dy (text-style-descent text-style medium))) (decf y dy) (when towards-y (decf towards-y dy)))) (:center - (let ((dy (- (text-style-descent (medium-text-style medium) medium) - (floor (text-style-height (medium-text-style medium) medium) 2)))) + (let ((dy (- (text-style-descent text-style medium) + (floor (text-style-height text-style medium) 2)))) (decf y dy) (when towards-y (decf towards-y dy)))) (:baseline nil) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 51b8f34b..202c76df 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: xm-silica -*- ;; -;; -[Thu Jul 22 16:32:23 1993 by colin]- +;; -[Wed Aug 25 11:15:21 1993 by colin]- ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.86 1993/07/27 01:55:59 colin Exp $ +;; $fiHeader: xt-silica.lisp,v 1.87 1993/08/12 16:05:13 cer Exp $ (in-package :xm-silica) @@ -51,6 +51,9 @@ (defmethod port-type ((port xt-port)) ':xt) +(defmethod port-name ((port xt-port)) + (ff:char*-to-string + (x11:display-display-name (port-display port)))) (defmethod port-copy-gc ((port xt-port)) ;;-- Assume 1-1 port-graft mapping? @@ -1196,8 +1199,8 @@ (find-widget-class-and-initargs-for-sheet port parent sheet) (let ((class-name (tk::widget-class-name (tk::class-handle (find-class class))))) - (values (getf initargs :name - (string-downcase class-name :start 0 :end 1)) + (values (or (getf initargs :name) + (string-downcase class-name :start 0 :end 1)) class-name)))) (defmethod find-widget-name-and-class @@ -1268,17 +1271,21 @@ *resource-class* resource-class) `(,@(and background `(:background ,background)) ,@(and foreground `(:foreground ,foreground)) - ,@(and text-style - `(:text-style - ,(let ((spec (read-from-string text-style))) - (etypecase spec - (cons (parse-text-style spec)) - (string (silica::make-device-font - port + ,@(let ((style (convert-text-style port display text-style))) + (and style `(:text-style ,style))))))))) + +(defun convert-text-style (port display text-style) + (ignore-errors + (let ((spec (read-from-string text-style))) + (if (consp spec) + (parse-text-style spec) + (let ((font-name (or (and (stringp spec) spec) + text-style))) + (silica::make-device-font port (make-instance 'tk::font :display display :name (car (tk::list-font-names - display spec))))))))))))))) + display font-name))))))))) ;;;--- Gadget activation deactivate diff --git a/utils/designs.lisp b/utils/designs.lisp index 5609876b..332fb226 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: designs.lisp,v 1.15 93/05/13 16:32:53 colin Exp $ +;; $fiHeader: designs.lisp,v 1.16 1993/07/27 01:57:08 colin Exp $ (in-package :clim-utils) @@ -296,9 +296,9 @@ (hh (mod (- hue .5f0) 1.0f0)) (hh (- (* hh 2.0f0 3.1415926535f0) 3.1415926535f0)) (s3 (sin saturation)) - (x (* (sqrt ihs-rgb-c1) s3 (cos hh) intensity)) - (y (* (sqrt ihs-rgb-c2) s3 (sin hh) intensity)) - (z (* (sqrt ihs-rgb-c3) (cos saturation) intensity))) + (x (* ihs-rgb-c1 s3 (cos hh) intensity)) + (y (* ihs-rgb-c2 s3 (sin hh) intensity)) + (z (* ihs-rgb-c3 (cos saturation) intensity))) (macrolet ((range (x) `(max 0.0f0 (min 1.0f0 ,x)))) (values (range (+ x x z)) diff --git a/utils/packages.lisp b/utils/packages.lisp index 3b0a9512..ebde891f 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.56 1993/07/27 01:57:48 colin Exp $ +;; $fiHeader: packages.lisp,v 1.57 1993/08/12 16:05:20 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -1851,6 +1851,7 @@ port-alive-p port-keyboard-input-focus port-modifier-state + port-name port-pointer port-properties port-server-path -- GitLab