home *** CD-ROM | disk | FTP | other *** search
/ Garbo / Garbo.cdr / mac / science / xlspstr1.sit / Examples / plotcontrols.lsp < prev    next >
Text File  |  1989-12-02  |  11KB  |  294 lines
  1. (defmeth graph-proto :add-control (c) (send self :add-overlay c))
  2. (defmeth graph-proto :delete-control (c) (send self :delete-overlay c))
  3.  
  4. (defproto graph-control-proto 
  5.   '(action location title) nil graph-overlay-proto)
  6.  
  7. (defmeth graph-control-proto :location (&optional (new nil set))
  8.   (when set
  9.         (send self :erase)
  10.         (setf (slot-value 'location) new)
  11.         (send self :redraw))
  12.   (slot-value 'location))
  13.  
  14. (defmeth graph-control-proto :title (&optional (new nil set))
  15.   (when set
  16.         (send self :erase)
  17.         (setf (slot-value 'title) new)
  18.         (send self :redraw))
  19.   (slot-value 'title))
  20.  
  21. (defmeth graph-control-proto :erase ()
  22.   (let ((graph (send self :graph))
  23.         (loc (send self :location))
  24.         (sz (send self :size)))
  25.     (if graph (apply #'send graph :erase-rect (append loc sz)))))
  26.  
  27. (defmeth graph-control-proto :size () 
  28.   (let ((graph (send self :graph))
  29.         (title (send self :title)))
  30.     (if graph
  31.         (list (+ 10 5 (send graph :text-width title)) 20)
  32.         (list 10 10))))
  33.  
  34. (defmeth graph-control-proto :redraw ()
  35.   (let* ((graph (send self :graph))
  36.          (loc (send self :location))
  37.          (loc-x (first loc))
  38.          (loc-y (second loc))
  39.          (title (send self :title)))
  40.     (send self :erase)
  41.     (send graph :frame-rect loc-x (+ 5 loc-y) 10 10)
  42.     (send graph :draw-text title (+ 15 loc-x) (+ 15 loc-y) 0 0)))
  43.  
  44. (defmeth graph-control-proto :do-click (x y a b)
  45.   (let* ((graph (send self :graph))
  46.          (loc (send self :location))
  47.          (loc-x (first loc))
  48.          (loc-y (+ 5 (second loc))))
  49.     (when (and (< loc-x x (+ loc-x 10)) (< loc-y y (+ loc-y 10)))
  50.           (send graph :paint-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
  51.           (send self :do-action (list a b))
  52.           (send graph :while-button-down
  53.                 #'(lambda (x y) (send self :do-action nil)) nil)
  54.           (send graph :erase-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
  55.           t)))
  56.  
  57. (defmeth graph-control-proto :do-action (x) (sysbeep))
  58.  
  59. ;;; Rockers
  60.  
  61. (defproto rocker-control-proto () () graph-control-proto)
  62.  
  63. (defmeth rocker-control-proto :size () 
  64.   (let ((graph (send self :graph))
  65.         (title (send self :title)))
  66.     (if graph
  67.         (list (+ 10 5 10 5 (send graph :text-width title)) 20)
  68.         (list 10 10))))
  69.  
  70. (defmeth rocker-control-proto :redraw ()
  71.   (let* ((graph (send self :graph))
  72.          (loc (send self :location))
  73.          (loc-x (first loc))
  74.          (loc-y (second loc))
  75.          (title (send self :title)))
  76.     (send self :erase)
  77.     (send graph :frame-rect loc-x (+ 5 loc-y) 10 10)
  78.     (send graph :frame-rect (+ 15 loc-x) (+ 5 loc-y) 10 10)
  79.     (send graph :draw-text title (+ 30 loc-x) (+ 15 loc-y) 0 0)))
  80.  
  81. (defmeth rocker-control-proto :do-click (x y a b)
  82.   (let* ((graph (send self :graph))
  83.          (loc (send self :location))
  84.          (loc-x1 (first loc))
  85.          (loc-x2 (+ 15 loc-x1))
  86.          (loc-y (+ 5 (second loc))))
  87.     (if (< loc-y y (+ loc-y 10))
  88.         (let* ((arg (cond 
  89.                      ((< loc-x1 x (+ loc-x1 10)) '-)
  90.                      ((< loc-x2 x (+ loc-x2 10)) '+)))
  91.                (loc-x (case arg (- loc-x1) (+ loc-x2))))
  92.           (when arg
  93.                 (send graph :paint-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
  94.                 (send self :do-action (list a b) arg)
  95.                 (send graph :while-button-down
  96.                       #'(lambda (x y) (send self :do-action nil arg)) nil)
  97.                 (send graph :erase-rect (+ 1 loc-x) (+ 1 loc-y) 8 8)
  98.                 t)))))
  99.  
  100. (defmeth rocker-control-proto :do-action (x arg) (sysbeep))
  101.  
  102. ;;; Slider
  103.  
  104. (defproto slider-control-proto 
  105.   '(index sequence display) () graph-control-proto)
  106.  
  107. (defmeth slider-control-proto :isnew (sequence &key 
  108.                                                (title "Value")
  109.                                                (display sequence)
  110.                                                (location '(10 20))
  111.                                                (index 0)
  112.                                                graph)
  113.   (call-next-method :title title :location location)
  114.   (send self :sequence sequence :display display)
  115.   (send self :index index)
  116.   (if graph (send graph :add-control self)))
  117.  
  118. (defmeth slider-control-proto :size () 
  119.   (let ((graph (send self :graph))
  120.         (title (send self :title)))
  121.     (list 100 30)))
  122.  
  123. (defmeth slider-control-proto :redraw ()
  124.   (let* ((graph (send self :graph))
  125.          (loc (send self :location))
  126.          (loc-x (first loc))
  127.          (loc-y (second loc))
  128.          (w (first (send self :size))))
  129.     (when graph
  130.           (send graph :draw-text (send self :title) loc-x (+ loc-y 15) 0 0)
  131.           (send graph :frame-rect loc-x (+ loc-y 20) w 10)
  132.           (send self :draw-indicator))))
  133.  
  134. (defmeth slider-control-proto :draw-indicator (&optional index)
  135.   (let* ((graph (send self :graph))
  136.          (loc (send self :location))
  137.          (loc-x (first loc))
  138.          (loc-y (second loc))
  139.          (w (first (send self :size)))
  140.          (min (send self :min))
  141.          (max (send self :max))
  142.          (index (if index index (send self :index)))
  143.          (val (floor (* (- w 7) (/ (- index min) (- max min))))))
  144.     (when graph
  145.           (let ((tw (send graph :text-width (send self :title))))
  146.             (send graph :start-buffering)
  147.             (send graph :erase-rect (+ 1 tw loc-x) loc-y (- w tw) 20)
  148.             (send graph :draw-text 
  149.                   (format nil "~a" (elt (send self :display) index))
  150.                   (+ loc-x w) (+ loc-y 15) 2 0)
  151.             (send graph :buffer-to-screen (+ 1 tw loc-x) loc-y (- w tw) 20))
  152.           (send graph :erase-rect (+ 1 loc-x) (+ 21 loc-y) (- w 2) 8)
  153.           (send graph :paint-rect (+ 1 loc-x val) (+ 21 loc-y) 5 8))))
  154.  
  155. (defmeth slider-control-proto :min () 0)
  156.  
  157. (defmeth slider-control-proto :max () (- (length (slot-value 'sequence)) 1))
  158.  
  159. (defmeth slider-control-proto :sequence (&optional (seq nil set) &key 
  160.                                                    (display seq))
  161.   (when set
  162.         (setf (slot-value 'sequence) (coerce seq 'vector))
  163.         (setf (slot-value 'display) (coerce display 'vector)))
  164.   (slot-value 'sequence))
  165.  
  166. (defmeth slider-control-proto :display () (slot-value 'display))
  167.  
  168. (defmeth slider-control-proto :index (&optional (new nil set))
  169.   (if set
  170.       (let* ((new (max (send self :min) (min new (send self :max)))))
  171.         (setf (slot-value 'index) new)
  172.         (send self :draw-indicator)
  173.         (send self :do-action (elt (send self :sequence) new))))
  174.   (slot-value 'index))
  175.  
  176. (defmeth slider-control-proto :do-click (x y a b)
  177.   (let* ((graph (send self :graph))
  178.          (loc (send self :location))
  179.          (loc-x (nth 0 loc))
  180.          (loc-y (nth 1 loc))
  181.          (w (first (send self :size))))
  182.     (when (and (< loc-x x (+ loc-x w)) (< (+ loc-y 20) y (+ loc-y 30)))
  183.           (let ((pos (+ (floor (* (- w 7) (/ (send self :index) 
  184.                                              (send self :max))))
  185.                         loc-x)))
  186.             (cond
  187.               ((<= pos x (+ pos 5))
  188.                (let ((off (- x pos)))
  189.                  (send graph :while-button-down
  190.                        #'(lambda (x y)
  191.                            (let ((val (max (+ loc-x 1)
  192.                                            (min (- x off) 
  193.                                                 (+ loc-x (- w 6))))))
  194.                              (setf pos val)
  195.                              (send self :draw-indicator 
  196.                                    (floor (* (send self :max) 
  197.                                              (/ (- pos loc-x) (- w 7)))))))))
  198.                  (send self :index 
  199.                        (floor (* (send self :max) 
  200.                                  (/ (- pos loc-x) (- w 7))))))
  201.               ((< loc-x x pos)
  202.                (send graph :while-button-down
  203.                      #'(lambda (x y)
  204.                          (let ((pos (+ (floor (* w (/ (send self :index) 
  205.                                                       (send self :max))))
  206.                                        loc-x)))
  207.                            (if (< x pos)
  208.                                (send self :index (- (send self :index) 1)))))
  209.                      nil))
  210.               ((< pos x (+ loc-x w))
  211.                (send graph :while-button-down
  212.                      #'(lambda (x y)
  213.                          (let ((pos (+ (floor (* w (/ (send self :index) 
  214.                                                       (send self :max))))
  215.                                        loc-x)))
  216.                            (if (> x pos)
  217.                                (send self :index (+ (send self :index) 1)))))
  218.                      nil))))
  219.           t)))
  220.  
  221. ;;;;
  222. ;;;; Rotation example
  223. ;;;;
  224.  
  225. ;;; Rotation around axes
  226.  
  227. (defproto spin-rotate-control-proto '(v) () rocker-control-proto)
  228.  
  229. (defmeth spin-rotate-control-proto :isnew (v)
  230.   (call-next-method :v v :location (list 10 (case v (0 10) (1 30) (2 50)))))
  231.  
  232. (defmeth spin-rotate-control-proto :title ()
  233.   (send (send self :graph) :variable-label (slot-value 'v)))
  234.  
  235. (defmeth spin-rotate-control-proto :do-action (first sign)
  236.   (let ((graph (send self :graph)))
  237.     (if first
  238.         (let* ((v (slot-value 'v))
  239.                (v1 (if (= v 0) 1 0))
  240.                (v2 (if (= v 2) 1 2))
  241.                (trans (send graph :transformation))
  242.                (cols (column-list 
  243.                       (if trans 
  244.                           trans 
  245.                           (identity-matrix (send graph :num-variables)))))
  246.                (angle (send graph :angle)))
  247.           (send graph :idle-on (car first))
  248.           (send graph :slot-value 'rotation-type
  249.                 (make-rotation (nth v1 cols) (nth v2 cols) 
  250.                                (case sign (+ angle) (- (- angle)))))))
  251.     (send graph :rotate)))
  252.  
  253. ;;; Plot Rocking Control
  254.  
  255. (defproto spin-rock-control-proto '(v) () graph-control-proto)
  256.  
  257. (defmeth spin-rock-control-proto :isnew ()
  258.   (call-next-method :location '(10 70) :title "Rock Plot"))
  259.  
  260. (defmeth spin-rock-control-proto :do-action (first) 
  261.   (send (send self :graph) :rock-plot))
  262.  
  263. (defmeth spin-proto :rock-plot (&optional (k 2))
  264.   (let ((angle (send self :angle)))
  265.     (dotimes (i k) (send self :rotate-2 0 2 angle))
  266.     (dotimes (i (* 2 k)) (send self :rotate-2 0 2 (- angle)))
  267.     (dotimes (i k) (send self :rotate-2 0 2 angle))))
  268.  
  269. ;;;; Speed Control
  270.  
  271. (defproto spin-speed-control-proto () () slider-control-proto)
  272.  
  273. (defmeth spin-speed-control-proto :isnew (&optional (points 21))
  274.   (call-next-method (rseq 0 .2 points) :location '(10 90) :title "Speed"))
  275.  
  276. (defmeth spin-speed-control-proto :do-action (v)
  277.   (let ((graph (send self :graph)))
  278.     (if graph (send graph :angle v))))
  279.  
  280. ;;;; Installation method
  281.  
  282. (defmeth spin-proto :add-spin-controls ()
  283.   (send self :margin 110 0 0 20)
  284.   (apply #'send self :size (+ (send self :size) '(100 0)))
  285.   (send self :resize)
  286.   (send self :add-control (send spin-rotate-control-proto :new 0))
  287.   (send self :add-control (send spin-rotate-control-proto :new 1))
  288.   (send self :add-control (send spin-rotate-control-proto :new 2))
  289.   (send self :add-control (send spin-rock-control-proto :new))
  290.   (send self :add-control (send spin-speed-control-proto :new)))
  291.  
  292.  
  293.         
  294.