#|

     class17.lsp   

    - OOP and a regression object

    - Exploring a built-in graphics object

    - Elements that support event-driven programming (more next time)

|#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                         ;;
;;    Defining a regression object prototype.              ;;
;;                                                         ;;
;;                                 Tierney, Chapter 6      ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;---  Define the prototype first  (can skip common slot/parent in this case)

  (defproto regr-proto 
    '(q r x y n ; q&r from x, input data
       c b      ; q slopes, x slopes
      recalc?   ; set to (x), (y), or (x y) when data changes
     )
    '()         ; no slots with value common to all instances
    *object*    ; single parent is 'mother' of all objects  
    ) 

  
;---  Creator method sets up each instance.  Gets called automagically by
;     the :new method of *object*.  Example of inherited behavior.

  (defmeth regr-proto :ISNEW (x y)
    (send self :x x)              ; slot-value function accesses slots
    (send self :y y)
    (setf (slot-value 'n) (length y))
    )                             ; undefined slots default to nil


;---  Accessor method provide read/write access to internals.  Make sure
;     data is in proper form.  Don't provide accessors to "private" slots.

  (defmeth regr-proto :X (&optional newx)
    ; Converts input x to an array with leading const col.
    ; Returns value of slot.
    (if newx
        (let* ((x (if (arrayp newx) newx 
                     (apply #'bind-columns newx))))
          (push 'x (slot-value 'recalc?))
          (setf (slot-value 'x) 
                (bind-columns (repeat 1 (array-dimension x 0)) x))
          )
        (slot-value 'x)
        ))

  (defmeth regr-proto :Y (&optional newy)
    (when newy
          (push 'y (slot-value 'recalc?))
          (setf (slot-value 'y) newy))
    (slot-value 'y))


;--- Computing slopes, etc

  (defmeth regr-proto :COEFFICIENTS ()
    (send self :recalc)
    (slot-value 'b))

  (defmeth regr-proto :RESIDUALS ()
    (send self :recalc)
    (- (slot-value 'y) (matmult (slot-value 'q) 
                                (slot-value 'c)))
    )

  (defmeth regr-proto :FIT-VALUES ()
    (- (slot-value 'y) (send self :residuals))
    )

  (defmeth regr-proto :RECALC ()
    (when (slot-value 'recalc?)
          (if (member 'x (slot-value 'recalc?) ) (send self :decomp))
          (send self :calc-coef)
          (setf (slot-value 'recalc?) nil)
          ))

  (defmeth regr-proto :DECOMP ()
    (format t "Performing QR decomp...~%")
    (let ((qr (qr-decomp (slot-value 'x)))  )
      (def save qr)
      (setf (slot-value 'q) (first qr))
      (setf (slot-value 'r) (second qr))
      ))

  (defmeth regr-proto :CALC-COEF ()
    (format t "Updating slope estimates...~%")
    (setf (slot-value 'b)
          (solve
           (slot-value 'r)
           (setf (slot-value 'c)
                 (matmult (transpose (slot-value 'q)) (slot-value 'y))
                 ))))

;--- Plots

  (defmeth regr-proto :PLOT-RESIDUALS ()
    (let* ((r (send self :residuals))
           (f (send self :fit-values))
           (p (plot-points f r :variable-labels '("Fit Values" "Residuals")))  )
      (send p :title "Residual Plot")
      (send p :abline 0 0)
      ))


#| 
;--- Examples of use

  (def xx (list '(1 2 3 4 5 6 7) '(1 3 2 4 5 6 6)))
  (def yy '(1 4 2 3 5 7 7))

  (def ro (send regr-proto :new xx yy))

  (send ro :method-selectors)
  (send ro :slot-names)
  (send ro :parents)
  (send ro :show)

  (send ro :plot-residuals)

  (send ro :y '(1 2 3 4 5 6 7))
  (send ro :plot-residuals)

  (send ro :slot-value 'q)  ; access "hidden slot"
  (send ro :slot-value 'c)  ; access another "hidden slot"


|#  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                         ;;
;;    Exploring LispStat's graphics objects.               ;;
;;                                                         ;;
;;                              Tierney, Chapter (7),8     ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|

;--- Most basic windows; not instantiated.

  (send window-proto :method-selectors)

;--- Drawing window

  (def w (send graph-window-proto :new))
  
  (send w :method-selectors)
  (send w :slot-names)
  (send w :show)

  (send w :show-window)
  (send w :remove)

;--- Drawing properties  (not permanent!)

  (send w :draw-line 0 0 100 100) ; from pt, to pt

  (send w :draw-mode 'xor)
  (send w :draw-line 0 0 100 100)
  (send w :draw-mode 'normal)
 
  *colors*  

  (send w :use-color t)
  (send w :draw-color 'red)
  (send w :draw-line 0 0 100 100)
  (send w :draw-color 'blue)
  (send w :paint-rect 100 100 50 50) ; top left xSize ySize
  (send w :draw-color 'green)
  (send w :paint-arc 125 125 60 60 0 135)   ; rect followed by start, end angles
  (send w :draw-color 'magenta)
  (send w :paint-poly '((0 100) (20 120) (40 180) (20 180)))

  (send w :erase-window) ; or simply resize

  (send w :draw-text "String" 100 100 1 1)  ; centered, below


;--- Redraw and maintaining text on screen for THIS window

  (send w :add-slot 'cx)
  (send w :add-slot 'cy)

  (defmeth w :RESIZE ()   ;override prior
    (setf (slot-value 'cx) (round (/ (send self :canvas-width) 2)))
    (setf (slot-value 'cy) (round (/ (send self :canvas-height) 2)))
    )

  (defmeth w :REDRAW ()
    (format t "Color is ~a~%"
             (send self :draw-color
                   (elt *colors* (random (length *colors*)))))
    (format t "Center is ~a , ~a~%" (slot-value 'cx) (slot-value 'cy))
    (send self :draw-text "String" 
          (slot-value 'cx) (slot-value 'cy)
          1 1))
|#   
      
;--- Define a new type of window

  (defproto STRING-WINDOW-PROTO 
    '(cx cy string)
    '()
    graph-window-proto)

  (defmeth string-window-proto :STRING (s)
    (setf (slot-value 'string) s)
    (send self :resize)
    (send self :redraw)
    )

  (defmeth string-window-proto :RESIZE ()   ;override prior
    (setf (slot-value 'cx) (round (/ (send self :canvas-width) 2)))
    (setf (slot-value 'cy) (round (/ (send self :canvas-height) 2)))
    )

  (defmeth string-window-proto :REDRAW ()
    (when (slot-value 'string)
          (send self :draw-color
                (elt *colors* (random (length *colors*))))
          (send self :draw-text (slot-value 'string)
                (slot-value 'cx) (slot-value 'cy)
                1 1)
          ))

#|
  
;--- Create string window

  (def sw (send string-window-proto :new))

  (send sw :string "Test String")


;--- Mouse tracking via the DO-MOTION, DO-CLICK methods

  (defmeth sw :DO-MOTION (x y)
    (setf (slot-value 'cx) x)
    (setf (slot-value 'cy) y)
    (send self :redraw)
    )

  (send sw :delete-method :do-motion)

  (defmeth sw :DO-CLICK (x y s o)
    (setf (slot-value 'cx) x)
    (setf (slot-value 'cy) y)
    (if s (send self :erase-window))
    (send self :redraw)
    )

  (defmeth sw :DO-CLICK (x y s o)
    (let ((old (send self :cursor))  )
      (send self :cursor 'hand)
      (flet ((tracker (x y)
                      (setf (slot-value 'cx) x)
                      (setf (slot-value 'cy) y)
                      (if s (send self :erase-window))
                      (send self :redraw))  )
        (tracker x y)
        (send self :while-button-down #'tracker))
      (send self :cursor old)
      ))

|#