home *** CD-ROM | disk | FTP | other *** search
- ; book pp.335-339
-
- (defproto observation-proto '(label state symbol color views))
- (defmeth observation-proto :label () (slot-value 'label))
- (defmeth observation-proto :state () (slot-value 'state))
- (defmeth observation-proto :symbol () (slot-value 'symbol))
- (defmeth observation-proto :color () (slot-value 'color))
- (send observation-proto :slot-value 'state 'normal)
- (send observation-proto :slot-value 'symbol 'disk)
- (defmeth observation-proto :add-view (graph key)
- (setf (slot-value 'views)
- (cons (list graph key) (slot-value 'views))))
- (defmeth observation-proto :delete-view (graph)
- (flet ((test (x y) (eq x (first y))))
- (let ((views (slot-value 'views)))
- (if (member graph views :test #'test)
- (setf (slot-value 'views)
- (delete graph views :test #'test))))))
- (defmeth observation-proto :views () (slot-value 'views))
- (defmeth observation-proto :change (slot value)
- (setf (slot-value slot) value)
- (dolist (view (send self :views))
- (send (first view) :changed (second view) slot value)))
-
- (defproto observation-plot-mixin '(observations variables))
- (defmeth observation-plot-mixin :observations ()
- (slot-value 'observations))
- (defmeth observation-plot-mixin :variables ()
- (slot-value 'variables))
- (defmeth observation-plot-mixin :isnew (vars &rest args)
- (apply #'call-next-method
- (length vars) :variable-labels (mapcar #'string vars) args)
- (setf (slot-value 'variables) vars))
- (defmeth observation-plot-mixin :add-observations
- (new-obs &key (draw t))
- (let* ((obs (send self :observations))
- (n (length obs))
- (m (length new-obs))
- (new-obs (coerce new-obs 'vector)))
- (setf (slot-value 'observations)
- (concatenate 'vector obs new-obs))
- (dotimes (i m)
- (send (aref new-obs i) :add-view self (+ i n)))
- (send self :needs-adjusting t)
- (if draw (send self :adjust-screen))))
- (defmeth observation-plot-mixin :remove ()
- (call-next-method)
- (let ((obs (send self :observations)))
- (dotimes (i (length obs))
- (send (aref obs i) :delete-view self))))
- (defmeth observation-plot-mixin :adjust-screen ()
- (if (send self :needs-adjusting)
- (let ((vars (send self :variables))
- (obs (send self :observations)))
- (send self :clear-points :draw nil)
- (when (< 0 (length obs))
- (flet ((variable (v)
- (map-elements #'(lambda (x) (send x v)) obs)))
- (send self :add-points (mapcar #'variable vars) :draw nil))
- (dotimes (i (length obs))
- (let ((x (aref obs i)))
- (send self :point-label i (send x :label))
- (send self :point-state i (send x :state))
- (send self :point-color i (send x :color))
- (send self :point-symbol i (send x :symbol)))))
- (send self :needs-adjusting nil)
- (send self :redraw-content))))
- (defmeth observation-plot-mixin :changed (key what value)
- (case what
- (state (send self :point-state key value))
- (t (send self :needs-adjusting t))))
-
- (defun synchronize-graphs ()
- (dolist (g (active-windows))
- (if (kind-of-p g observation-plot-mixin)
- (send g :adjust-screen))))
- (defmeth observation-plot-mixin :erase-selection ()
- (let ((obs (send self :observations)))
- (dolist (i (send self :selection))
- (send (aref obs i) :change 'state 'invisible)))
- (synchronize-graphs))
- (defmeth observation-plot-mixin :show-all-points ()
- (let ((obs (send self :observations)))
- (dotimes (i (length obs))
- (send (aref obs i) :change 'state 'normal)))
- (synchronize-graphs))
- (defmeth observation-plot-mixin :focus-on-selection ()
- (let* ((obs (send self :observations))
- (showing (send self :points-showing))
- (selection (send self :selection)))
- (dolist (i (set-difference showing selection))
- (send (aref obs i) :change 'state 'invisible)))
- (synchronize-graphs))
- (defmeth observation-plot-mixin :menu-template ()
- (remove 'link (call-next-method)))
- (defmeth observation-plot-mixin :unselect-all-points ()
- (let ((obs (send self :observations)))
- (dolist (i (send self :selection))
- (send (aref obs i) :change 'state 'normal))
- (send self :adjust-screen)))
- (defmeth observation-plot-mixin :adjust-points-in-rect
- (left top width height state)
- (let ((points (send self :points-in-rect left top width height))
- (selection (send self :selection))
- (obs (send self :observations)))
- (case state
- (selected
- (dolist (i (set-difference points selection))
- (send (aref obs i) :change 'state 'selected)))
- (hilited
- (let* ((points (set-difference points selection))
- (hilited (send self :points-hilited))
- (new (set-difference points hilited))
- (old (set-difference hilited points)))
- (dolist (i new) (send (aref obs i) :change 'state 'hilited))
- (dolist (i old) (send (aref obs i) :change 'state 'normal))))))
- (synchronize-graphs))
-
- (defproto obs-scatterplot-proto () () (list observation-plot-mixin
- scatterplot-proto))
- (defun plot-observations (obs vars)
- (let ((graph (send obs-scatterplot-proto :new vars)))
- (send graph :new-menu)
- (send graph :add-observations obs)
- (send graph :adjust-to-data)
- graph))
-