This page is hosted on AFS file server space, which is being shut down on November 13, 2018. If you are seeing this message, your service provider needs to take steps now. Visit afs.unc.edu for more information.

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)