color-map.lisp

   1
   2 (defun get-red (color-list)
   3   (cadr (assoc :red color-list)))
   4
   5 (defun get-green (color-list)
   6   (cadr (assoc :green color-list)))
   7
   8 (defun get-blue (color-list)
   9   (cadr (assoc :blue color-list)))
  10
  11 (defun get-point (color-list)
  12   (cadr (assoc :point color-list)))
  13
  14 (defun calc-normal-alpha (start end alpha)
  15   (* (- alpha start) (/ 1.0 (- end start))))
  16
  17 (defun add-point-to-color-list (color-list point &key red green blue)
  18   (list
  19    `((:red . ,red)
  20     (:green . ,green)
  21     (:blue . ,blue)
  22     (:point . ,point))
  23     color-list))
  24
  25 (defun add-points-to-color-list (color-list points)
  26   (append
  27     (loop
  28       for point in points
  29       collect
  30          (destructuring-bind
  31                (p &key red green blue)
  32              point
  33         `((:red ,red)
  34           (:green ,green)
  35           (:blue ,blue)
  36           (:point ,p))))
  37    color-list))
  38
  39 (defparameter *color-list*
  40   (add-points-to-color-list
  41    nil
  42   '((0.0 :red 255 :green 255 :blue 255)
  43      (0.1 :red 64 :green 0 :blue 64)
  44      (0.5 :red 0 :green 64 :blue 64)
  45      (1.0 :red 64 :green 63 :blue 0))))
  46
  47 (defun sort-color-list (color-list)
  48        (sort color-list
  49              #'(lambda (x y)
  50                  (< (cadr (assoc :point x))
  51                     (cadr (assoc :point y))))))
  52
  53 (defun make-color-list-interpolator (color-list)
  54   (let
  55       ((sorted-color-list (sort-color-list color-list)))
  56     (lambda (alpha)
  57       (destructuring-bind
  58             (start end)
  59           (loop
  60              for next-color in sorted-color-list
  61              and color = nil then next-color
  62              when (<= alpha (cadr (assoc :point next-color)))
  63              return
  64                (list color next-color))
  65         (list
  66          (cons
  67           :red
  68           ((cadr (assoc :red start))
  69            + (*
  70               (- (cadr (assoc :red end))
  71                  (cadr (assoc :red end))
  72 ))
  73
  74   (format t "~A ~A~%~A~%" color next-color
  75                    (>= alpha (cadr (assoc :point next-color))))))))
  76
  77
  78          return (cons color next-color)))))
  79
  80 ;; to do --
  81 ;; sort-color-list
  82 ;; make-color-list-interpolator