CLIM mail archive
clim 2.0 color dialog code

To: clim@BBN.COM
Subject: clim 2.0 color dialog code
From: Philip Chu-Summer 92 <pchu@ptolemy.arc.nasa.gov>
Date: Wed, 5 Aug 92 17:00:16 PDT
This is my first cut at CLIM 2.0 code (and, as yet, still one of my
early uses of any version of CLIM). It consists of color dialogs that
have sliders to change the color components. The calling form is
(CHOOSE-COLOR mode) where mode is one of :RGB or :GRAY. (I had started
to add :IHS as option, but I found that COLOR-IHS couldn't extract
components from non-ihs colors, a bug I've reported to Franz).

I've only run this with Franz ACL and Motif, so I don't have any idea how
it looks on other setups. I'd appreciate anyone giving the code a look-over
and some feedback. In particular, is DEFINE-APPLICATION-FRAME an
appropriate way to define dialogs that are used as part of a larger
application? Am I defining the callbacks in an appropriate manner?
etc.

Thanks in advance.

-Phil Chu


;;; basic stuff

(defvar *scale* 255)

(defclass color-chooser (standard-application-frame)
	  ((color :accessor color
		  :initform +black+)))

(defmethod display ((frame color-chooser) stream)
  "Color display function."
  (setf (medium-background stream) (color frame))
  (window-clear (get-frame-pane frame 'display)))

(defmethod value-changed-callback :after ((slider slider) (client (eql 'color)) id value)
  "Make sure new color is displayed."
  (redisplay-frame-pane *application-frame* 'display))

(defmethod activate-callback ((gadget push-button) (client (eql 'color)) (id (eql 'ok)))
  "Callback for OK button."
  (frame-exit *application-frame*))

;;; this is the function to run

(defun choose-color (&optional (mode :rgb) &key (scale *scale*))
  "Pops up a dialog and returns the chosen color."
  (let ((dialog (color-dialog mode)))
    (run-frame-top-level dialog)
    (color dialog)))

;;; gray scale

(defmethod color-dialog ((mode (eql :gray)))
  (make-application-frame 'gray-chooser :pretty-name "Gray Scale"))

(define-application-frame gray-chooser (color-chooser)
  ()
  (:panes (display :application
		   :scroll-bars nil
		   :display-function 'display)
	  (ok push-button :client 'color :id 'ok)
	  (gray slider :show-value-p t
		:foreground +blue+
		:client 'color
		:id 'gray
		:orientation :vertical :min-value 0 :max-value *scale*))
  (:layouts (default (horizontally ()
				   (vertically () display ok)
				   gray))))

(defmethod value-changed-callback ((slider slider) (client (eql 'color)) (id (eql 'gray)) value)
  ""
  (setf (color *application-frame*)
    (make-gray-color (/ value *scale*))))

;;; rgb colors

(defmethod color-dialog ((mode (eql :rgb)))
  (make-application-frame 'rgb-chooser :pretty-name "RGB Color"))

(define-application-frame rgb-chooser (color-chooser)
  ()
  (:panes (display :application
		   :scroll-bars nil
		   :display-function 'display)
	  (ok push-button :client 'color :id 'ok)
	  (red slider :min-value 0 :max-value *scale*
	       :orientation :vertical
	       :id 'red
	       :client 'color
	       :foreground +red+
	       :show-value-p t)
	  (green slider :show-value-p t
		 :foreground +green+
		 :client 'color
		 :id 'green
		 :orientation :vertical :min-value 0 :max-value *scale*)
	  (blue slider :show-value-p t
		:foreground +blue+
		:client 'color
		:id 'blue
		:orientation :vertical :min-value 0 :max-value *scale*))
  (:layouts (default (horizontally ()
				   (vertically () display ok)
				   red green blue))))

(defmethod value-changed-callback ((slider slider) (client (eql 'color)) (id (eql 'red)) value)
  ""
  (multiple-value-bind (red green blue) (color-rgb (color *application-frame*))
    (setf (color *application-frame*)
      (make-rgb-color (/ value *scale*) green blue))))

(defmethod value-changed-callback ((slider slider) (client (eql 'color)) (id (eql 'green)) value)
  ""
  (multiple-value-bind (red green blue) (color-rgb (color *application-frame*))
    (setf (color *application-frame*)
      (make-rgb-color red (/ value *scale*) blue))))

(defmethod value-changed-callback ((slider slider) (client (eql 'color)) (id (eql 'blue)) value)
  ""
  (multiple-value-bind (red green blue) (color-rgb (color *application-frame*))
    (setf (color *application-frame*)
      (make-rgb-color red green (/ value *scale*)))))