7 Color in the Window Tool Kit

7.4 Color demonstration code

;;; Register primary and extended library colors if they aren't
;;; already registered.  It is okay to make this call more than
;;; once.
(setup-color-library
  :primary-colors t                   ; register primary colors
  :extended-colors t                  ; register extended colors
  )

;;; The function GET-CONTRAST-COLOR returns a good contrast color
;;; for the given color. If the given color is light, use BLACK;
;;; if it's dark, use WHITE.
(defun get-contrast-color (colorname)
  (multiple-value-bind (red green blue)
      (find-mic :color colorname)
    (if (> (/ (+ red green blue) 3) (/ max-mic-value 2))
           "BLACK" "WHITE")))

;;; The function DISPLAY-ALL-COLORS displays all existing colors
;;; in a scrolling window.
(defun display-all-colors (&optional (x 0) 
                                     (y 0) 
                                     (width 200) (height nil))
  (let* ((x 5)
         (font *default-font*)
         (font-height (font-height font))
         (height (or height (- (bitmap-height 
                                 (root-viewport)) 30)))
         (bitmap (make-bitmap
                   :width (- width 10)
                   :height (max height
                            (+ (* font-height (color-registry-size))
                                   x))
                   :depth (display-depth)))
         (window (make-window
                   :x x :y y 
                   :width width 
                   :height height
                   :depth (display-depth)
                   :scroll t :bitmap bitmap :activate t :depth 8))
         )

    (loop for color from 0 to (1- (color-map-size))
          do (let ((rcolor (find-color :color color)))
               (when rcolor             ; many will not be colors
                 (stringblt bitmap
                     (make-position x (* font-height (1+ color)))
                            font
                            (format nil "~D ~A" color rcolor)
                            :foreground (get-contrast-color rcolor)
                            :background rcolor))))
    window))

;;; The function PALETTE allows color shade selection with left
;;; click of the mouse on the color bars. With this function, you
;;; can create a new color by mixing red, blue, and green.
(defun palette (&optional (x 0) (y 0) (width 150) (height 100))
  ;; new color entry to change
  (let* ((palette-entry (allocate-color)) 
         (current-red 0)
         (current-green 0)
         (current-blue 0)
         (bar-margin 5)
         (bar-height (- height bar-margin 20))
         (bar-width 15)
         (red-pos 5)
         (green-pos 35)
         (blue-pos 65)
         window)
    ;; It is always a good idea to check.
    (unless palette-entry           
      (error "We appear to be out of color map entries!"))
    (setq window
          (make-window
            :x x :y y :inside-width width :inside-height height
            :depth (display-depth)
            :title "Palette"))
    (set-color-map-mic
      palette-entry current-red current-green current-blue)
    (draw-circle
      window (make-position 120 50) 20 :foreground palette-entry
                                       :width 20)

    ;; Draw a color bar with a level indicator showing current
    ;; color amount.
    (flet ((draw-bar (window x color line-y mic-value)
             (draw-rectangle
               window x bar-margin :width bar-width 
                                   :height bar-height
                                   :foreground color)
             (draw-line
               window (make-position x line-y)
               (make-position (+ x bar-width -1) line-y) :width 2)
             (stringblt window (make-position x (+ bar-height 20))
                        *default-font*
                        (format nil "~2,2F" 
                          (/ mic-value max-mic-value)))))
      ;; RED
      (draw-bar window red-pos "RED" (+ bar-margin 2) 0)
      (make-active-region
        (make-region
          :x red-pos :y bar-margin 
          :width bar-width 
          :height bar-height)
          :bitmap window
          :mouse-documentation "Mouse-Left: Change color amount"
          :mouse-left-down
          #'(lambda (viewport region extent x y)
              (declare (ignore region extent x))
              (setq current-red
                    (round (* max-mic-value
                              (/ (- y bar-margin) bar-height))))
              (draw-bar viewport red-pos "RED" y current-red)
              (set-color-map-mic
                palette-entry current-red 
                              current-green 
                              current-blue)))

      ;; GREEN
      (draw-bar window green-pos "GREEN" (+ bar-margin 2) 0)
      (make-active-region
        (make-region
          :x green-pos :y bar-margin 
          :width bar-width 
          :height bar-height)
        :bitmap window
        :mouse-documentation "Mouse-Left: Change color amount"
        :mouse-left-down
        #'(lambda (viewport region extent x y)
            (declare (ignore region extent x))
            (setq current-green
                  (round (* max-mic-value
                            (/ (- y bar-margin) bar-height))))
            (draw-bar viewport green-pos "GREEN" y current-green)
            (set-color-map-mic
              palette-entry current-red 
                            current-green 
                            current-blue)))
      ;; BLUE
      (draw-bar window blue-pos "BLUE" (+ bar-margin 2) 0)
      (make-active-region
        (make-region
          :x blue-pos :y bar-margin 
          :width bar-width 
          :height bar-height)
        :bitmap window
        :mouse-documentation "Mouse-Left: Change color amount"
        :mouse-left-down
        #'(lambda (viewport region extent x y)
            (declare (ignore region extent x))
            (setq current-blue
                  (round (* max-mic-value
                            (/ (- y bar-margin) bar-height))))
            (draw-bar viewport blue-pos "BLUE" y current-blue)
            (set-color-map-mic
              palette-entry current-red 
                            current-green 
                            current-blue))))))

Generated with Harlequin WebMaker