(defmeth graph-proto :add-control (c) (send self :add-overlay c))
(defmeth graph-proto :delete-control (c) (send self :delete-overlay c))
(defproto graph-control-proto
'(action location title) nil graph-overlay-proto)
(defmeth graph-control-proto :location (&optional (new nil set))
(when set
(send self :erase)
(setf (slot-value 'location) new)
(send self :redraw))
(slot-value 'location))
(defmeth graph-control-proto :title (&optional (new nil set))
(when set
(send self :erase)
(setf (slot-value 'title) new)
(send self :redraw))
(slot-value 'title))
(defmeth graph-control-proto :erase ()
(let ((graph (send self :graph))
(loc (send self :location))
(sz (send self :size)))
(if graph (apply #'send graph :erase-rect (append loc sz)))))
(defmeth graph-control-proto :size ()
(let ((graph (send self :graph))
(title (send self :title)))
(if graph
(list (+ 10 5 (send graph :text-width title)) 20)
(list 10 10))))
(defmeth graph-control-proto :redraw ()
(let* ((graph (send self :graph))
(loc (send self :location))
(loc-x (first loc))
(loc-y (second loc))
(title (send self :title)))
(send self :erase)
(send graph :frame-rect loc-x (+ 5 loc-y) 10 10)
(send graph :draw-text title (+ 15 loc-x) (+ 15 loc-y) 0 0)))
(defmeth graph-control-proto :do-click (x y a b)
(let* ((graph (send self :graph))
(loc (send self :location))
(loc-x (first loc))
(loc-y (+ 5 (second loc))))
(when (and (< loc-x x (+ loc-x 10)) (< loc-y y (+ loc-y 10)))
(send graph :paint-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
(send self :do-action (list a b))
(send graph :while-button-down
#'(lambda (x y) (send self :do-action nil)) nil)
(send graph :erase-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
t)))
(defmeth graph-control-proto :do-action (x) (sysbeep))
;;; Rockers
(defproto rocker-control-proto () () graph-control-proto)
(defmeth rocker-control-proto :size ()
(let ((graph (send self :graph))
(title (send self :title)))
(if graph
(list (+ 10 5 10 5 (send graph :text-width title)) 20)
(list 10 10))))
(defmeth rocker-control-proto :redraw ()
(let* ((graph (send self :graph))
(loc (send self :location))
(loc-x (first loc))
(loc-y (second loc))
(title (send self :title)))
(send self :erase)
(send graph :frame-rect loc-x (+ 5 loc-y) 10 10)
(send graph :frame-rect (+ 15 loc-x) (+ 5 loc-y) 10 10)
(send graph :draw-text title (+ 30 loc-x) (+ 15 loc-y) 0 0)))
(defmeth rocker-control-proto :do-click (x y a b)
(let* ((graph (send self :graph))
(loc (send self :location))
(loc-x1 (first loc))
(loc-x2 (+ 15 loc-x1))
(loc-y (+ 5 (second loc))))
(if (< loc-y y (+ loc-y 10))
(let* ((arg (cond
((< loc-x1 x (+ loc-x1 10)) '-)
((< loc-x2 x (+ loc-x2 10)) '+)))
(loc-x (case arg (- loc-x1) (+ loc-x2))))
(when arg
(send graph :paint-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
(send self :do-action (list a b) arg)
(send graph :while-button-down
#'(lambda (x y) (send self :do-action nil arg)) nil)
(send graph :erase-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
t)))))
(defmeth rocker-control-proto :do-action (x arg) (sysbeep))
;;; Slider
(defproto slider-control-proto
'(index sequence display) () graph-control-proto)
(defmeth slider-control-proto :isnew (sequence &key
(title "Value")
(display sequence)
(location '(10 20))
(index 0)
graph)
(call-next-method :title title :location location)
(send self :sequence sequence :display display)
(send self :index index)
(if graph (send graph :add-control self)))
(defmeth slider-control-proto :size ()
(let ((graph (send self :graph))
(title (send self :title)))
(list 100 30)))
(defmeth slider-control-proto :redraw ()
(let* ((graph (send self :graph))
(loc (send self :location))
(loc-x (first loc))
(loc-y (second loc))
(w (first (send self :size))))
(when graph
(send graph :draw-text (send self :title) loc-x (+ loc-y 15) 0 0)
(send graph :frame-rect loc-x (+ loc-y 20) w 10)
(send self :draw-indicator))))
(defmeth slider-control-proto :draw-indicator (&optional index)
(let* ((graph (send self :graph))
(loc (send self :location))
(loc-x (first loc))
(loc-y (second loc))
(w (first (send self :size)))
(min (send self :min))
(max (send self :max))
(index (if index index (send self :index)))
(val (floor (* (- w 7) (/ (- index min) (- max min))))))
(when graph
(let ((tw (send graph :text-width (send self :title))))
(send graph :start-buffering)
(send graph :erase-rect (+ 1 tw loc-x) loc-y (- w tw) 20)
(send graph :draw-text
(format nil "~a" (elt (send self :display) index))
(+ loc-x w) (+ loc-y 15) 2 0)
(send graph :buffer-to-screen (+ 1 tw loc-x) loc-y (- w tw) 20))
(send graph :erase-rect (+ 1 loc-x) (+ 21 loc-y) (- w 2) 8)
(send graph :paint-rect (+ 1 loc-x val) (+ 21 loc-y) 5 8))))
(defmeth slider-control-proto :min () 0)
(defmeth slider-control-proto :max () (- (length (slot-value 'sequence)) 1))
(defmeth slider-control-proto :sequence (&optional (seq nil set) &key
(display seq))
(when set
(setf (slot-value 'sequence) (coerce seq 'vector))
(setf (slot-value 'display) (coerce display 'vector)))
(slot-value 'sequence))
(defmeth slider-control-proto :display () (slot-value 'display))
(defmeth slider-control-proto :index (&optional (new nil set))
(if set
(let* ((new (max (send self :min) (min new (send self :max)))))
(setf (slot-value 'index) new)
(send self :draw-indicator)
(send self :do-action (elt (send self :sequence) new))))
(slot-value 'index))
(defmeth slider-control-proto :do-click (x y a b)
(let* ((graph (send self :graph))
(loc (send self :location))
(loc-x (nth 0 loc))
(loc-y (nth 1 loc))
(w (first (send self :size))))
(when (and (< loc-x x (+ loc-x w)) (< (+ loc-y 20) y (+ loc-y 30)))
(let ((pos (+ (floor (* (- w 7) (/ (send self :index)
(send self :max))))
loc-x)))
(cond
((<= pos x (+ pos 5))
(let ((off (- x pos)))
(send graph :while-button-down
#'(lambda (x y)
(let ((val (max (+ loc-x 1)
(min (- x off)
(+ loc-x (- w 6))))))
(setf pos val)
(send self :draw-indicator
(floor (* (send self :max)
(/ (- pos loc-x) (- w 7)))))))))
(send self :index
(floor (* (send self :max)
(/ (- pos loc-x) (- w 7))))))
((< loc-x x pos)
(send graph :while-button-down
#'(lambda (x y)
(let ((pos (+ (floor (* w (/ (send self :index)
(send self :max))))
loc-x)))
(if (< x pos)
(send self :index (- (send self :index) 1)))
(pause 2)))
nil))
((< pos x (+ loc-x w))
(send graph :while-button-down
#'(lambda (x y)
(let ((pos (+ (floor (* w (/ (send self :index)
(send self :max))))
loc-x)))
(if (> x pos)
(send self :index (+ (send self :index) 1)))
(pause 2)))
nil))))
t)))
;;;;
;;;; Rotation example
;;;;
;;; Rotation around axes
(defproto spin-rotate-control-proto '(v) () rocker-control-proto)
(defmeth spin-rotate-control-proto :isnew (v)
(call-next-method :v v :location (list 10 (case v (0 10) (1 30) (2 50)))))
(defmeth spin-rotate-control-proto :title ()
(send (send self :graph) :variable-label (slot-value 'v)))
(defmeth spin-rotate-control-proto :do-action (first sign)
(let ((graph (send self :graph)))
(if first
(let* ((v (slot-value 'v))
(v1 (if (= v 0) 1 0))
(v2 (if (= v 2) 1 2))
(trans (send graph :transformation))
(cols (column-list
(if trans
trans
(identity-matrix (send graph :num-variables)))))
(angle (send graph :angle)))
(send graph :idle-on (car first))
(send graph :slot-value 'rotation-type
(make-rotation (nth v1 cols) (nth v2 cols)
(case sign (+ angle) (- (- angle)))))))
(send graph :rotate)
(pause 2)))
;;; Plot Rocking Control
(defproto spin-rock-control-proto '(v) () graph-control-proto)
(defmeth spin-rock-control-proto :isnew ()
(call-next-method :location '(10 70) :title "Rock Plot"))
(defmeth spin-rock-control-proto :do-action (first)
(send (send self :graph) :rock-plot))
(defmeth spin-proto :rock-plot (&optional (k 2))
(let ((angle (send self :angle)))
(dotimes (i k) (send self :rotate-2 0 2 angle)(pause 2))
(dotimes (i (* 2 k)) (send self :rotate-2 0 2 (- angle)) (pause 2))
(dotimes (i k) (send self :rotate-2 0 2 angle))) (pause 2))
;;;; Speed Control
(defproto spin-speed-control-proto () () slider-control-proto)
(defmeth spin-speed-control-proto :isnew (&optional (points 21))
(call-next-method (rseq 0 .2 points) :location '(10 90) :title "Speed"))
(defmeth spin-speed-control-proto :do-action (v)
(let ((graph (send self :graph)))
(if graph (send graph :angle v))))
;;;; Installation method
(defmeth spin-proto :add-spin-controls ()
(send self :margin 110 0 0 20)
(apply #'send self :size (+ (send self :size) '(100 0)))
(send self :resize)
(send self :add-control (send spin-rotate-control-proto :new 0))
(send self :add-control (send spin-rotate-control-proto :new 1))
(send self :add-control (send spin-rotate-control-proto :new 2))
(send self :add-control (send spin-rock-control-proto :new))
(send self :add-control (send spin-speed-control-proto :new)))
syntax highlighted by Code2HTML, v. 0.9.1