From 45aa75b8441d1ecc2374c9b899ef26ed421d9d79 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Thu, 29 Oct 1992 16:55:47 +0000 Subject: [PATCH] fixes --- demo/color-editor.lisp | 29 ++--- demo/graphics-editor.lisp | 26 +++-- demo/ico.lisp | 131 +++++++++++---------- demo/plot.lisp | 2 +- demo/puzzle.lisp | 52 ++++----- silica/medium.lisp | 38 +------ silica/port.lisp | 6 +- tk-silica/xm-silica.lisp | 19 ++-- tk-silica/xt-graphics.lisp | 228 ++++++++++++++++++------------------- tk-silica/xt-silica.lisp | 2 +- tk/xlib.lisp | 8 +- utils/base-designs.lisp | 57 +++++----- utils/designs.lisp | 214 +++++++++++++++++----------------- utils/packages.lisp | 66 ++++------- 14 files changed, 410 insertions(+), 468 deletions(-) diff --git a/demo/color-editor.lisp b/demo/color-editor.lisp index c056f41c..d707f0e3 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.7 92/10/07 14:43:21 cer Exp $ +;; $fiHeader: color-editor.lisp,v 1.8 92/10/28 11:32:53 cer Exp $ (in-package :clim-demo) @@ -14,7 +14,7 @@ (display-color (pane-frame stream) stream)) (define-application-frame color-chooser () - (color mutable-p + (color dynamic-p red blue green intensity hue saturation) (:menu-bar nil) @@ -79,21 +79,22 @@ rgb ihs)))) (defmethod run-frame-top-level :before ((frame color-chooser) &key) - (with-slots (color mutable-p) frame - (setf color (if (setf mutable-p (palette-color-p (frame-palette frame))) - (make-mutable-color +black+) - +black+)))) + (with-slots (color dynamic-p) frame + (setf dynamic-p (palette-dynamic-p (frame-palette frame)) + color (if dynamic-p + (make-dynamic-color +black+) + +black+)))) (defmethod color ((frame color-chooser)) - (with-slots (color mutable-p) frame - (if mutable-p - (mutable-color-color color) + (with-slots (color dynamic-p) frame + (if dynamic-p + (dynamic-color-color color) color))) (defmethod (setf color) (new-color (frame color-chooser)) - (with-slots (color mutable-p) frame - (if mutable-p - (setf (mutable-color-color color) new-color) + (with-slots (color dynamic-p) frame + (if dynamic-p + (setf (dynamic-color-color color) new-color) (setf color new-color)))) (defmethod display-color ((frame color-chooser) stream) @@ -167,8 +168,8 @@ (defmethod value-changed-callback :after ((slider slider) (client (eql 'color)) id value) (declare (ignore id value)) (let ((frame (pane-frame slider))) - (with-slots (mutable-p) frame - (unless mutable-p + (with-slots (dynamic-p) frame + (unless dynamic-p ;; Redisplay the color swatch only if we haven't done so ;; by changing the color in-place (redisplay-frame-pane (pane-frame slider) 'display))))) diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp index 706552b9..5b434ba5 100644 --- a/demo/graphics-editor.lisp +++ b/demo/graphics-editor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-editor.lisp,v 1.12 92/10/28 11:32:57 cer Exp Locker: cer $ +;; $fiHeader: graphics-editor.lisp,v 1.13 92/10/28 13:17:33 cer Exp $ (in-package :clim-graphics-editor) @@ -162,14 +162,6 @@ (box-label object) (+ left (floor (- right left) 2)) (+ top 2) :align-x :center :align-y :top)))) -#+allegro -(defparameter *box-highlighting-ink* - (make-flipping-ink +background-ink+ +red+)) - -#+allegro -(defparameter *box-highlighting-line-style* - (make-line-style :thickness 2)) - #+allegro (define-presentation-method highlight-presentation ((type box) record stream state) (declare (ignore state)) @@ -180,8 +172,13 @@ (draw-rectangle* stream (+ xoff (- left 3)) (+ yoff (- top 3)) (+ xoff right 3) (+ yoff bottom 3) - :ink *box-highlighting-ink* - :line-style *box-highlighting-line-style* + :ink (make-flipping-ink + (if (palette-color-p + (frame-palette (pane-frame stream))) + +red+ + +foreground-ink+) + +background-ink+) + :line-style (make-line-style :thickness 2) :filled nil)))) (defmethod move-object :after ((object box) x y) @@ -428,7 +425,12 @@ (last-box (slot-value *application-frame* 'last-box)) (style (slot-value *application-frame* 'style)) (shape (slot-value *application-frame* 'shape)) - (flipping-ink #+allegro (make-flipping-ink +blue+ +background-ink+) + (flipping-ink #+allegro + (make-flipping-ink (if (palette-color-p + (frame-palette *application-frame*)) + +blue+ + +foreground-ink+) + +background-ink+) #-allegro +flipping-ink+)) ;;--- Zdrava supplies primitives to input basic objects such as ;;--- points, lines, rectangles and polygons, circles and ellipses, diff --git a/demo/ico.lisp b/demo/ico.lisp index 4950e493..66bbc55b 100644 --- a/demo/ico.lisp +++ b/demo/ico.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ico.lisp,v 1.11 92/10/28 11:32:58 cer Exp Locker: cer $ +;; $fiHeader: ico.lisp,v 1.12 92/10/28 13:17:35 cer Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -29,8 +29,8 @@ ((ico-time-p :initform t) (ico-line-style :initform :thin) (ico-buffers :initform 1) - (ico-color-group2 :initform nil) - (ico-color-group3 :initform nil) + (ico-color-set2 :initform nil) + (ico-color-set3 :initform nil) (inks0 :initform (vector *background-color*)) (inks1 :initform (vector *line-color*)) (inks2 :initform (vector *face1-color*)) @@ -70,63 +70,54 @@ :default ico-line-style :stream pane :prompt "Line style"))) + (when (palette-dynamic-p (frame-palette frame)) (formatting-cell (pane) - (let ((x (append (and draw-faces '(:faces)) - (and draw-edges '(:edges))))) - (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose")) - (setf draw-edges (and (member :edges x) t) - draw-faces (and (member :faces x) t)))) - (formatting-cell (pane) - (setf ico-line-style (accept '(member :thin :thick) - :default ico-line-style - :stream pane - :prompt "Line Style"))) - (when (palette-mutable-p (frame-palette frame)) - (formatting-cell (pane) - (multiple-value-bind (buffering ptype changed) - (accept '(member :single :double :triple) - :default (svref #(:single :double :triple) (1- ico-buffers)) - :stream pane - :prompt "Buffering") - (declare (ignore ptype)) - (when changed - (with-slots (ico-color-group2 ico-color-group3 - inks0 inks1 inks2 inks3) frame - (case buffering - (:single - (setf ico-buffers 1 - inks0 (vector *background-color*) - inks1 (vector *line-color*) - inks2 (vector *face1-color*) - inks3 (vector *face2-color*))) - (:double - (let ((g (or ico-color-group2 - (setf ico-color-group2 (make-color-group 4 4))))) - (setf ico-buffers 2 - inks0 (vector (group-color g 0 nil) - (group-color g nil 0)) - inks1 (vector (group-color g 1 nil) - (group-color g nil 1)) - inks2 (vector (group-color g 2 nil) - (group-color g nil 2)) - inks3 (vector (group-color g 3 nil) - (group-color g nil 3))))) - (:triple - (let ((g (or ico-color-group3 - (setf ico-color-group3 (make-color-group 4 4 4))))) - (setf ico-buffers 3 - inks0 (vector (group-color g 0 nil nil) - (group-color g nil 0 nil) - (group-color g nil nil 0)) - inks1 (vector (group-color g 1 nil nil) - (group-color g nil 1 nil) - (group-color g nil nil 1)) - inks2 (vector (group-color g 2 nil nil) - (group-color g nil 2 nil) - (group-color g nil nil 2)) - inks3 (vector (group-color g 3 nil nil) - (group-color g nil 3 nil) - (group-color g nil nil 3)))))))))))))) + (multiple-value-bind (buffering ptype changed) + (accept '(member :single :double :triple) + :default (svref #(:single :double :triple) (1- ico-buffers)) + :stream pane + :prompt "Buffering") + (declare (ignore ptype)) + (when changed + (with-slots (ico-color-set2 ico-color-set3 + inks0 inks1 inks2 inks3) frame + (case buffering + (:single + (setf ico-buffers 1 + inks0 (vector *background-color*) + inks1 (vector *line-color*) + inks2 (vector *face1-color*) + inks3 (vector *face2-color*))) + (:double + (let ((g (or ico-color-set2 + (setf ico-color-set2 + (make-layered-color-set 4 4))))) + (setf ico-buffers 2 + inks0 (vector (layered-color g 0 nil) + (layered-color g nil 0)) + inks1 (vector (layered-color g 1 nil) + (layered-color g nil 1)) + inks2 (vector (layered-color g 2 nil) + (layered-color g nil 2)) + inks3 (vector (layered-color g 3 nil) + (layered-color g nil 3))))) + (:triple + (let ((g (or ico-color-set3 + (setf ico-color-set3 + (make-layered-color-set 4 4 4))))) + (setf ico-buffers 3 + inks0 (vector (layered-color g 0 nil nil) + (layered-color g nil 0 nil) + (layered-color g nil nil 0)) + inks1 (vector (layered-color g 1 nil nil) + (layered-color g nil 1 nil) + (layered-color g nil nil 1)) + inks2 (vector (layered-color g 2 nil nil) + (layered-color g nil 2 nil) + (layered-color g nil nil 2)) + inks3 (vector (layered-color g 3 nil nil) + (layered-color g nil 3 nil) + (layered-color g nil nil 3)))))))))))))) (define-ico-frame-command (com-ico-throw-ball :menu "Throw ball" :keystroke #\t) () (with-application-frame (frame) @@ -138,8 +129,16 @@ (define-ico-frame-command (com-ico-quit :menu "Quit" :keystroke #\q) () (with-application-frame (frame) - (catch-ball frame) - (frame-exit frame))) + (with-slots (ico-color-set2 ico-color-set3) frame + (let ((palette (frame-palette frame))) + (catch-ball frame) + (when ico-color-set2 + (remove-from-palette palette ico-color-set2) + (setf ico-color-set2 nil)) + (when ico-color-set3 + (remove-from-palette palette ico-color-set3) + (setf ico-color-set3 nil)) + (frame-exit frame))))) (defmethod disable-frame :after ((frame ico-frame)) (catch-ball frame)) @@ -256,11 +255,11 @@ (svref inks2 buffer) (svref inks3 buffer))))) (when (> ico-buffers 1) - (with-delayed-mutations - (mutate-color (svref inks0 buffer) *background-color*) - (mutate-color (svref inks1 buffer) *line-color*) - (mutate-color (svref inks2 buffer) *face1-color*) - (mutate-color (svref inks3 buffer) *face2-color*))) + (with-delayed-recoloring + (setf (layered-color-color (svref inks0 buffer)) *background-color* + (layered-color-color (svref inks1 buffer)) *line-color* + (layered-color-color (svref inks2 buffer)) *face1-color* + (layered-color-color (svref inks3 buffer)) *face2-color*))) (silica:medium-force-output medium)) #+xlib-ignore diff --git a/demo/plot.lisp b/demo/plot.lisp index 18394f09..f695ee36 100644 --- a/demo/plot.lisp +++ b/demo/plot.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: plot.lisp,v 1.13 92/10/28 11:33:05 cer Exp Locker: cer $ +;; $fiHeader: plot.lisp,v 1.14 92/10/29 15:02:50 cer Exp Locker: cer $ (in-package :clim-demo) diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp index d766f63e..320a19b0 100644 --- a/demo/puzzle.lisp +++ b/demo/puzzle.lisp @@ -1,28 +1,25 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: puzzle.lisp,v 1.19 92/10/07 14:43:50 cer Exp $ +;; $fiHeader: puzzle.lisp,v 1.20 92/10/28 11:33:08 cer Exp Locker: cer $ (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 - :text-cursor nil - :width :compute - :max-width +fill+ - :height :compute - :max-height +fill+ - :end-of-page-action :allow - :end-of-line-action :allow - :text-style '(:fix :bold :very-large) - :incremental-redisplay t - :display-function 'draw-puzzle)) + (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)) @@ -72,22 +69,19 @@ (defmethod draw-puzzle ((puzzle puzzle) stream &key max-width max-height) (declare (ignore max-width max-height)) (let ((puzzle-array (puzzle-puzzle puzzle))) - ;; I'm not sure why the table sometimes draws in the wrong place if I don't do this - (stream-set-cursor-position stream 0 0) - (updating-output (stream) - (formatting-table (stream) + (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 (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/silica/medium.lisp b/silica/medium.lisp index 0af27057..8268ad1f 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.26 92/10/28 11:30:50 cer Exp Locker: cer $ +;; $fiHeader: medium.lisp,v 1.27 92/10/28 13:17:09 cer Exp $ (in-package :silica) @@ -448,39 +448,3 @@ (generate-trampolines medium-protocol medium standard-sheet-output-mixin `(sheet-medium ,standard-sheet-output-mixin)) -;;; not clear that these should be here. - -(defmethod sheet-palette ((sheet sheet)) - (let* ((frame (pane-frame sheet)) - (framem (and frame (frame-manager frame)))) - (if framem - (frame-manager-palette framem) - (port-default-palette (port sheet))))) - -(defmethod medium-palette ((medium medium)) - (sheet-palette (medium-sheet medium))) - -;;; especially these - could be with other named-color stuff in -;;; utils/designs but things like port, sheet, medium aren't known -;;; there. - -;;; think we might want a silica/palette.lisp - -(defmethod find-named-color (name (port port)) - (find-named-color name (port-default-palette port))) - -(define-condition palette-full (serious-condition) ()) - -(defmethod add-to-palette ((palette basic-palette) &rest colors) - (let ((colors-done nil)) - (dolist (color colors) - (handler-case - (allocate-color color palette) - (palette-full (condition) - (dolist (color colors-done) - (free-color color palette)) - (signal condition)))))) - -(defmethod remove-from-palette ((palette basic-palette) &rest colors) - (dolist (color colors) - (free-color color palette))) diff --git a/silica/port.lisp b/silica/port.lisp index b8b1ccd9..7946a1ac 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.21 92/10/02 15:18:32 cer Exp $ +;; $fiHeader: port.lisp,v 1.22 92/10/28 11:30:53 cer Exp $ (in-package :silica) @@ -32,6 +32,9 @@ (return-from find-port port)))) (make-port :server-path server-path)) +(defmethod find-named-color (name (port port)) + (find-named-color name (port-default-palette port))) + #+Genera (scl:add-initialization "Reset ports" '(progn @@ -245,4 +248,3 @@ (defgeneric graft-height (graft)) (defgeneric graft-pixels-per-millimeter (graft)) (defgeneric graft-pixels-per-inch (graft)) - diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 4ec57d56..5171e671 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.25 92/08/18 17:54:31 cer Exp $ +;; $fiHeader: xm-silica.lisp,v 1.26 92/10/02 15:21:04 cer Exp $ (in-package :xm-silica) @@ -75,13 +75,16 @@ :height 11 :managed t)) -;(ff:defforeign 'xmprocesstraversal -; :entry-point "_XmProcessTraversal") -;(defmethod port-note-cursor-change :after ((port motif-port) -; cursor stream type old new) -; (declare (ignore old type cursor)) -; (when new -; (xmprocesstraversal (sheet-mirror stream) 0))) +#+ignore +(ff:defforeign 'xmprocesstraversal + :entry-point "_XmProcessTraversal") + +#+ignore +(defmethod port-note-cursor-change :after ((port motif-port) + cursor stream type old new) + (declare (ignore old type cursor)) + (when new + (xmprocesstraversal (sheet-mirror stream) 0))) (defmethod enable-xt-widget ((parent tk::xm-dialog-shell) (mirror t)) ;; this is a nasty hack just to make sure that the child is managed. diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 5f852215..bf53f82d 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -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.46 92/10/28 11:33:22 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.47 92/10/28 13:17:45 cer Exp $ (in-package :tk-silica) @@ -82,7 +82,7 @@ (make-instance 'xt-palette :port port :colormap colormap - :mutable-p (and + :dynamic-p (and (member (port-visual-class port) '(:gray-scale :pseudo-color :direct-color)) t) @@ -93,6 +93,14 @@ (defmethod make-palette ((port xt-port) &key) (make-xt-palette port (tk::create-colormap (port-display port)))) +(defmethod medium-palette ((medium xt-medium)) + (let* ((sheet (medium-sheet medium)) + (frame (pane-frame sheet)) + (framem (and frame (frame-manager frame)))) + (if framem + (frame-manager-palette framem) + (port-default-palette (port sheet))))) + #+ignore (defmethod (setf frame-manager-palette) :after ((palette xt-palette) (framem standard-frame-manager)) @@ -157,30 +165,23 @@ ;;; things we can install in a palete ;;; 1 - color (rgb etc) -;;; 2 - mutable-color -;;; 3 - color-group or group-color or both ?? - -(defmethod allocate-color :around (color (palette xt-palette)) - (declare (ignore color)) - (handler-case - (call-next-method) - (tk::x-colormap-error () - (error 'palette-full)))) - +;;; 2 - dynamic-color +;;; 3 - layered-color + (defmethod allocate-color ((color color) (palette xt-palette)) (unless (gethash color (palette-color-cache palette)) (decode-color-in-palette color palette))) -(defmethod allocate-color ((color mutable-color) (palette xt-palette)) - (unless (gethash color (palette-mutable-color-cache palette)) +(defmethod allocate-color ((color dynamic-color) (palette xt-palette)) + (unless (gethash color (palette-dynamic-color-cache palette)) (decode-color-in-palette color palette))) -(defmethod allocate-color ((group color-group) (palette xt-palette)) - (unless (gethash group (palette-color-group-cache palette)) - (decode-color-group group palette))) +(defmethod allocate-color ((set layered-color-set) (palette xt-palette)) + (unless (gethash set (palette-layered-color-cache palette)) + (decode-layered-color-set set palette))) -(defmethod allocate-color ((color group-color) (palette xt-palette)) - (allocate-color (group-color-group color) palette)) +(defmethod allocate-color ((color layered-color) (palette xt-palette)) + (allocate-color (layered-color-set color) palette)) (defmethod free-color ((color color) (palette xt-palette)) (let* ((color-cache (palette-color-cache palette)) @@ -189,22 +190,22 @@ (tk::free-color-cells (palette-colormap palette) pixel 0) (remhash color color-cache)))) -(defmethod free-color ((color mutable-color) (palette xt-palette)) - (let* ((mutable-color-cache (palette-mutable-color-cache palette)) - (pixel (gethash color mutable-color-cache))) +(defmethod free-color ((color dynamic-color) (palette xt-palette)) + (let* ((dynamic-color-cache (palette-dynamic-color-cache palette)) + (pixel (gethash color dynamic-color-cache))) (when pixel (tk::free-color-cells (palette-colormap palette) pixel 0) - (remhash color mutable-color-cache)))) + (remhash color dynamic-color-cache)))) -(defmethod free-color ((color group-color) (palette xt-palette)) - (free-color (group-color-group color) palette)) +(defmethod free-color ((color layered-color) (palette xt-palette)) + (free-color (layered-color-set color) palette)) -(defmethod free-color ((group color-group) (palette xt-palette)) - (let* ((color-group-cache (palette-color-group-cache palette)) - (pixel-planes (gethash group color-group-cache))) +(defmethod free-color ((set layered-color-set) (palette xt-palette)) + (let* ((layered-color-cache (palette-layered-color-cache palette)) + (pixel-planes (gethash set layered-color-cache))) (when pixel-planes - (let ((mutable-color-cache (palette-mutable-color-cache palette)) - (mutable-array (color-group-mutable-array group)) + (let ((dynamic-color-cache (palette-dynamic-color-cache palette)) + (dynamic-array (layered-color-set-dynamic-array set)) (planes 0)) (dolist (plane-masks (cdr pixel-planes)) (dolist (plane-mask plane-masks) @@ -212,28 +213,20 @@ (tk::free-color-cells (palette-colormap palette) (car pixel-planes) planes) - (map-over-group-colors + (map-over-layered-colors #'(lambda (dimensions) - (let ((mutable-color (apply #'aref mutable-array dimensions))) - (remhash mutable-color mutable-color-cache) - (setf (mutable-color-palettes mutable-color) - (delete palette (mutable-color-palettes mutable-color))))) - group) - (maphash #'(lambda (group-color pixel-mask) + (let ((dynamic-color (apply #'aref dynamic-array dimensions))) + (remhash dynamic-color dynamic-color-cache) + (setf (dynamic-color-palettes dynamic-color) + (delete palette (dynamic-color-palettes dynamic-color))))) + set) + (maphash #'(lambda (layered-color pixel-mask) (declare (ignore pixel-mask)) - (when (and (typep group-color 'group-color) - (eq (group-color-group group-color) group)) - (remhash group-color color-group-cache))) - color-group-cache) - (remhash group color-group-cache))))) -;;; - -(defmethod medium-drawable ((medium xt-medium)) - (with-slots (drawable sheet) medium - (or drawable - (setf drawable (fetch-medium-drawable - sheet - (sheet-mirror sheet)))))) + (when (and (typep layered-color 'layered-color) + (eq (layered-color-set layered-color) set)) + (remhash layered-color layered-color-cache))) + layered-color-cache) + (remhash set layered-color-cache))))) ;; @@ -482,7 +475,7 @@ ;;; there otherwise make a gc using decode-color-in-palette to get the ;;; pixel value -;;--- This is really on color, mutable-color, and group-color. +;;--- This is really on color, dynamic-color, and layered-color. ;;--- Perhaps there should be a class like basic-color? (defmethod decode-ink ((ink design) (medium xt-medium)) @@ -512,34 +505,33 @@ (defmethod decode-ink ((ink flipping-ink) (medium xt-medium)) (let ((palette (medium-palette medium))) - (with-slots (color-p) palette - (with-slots (ink-table sheet tile-gcontext drawable indirect-inks) - medium - (or (gethash ink ink-table) - (let* ((drawable (or drawable - (tk::display-root-window (port-display (port sheet))))) - (new-gc (make-instance 'fast-gcontext - :drawable drawable - :function boole-xor))) - (multiple-value-bind (color1 color2) - (decode-flipping-ink ink) - (cond (color-p - (setf (tk::gcontext-foreground new-gc) - (logxor (decode-color color1 medium) - (decode-color color2 medium)))) - ;;-- support gray-scale here - (t - ;; in a monochrome context there is only one - ;; flipping ink availiable ie white <-> black - (slot-value medium 'flipping-gcontext))) - (when (indirect-ink-p ink) - (push ink indirect-inks)) - (setf (gethash ink ink-table) new-gc)))))))) + (with-slots (ink-table sheet tile-gcontext drawable indirect-inks) + medium + (or (gethash ink ink-table) + (let* ((drawable (or drawable + (tk::display-root-window (port-display (port sheet))))) + (new-gc (make-instance 'fast-gcontext + :drawable drawable + :function boole-xor))) + (multiple-value-bind (color1 color2) + (decode-flipping-ink ink) + (cond ((palette-color-p palette) + (setf (tk::gcontext-foreground new-gc) + (logxor (decode-color color1 medium) + (decode-color color2 medium)))) + ;;-- support gray-scale here + (t + ;; in a monochrome context there is only one + ;; flipping ink availiable ie white <-> black + (slot-value medium 'flipping-gcontext))) + (when (indirect-ink-p ink) + (push ink indirect-inks)) + (setf (gethash ink ink-table) new-gc))))))) (defmethod decode-ink ((ink color) (medium xt-medium)) (let ((palette (medium-palette medium))) - (with-slots (white-pixel black-pixel color-p) palette + (with-slots (white-pixel black-pixel) palette (with-slots (ink-table sheet tile-gcontext drawable) medium (or (gethash ink ink-table) (let* ((drawable @@ -645,37 +637,43 @@ and on color servers, unless using white or black") (setf (gethash color color-cache) (with-slots (white-pixel black-pixel) palette (cond ((palette-color-p palette) - (tk::allocate-color - (palette-colormap palette) (get-xcolor color palette))) + (handler-case + (tk::allocate-color + (palette-colormap palette) (get-xcolor color palette)) + (tk::x-colormap-error () + (error 'palette-full)))) ;;-- support gray-scale here (t (multiple-value-bind (r g b) (color-rgb color) (let ((luminosity (color-luminosity r g b))) (if (> luminosity .5) white-pixel black-pixel)))))))))) -(defmethod decode-color-in-palette ((color mutable-color) (palette xt-palette)) - (let ((mutable-color-cache (palette-mutable-color-cache palette))) - (or (gethash color mutable-color-cache) - (let ((pixel (aref (tk::alloc-color-cells - (palette-colormap palette) 1 0) +(defmethod decode-color-in-palette ((color dynamic-color) (palette xt-palette)) + (let ((dynamic-color-cache (palette-dynamic-color-cache palette))) + (or (gethash color dynamic-color-cache) + (let ((pixel (aref (handler-case + (tk::alloc-color-cells + (palette-colormap palette) 1 0) + (tk::x-colormap-error () + (error 'palette-full))) 0))) - (update-palette-entry palette pixel (mutable-color-color color)) - (push palette (mutable-color-palettes color)) - (setf (gethash color mutable-color-cache) pixel))))) + (update-palette-entry palette pixel (dynamic-color-color color)) + (push palette (dynamic-color-palettes color)) + (setf (gethash color dynamic-color-cache) pixel))))) -(defmethod decode-color-in-palette ((color group-color) (palette xt-palette)) - (let ((color-group-cache (palette-color-group-cache palette))) +(defmethod decode-color-in-palette ((color layered-color) (palette xt-palette)) + (let ((layered-color-cache (palette-layered-color-cache palette))) (values-list - (or (gethash color color-group-cache) - (setf (gethash color color-group-cache) - (let* ((group (group-color-group color)) - (pixel-planes (gethash group color-group-cache))) + (or (gethash color layered-color-cache) + (setf (gethash color layered-color-cache) + (let* ((set (layered-color-set color)) + (pixel-planes (gethash set layered-color-cache))) (unless pixel-planes - (setq pixel-planes (decode-color-group group palette))) + (setq pixel-planes (decode-layered-color-set set palette))) (multiple-value-list - (decode-group-color (group-color-layers color) pixel-planes)))))))) + (decode-layered-color (layered-color-layers color) pixel-planes)))))))) -(defun decode-group-color (layers pixel-planes) +(defun decode-layered-color (layers pixel-planes) (let ((pixel (car pixel-planes)) (planes (cdr pixel-planes)) (mask 0)) @@ -692,11 +690,11 @@ and on color servers, unless using white or black") (setq mask (logior mask plane-mask)))))) (values pixel (lognot mask)))) -(defun decode-color-group (group palette) - (let ((color-group-cache (palette-color-group-cache palette)) - (mutable-color-cache (palette-mutable-color-cache palette)) - (layers (color-group-layers group)) - (mutable-array (color-group-mutable-array group)) +(defun decode-layered-color-set (set palette) + (let ((layered-color-cache (palette-layered-color-cache palette)) + (dynamic-color-cache (palette-dynamic-color-cache palette)) + (layers (layered-color-set-layers set)) + (dynamic-array (layered-color-set-dynamic-array set)) layer-nplanes (total-nplanes 0)) (dolist (layer layers) @@ -704,8 +702,11 @@ and on color servers, unless using white or black") (push nplanes layer-nplanes) (incf total-nplanes nplanes))) (multiple-value-bind (pixels masks) - (tk::alloc-color-cells - (palette-colormap palette) 1 total-nplanes) + (handler-case + (tk::alloc-color-cells + (palette-colormap palette) 1 total-nplanes) + (tk::x-colormap-error () + (error 'palette-full))) (let ((pixel (aref pixels 0)) (count 0) (planes nil)) @@ -716,23 +717,22 @@ and on color servers, unless using white or black") (incf count)) (push plane-masks planes))) (let ((pixel-planes (cons pixel planes))) - (map-over-group-colors + (map-over-layered-colors #'(lambda (dimensions) - (let ((mutable-color (apply #'aref mutable-array dimensions)) - (pixel (decode-group-color dimensions - pixel-planes))) - (setf (gethash mutable-color mutable-color-cache) pixel) - (update-palette-entry palette pixel (mutable-color-color mutable-color)) - (push palette (mutable-color-palettes mutable-color)))) - group) - (setf (gethash group color-group-cache) pixel-planes)))))) + (let ((dynamic-color (apply #'aref dynamic-array dimensions)) + (pixel (decode-layered-color dimensions + pixel-planes))) + (setf (gethash dynamic-color dynamic-color-cache) pixel) + (update-palette-entry palette pixel (dynamic-color-color dynamic-color)) + (push palette (dynamic-color-palettes dynamic-color)))) + set) + (setf (gethash set layered-color-cache) pixel-planes)))))) (defmethod decode-color ((ink contrasting-ink) (medium xt-medium)) (let ((palette (medium-palette medium))) - (with-slots (color-p) palette - (decode-color (if color-p - (make-color-for-contrasting-ink ink) - (make-gray-color-for-contrasting-ink ink)) medium)))) + (decode-color (if (palette-color-p palette) + (make-color-for-contrasting-ink ink) + (make-gray-color-for-contrasting-ink ink)) medium))) (defvar *default-dashes* '(4 4)) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index a598429f..7386f2d3 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.52 92/10/28 13:17:48 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.53 92/10/29 15:02:59 cer Exp Locker: cer $ (in-package :xm-silica) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index ff1fcbba..6c574d66 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.30 92/10/28 11:30:39 cer Exp Locker: cer $ +;; $fiHeader: xlib.lisp,v 1.31 92/10/28 13:17:01 cer Exp $ (in-package :tk) @@ -247,7 +247,7 @@ (eval-when (load) (setup-error-handlers)) -(define-condition x-colormap-error (serious-condition) ()) +(define-condition x-colormap-full (serious-condition) ()) ;;-- @@ -335,7 +335,7 @@ ;;-- Perhaps the colormap code should enable the user to ;;-- intercept this or we should just resort to some kind of stippling (if (zerop z) - (error 'x-colormap-error) + (error 'x-colormap-full) (values (x11:xcolor-pixel y) (make-instance 'color :foreign-address y)))))) @@ -421,7 +421,7 @@ pixels ncolors))) (when (zerop z) - (error 'x-colormap-error)) + (error 'x-colormap-full)) (values pixels masks))) diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp index 22abcb74..469e7ad3 100644 --- a/utils/base-designs.lisp +++ b/utils/base-designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: base-designs.lisp,v 1.2 92/10/04 14:16:12 cer Exp $ +;; $fiHeader: base-designs.lisp,v 1.3 92/10/28 11:30:57 cer Exp $ (in-package :clim-utils) @@ -64,7 +64,6 @@ (with-slots (red green blue) color `(make-rgb-color ,red ,green ,blue))) - (defclass ihs-color (color) ((intensity :type single-float :initarg :intensity) (hue :type single-float :initarg :hue) @@ -85,14 +84,14 @@ (defclass basic-palette (palette) ((port :reader palette-port :initarg :port) (color-p :reader palette-color-p :initarg :color-p) - (mutable-p :reader palette-mutable-p :initarg :mutable-p) + (dynamic-p :reader palette-dynamic-p :initarg :dynamic-p) (color-cache :reader palette-color-cache :initform (make-hash-table)) - (mutable-color-cache :reader palette-mutable-color-cache + (dynamic-color-cache :reader palette-dynamic-color-cache + :initform (make-hash-table)) + (layered-color-cache :reader palette-layered-color-cache :initform (make-hash-table)) - (color-group-cache :reader palette-color-group-cache - :initform (make-hash-table)) - (delayed-mutations :reader palette-delayed-mutations - :initform (make-array 32 :adjustable t :fill-pointer 0)))) + (delayed-recolors :reader palette-delayed-recolors + :initform (make-array 32 :adjustable t :fill-pointer 0)))) (defgeneric make-palette (port &key)) @@ -105,42 +104,42 @@ (defgeneric update-palette-entries (palette updates)) -;;; Mutable Colors +;;; Dynamic Colors -(defclass mutable-color (color) - ((color :accessor mutable-color-color :initarg :color) +(defclass dynamic-color (color) + ((color :accessor dynamic-color-color :initarg :color) (palettes :type list :initform nil - :accessor mutable-color-palettes))) + :accessor dynamic-color-palettes))) -(define-constructor make-mutable-color-1 mutable-color (color) +(define-constructor make-dynamic-color dynamic-color (color) :color color) -(defmethod make-load-form ((color mutable-color)) +(defmethod make-load-form ((color dynamic-color)) (with-slots (color) color - `(make-mutable-color ,color))) + `(make-dynamic-color ,color))) -;;; Color Groups +;;; Layered Colors -(defclass color-group () - ((layers :initform nil :reader color-group-layers :initarg :layers) - (cache :initform (make-hash-table :test #'equal) :reader color-group-cache) - (mutable-array :reader color-group-mutable-array :initarg :mutable-array))) +(defclass layered-color-set () + ((layers :initform nil :reader layered-color-set-layers :initarg :layers) + (cache :initform (make-hash-table :test #'equal) :reader layered-color-set-cache) + (dynamic-array :reader layered-color-set-dynamic-array :initarg :dynamic-array))) -(define-constructor make-color-group color-group (&rest layers) +(define-constructor make-layered-color-set layered-color-set (&rest layers) :layers layers - :mutable-array (make-array layers)) + :dynamic-array (make-array layers)) -(defgeneric group-color (color-group &rest layers)) +(defgeneric layered-color (layered-color-set &rest layers)) -(defclass group-color (design) - ((group :reader group-color-group :initarg :group) - (layers :initform nil :reader group-color-layers :initarg :layers) - (mutables :initform nil))) +(defclass layered-color (design) + ((set :reader layered-color-set :initarg :set) + (layers :initform nil :reader layered-color-layers :initarg :layers) + (dynamics :initform nil))) -(define-constructor make-group-color group-color (group layers) - :group group :layers layers) +(define-constructor make-layered-color layered-color (set layers) + :set set :layers layers) ;;; Foreground and background (indirect) inks diff --git a/utils/designs.lisp b/utils/designs.lisp index 79fdd764..7cf1a54f 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.8 92/10/28 11:31:04 cer Exp Locker: cer $ +;; $fiHeader: designs.lisp,v 1.9 92/10/28 13:17:12 cer Exp $ (in-package :clim-utils) @@ -294,140 +294,134 @@ (defmethod color-ihs ((color ihs-color)) (with-slots (intensity hue saturation) color (values intensity hue saturation))) - -;;; Mutable Colors +;;; Palettes + +(define-condition palette-full (serious-condition) ()) + +(defmethod add-to-palette ((palette basic-palette) &rest colors) + (let ((colors-done nil)) + (dolist (color colors) + (handler-case + (progn + (push color colors-done) + (allocate-color color palette)) + (palette-full (condition) + (dolist (color colors-done) + (free-color color palette)) + (error condition)))))) + +(defmethod remove-from-palette ((palette basic-palette) &rest colors) + (dolist (color colors) + (free-color color palette))) -(defun make-mutable-color (color) - (make-mutable-color-1 color)) + +;;; Dynamic Colors -(defmethod print-object ((color mutable-color) stream) +(defmethod print-object ((color dynamic-color) stream) (print-unreadable-object (color stream :type t :identity t) - (princ (mutable-color-color color) stream))) + (princ (dynamic-color-color color) stream))) -(defmethod color-rgb ((color mutable-color)) - (color-rgb (mutable-color-color color))) +(defmethod color-rgb ((color dynamic-color)) + (color-rgb (dynamic-color-color color))) -(defmethod color-ihs ((color mutable-color)) - (color-ihs (mutable-color-color color))) +(defmethod color-ihs ((color dynamic-color)) + (color-ihs (dynamic-color-color color))) -(defvar *doing-delayed-mutations* nil) +(defvar *doing-delayed-recolors* nil) -(defmethod mutate-mutable ((mutable mutable-color) (color color)) - (if *doing-delayed-mutations* - (dolist (palette (mutable-color-palettes mutable)) - (let ((cell (gethash mutable (palette-mutable-color-cache palette))) - (mutations (palette-delayed-mutations palette))) +(defmethod recolor-dynamic ((dynamic-color dynamic-color) (color color)) + (if *doing-delayed-recolors* + (dolist (palette (dynamic-color-palettes dynamic-color)) + (let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette))) + (recolors (palette-delayed-recolors palette))) (without-scheduling - (vector-push-extend cell mutations) - (vector-push-extend color mutations)))) - (dolist (palette (mutable-color-palettes mutable)) - (let ((cell (gethash mutable (palette-mutable-color-cache palette)))) - (update-palette-entry palette cell color))))) - -(defmethod (setf mutable-color-color) :after ((color color) (mutable mutable-color)) - (mutate-mutable mutable color)) - -(defmethod mutate-color ((mutable mutable-color) (color color)) - (setf (slot-value mutable 'color) color) - (mutate-mutable mutable color)) - -;; Note that the actual color mutation occurs on exiting the outermost -;; call to WITH-DELAYED-MUTATIONS -(defmacro with-delayed-mutations (&body body) - (let ((outer-doing-delayed-mutations '#:outer-doing-delayed-mutations) + (vector-push-extend cell recolors) + (vector-push-extend color recolors)))) + (dolist (palette (dynamic-color-palettes dynamic-color)) + (let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette)))) + (update-palette-entry palette cell color))))) + +(defmethod (setf dynamic-color-color) :after + ((color color) (dynamic-color dynamic-color)) + (recolor-dynamic dynamic-color color)) + +;; Note that the actual color recoloring occurs on exiting the outermost +;; call to WITH-DELAYED-RECOLORING +(defmacro with-delayed-recoloring (&body body) + (let ((outer-doing-delayed-recolors '#:outer-doing-delayed-recolors) (palette '#:palette) - (mutations '#:mutations)) - `(let ((,outer-doing-delayed-mutations *doing-delayed-mutations*) - (*doing-delayed-mutations* t)) + (recolors '#:recolors)) + `(let ((,outer-doing-delayed-recolors *doing-delayed-recolors*) + (*doing-delayed-recolors* t)) (unwind-protect ,@body (progn - (unless ,outer-doing-delayed-mutations + (unless ,outer-doing-delayed-recolors (dolist (,palette *all-palettes*) - (let ((,mutations (palette-delayed-mutations ,palette))) - (update-palette-entries ,palette ,mutations) - (setf (fill-pointer ,mutations) 0))))))))) + (let ((,recolors (palette-delayed-recolors ,palette))) + (update-palette-entries ,palette ,recolors) + (setf (fill-pointer ,recolors) 0))))))))) -;;; Color Groups - -(defun map-over-group-colors (function group &optional layers) - (declare (dynamic-extent function)) - (let ((group-layers (color-group-layers group))) - ;; It would be nice if this didn't cons so much - (labels ((iterate (layers group-layers dimensions) - (if group-layers - (let ((layer (car layers)) - (group-layer (car group-layers))) - (if layer - (iterate (cdr layers) - (cdr group-layers) - (cons layer dimensions)) - (dotimes (i group-layer) - (iterate (cdr layers) - (cdr group-layers) - (cons i dimensions))))) - (funcall function dimensions)))) - (iterate (reverse layers) (reverse group-layers) nil)))) - -(defmethod initialize-instance :after ((group color-group) &key mutable-array) - (map-over-group-colors - #'(lambda (dimensions) - (setf (apply #'aref mutable-array dimensions) - (make-mutable-color-1 +black+))) - group)) - -(defmethod group-color ((color-group color-group) &rest layers) - (declare (dynamic-extent layers)) - (let ((cache (color-group-cache color-group))) - (or (gethash layers cache) - (let ((layers (copy-list layers))) - (setf (gethash layers cache) - (make-group-color color-group layers)))))) - -(defmethod mutate-color ((group-color group-color) (color color)) - (with-delayed-mutations - (dolist (mutable (group-color-mutables group-color)) - (mutate-color mutable color)))) +;;; Layered Colors - -;; GROUP-COLOR-MUTABLES should not be exported to the user. It is important -;; that these mutables are not drawn with. Instead the fully specified group -;; colors should be used -(defmethod group-color-mutables ((group-color group-color)) - (with-slots (group layers mutables) group-color - (or mutables - (setf mutables - (let ((mutable-array (color-group-mutable-array group)) - mutables) - (map-over-group-colors #'(lambda (dimensions) - (push (apply #'aref mutable-array dimensions) - mutables)) - group - layers) - mutables))))) - - -(defun map-over-group-colors (function group &optional layers) - (let* ((group-layers (color-group-layers group)) - (dimensions (make-list (length group-layers)))) - (labels ((iterate (layers group-layers dims) - (if group-layers +(defun map-over-layered-colors (function set &optional layers) + (let* ((set-layers (layered-color-set-layers set)) + (dimensions (make-list (length set-layers)))) + (labels ((iterate (layers set-layers dims) + (if set-layers (let ((layer (car layers)) (rest-layers (cdr layers)) - (group-layer (car group-layers)) - (rest-group-layers (cdr group-layers)) + (set-layer (car set-layers)) + (rest-set-layers (cdr set-layers)) (rest-dims (cdr dims))) (if layer (progn (setf (car dims) layer) - (iterate rest-layers rest-group-layers rest-dims)) - (dotimes (i group-layer) + (iterate rest-layers rest-set-layers rest-dims)) + (dotimes (i set-layer) (setf (car dims) i) - (iterate rest-layers rest-group-layers rest-dims)))) + (iterate rest-layers rest-set-layers rest-dims)))) (funcall function dimensions)))) - (iterate layers group-layers dimensions)))) + (iterate layers set-layers dimensions)))) + +(defmethod initialize-instance :after ((set layered-color-set) &key dynamic-array) + (map-over-layered-colors + #'(lambda (dimensions) + (setf (apply #'aref dynamic-array dimensions) + (make-dynamic-color +black+))) + set)) + +(defmethod layered-color ((set layered-color-set) &rest layers) + (declare (dynamic-extent layers)) + (let ((cache (layered-color-set-cache set))) + (or (gethash layers cache) + (let ((layers (copy-list layers))) + (setf (gethash layers cache) + (make-layered-color set layers)))))) + +(defmethod (setf layered-color-color) + ((color color) (layered-color layered-color)) + (with-delayed-recoloring + (dolist (dynamic-color (layered-color-dynamics layered-color)) + (setf (dynamic-color-color dynamic-color) color)))) + +;; LAYERED-COLOR-DYNAMICS should not be exported to the user. It is important +;; that these dynamics are not drawn with. Instead the fully specified layered +;; colors should be used +(defmethod layered-color-dynamics ((layered-color layered-color)) + (with-slots (set layers dynamics) layered-color + (or dynamics + (setf dynamics + (let ((dynamic-array (layered-color-set-dynamic-array set)) + dynamics) + (map-over-layered-colors + #'(lambda (dimensions) + (push (apply #'aref dynamic-array dimensions) dynamics)) + set + layers) + dynamics))))) ;;; Foreground and background (indirect) inks diff --git a/utils/packages.lisp b/utils/packages.lisp index 1597652e..c2be0da9 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.34 92/10/28 11:31:08 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.35 92/10/28 13:17:14 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2029,38 +2029,22 @@ design designp find-named-color - group-color - make-color-group + layered-color + layered-color-color + make-layered-color-set make-contrasting-inks make-flipping-ink make-gray-color make-ihs-color - make-mutable-color + make-dynamic-color make-opacity make-rgb-color - mutable-color-color - mutate-color + dynamic-color-color opacity opacity-value opacityp - with-delayed-mutations + with-delayed-recoloring - - palette - palette-color-p - palette-mutable-p - palettep - make-palette - port-default-palette - medium-palette - sheet-palette - frame-palette - frame-manager-palette - - palette-full - add-to-palette - remove-from-palette - ;; Designs compose-in compose-out @@ -2077,14 +2061,15 @@ frame-manager-palette frame-palette make-palette - medium-palette palette palette-color-p - palette-mutable-p + palette-dynamic-p palettep port-default-palette - sheet-palette - + palette-full + add-to-palette + remove-from-palette + ;; Extended output beep cursor @@ -3261,10 +3246,11 @@ ;; From BASE-DESIGNS and DESIGNS *all-palettes* + allocate-color basic-palette - color-group - color-group-layers - color-group-mutable-array + layered-color-set + layered-color-set-layers + layered-color-set-dynamic-array color-luminosity composite-in composite-out @@ -3276,23 +3262,23 @@ decode-rectangular-tile decode-tile-as-stipple flipping-ink - flipping-ink + flipping-ink + free-color gray-color gray-color-luminosity - group-color-group - group-color-layers + layered-color-layers ihs-color make-color-for-contrasting-ink make-design-from-output-record make-flipping-ink make-gray-color-for-contrasting-ink - map-over-group-colors - mutable-color - mutable-color-palettes + map-over-layered-colors + dynamic-color + dynamic-color-palettes palette-color-cache - palette-mutable-color-cache - palette-color-group-cache - palette-delayed-mutations + palette-dynamic-color-cache + palette-layered-color-cache + palette-delayed-recolors pattern rectangular-tile rgb-color @@ -3346,7 +3332,6 @@ activate-gadget-event add-sheet-callbacks all-drawing-options-lambda-list - allocate-color allocate-event basic-pixmap-medium bury-mirror @@ -3398,7 +3383,6 @@ frame-user-specified-position-p frame-user-specified-size-p frame-wrapper - free-color gadget-alignment gadget-columns gadget-editable-p -- GitLab