src/lsp/graphics.lsp

   1 ;;;;
   2 ;;;; graphics.lsp XLISP-STAT dynamic graphics functions and objects
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9 (provide "graphics")
  10 (require "stats")
  11 (require "dialogs")
  12
  13
  14 ;;;
  15 ;;; Constants
  16 ;;;
  17
  18 (defconstant *cursors*
  19   '(arrow watch cross brush hand finger hour-glass trash-bag trash-can))
  20 (defconstant *colors*
  21   '(white black red green blue cyan magenta yellow))
  22 (defconstant *plot-symbols*
  23   '(dot dot1 dot2 dot3 dot4 disk diamond cross square wedge1 wedge2 x))
  24
  25
  26 ;;;
  27 ;;; Miscelaneous Functions
  28 ;;;
  29
  30 (defun close-all-plots ()
  31 "Args: ()
  32 Close all plot windos."
  33   (let ((plots (remove nil
  34                        (mapcar #'(lambda (x)
  35                                  (let ((object (nth 2 x)))
  36                                    (if (kind-of-p object graph-window-proto)
  37                                        object
  38                                        nil)))
  39                                *hardware-objects*))))
  40     (mapcar #'(lambda (x) (send x :remove)) plots)))
  41
  42 (defun get-new-integer (prompt low high initial)
  43 "Args: (prompt low high initial)
  44 Open dialog to get an integer in the range (LOW HIGH). Returns the integer
  45 or NIL if Cancelled or integer is not in range. Beeps if integer is bad."
  46   (let ((val (get-value-dialog (format nil "~a: (between ~d and ~d)"
  47                                        prompt low high) :initial initial)))
  48     (if val (cond
  49               ((and (integerp (car val)) (< low (car val) high)) (car val))
  50               (t (sysbeep) nil)))))
  51
  52 (defun linked-plots ()
  53 "Args: ()
  54 Return list of all linked plots."
  55   (let ((plots nil))
  56     (dolist (x *hardware-objects*)
  57             (let ((x (nth 2 x)))
  58               (if (and (kind-of-p x graph-proto) (send x :linked))
  59                   (push x plots))))
  60     plots))
  61
  62 (defun active-graph-windows ()
  63 "Args: ()
  64 Return list of all currently visible graph windows."
  65   (remove-if-not #'(lambda (x) (kind-of-p x graph-window-proto))
  66                  (mapcar #'third *hardware-objects*)))
  67
  68 (defun color-symbols ()
  69 "Args: ()
  70 Returns list of symbols with color definitions."
  71   (let ((res nil))
  72     (do-all-symbols (s res)
  73       (if (get s '|color-index|) (push s res)))))
  74
  75 (defun cursor-symbols ()
  76 "Args: ()
  77 Returns list of symbols with cursor definitions."
  78   (let ((res nil))
  79     (do-all-symbols (s res)
  80       (if (get s '|cursor-index|) (push s res)))))
  81
  82 (defun plot-symbol-symbols ()
  83 "Args: ()
  84 Returns list of symbols with plot symbol definitions."
  85   (let ((res nil))
  86     (do-all-symbols (s res)
  87       (if (get s '|symbol-index|) (push s res)))))
  88
  89 (defun pause (n)
  90 "Args: (n)
  91 Pause for N/60 seconds."
  92   (flush-graphics)
  93   (let ((ticks (+ (* (/ n 60) internal-time-units-per-second)
  94                   (get-internal-run-time))))
  95     (loop (if (<= ticks (get-internal-run-time)) (return)))))
  96
  97 ;;;
  98 ;;; Functions to link several plots
  99 ;;;
 100
 101 (defun link-views (&rest args)
 102 "Args: (&rest plots)
 103 Links the argument plots: any change in hiliting or visibility of points in
 104 the current plot is propagated to the other plots."
 105   (mapc #'(lambda (x) (send x :linked t)) args))
 106
 107 (defun unlink-views (&rest args)
 108 "Args: (&rest plots)
 109 Removes links to its arguments. With no arguments removes all links."
 110   (if args
 111       (mapc #'(lambda (x) (send x :linked nil)) args)
 112       (unlink-all-windows)))
 113
 114 ;;;;
 115 ;;;; GRAPH-PROTO Methods
 116 ;;;;
 117
 118 (defmeth graph-proto :current-variables (&optional x y &key (draw t))
 119 "Method args: (&optional x y &key (draw t))
 120 Sets or retrieves current variables."
 121   (when x
 122             (send self :content-variables x y)
 123             (if draw (send self :redraw)))
 124   (send self :content-variables))
 125
 126 (defmeth spin-proto :current-variables (&optional x y z &key (draw t))
 127 "Method args: (&optional x y z &key (draw t))
 128 Sets or retrieves current variables."
 129   (when x
 130             (send self :content-variables x y z)
 131             (if draw (send self :redraw)))
 132   (send self :content-variables))
 133
 134 (defmeth graph-proto :scale-type (&optional (new nil set) &key (draw t))
 135 "Method args: (&optional new)
 136 Sets or returns scale type."
 137   (when set
 138 ;       (setf (slot-value 'scale-type)
 139 ;                     (case new ((fixed variable) new) (t nil)))
 140         (setf (slot-value 'scale-type) new)
 141         (send self :adjust-to-data :draw draw))
 142   (slot-value 'scale-type))
 143
 144 (defmeth graph-proto :menu-title (&optional (title nil set))
 145   (if set (setf (slot-value 'menu-title) title))
 146   (slot-value 'menu-title))
 147
 148 (defmeth graph-proto :variable-labels (&optional (val nil set))
 149   (if set (setf (slot-value 'variable-labels) (map 'vector #'string val)))
 150   (slot-value 'variable-labels))
 151
 152 (defmeth graph-proto :black-on-white (&optional (val nil set))
 153   (if set (setf (slot-value 'black-on-white) val))
 154   (slot-value 'black-on-white))
 155
 156 (defmeth graph-proto :center (&rest args)
 157 "Method args: (var &optional shift &key (draw t))
 158 Sets or retrieves current center for variable VAR. Sends :RESIZE and :REDRAW
 159 messages if DRAW is true. Vectorized."
 160   (apply #'send self :shift args))
 161
 162 ; dummy message to allow depth cuing to be turned off when symbols
 163 ; are changed
 164 (defmeth graph-proto :depth-cuing (&optional (on nil set))
 165   (declare (ignore set))
 166   nil)
 167
 168 (defmeth graph-proto :set-selection-symbol ()
 169 "Method args: ()
 170 Open dialog to set symbol used to plot selected points."
 171   (let* ((symbols (remove-if #'(lambda (x) (member x '(dot1 dot2 dot3 dot4)))
 172                              *plot-symbols*))
 173          (i (choose-item-dialog "Symbol for selected points"
 174                                 (mapcar #'string symbols))))
 175     (when i
 176           (let ((plots (adjoin self (linked-plots)))
 177                 (selection (send self :selection))
 178                 (symbol (nth i symbols)))
 179             (dolist (p plots)
 180                     (if (send p :depth-cuing) (send p :depth-cuing nil))
 181                     (send p :point-symbol selection symbol)
 182                     (send p :redraw))))))
 183
 184 (defmeth graph-proto :set-selection-color ()
 185 "Method args: ()
 186 Open dialog to set color used to plot selected points."
 187   (let ((c (choose-item-dialog "Color for selected points"
 188                                   (cons "None" (mapcar #'string *colors*)))))
 189     (when c
 190           (setf c (if (= c 0) nil (nth (- c 1) *colors*)))
 191           (let ((plots (adjoin self (linked-plots)))
 192                 (selection (send self :selection)))
 193             (dolist (p plots)
 194                     (if c (send p :use-color t))
 195                     (send p :point-color selection c)
 196                     (send p :redraw))))))
 197
 198 (defmeth graph-proto :show-all-points ()
 199   (send self :point-showing (iseq 0 (- (send self :num-points) 1)) t)
 200   (send self :adjust-to-data))
 201
 202 (defmeth graph-proto :selection-dialog ()
 203 "Method args: ()
 204 Open dialog to save or set selection."
 205   (if (send self :any-points-selected-p)
 206       (let ((s (get-string-dialog "Name for the selection:")))
 207         (when s
 208               (setq s (intern (string-upcase s)))
 209               (set s (send self :selection))
 210               (pushnew s *variables*)))
 211       (let ((s (get-value-dialog "Expression for indices to select:")))
 212         (if s (send self :point-selected (car s) t)))))
 213
 214 ;;; :DRAG-POINT - if there is a point close to the mouse drag it
 215 ;;; and return its index. Otherwise returns NIL.
 216 ;;; For transformed data result only makes sense if transform is
 217 ;;; orthogonal.
 218 ;;;
 219 (defmeth graph-proto :drag-point (x y &key (draw t))
 220   (let* ((cont-vars (send self :content-variables))
 221          (cont-x (nth 0 cont-vars))
 222          (cont-y (nth 1 cont-vars))
 223          (tol 5)
 224          (width (* 2 tol))
 225          (points (send self :points-in-rect
 226                        (- x tol) (- y tol) width width))
 227          (p (if points (car points)))
 228          (transform (send self :transformation)))
 229     (if (null transform)
 230         (if p
 231             (let* ((coords (send self :drag-grey-rect x y tol tol))
 232                    (sx (+ (nth 0 coords) tol))
 233                    (sy (+ (nth 1 coords) tol))
 234                    (rcoords (send self :canvas-to-real sx sy)))
 235               (send self :point-coordinate cont-x p (nth 0 rcoords))
 236               (send self :point-coordinate cont-y p (nth 1 rcoords))
 237               (if draw (send self :redraw))
 238               p))
 239         (if p
 240             (let* ((coords (send self :drag-grey-rect x y tol tol))
 241                    (sx (+ (nth 0 coords) tol))
 242                    (sy (+ (nth 1 coords) tol))
 243                    (sc-coords (send self :canvas-to-scaled sx sy))
 244                    (sc-x (first sc-coords))
 245                    (sc-y (second sc-coords))
 246                    (old-sc-x (send self :point-transformed-coordinate
 247                                    cont-x p))
 248                    (old-sc-y (send self :point-transformed-coordinate
 249                                    cont-y p))
 250                    (dims (iseq 0 (- (send self :num-variables) 1)))
 251                    (reals (send self :point-coordinate dims p))
 252                    (scale (send self :scale dims))
 253                    (x-col (compound-data-seq
 254                            (select transform cont-x dims)))
 255                    (y-col (compound-data-seq
 256                            (select transform cont-y dims))))
 257               (send self :point-coordinate dims p
 258                     (+ reals (* (+ (* x-col (- sc-x old-sc-x))
 259                                    (* y-col (- sc-y old-sc-y)))
 260                                 scale)))
 261               (if draw (send self :redraw))
 262               p)))))
 263
 264
 265 ;;; :SAVE-IMAGE - saves a postscript image to a file.
 266 #+unix
 267 (defmeth graph-window-proto :save-image (&optional (file "image.ps") &key (scale 1))
 268 "Method args: (&optional (file \"image.ps\"))
 269 Saves a postscript image of the window to file named FILE by buffering,
 270 sending the window the :REDRAW message, and dumping the buffer to a file."
 271   (let ((file (open file :direction :output)))
 272     (unwind-protect (send self :image-to-file file scale)
 273       (close file))))
 274
 275 #+unix
 276 (defmeth graph-window-proto :ask-save-image (&optional (file "image.ps"))
 277   (let ((file (get-string-dialog "Enter a file name for postscript output"
 278                                  :initial file)))
 279     (when file
 280         (if (= (length file) 0) (error "null file name string"))
 281         (format t "; saving postscript image to file ~a..." file)
 282         (force-output)
 283         (send self :save-image file)
 284         (format t "done~%"))))
 285
 286 ;;;;
 287 ;;;;
 288 ;;;; Graph Object Menu and Dialog Methods
 289 ;;;;
 290 ;;;;
 291
 292 (send graph-proto :menu-title "Plot")
 293
 294 (defmeth graph-proto :menu-template (&optional (val nil set))
 295   (if set (setf (slot-value 'menu-template) val))
 296   (slot-value 'menu-template))
 297
 298 (send graph-proto :menu-template '(link showing-labels mouse resize-brush dash
 299                                         erase-selection focus-on-selection
 300                                         show-all symbol
 301                                         color
 302                                         selection dash
 303                                         slicer
 304                                         rescale
 305                                         options
 306 #+unix                                  save-image))
 307
 308 (defmeth graph-proto :make-menu-item (item-template)
 309   (if (kind-of-p item-template menu-item-proto)
 310       item-template
 311       (case item-template
 312         (dash (send dash-item-proto :new))
 313         (link (send link-item-proto :new self))
 314         (erase-selection
 315          (send graph-item-proto :new "Remove Selection" self
 316                :erase-selection :any-points-selected-p))
 317         (focus-on-selection
 318          (send graph-item-proto :new "Focus on Selection" self
 319                :focus-on-selection :any-points-selected-p))
 320         (showing-labels
 321          (send graph-item-proto :new "Show Labels" self
 322                :showing-labels :showing-labels :toggle t))
 323         (show-all
 324          (send graph-item-proto :new "Show All" self
 325                :show-all-points :all-points-showing-p :negate t))
 326         (selection
 327          (send graph-item-proto :new "Selection ..." self
 328                :selection-dialog))
 329         (mouse (send mouse-mode-item-proto :new self))
 330         (resize-brush
 331          (send graph-item-proto :new "Resize Brush" self :resize-brush))
 332         (redraw
 333          (send graph-item-proto :new "Redraw Plot" self :redraw))
 334         (rescale
 335          (send graph-item-proto :new "Rescale Plot" self :adjust-to-data))
 336         (options
 337          (if (not (small-machine-p))
 338              (send graph-item-proto :new "Options ..." self :set-options)))
 339         (slicer
 340          (if (not (small-machine-p))
 341              (send graph-item-proto :new
 342                    "Slicer ..." self :make-slicer-dialog)))
 343         (symbol
 344          (send graph-item-proto :new "Selection Symbol" self
 345                :set-selection-symbol :any-points-selected-p))
 346         (color
 347          (if (screen-has-color)
 348              (send graph-item-proto :new "Selection Color" self
 349                    :set-selection-color :any-points-selected-p)))
 350         (save-image
 351          (send graph-item-proto :new "Save to File" self :ask-save-image)))))
 352
 353 (defmeth graph-proto :new-menu (&optional title &key (items (send self :menu-template)))
 354   (unless title (setq title (slot-value 'menu-title)))
 355   (if (slot-value 'menu) (send (slot-value 'menu) :dispose))
 356   (flet ((make-item (item) (send self :make-menu-item item)))
 357     (let ((menu (send menu-proto :new title)))
 358       (send self :menu menu)
 359       (apply #'send menu :append-items  (remove nil (mapcar #'make-item items)))
 360       menu)))
 361
 362 (defmeth graph-window-proto :clobber ()
 363   (call-next-method)
 364   (if (slot-value 'menu) (send (slot-value 'menu) :dispose)))
 365
 366 (defmeth graph-window-proto :close () (send self :remove))
 367
 368 (defmeth graph-proto :remove ()
 369   (if (send self :allocated-p) (send self :linked nil))
 370   (call-next-method))
 371
 372 (defmeth graph-proto :add-dialog (d) (send self :add-subordinate d))
 373 (defmeth graph-proto :remove-dialog (d) (send self :delete-subordinate d))
 374
 375 (defmeth graph-proto :clear (&rest args)
 376 "Message args: (&key (draw t))
 377 Clears the plot data. If DRAW is nil the plot is redrawn; otherwise its
 378 current screen image remains unchanged."
 379   (let ((draw (null args)))       ;;;temporary cheat to allow optional or key arg
 380     (send self :clear-points :draw nil)
 381     (send self :clear-lines :draw draw)))
 382
 383 (defmeth graph-proto :focus-on-selection ()
 384 "Message args: ()
 385 removes all unselected points invisible"
 386   (let ((i (iseq 0 (- (send self :num-points) 1))))
 387     (send self :point-showing (set-difference i (send self :selection)) nil)))
 388
 389 ;;
 390 ;; Graph Menu Item Prototypes
 391 ;;
 392
 393 ;; GRAPH-ITEM-PROTO
 394 (defproto graph-item-proto
 395           '(graph update-message toggle negate redraw) () menu-item-proto)
 396
 397 (defmeth graph-item-proto :isnew (title graph message
 398            &optional update-message &key toggle negate redraw)
 399   (setf (slot-value 'graph) graph)
 400   (setf (slot-value 'action) message)
 401   (setf (slot-value 'update-message) update-message)
 402   (setf (slot-value 'toggle) toggle)
 403   (setf (slot-value 'negate) negate)
 404   (setf (slot-value 'redraw) redraw)
 405   (call-next-method title))
 406
 407 (defmeth graph-item-proto :do-action ()
 408   (let ((graph (slot-value 'graph))
 409         (action (send self :action)))
 410     (if (and action (symbolp action))
 411         (if (slot-value 'toggle)
 412             (send graph action (not (send self :update-message)))
 413             (send graph action))
 414         (if action (funcall action graph)))
 415     (if (slot-value 'redraw) (send graph :redraw))))
 416
 417 (defmeth graph-item-proto :update-message ()
 418   (let ((graph (slot-value 'graph)))
 419     (if (slot-value 'update-message)
 420         (if (symbolp (slot-value 'update-message))
 421             (send graph (slot-value 'update-message))
 422             (funcall (slot-value 'update-message) graph)))))
 423
 424 (defmeth graph-item-proto :update ()
 425   (if (slot-value 'update-message)
 426     (let ((test (if (send self :update-message) t nil)))
 427       (send self
 428            (if (slot-value 'toggle) :mark :enabled)
 429            (if (slot-value 'negate) (not test) test)))))
 430
 431 ;; LINK-ITEM-PROTO. Toggles linking and menu text
 432 (defproto link-item-proto '(graph) () menu-item-proto)
 433
 434 (defmeth link-item-proto :isnew (v)
 435   (setf (slot-value 'graph) v)
 436   (call-next-method "Link View"))
 437
 438 (defmeth link-item-proto :do-action ()
 439   (send (slot-value 'graph)
 440         :linked (not (send (slot-value 'graph) :linked))))
 441
 442 (defmeth link-item-proto :update ()
 443   (send self :title
 444         (if (send (slot-value 'graph) :linked)
 445             "Unlink View"
 446             "Link View")))
 447
 448 ;; MOUSE-MODE-ITEM-PROTO. Rotates among selecting, brushing, user modes
 449
 450 (defproto mouse-mode-item-proto '(graph) () menu-item-proto
 451   "Menu item for changing the mouse mode")
 452
 453 (defmeth mouse-mode-item-proto :isnew (v)
 454   (setf (slot-value 'graph) v)
 455   (call-next-method "Mouse Mode ..."))
 456
 457 (defmeth mouse-mode-item-proto :do-action ()
 458   (let ((graph (slot-value 'graph)))
 459     (send graph :choose-mouse-mode)))
 460
 461 ;;;
 462 ;;; Graph mode methods
 463 ;;;
 464
 465 (defmeth graph-proto :add-mouse-mode (mode &key
 466                                            (title (string mode))
 467                                            (cursor 'arrow)
 468                                            click
 469                                            motion)
 470 "Method args: (mode &key (title (string mode)) (cursor 'arrow) click motion)
 471 Adds MODE to the mode list. TITLE is the string used in the menu, CLICK
 472 and MOTION are the selectors for the mouse actions."
 473   (let ((mode-list (remove mode (slot-value 'mode-list)
 474                            :test #'(lambda (x y)
 475                                      (and (consp y) (eql x (car y)))))))
 476     (send self :add-slot 'mode-list
 477           (cons (list mode title cursor click motion) mode-list)))
 478    mode)
 479
 480 (defmeth graph-proto :delete-mouse-mode (mode)
 481 "Method args: (mode)
 482 Deletes MODE to the mode list."
 483   (let* ((mode-list (slot-value 'mode-list))
 484          (new-list (remove mode mode-list
 485                            :test #'(lambda (x y)
 486                                      (and (consp y) (eql x (car y)))))))
 487     (unless (equal mode-list new-list)
 488             (if (null new-list) (error "Need at least one mouse mode"))
 489             (send self :add-slot 'mode-list new-list)
 490             (if (eq mode (send self :mouse-mode))
 491                 (send self :mouse-mode (first (send self :mouse-modes))))
 492             mode)))
 493
 494 (defmeth graph-proto :set-mode-cursor ()
 495 "Method args: ()
 496 Installs appropriate cursor for current mode."
 497   (let* ((mode-info (assoc (slot-value 'mouse-mode) (slot-value 'mode-list)))
 498          (cursor (if mode-info (nth 2 mode-info) 'arrow)))
 499     (send self :cursor cursor)))
 500
 501 (send graph-proto :add-mouse-mode 'selecting
 502       :title "Selecting Mode" :click :do-select-click)
 503 (send graph-proto :add-mouse-mode 'brushing
 504       :title "Brushing Mode" :cursor 'brush
 505       :click :do-brush-click :motion :do-brush-motion)
 506
 507 (defmeth graph-proto :mouse-mode-title (mode)
 508 "Method args: (mode)
 509 Returns title for menu item for mouse mode MODE."
 510   (let ((mode-info (assoc mode (slot-value 'mode-list))))
 511     (if mode-info (nth 1 mode-info))))
 512
 513 (defmeth graph-proto :mouse-modes ()
 514 "Method args: ()
 515 Returns a list of the current mouse modes."
 516   (reverse (mapcar #'car (slot-value 'mode-list))))
 517
 518 (defmeth graph-proto :choose-mouse-mode ()
 519 "Method args: ()
 520 Presents a dialog to set the mouse mode."
 521   (let* ((modes (send self :mouse-modes))
 522          (m (choose-item-dialog "New Mode:"
 523                                 (mapcar #'(lambda (x)
 524                                             (send self :mouse-mode-title x))
 525                                         modes)
 526                                 :initial (position (send self :mouse-mode)
 527                                                    modes))))
 528     (if m (send self :mouse-mode (nth m modes)))))
 529
 530 ;;;
 531 ;;; Overlay Methods
 532 ;;;
 533
 534 (defmeth graph-proto :redraw-overlays ()
 535   (dolist (ov (reverse (slot-value 'overlays)))
 536           (send ov :redraw)))
 537
 538 (defmeth graph-proto :resize-overlays ()
 539   (dolist (ov (slot-value 'overlays))
 540           (send ov :resize)))
 541
 542 (defmeth graph-proto :overlay-click (x y m1 m2)
 543   (dolist (ov (slot-value 'overlays))
 544     (if (send ov :do-click x y m1 m2) (return t))))
 545
 546 (defmeth graph-proto :add-overlay (ov)
 547   (if (send ov :graph) (error "Already installed in a graph"))
 548   (send ov :slot-value 'graph self)
 549   (setf (slot-value 'overlays) (cons ov (slot-value 'overlays))))
 550
 551 (defmeth graph-proto :delete-overlay (ov)
 552   (when (member ov (slot-value 'overlays))
 553         (send ov :slot-value 'graph nil)
 554         (setf (slot-value 'overlays) (remove ov (slot-value 'overlays)))))
 555
 556 (defproto graph-overlay-proto '(graph))
 557
 558 (defmeth graph-overlay-proto :graph () (slot-value 'graph))
 559 (defmeth graph-overlay-proto :resize () nil)
 560 (defmeth graph-overlay-proto :redraw () nil)
 561 (defmeth graph-overlay-proto :do-click (x y m1 m2)
 562   (declare (ignore x y m1 m2))
 563   nil)
 564
 565 (require "graph2")