examples/color-selector.lisp

   1 #|
   2   OpenGL color selector.
   3   Show 3 color planes (+x=red, +y=green, and +z=blue);
   4   select the color at their intersection.
   5 |#
   6 (require '#:asdf)
   7 (asdf:oos 'asdf:load-op '#:cl-glfw)
   8 (asdf:oos 'asdf:load-op '#:cl-glfw-opengl-version_1_0)
   9 (asdf:oos 'asdf:load-op '#:cl-glfw-glu)
  10
  11 ;;;; The viewer
  12 (defparameter *red* 0)
  13 (defparameter *green* 0)
  14 (defparameter *blue* 0)
  15
  16 (defun key-callback (key action)
  17   (when (eql action glfw:+press+)
  18     (case key
  19       (#\Z
  20        (if (eql (glfw:get-key glfw:+key-lshift+) glfw:+press+)
  21            (decf *blue*)
  22            (incf *blue*)))
  23       (:esc   (glfw:close-window))
  24       (:up    (incf *red*))
  25       (:down  (decf *red*))
  26       (:left  (decf *green*))
  27       (:right (incf *green*)))))
  28
  29 (defun color-selector ()
  30  (let ((frames 0)
  31       t0 t1)
  32    (setf *red* 0
  33          *green* 0
  34          *blue* 0)
  35   (glfw:do-window (:title "Color Selector" :width 640 :height 480)
  36       ((glfw:enable glfw:+sticky-keys+)
  37        (glfw:enable glfw:+key-repeat+)
  38        (gl:disable gl:+cull-face+)
  39        (gl:enable gl:+depth-test+)
  40        (gl:depth-mask gl:+true+)
  41        (glfw:swap-interval 0)
  42        (glfw:set-key-callback 'key-callback)
  43        (setf t0 (glfw:get-time)
  44              t1 (glfw:get-time)))
  45
  46     (when (eql (glfw:get-key glfw:+key-esc+) glfw:+press+)
  47       (return-from glfw:do-window))
  48
  49     (setf t1 (glfw:get-time))
  50
  51     (when (> (- t1 t0) 1)
  52       (glfw:set-window-title (format nil "Color Selector (~,1f FPS)" (/ frames (- t1 t0))))
  53       (setf frames 0
  54             t0 t1))
  55
  56     (incf frames)
  57
  58     (destructuring-bind (width height) (glfw:get-window-size)
  59       (setf height (max height 1))
  60       (gl:viewport 0 0 width height)
  61
  62       (gl:clear-color 0 0 0 0)
  63       (gl:clear (logior gl:+color-buffer-bit+
  64                         gl:+depth-buffer-bit+))
  65
  66       (gl:matrix-mode gl:+projection+)
  67       (gl:load-identity)
  68       (glu:perspective 65 (/ width height) 1 100)
  69       (gl:matrix-mode gl:+modelview+)
  70       (gl:load-identity)
  71       (glu:look-at 0  1 0
  72                    0 20 0
  73                    0  0 1)
  74
  75       (gl:translate-f 0 14 0)
  76
  77       (gl:with-push-matrix
  78         (gl:rotate-f 20 1 0 0)
  79         (gl:rotate-f 0 0 1 0)
  80         (gl:rotate-f -135 0 0 1)
  81         (gl:scale-f 5 5 5)
  82
  83         (gl:with-begin gl:+quads+
  84           (flet ((show (r g b)
  85                    (gl:color-3f r g b)
  86                    (gl:vertex-3f r g b)))
  87             (macrolet ((bound (axis)
  88                          `(cond ((< ,axis 0) (setf ,axis 0) 0)
  89                                 ((> ,axis 255) (setf ,axis 255) 1)
  90                                 (t (/ ,axis 255)))))
  91               (let ((red (bound *red*))
  92                     (green (bound *green*))
  93                     (blue (bound *blue*)))
  94                 ;; red (green-blue plane)
  95                 (show red 0 0)
  96                 (show red 0 1)
  97                 (show red 1 1)
  98                 (show red 1 0)
  99                 ;; green (blue-red plane)
 100                 (show 0 green 0)
 101                 (show 0 green 1)
 102                 (show 1 green 1)
 103                 (show 1 green 0)
 104                 ;; blue (red-green plane)
 105                 (show 0 0 blue)
 106                 (show 0 1 blue)
 107                 (show 1 1 blue)
 108                 (show 1 0 blue))))))))))
 109
 110 (color-selector)