Examples/rotatedemo.lsp

   1 #+macintosh(require "addbox" ":Examples:addbox")
   2 #+macintosh(require "addhandrotate" ":Examples:addhandrotate")
   3 #+macintosh(require ":Data:tutorial")
   4 #+unix(require "addbox" "Examples/addbox")
   5 #+unix(require "addhandrotate" "Examples/addhandrotate")
   6 #+unix(load-data "tutorial")
   7 #+msdos(require "addbox" "Examples\\addbox")
   8 #+msdos(require "addhandrotate" "Examples\\addhandr")
   9 #+msdos(load-data "tutorial")
  10
  11 (defun sphere-rand (n &optional (dim 3))
  12   (mapcar #'(lambda (k)
  13               (do ((x
  14                     (- (* 2 (uniform-rand k)) 1)
  15                     (- (* 2 (uniform-rand k)) 1)))
  16                   ((< (sum (* x x)) 1) x))) (repeat dim n)))
  17
  18 (defmeth spin-proto :data-rotate (&optional axis (angle pi))
  19   (unless axis
  20           (setf axis (choose-item-dialog "Axis:" '("X" "Y" "Z")))
  21           (if axis (setf axis (select '(x y z) axis)))
  22           (send self :redraw))
  23   (if axis
  24       (let* ((alpha (send self :angle))
  25              (cols (column-list
  26                     (let ((m (send self :transformation)))
  27                        (if m m (identity-matrix 3)))))
  28              (m (case axis
  29                   (x (make-rotation (nth 1 cols) (nth 2 cols) alpha))
  30                   (y (make-rotation (nth 0 cols) (nth 2 cols) alpha))
  31                   (z (make-rotation (nth 0 cols) (nth 1 cols) alpha)))))
  32         (dotimes (i (floor (/ angle alpha)))
  33                  (send self :apply-transformation m)))))
  34
  35 (defmeth spin-proto :toggle-box ()
  36   (if (not (send self :has-slot 'has-box :own t))
  37       (send self :add-slot 'has-box))
  38   (let ((has-box (slot-value 'has-box)))
  39     (if (not has-box) (send self :add-box) (send self :clear-lines :draw nil))
  40     (send self :redraw)
  41     (setf (slot-value 'has-box) (not has-box))))
  42
  43 (defmeth spin-proto :rock-plot (&optional (n 10) (k 3))
  44   (let ((a (send self :angle)))
  45     (dotimes (i k) (send self :rotate-2 0 2 (- a)))
  46     (dotimes (i n)
  47              (dotimes (i (* 2 k)) (send self :rotate-2 0 2 a))
  48              (dotimes (i (* 2 k)) (send self :rotate-2 0 2 (- a))))))
  49
  50 (defun add-demo-menu-items (bar)
  51   (send (send bar :menu) :append-items
  52         (send dash-item-proto :new)
  53         (send menu-item-proto :new "Toggle Box" :action
  54               #'(lambda () (send bar :toggle-box)))
  55         (send menu-item-proto :new "Toggle Scaling" :action
  56               #'(lambda ()
  57                   (send bar :scale-type
  58                         (if (eq (send bar :scale-type) 'fixed)
  59                             'variable
  60                             'fixed))))
  61         (send menu-item-proto :new "Rotate..." :action
  62               #'(lambda () (send bar :data-rotate)))
  63         (send menu-item-proto :new "Rock Plot" :key #\R :action
  64               #'(lambda () (send bar :rock-plot)))))
  65
  66 (defun make-bar-demo ()
  67   (close-all-plots)
  68   (def bar (spin-plot (let* ((x1 (* 20 (uniform-rand 40)))
  69                              (x2 (normal-rand 40))
  70                              (y (normal-rand 40)))
  71                         (list x1 y x2))
  72                       :variable-labels '("X1" "Y" "X2")
  73                       :scale 'fixed))
  74   (send bar :depth-cuing nil)
  75   (send bar :redraw)
  76   (add-demo-menu-items bar))
  77
  78 (defun make-abrasion-demo ()
  79   (close-all-plots)
  80   (def abr (spin-plot (list tensile-strength abrasion-loss hardness)
  81                       :variable-labels '("T" "A" "H")))
  82   (add-demo-menu-items abr))
  83
  84 (defun make-spheres-demo ()
  85   (close-all-plots)
  86   (let ((x (sphere-rand 100)))
  87     (def p1 (spin-plot (transpose x)))
  88     (add-demo-menu-items p1)
  89     (def p2 (spin-plot (transpose (mapcar
  90                                    #'(lambda (x)
  91                                        (let ((n (sqrt (sum (* x x)))))
  92                                          (* (+ .8 (* .2 n)) (/ x n)))) x))))
  93     (send p2 :location 250 21)
  94     (add-demo-menu-items p2)))
  95
  96 (defun make-randu-demo ()
  97   (close-all-plots)
  98   #+macintosh (require ":Data:randu")
  99   #+unix (load-data "randu")
 100   (let ((p (spin-plot randu))) (add-demo-menu-items p))
 101   (undef 'randu))
 102
 103 (defun make-diabetes-demo ()
 104   (close-all-plots)
 105   #+macintosh (require ":Data:diabetes")
 106   #+unix (load-data "diabetes")
 107   (let ((p (spin-plot (select diabetes '(0 1 2))
 108                       :variable-labels (select dlabs '(0 1 2)))))
 109     (add-demo-menu-items p))
 110   (undef 'diabetes))
 111
 112 (setf demo-menu (send menu-proto :new "Demos"))
 113 (send demo-menu :append-items
 114       (send menu-item-proto :new "Bar" :action
 115             #'(lambda () (make-bar-demo)))
 116       (send menu-item-proto :new "Abrasion" :action
 117             #'(lambda () (make-abrasion-demo)))
 118       (send menu-item-proto :new "Spheres" :action
 119             #'(lambda () (make-spheres-demo)))
 120       (send menu-item-proto :new "Randu" :action
 121             #'(lambda () (make-randu-demo)))
 122       (send menu-item-proto :new "Diabetes" :action
 123             #'(lambda () (make-diabetes-demo))))
 124 (send demo-menu :install)
 125
 126 (defun demo (which)
 127   (case which
 128         (bar (make-bar-demo))
 129         (abrasion (make-abrasion-demo))
 130         (spheres (make-spheres-demo))
 131         (randu (make-randu-demo))
 132         (diabetes (make-diabetes-demo))))
 133