;;Lisp Graphics Programming Examples
;;These examples follow Luke Tierney's Chapter 8 closely.

#|
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

(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)


;8.3 Double Buffering and Animation</h4>

;Animation with xor - try changing (pause 1) to some other value

(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</h4>

;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)