Psych 285: Computational Statistics
and Statistical Visualization

Professor Forrest Young

LispStat Programming Examples

These examples follow Luke Tierney's Chapter 8 closely. (Click here for a lisp only version).


  • Chapter 8 - Graphics Programming
  • This chapter deals with low-level graphics programming. It is pretty much the standard approach to graphical programming in use today, following most closely the Macintosh quick-draw approach. We start by setting up a graphical window object, to which we send messages to demonstrate graphical programming.
    (setf w (send graph-window-proto :new))
    

  • 8.2 Graphical Messages
  • 8.2.1 Initialization and State Messages
    (send w :use-color)   
    (send w :use-color t)
    (send w :back-color)  
    (send w :back-color 'red)
    ;You must resize the window to see the color 
    (send w :draw-color)
    (send w :draw-color 'blue)
    (send w :draw-mode)
    (send w :draw-mode 'xor)
    (send w :draw-mode 'normal)
    (send w :line-width)
    (send w :line-type)    
    (send w :line-type 'dashed)
    (send w :line-type 'solid)  
    (send w :reverse-colors)
    (send w :reverse-colors)
    
    8.2.2 Basic Drawing Messages
    (send w :draw-color 'black)
    (send w :draw-point 15 10)
    (send w :draw-line 5 10 50 70)
    (send w :frame-rect 50 70 100 50)
    (send w :paint-rect 50 125 100 50)
    
    (send w :draw-color 'yellow)
    (send w :frame-oval 50 70 100 50)
    (send w :draw-color 'green)
    (send w :paint-oval 50 125 100 50)
    (send w :draw-color 'magenta)
    (send w :paint-arc 50 125 100 50 0 90)
    
    (send w :paint-poly '((50 200) (70 200) (120 250) (100 250)))
    
    (send w :draw-color 'black)
    (send w :draw-string "Examples of Basic Drawing Messages" 50 50)
    (send w :draw-string-up "XLisp Stat" 25 100)
    
    (send w :draw-symbol 'disk t 200 200)
    (send w :draw-symbol 'cross t 210 200)
    
    ;This is the bitmap that creates the ViSta tool icon.
    (setf bitmap 
    '#2a(
    (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0) 
    (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 1 1) 
    (1 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0 0 1 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 1 1) 
    (1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
    (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) 
    (0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) ))
    (send w :draw-bitmap bitmap 210 210)
    
    8.2.3 Additional Drawing Messages
    (send w :erase-window)
    (send w :canvas-height)
    (send w :canvas-width)
    (send w :text-ascent)
    (send w :text-descent)
    (send w :draw-text 20 20 1 0)
    (send w :draw-text-up 20 200 1 0)
    
    

  • 8.3 Double Buffering and Animation
  • Animation with xor
    (let ((width (send w :canvas-width))
          (height (send w :canvas-height))
          (mode (send w :draw-mode)))
      (send w :draw-mode 'xor)
      (dotimes (i (min width height))
               (send w :draw-symbol 'disk t i i)
               (pause 1)
               (send w :draw-symbol 'disk t i i))
      (send w :draw-mode mode))
    
    Animation by buffering
    (let ((width (send w :canvas-width))
          (height (send w :canvas-height)))
      (dotimes (i (min width height))
               (send w :start-buffering)
               (send w :erase-window)
               (send w :draw-symbol 'disk t i i)
               (send w :buffer-to-screen)))
    

  • 8.4 Responding to Events
  • 8.4.1 Resize and Exposure Events
    Define a method to demonstrate redraw, and then show how redraw starts out null, and can then be redefined.
    (defun examples ()
      (send w :draw-color 'black)
      (send w :draw-point 15 10)
      (send w :draw-line 5 10 50 70)
      (send w :frame-rect 50 70 100 50)
      (send w :paint-rect 50 125 100 50)
      
      (send w :draw-color 'yellow)
      (send w :frame-oval 50 70 100 50)
      (send w :draw-color 'green)
      (send w :paint-oval 50 125 100 50)
      (send w :draw-color 'magenta)
      (send w :paint-arc 50 125 100 50 0 90)
      
      (send w :paint-poly '((50 200) (70 200) (120 250) (100 250)))
      
      (send w :draw-color 'black)
      (send w :draw-string "Examples of Basic Drawing Messages" 50 50)
      (send w :draw-string-up "XLisp Stat" 25 100)
      
      (send w :draw-symbol 'disk t 200 200)
      (send w :draw-symbol 'cross t 210 200)
      (send w :draw-bitmap bitmap 210 210)
      )
    
    (defmeth w :redraw ()
      (examples))
    
    Return redraw to being undefined and then add slots for another demonstration of redraw.
    (defmeth w :redraw () 
       )
    
    (send w :add-slot 'x (/ (send w :canvas-width) 2))
    (send w :add-slot 'y (/ (send w :canvas-height) 2))
    
    (defmeth w :x (&optional (val nil set))
          (if set (setf (slot-value 'x) val))
          (slot-value 'x))
    
    (defmeth w :y (&optional (val nil set))
          (if set (setf (slot-value 'y) val))
          (slot-value 'y))
    
    (defmeth w :resize ()
      (send self :x (/ (send self :canvas-width) 2))
      (send self :y (/ (send self :canvas-height) 2)))
    
    (defmeth w :redraw ()
      (let ((x (round (send self :x)))
            (y (round (send self :y))))
        (send w :draw-line 0 0 x y)
        (send w :paint-oval (- x 10) (- y 10) 20 20)
        (send w :paint-oval 0 0 x y)
        (send w :paint-oval x y (* 2 x) (* 2 y))))
    
    (defmeth w :redraw ()
      (let ((x (round (send self :x)))
            (y (round (send self :y)))
            )
        (send self :erase-window)
        (send w :paint-oval (- x 20) (- y 20) 40 40)))
    
    8.4.2 Mouse Events
    (defmeth w :do-motion (x y)
      (send self :x x)
      (send self :y y)
      (send self :redraw))
    
    (defmeth w :do-motion (x y))
    
    (defmeth w :do-click (x y m1 m2)
      (send self :x x)
      (send self :y y)
      (send self :redraw))
    
    (defmeth w :do-click (x y m1 m2)
      (flet ((set-symbol (x y)
                         (send self :x x)
                         (send self :y y)
                         (send self :redraw)))
        (set-symbol x y)
        (send self :while-button-down #'set-symbol)))
    
    (defmeth w :do-click (x y m1 m2)
      (flet ((set-symbol (x y)
                         (send self :x x)
                         (send self :y y)
                         (send self :redraw)))
        (set-symbol x y)
        (send self :while-button-down #'set-symbol nil)))
    
    (defmeth w :do-click (x y m1 m2)
      (let ((xy (send self :drag-grey-rect x y 40 40 20 20)))
        (send self :x (+ 20 (first xy)))
        (send self :y (+ 20 (second xy)))
        (send self :redraw)))
    
    (defmeth w :do-click (x y m1 m2)
      (let ((cursor (send self :cursor)))
        (send self :cursor 'cross)
        (let ((xy (send self :drag-grey-rect x y 40 40 20 20)))
          (send self :x (+ 20 (first xy)))
          (send self :y (+ 20 (second xy)))
          (send self :redraw))
        (send self :cursor cursor)))
    
    8.4.3 Key Events
    (send w :add-slot 'step-size 2)
    
    (defmeth w :step-size (&optional (val nil set))
          (if set (setf (slot-value 'step-size) val))
          (slot-value 'step-size))
    
    (defmeth w :move (x y)
      (send self :x (+ x (send self :x)))
      (send self :y (+ y (send self :y)))
      (send self :redraw))
    
    (defmeth w :do-key (c m1 m2)
      (let ((step (send self :step-size)))
        (case c
          (#\u (send self :move 0 (- step) ))
          (#\d (send self :move 0 step))
          (#\r (send self :move step 0))
          (#\l (send self :move (- step) 0))
          (#\f (send self :step-size (* (send self :step-size) 2)))
          (#\s (when (> (send self :step-size) 2)
                     (send self :step-size (/ (send self :step-size) 2)))))))
    
    8.4.4 Idle Actions
    (defmeth w :do-idle ()
      (let ((step (send self :step-size)))
        (case (random 4)
          (0 (send self :move 0 (- step) ))
          (1 (send self :move 0 step))
          (2 (send self :move step 0))
          (3 (send self :move (- step) 0)))))
    
    (send w :idle-on t)
    (send w :idle-on nil)
    
    8.4.5 Menus
    (defmeth w :restart ()
      (send self :x (/ (send self :canvas-width) 2))
      (send self :y (/ (send self :canvas-height) 2))
      (send self :redraw))
    
    (let ((walk-menu (send menu-proto :new "RandomWalk"))
          (restart-item
           (send menu-item-proto :new "Re-Center"
                 :action #'(lambda () (send w :restart))))
          (run-item
           (send menu-item-proto :new "Start Walking"
                 :action #'(lambda ()
                             (send w :idle-on t))))
          (stop-item 
           (send menu-item-proto :new "Stop Walking"
                 :action #'(lambda ()
                             (send w :idle-on nil))))
          (bigger-step
           (send menu-item-proto :new "Bigger Step"
                 :action #'(lambda ()
                             (send w :step-size 
                                   (* (send w :step-size) 2)))))
          (smaller-step
           (send menu-item-proto :new "Smaller Step"
                 :action #'(lambda ()
                             (when (> (send w :step-size) 2)
                                   (send w :step-size 
                                         (/ (send w :step-size) 2))))))
          )
      (send walk-menu :append-items 
            restart-item 
            (send dash-item-proto :new)
            run-item stop-item 
            (send dash-item-proto :new)
            bigger-step smaller-step)
      (send w :menu walk-menu))
    
    (defmeth w :do-click (x y m1 m2)
      (send (send self :menu) :popup x y self))
    
    8.5 Additional Features

    8.5.1 Canvas Dimensions

    (screen-size)
    :has-v-scroll
    :has-h-scroll
    :view-rect
    
    8.5.2 Clipping
    :clip-rect
    
    8.5.4 Adding New Colors
    (color-symbols)
    (make-color colorname .2 .3 .4)
    (free-color colorname)
    
    8.5.4 Adding New Cursors
    (best-cursor-size)
    (cursor-symbols)
    (make-cursor cursor-name image-bitmap mask-bitmap &optional hotx hoty)