src/lsp/graph3.lsp

   1 (provide "graph3")
   2 (require "graphics")
   3
   4 ;;;
   5 ;;; Options dialog stuff
   6 ;;;
   7
   8 (defproto graph-toggle-item-proto '(graph message) () toggle-item-proto)
   9
  10 (defmeth graph-toggle-item-proto :isnew (title graph message)
  11   (setf (slot-value 'graph) graph)
  12   (setf (slot-value 'message) message)
  13   (call-next-method title :value (send graph message)))
  14
  15 (defmeth graph-toggle-item-proto :set-value ()
  16   (let* ((message (slot-value 'message))
  17          (graph (slot-value 'graph))
  18          (old (if (send graph message) t nil))
  19          (new (if (send self :value) t nil)))
  20     (unless (eq old new) (send graph message new))))
  21
  22 (defproto graph-backcolor-choice-item-proto '(graph) () choice-item-proto)
  23
  24 (defmeth graph-backcolor-choice-item-proto :isnew (graph)
  25   (setf (slot-value 'graph) graph)
  26   (call-next-method (list "White Background" "Black Background")
  27                     :value (if (eq (send graph :back-color) 'white) 0 1)))
  28
  29 (defmeth graph-backcolor-choice-item-proto :set-value ()
  30   (let ((graph (slot-value 'graph)))
  31     (case (send self :value)
  32       (0 (send graph :back-color 'white)
  33          (send graph :draw-color 'black))
  34       (1 (send graph :back-color 'black)
  35          (send graph :draw-color 'white)))))
  36
  37 (defproto graph-scaling-choice-item-proto '(graph) () choice-item-proto)
  38
  39 (defmeth graph-scaling-choice-item-proto :isnew (graph)
  40   (setf (slot-value 'graph) graph)
  41   (call-next-method (list "Variable Scaling" "Fixed Scaling" "No Scaling")
  42                     :value (case (send graph :scale-type)
  43                                  (variable 0)
  44                                  (fixed 1)
  45                                  (t 2))))
  46
  47 (defmeth graph-scaling-choice-item-proto :set-value ()
  48   (let ((graph (slot-value 'graph)))
  49     (send graph :scale-type
  50           (case (send self :value)
  51                 (0 'variable)
  52                 (1 'fixed)
  53                 (2 nil)))))
  54
  55 (defmeth graph-proto :set-options ()
  56 "Method args: ()
  57 Opens dialog to set plot options. Items are obtained using the
  58 :make-options-dialog-items message."
  59   (let* ((items (send self :make-options-dialog-items))
  60          (d (send ok-or-cancel-dialog-proto :new items :title "Options"
  61                   :ok-action #'(lambda ()
  62                                  (dolist (i items)
  63                                          (send i :set-value))
  64                                  (send self :redraw)))))
  65     (unwind-protect (send d :modal-dialog)
  66                     (send d :remove))))
  67
  68 (defmeth graph-proto :make-options-dialog-items ()
  69   (remove
  70    nil
  71    (list
  72     (send graph-backcolor-choice-item-proto :new self)
  73     (send graph-toggle-item-proto :new "Vertical Scroll" self :has-v-scroll)
  74     (send graph-toggle-item-proto :new "Horizontal Scroll" self :has-h-scroll)
  75     (send graph-toggle-item-proto :new "Fixed Aspect Ratio" self :fixed-aspect)
  76     (if (screen-has-color)
  77         (send graph-toggle-item-proto :new "Use color" self :use-color)))))
  78
  79 (defmeth scatmat-proto :make-options-dialog-items ()
  80   (remove
  81    nil
  82    (list
  83     (send graph-backcolor-choice-item-proto :new self)
  84     (send graph-toggle-item-proto :new "Vertical Scroll" self :has-v-scroll)
  85     (send graph-toggle-item-proto :new "Horizontal Scroll" self :has-h-scroll)
  86     (if (screen-has-color)
  87         (send graph-toggle-item-proto :new "Use color" self :use-color)))))
  88
  89 (defmeth spin-proto :make-options-dialog-items ()
  90   (remove
  91    nil
  92    (list
  93     (send graph-backcolor-choice-item-proto :new self)
  94     (send graph-scaling-choice-item-proto :new self)
  95     (if (screen-has-color)
  96         (send graph-toggle-item-proto :new "Use color" self :use-color)))))
  97
  98 ;;;;
  99 ;;;;
 100 ;;;; Plot Sliders and Slicers
 101 ;;;;
 102 ;;;;
 103
 104 ;;; Graph dialogs
 105
 106 (defproto graph-dialog-proto '(plot))
 107
 108 (defmeth graph-dialog-proto :install (plot)
 109   (setf (slot-value 'plot) plot)
 110   (send plot :add-subordinate self))
 111
 112 (defmeth graph-dialog-proto :clobber ()
 113   (let ((plot (slot-value 'plot)))
 114     (if plot (send plot :delete-subordinate self)))
 115   (setf (slot-value 'plot) nil))
 116
 117 ;;; Graph slicers
 118
 119 (defmeth graph-proto :add-slicer (s)
 120   (setf (slot-value 'slicers) (adjoin s (slot-value 'slicers)))
 121   (if (send self :allocated-p) (send self :adjust-slices)))
 122
 123 (defmeth graph-proto :remove-slicer (s)
 124   (setf (slot-value 'slicers) (remove s (slot-value 'slicers)))
 125   (when (send self :allocated-p)
 126         (if (eq 'show (send s :type)) (send self :show-all-points))
 127         (send self :adjust-slices)))
 128
 129 (defproto graph-slicer-proto
 130           '(variable delta selecting)
 131           ()
 132           (list graph-dialog-proto interval-slider-dialog-proto))
 133
 134 (defmeth graph-slicer-proto :isnew (plot var delta range
 135                                          &rest args
 136                                          &key select)
 137   (setf (slot-value 'variable) var)
 138   (setf (slot-value 'delta) delta)
 139   (setf (slot-value 'selecting) select)
 140   (apply #'call-next-method range
 141          :action #'(lambda (x) (send plot :adjust-slices)) args)
 142   (send self :install plot))
 143
 144 (defmeth graph-slicer-proto :install (plot)
 145   (call-next-method plot)
 146   (send plot :add-slicer self))
 147
 148 (defmeth graph-slicer-proto :clobber ()
 149   (let ((plot (slot-value 'plot)))
 150     (if plot (send plot :remove-slicer self)))
 151   (call-next-method))
 152
 153 (defmeth graph-slicer-proto :selection ()
 154   (let ((x (send self :value))
 155         (var (slot-value 'variable))
 156         (d (slot-value 'delta)))
 157     (which (< (- x d) var (+ x d)))))
 158
 159 (defmeth graph-slicer-proto :type ()
 160   (if (slot-value 'selecting) 'select 'show))
 161
 162 (defmeth graph-proto :adjust-slices ()
 163   (cond
 164     ((slot-value 'slicers)
 165      (let ((indices (reduce #'intersection
 166                             (mapcar #'(lambda (x) (send x :selection))
 167                                     (slot-value 'slicers))))
 168             (show (some #'(lambda (x) (eq 'show (send x :type)))
 169                         (slot-value 'slicers))))
 170        (cond
 171          (show (send self :points-showing indices))
 172          (t (send self :points-selected indices)))))
 173     (t (send self :unselect-all-points) (send self :show-all-points))))
 174
 175 ;; Installing graph slicers
 176
 177 (defmeth graph-proto :slicer (var &rest args
 178                                   &key
 179                                   (fraction 0.25)
 180                                   title
 181                                   (points 20))
 182   (unless title (setq title "Slicer"))
 183   (let* ((range (list (min var) (max var)))
 184          (p (* 0.5  fraction (- (nth 1 range) (nth 0 range))))
 185          (slicer (apply #'send graph-slicer-proto :new self var p
 186                         (list (+ (nth 0 range) p) (- (nth 1 range) p))
 187                         :title title
 188                         :points points
 189                         args)))
 190     (send slicer :value (/ (+ (nth 0 range) (nth 1 range)) 2))
 191     slicer))
 192
 193 (defmeth graph-proto :make-slicer-dialog ()
 194   (let* ((fractions (list 0.1 0.2 0.3))
 195          (var-item (send edit-text-item-proto :new
 196                          (format nil "(iseq 0 ~d)          "
 197                                  (- (send self :num-points) 1))))
 198          (fraction-item (send choice-item-proto :new
 199                               (mapcar #'(lambda (x) (format nil "~a" x))
 200                                       fractions)
 201                               :value 1))
 202          (type-item (send choice-item-proto :new
 203                           (list "Select Slice"
 204                                 "Show Only Slice")))
 205          expr
 206          title
 207          var
 208          fraction
 209          select
 210          ok)
 211     (flet ((ok-action ()
 212                       (setq expr (read (make-string-input-stream
 213                                         (send var-item :text))))
 214                       (setq title (format nil "~a" expr))
 215                       (setq var (eval expr))
 216                       (setq fraction (nth (send fraction-item :value)
 217                                           fractions))
 218                       (setq select (= 0 (send type-item :value)))
 219                       t))
 220       (let* ((d (send ok-or-cancel-dialog-proto :new
 221                       (list (send text-item-proto :new "Variable")
 222                             var-item
 223                             (list (list
 224                                    (send text-item-proto :new "Fraction")
 225                                    fraction-item)
 226                                   (list
 227                                    (send text-item-proto :new "Slicer Type")
 228                                    type-item)))
 229                       :ok-action #'ok-action)))
 230         (unwind-protect (setq ok (send d :modal-dialog))
 231                         (send d :remove))))
 232     (if ok
 233         (send self :slicer var
 234               :title title
 235               :fraction fraction
 236               :select select))))
 237
 238