(defpackage utest (:use :clim :clim-lisp))
(in-package :utest)

(defclass unit ()())
(define-presentation-type unit ())

(defclass test-unit (unit)
  ((x-value :initarg :x :accessor x-of)
   (y-value :initarg :y :accessor y-of)
   (color   :initarg :color
            :accessor color-of)
   (size :initform 10))
  (:default-initargs
   :x 10 :y 10 :color +green+))

(defmethod print-object ((obj test-unit) stream)
  (print-unreadable-object (obj stream :type t)
    (format stream "<~d ~d>"
            (x-of obj)(y-of obj))))

(defclass example-pane (application-pane)
  ((units :initform nil
          :initarg :units
          :accessor units-of)
   (dx :initform 10)
   (dy :initform 10))
  (:default-initargs
   :width  300
   :height 300
   :incremental-redisplay t
   :display-function 'example-pane-displayer))

(defmethod draw-unit ((pane example-pane)(unit test-unit))
  (with-slots ((x x-value) (y y-value) size color) unit
    (format *trace-output* "~&draw-unit ~a~%" unit)
    (updating-output (pane :unique-id unit
                           :cache-value (list* x y size color)
                           :cache-test #'equalp)
      (with-output-as-presentation (pane unit 'unit)
        (format *trace-output* "~&--draw-circle~%")
        (draw-circle* pane x y size :ink (color-of unit))))))

#+notyet
(define-presentation-method highlight-presentation
  ((type unit) record stream state)
  (with-bounding-rectangle* (x0 y0 xz yz) record
    (declare (ignorable xz yz))
    (let ((ink (if (eql state :highlight) +flipping-ink+ +background-ink+)))
      (draw-rectangle* stream (1- x0)(1- y0) xz yz
                       :ink ink :filled nil))))

(defmethod example-pane-displayer (frame (pane example-pane))
  (declare (ignore frame)) ; need tracking-pointer here - see plotter
  (with-bounding-rectangle* (x1 y1 x2 y2) pane
    (updating-output (pane :cache-value (list* x1 y1 x2 y2)
                           :cache-test #'equalp)
      (draw-rectangle* pane x1 y1 x2 y2 :ink +blue+ :filled nil))
    (with-first-quadrant-coordinates (pane x1 y2)
      (dolist (unit (units-of pane))
        (draw-unit pane unit))
      )))

(define-application-frame utest ()
  ((x-dim :initform 'x :initarg :x-dim)
   (y-dim :initform 'y :initarg :y-dim))
  (:menu-bar t)
  #-mcclim(:command-table t)
  #+mcclim(:command-table (utest))
  (:panes
   (p1
    (make-pane 'example-pane
               :units (list (make-instance
                             'test-unit :x 150 :y 150
                             :color +green+)
                            (make-instance
                             'test-unit :x 250 :y 50
                             :color +blue+))
               :width 300 :height 300
               :max-width +fill+
               :max-height +fill+
               )))
  (:layouts 
   (default  p1)))

(define-utest-command (com-move-unit)((which '(member :x :y))
                                      (unit 'test-unit)
                                      (pane 'example-pane)
                                      (direction '(member :up :down
                                                          :left :rignt)))
  (declare (ignorable pane))
  (with-slots (x-value y-value) unit
    (let ((incr 5.0))
      (case which
        (:x (incf x-value (case direction (:left (- incr))(:right incr))))
        (:y (incf y-value (case direction (:up incr)(:down (- incr))))))
      )))

(define-presentation-to-command-translator xlate-move-unit-l
    (blank-area com-move-unit utest
                  :pointer-documentation "Move Left"
                  :gesture :select)
    ;; object is blank-area
    (object window x y)
  (declare (ignore object x y)) (terpri *trace-output*)
  (let* ((units (units-of window))
         (unit (first units)))
    `(:x ,unit ,window :left)))

(define-presentation-to-command-translator xlate-move-unit-r
    (blank-area com-move-unit utest
                  :pointer-documentation "Move Right"
                  :gesture :menu)
    ;; object is blank-area
    (object window x y)
  (declare (ignore object x y))
  (let* ((units (units-of window))
         (unit (first units)))
    `(:x ,unit ,window :right)))

(defun testme ()
  (run-frame-top-level
   (make-application-frame 'utest
     :left 950 :top 40)))