;;;; Graphical Logo
;;; A. Castillo, Spring 1995
;;; Initial version (based on brian's sample code)
;;;
;;; Evaluate the buffer, then choose "New Logo Window" from File menu.
;;; - Click on palette objects to add them to the main window.
;;; - Drag new objects to adjust their postion or 
;;;     double-click on them to find out their type.
;;; - To start again with a fresh screen, choose "Clear screen" from Edit menu.
;;; - When you are ready, see the equivalent Logo code by choosing "Eval" menu.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defvar graphics-window)
(defvar palette-windoid)
(defvar offscreen)
(defvar tilestack)
(defvar rgn1 (#_newrgn))
(defvar rgn2 (#_newrgn))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tile definitions

(defstruct tile type rect)

(defun new-tile (whattype x y)
  (let ((a (make-tile :type whattype
                      :rect (make-record :rect :top y :left x 
                                         :bottom (+ y 20)
                                         :right (+ x 40)))))
    (push a tilestack)
    (update-rect (tile-rect a))
     a))

(defun get-pos (tile)
  (let ((therect (tile-rect tile)))
    (make-point (slot-value therect 'right) (slot-value therect 'bottom))))

(defun kill-tile ()  ;; Destroy a tile
  (let ((a (pop tilestack)))
    (if a 
      (update-rect (tile-rect a)))))

(defun move-tile (tile x y)
  (let ((r (tile-rect tile)))
    (#_rectrgn rgn1 r)
    (rset r :rect.top y)
    (rset r :rect.left x)
    (rset r :rect.bottom (+ y 20))
    (rset r :rect.right (+ x 40))
    (#_rectrgn rgn2 r)
    (#_unionrgn rgn1 rgn2 rgn1)
    (update-rgn rgn1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tile event handlers

(defun tile-window-click (where)
  (let ((which (find-tile where)))
    (if which (tile-click which where))))

(defun find-tile (where)
  (loop for i in tilestack
        if (#_ptinrect where (tile-rect i))
        do (return i)
        finally (return nil)))

(defun tile-click (which where)
  (bring-to-front which)
  ;; Display tile type in a dialog, if doubleclick
  (if (double-click-p) 
    (message-dialog (string (tile-type which)))) 
  ;; otherwise check for tile displacement
  (loop while (mouse-down-p)
        for newwhere = (view-mouse-position graphics-window)
        unless (eql where newwhere)
        do (displace-tile which
                          (point-h (subtract-points newwhere where))
                          (point-v (subtract-points newwhere where)))
           (setq where newwhere))
  ;; After mouse-up, snap tile into place...
  (rlet ((irect :rect))
    (let ((therect (slot-value which 'rect))
          (thestack (remove which tilestack)))
      (dolist (i (reverse thestack))
        (let ((temprect (slot-value i 'rect)))
          (if (#_sectrect temprect therect irect) 
            (move-tile which 
                       (rref temprect :rect.left) 
                       (rref temprect :rect.bottom))))))))

(defun bring-to-front (tile)
  (setq tilestack (remove tile tilestack))
  (push tile tilestack)
  (update-rect (tile-rect tile)))

(defun displace-tile (which dx dy)
  (let ((r (tile-rect which)))
    (move-tile which 
               (+ dx (rref r :rect.left))
               (+ dy (rref r :rect.top)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Display functions

;;; Offscreen-buffer (courtesy of Brian)
(defmacro offscreen (&rest forms)
  `(%stack-block ((ogd 4)(oport 4))
      (#_getgworld ogd oport)
      (#_setgworld offscreen (%null-ptr))
      (unwind-protect (progn ,@forms)
        (#_setgworld (%get-ptr ogd)(%get-ptr oport)))))

(defun init-offscreen ()
  (with-focused-view graphics-window
    (%stack-block ((result 4))
        (#_NewGWorld result 0 (pref (wptr graphics-window) :grafport.portrect) 
                  (%null-ptr)(%null-ptr) 0)
        (setq offscreen (%get-ptr result))
        (#_lockpixels (#_getgworldpixmap offscreen)))))

(defun update-rect (r)
  (rlet ((temprect :rect))
    (offscreen (#_eraserect r))
    (dolist (i (reverse tilestack))
      (let ((tr (slot-value i 'rect)))
        (if (#_sectrect tr r temprect)
          (offscreen (draw-tile i)))))
    (copy-from-offscreen r)))

(defun update-rgn (rgn)
  (offscreen (#_erasergn rgn))
  (dolist (i (reverse tilestack))
    (let ((tr (slot-value i 'rect)))
      (if (#_rectinrgn tr rgn)
        (offscreen (draw-tile i)))))
  (copy-from-offscreen  (pref (wptr graphics-window) :grafport.portrect) rgn))

(defun copy-from-offscreen (r &optional (rgn (%null-ptr)))
  (with-focused-view graphics-window
    (#_copybits (%inc-ptr offscreen 2) (%inc-ptr (wptr graphics-window) 2)
     r r 0 rgn)))

(defun draw-tile (r)
  (let ((therect (slot-value r 'rect)) 
        (thetype (slot-value r 'type)))
    (if (or (eql thetype 'sensor) (eql thetype 'switch))
      (draw-red-tile therect)
      (draw-blue-tile therect))))

(defun draw-red-tile (therect)
  (rlet ((frame-color :rgbcolor :red 10000 :green 10000 :blue 10000)
         (red-fill-color :rgbcolor :red 60000 :green 32000 :blue 32000))
    (#_pennormal)
    (#_rgbforecolor red-fill-color)
    (#_paintroundrect therect 15 15)
    (#_rgbforecolor frame-color)
    (#_pensize 2 2)
    (#_frameroundrect therect 15 15)))

(defun draw-blue-tile (therect)
  (rlet ((frame-color :rgbcolor :red 10000 :green 10000 :blue 10000)
         (blue-fill-color :rgbcolor :red 32000 :green 32000 :blue 60000))
    (#_pennormal)
    (#_rgbforecolor blue-fill-color)
    (#_paintrect therect)
    (#_rgbforecolor frame-color)
    (#_pensize 2 2)
    (#_framerect therect)))

(defun cleanup-windows ()
  (window-close palette-windoid)
  (#_disposergn rgn1)
  (#_disposergn rgn2)
  (setq tilestack nil))

(defun clear-graphics ()
  (setq tilestack nil)
  (view-draw-contents graphics-window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Main Graphics Window

(defun logo ()
  (setq tilestack nil)
  (setq graphics-window (make-instance 'window :window-type :document 
                                       :color-p t
                                       :view-size #@(600 300) 
                                       :view-position #@(30 45)
                                       :window-title "Logo"))
  (init-tools-palette)
  (init-offscreen)
  (defmethod view-draw-contents ((window (eql graphics-window)))
    (update-rect (rref (wptr graphics-window) :grafport.portrect)))
  (defmethod view-click-event-handler ((window (eql graphics-window)) where)
    (tile-window-click where))
  (defmethod window-close :before ((window (eql graphics-window)))
    (cleanup-windows)))

(defvar the-code)

(defun generate-code ()
  (setq the-code '("to <foo>"))
  (dolist (primitive (reverse tilestack))
    (case (slot-value primitive 'type)
      (sensor (setq the-code (append the-code '("when <sensora test>"))))
      (switch (setq the-code (append the-code '("when switcha"))))
      (on (setq the-code (append the-code '("a, on"))))
      (off (setq the-code (append the-code '("a, off"))))
      (rd (setq the-code (append the-code '("a, rd"))))
      (wait (setq the-code (append the-code '("wait <x>"))))
      (t (#_sysbeep 1))
      ))
  (setq the-code (append the-code '("end")))
  (select-item-from-list the-code :window-title "Logo Code"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Palette Windoid

(defvar sensor-view)
(defvar switch-view)
(defvar on-view)
(defvar off-view)
(defvar wait-view)
(defvar rd-view)

(defun init-tools-palette ()
  (setq palette-windoid (make-instance 'windoid 
                          :color-p t
                          :view-size #@(70 120)
                          :view-position #@(40 60)
                          :view-font '("geneva" 9)
                          :window-title "Logopalette"
                          ;:close-box-p nil
                          ))
  
  (setq sensor-view (make-instance 'view
                      :view-container palette-windoid
                      :view-size #@(34 29)
                      :view-position #@(0 0)))
  (setq switch-view (make-instance 'view
                      :view-container palette-windoid
                      :view-size #@(34 29)
                      :view-position #@(36 0)))
  (setq on-view (make-instance 'view
                      :view-container palette-windoid
                      :view-size #@(34 29)
                      :view-position #@(0 30)))
  (setq off-view (make-instance 'view
                      :view-container palette-windoid
                      :view-size #@(34 29)
                      :view-position #@(36 30)))
  (setq rd-view (make-instance 'view
                      :view-container palette-windoid
                      :view-size #@(34 29)
                      :view-position #@(0 60)))
  (setq wait-view (make-instance 'view
                      :view-container palette-windoid
                      :view-size #@(34 29)
                      :view-position #@(36 60)))   
                    
  (draw-palette)
  (defmethod view-draw-contents ((window (eql palette-windoid)))
    (call-next-method)
    (draw-palette))
  (defmethod view-click-event-handler ((window (eql palette-windoid)) where)
    (call-next-method)
    (palette-windoid-click where)))

;;; Palette windoid event handler
(defun palette-windoid-click (where)
  (cond ((view-contains-point-p sensor-view where) (new-tile 'sensor 300 100))
        ((view-contains-point-p switch-view where) (new-tile 'switch 310 100))
        ((view-contains-point-p on-view where) (new-tile 'on 300 110))
        ((view-contains-point-p off-view where) (new-tile 'off 310 110))
        ((view-contains-point-p rd-view where) (new-tile 'rd 300 120))
        ((view-contains-point-p wait-view where) (new-tile 'wait 310 120))
        (t (#_sysbeep 1))))

(defun draw-palette ()                      
  ;; Draw palette grid                    
  (with-focused-view palette-windoid
    (#_pennormal)
    (#_moveto 0 29)
    (#_lineto 70 29)
    (#_moveto 0 31)
    (#_lineto 70 31)
    (#_moveto 0 60)
    (#_lineto 70 60)
    (#_moveto 0 90)
    (#_lineto 70 90)
    (#_moveto 35 120)
    (#_lineto 35 0))
  ;; Draw palette items
  (rlet ((frame-color :rgbcolor :red 10000 :green 10000 :blue 10000)
         (fill-red :rgbcolor :red 60000 :green 32000 :blue 32000)
         (fill-blue :rgbcolor :red 32000 :green 32000 :blue 60000)
         (r1 :rect :topleft #@(2 6) :bottomright #@(33 24))
         (r2 :rect :topleft #@(38 6) :bottomright #@(68 24))
         (r3 :rect :topleft #@(2 38) :bottomright #@(33 55))
         (r4 :rect :topleft #@(38 38) :bottomright #@(68 55))
         (r5 :rect :topleft #@(2 66) :bottomright #@(33 83))
         (r6 :rect :topleft #@(38 66) :bottomright #@(68 83))
         )
    (with-focused-view palette-windoid
      (#_rgbforecolor fill-red)
      (#_paintroundrect r1 15 15) ; sensor
      (#_paintroundrect r2 15 15) ; switch
      (#_rgbforecolor fill-blue)
      (#_paintrect r3)            ; on
      (#_paintrect r4)            ; off
      (#_paintrect r5)            ; rd
      (#_paintrect r6)            ; wait
      (#_rgbforecolor frame-color)
      (#_pensize 2 2)
      (#_frameroundrect r1 15 15)
      (#_frameroundrect r2 15 15)
      (#_framerect r3)
      (#_framerect r4)
      (#_framerect r5)
      (#_framerect r6)
      (with-pstrs ((sensor-string "Sens") (switch-string "Swch") 
                   (on-string "On") (off-string "Off") 
                   (wait-string "Wait") (rd-string "Rd"))
        (#_moveto 7 18)
        (#_drawstring sensor-string)
        (#_moveto 41 18)
        (#_drawstring switch-string)
        (#_moveto 12 50)
        (#_drawstring on-string)
        (#_moveto 45 50)
        (#_drawstring off-string)
        (#_moveto 12 78)
        (#_drawstring rd-string)
        (#_moveto 44 78 )
        (#_drawstring wait-string)
        ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Setup Menubar

(defvar *user-menubar* (menubar))

(defparameter *logobar*
  (list (car *default-menubar*)
        (make-instance 'menu
                       :menu-title "File"
                       :menu-items
                       (list (make-instance 'menu-item
                               :menu-item-title "New Logo Window"
                               :menu-item-action #'(lambda nil (logo))
                               :command-key #\N)
                             (make-instance 'menu-item
                               :menu-item-title "Open..."
                               :disabled t
                               :menu-item-action
                               'choose-file-dialog
                               :command-key #\O)
                             (make-instance 'menu-item
                               :menu-item-title "-"
                               :disabled t)
                             (make-instance 'menu-item
                               :menu-item-title "Close"
                               :menu-item-action
                               #'(lambda nil (window-close graphics-window))
                               :command-key #\W)
                             (make-instance 'menu-item
                               :menu-item-title "Save"
                               :disabled t
                               :command-key #\S
                               :menu-item-action 'window-save)
                             (make-instance 'menu-item
                               :menu-item-title "Save As..."
                               :disabled t
                               :menu-item-action 'window-save-as)
                             (make-instance 'menu-item
                               :menu-item-title "-"
                               :disabled t)
                             (make-instance 'menu-item
                               :menu-item-title "Quit"
                               :menu-item-action
                               'quit)))
        (make-instance 'menu
                       :menu-title "Edit"
                       :menu-items
                       (list (make-instance 'menu-item
                                            :menu-item-title "Undo"
                                            :disabled t
                                            :command-key #\Z
                                            :menu-item-action 'undo)
                             (make-instance 'menu-item
                                            :menu-item-title "-"
                                            :disabled t)
                             (make-instance 'window-menu-item
                                            :menu-item-title "Cut"
                                            :command-key #\X
                                            :menu-item-action 'cut)
                             (make-instance 'window-menu-item
                                            :menu-item-title "Copy"
                                            :command-key #\C
                                            :menu-item-action 'copy)
                             (make-instance 'window-menu-item
                                            :menu-item-title "Paste"
                                            :command-key #\V
                                            :menu-item-action 'paste)
                             (make-instance 'window-menu-item
                                            :menu-item-title "Clear"
                                            :menu-item-action 'clear)
                             (make-instance 'menu-item
                                            :menu-item-title "-"
                                            :disabled t)
                             (make-instance 'menu-item
                                            :menu-item-title "Clear screen"
                                            :menu-item-action #'(lambda ()
                                                                  (clear-graphics)))
                             (make-instance 'menu-item
                                            :menu-item-title "-"
                                            :disabled t)
                             (make-instance 'menu-item
                                            :menu-item-title "Original Menubar"
                                            :menu-item-action #'(lambda ()
                                                                  (set-menubar *user-menubar*)))))
        (make-instance 'menu
                       :menu-title "Eval"
                       :menu-items
                       (list (make-instance 'menu-item
                                            :menu-item-title "Generate Logo Code"
                                            :menu-item-action 
                                            #'(lambda nil
                                                (generate-code)))))
        (make-instance 'menu
                       :menu-title "Help"
                       :menu-items
                       (list (make-instance 'menu-item
                                            :menu-item-title "About"
                                            :menu-item-action
                                            #'(lambda nil
                                                (message-dialog "Visual Logo        Ver. 0")))))))

;;; Load the new menubar and GO!
;;; Choose "New Logo Window" from File menu                            
(set-menubar *logobar*)