code.consxy.com Git - clnl/blob - src/main/clnl-gltk/switch.lisp

   1 (in-package #:clnl-gltk)
   2
   3 (defstruct switch x y width text callback hover on)
   4
   5 ; Height is constant for switches in netlogo
   6 (defvar *switch-height* 33
   7  "*SWITCH-HEIGHT*
   8
   9 VALUE TYPE:
  10
  11   an integer
  12
  13 INITIAL VALUE:
  14
  15   33
  16
  17 DESCRIPTION:
  18
  19   The default switch height.")
  20
  21 (defun in-switch (m-x m-y switch)
  22  (with-slots (x y width) switch
  23   (and (< x m-x (+ x width)) (< y m-y (+ y *switch-height*)))))
  24
  25 (defun switch (x y width text callback &optional initial-state)
  26  "SWITCH X Y WIDTH TEXT CALLBACK &optional INITIAL-STATE => SWITCH
  27
  28 ARGUMENTS AND VALUES:
  29
  30   X: x offset, in pixels
  31   Y: y offset, in pixels
  32   WIDTH: width, in pixels
  33   TEXT: string for the textual display
  34   CALLBACK: a function
  35   INITIAL-STATE: a boolean, defaulting to nil
  36   SWITCH: a switch that can later be rendered
  37
  38 DESCRIPTION:
  39
  40   SWITCH creates a switch widget.
  41
  42   The widget will center the viewable TEXT inside itself, replacing the
  43   last three characters with an ellipses if the text is too large for the
  44   given dimensions.  It will never clip a character.
  45
  46   SWITCH objects also work with mouse movement functions.  When it identifies
  47   that a mousedown has happened, the state of the SWITCH will be changed,
  48   and CALLBACK will be called with the new state.
  49
  50   The INITIAL-STATE defines whether the switch starts on or off."
  51  (make-switch :x x :y y :width width :text text :callback callback :on initial-state))
  52
  53 (defmethod render ((switch switch))
  54  (gl:color 1f0 1f0 1f0)
  55  (with-slots (x y width text hover on) switch
  56   (gl:with-pushed-matrix
  57    (gl:translate x y 0)
  58
  59    (when hover
  60     (gl:color .25f0 .25f0 .25f0)
  61     (gl:begin :quads)
  62     (gl:vertex 0 0) (gl:vertex width 0) (gl:vertex width *switch-height*) (gl:vertex 0 *switch-height*)
  63     (gl:end))
  64
  65    (gl:color 1f0 1f0 1f0)
  66    (gl:begin :quads)
  67    (gl:vertex 6 4) (gl:vertex 8 4) (gl:vertex 8 28) (gl:vertex 6 28)
  68    (gl:end)
  69
  70    (let
  71     ((bottom (if on 21 8)))
  72     (gl:color 0f0 0f0 0f0)
  73     (gl:begin :quads)
  74     (gl:vertex 2 bottom) (gl:vertex 12 bottom) (gl:vertex 12 (+ bottom 4)) (gl:vertex 2 (+ bottom 4))
  75     (gl:end)
  76     (gl:color 1f0 1f0 1f0)
  77     (draw-border 2 bottom 12 (+ bottom 4)))
  78
  79    (gl:color 1f0 1f0 1f0)
  80    (gl:with-pushed-matrix (gl:translate 14 15 0) (font-print "On"))
  81    (gl:with-pushed-matrix (gl:translate 14 1 0) (font-print "Off"))
  82
  83    (draw-border 0 0 width *switch-height*)
  84
  85    ; It also clips off text if too long, and replaces with elipses, so we can do similar
  86    (let
  87     ((text
  88       (if (< (* *font-width* (length text)) (- width 46))
  89        text
  90        (format nil "~A..." (subseq text 0 (- (truncate (- width 46) *font-width*) 3))))))
  91     (gl:translate
  92      (truncate (- width -28 (* *font-width* (length text))) 2)
  93      (truncate (- *switch-height* 4 *font-height*) 2)
  94      0)
  95     (font-print text)))))
  96
  97 (defmethod toggle ((switch switch) &optional (state :unused))
  98  (setf (switch-on switch) (if (eql state :unused) (not (switch-on switch)) state)))
  99
 100 (defmethod reposition ((switch switch) x y)
 101  (setf (switch-x switch) x)
 102  (setf (switch-y switch) y))
 103
 104 (defmethod resize ((switch switch) width height)
 105  (declare (ignore height))
 106  (setf (switch-width switch) width))
 107
 108 (defmethod mousemove ((switch switch) m-x m-y)
 109  (setf (switch-hover switch) (in-switch m-x m-y switch)))
 110
 111 (defmethod mousedown ((switch switch) m-x m-y)
 112  (when (in-switch m-x m-y switch) (toggle switch) (funcall (switch-callback switch) (switch-on switch))))