;; -*- rcs-header: "$Header: /hope/cam1/hope.5/compound/33/LISPcapi-examples/RCS/graphics:pinboard-test.lisp,v 1.8.1.1.1.1 1998/11/26 01:08:39 nick Exp $" -*-

;;----------------------------------------------------------------------------
;;
;; examples/capi/graphics/pinboard-test.lisp
;;
;; This example demonstrates the uses of pinboard-objects and
;; pinboard-layouts in the CAPI.
;;
;; To try it, compile and load this file and then execute:
;;
;;      (CL-USER::TEST-PINBOARD)
;;
;;----------------------------------------------------------------------------
;; #<harlequin copyright marker>
;;----------------------------------------------------------------------------


(in-package "CL-USER")


;;----------------------------------------------------------------------------
;; Define an interface
;;----------------------------------------------------------------------------

(capi:define-interface pinboard-test ()
  ((new-class :accessor new-class :initform nil)
   (start-x :accessor start-x)
   (start-y :accessor start-y)
   (last-x :accessor last-x)
   (last-y :accessor last-y))
  (:panes
   (shape-buttons
    capi:radio-button-panel
    :accessor shape-buttons
    :title "Shape:"
    :title-position :top
    :layout-class 'capi:column-layout
    :items '(square ellipse text)
    :print-function 'string-capitalize)
   (color-buttons
    capi:radio-button-panel
    :accessor color-buttons
    :title "Color:"
    :title-position :top
    :layout-class 'capi:column-layout
    :items '(:red :green :blue :black :white)
    :print-function 'string-capitalize)
   (style-buttons
    capi:radio-button-panel
    :accessor style-buttons
    :title "Style:"
    :title-position :top
    :layout-class 'capi:column-layout
    :items '(:solid :outline)
    :print-function 'string-capitalize))
  (:layouts
   (pinboard
    capi:pinboard-layout
    '()
    :background :white
    :input-model '(((:button-1 :press)   press-button-1)
                   ((:motion :button-1)  drag-button-1)
                   ((:button-1 :release) release-button-1)
                   ((:button-2 :press)   press-button-2))
    :drawing-style (:initarg :display-type)
    :vertical-scroll t
    :horizontal-scroll t
    :min-width 500
    :min-height 500)
   (button-layout
    capi:column-layout
    '(shape-buttons color-buttons style-buttons)
    :y-gap 10)
   (sub-layout
    capi:column-layout
    '(pinboard)
    :title "Drag button 1 to add an object and button 2 to delete one")
   (main-layout
    capi:row-layout
    '(button-layout sub-layout)
    ))
  (:default-initargs
   :layout 'main-layout
   :title "Pinboard Test"
   :best-height 400
   :best-width 200))

(defun pinboard-test-color (pinboard-test)
  (capi:choice-selected-item (color-buttons pinboard-test)))

(defun pinboard-test-filled (pinboard-test)
  (eq (capi:choice-selected-item (style-buttons pinboard-test)) :solid))

(defun pinboard-test-shape (pinboard-test)
  (capi:choice-selected-item (shape-buttons pinboard-test)))


;;----------------------------------------------------------------------------
;; A few useful utilities
;;----------------------------------------------------------------------------

;; x-y-width-and-height is a simple function which given two coordinates
;; returns the top-left x and y, and the width and height
(defun x-y-width-and-height (x1 y1 x2 y2)
  (values (min x1 x2)
          (min y1 y2)
          (abs (- x1 x2))
          (abs (- y1 y2))))

;; WITH-XOR makes all graphics-port operations done within its body be drawn
;; using exclusive-or.
(defmacro with-xor ((port) &body body)
  `(gp:with-graphics-state (,port
                            :foreground (gp:compute-xor-pixel ,port)
			    :operation boole-xor)
    ,@body))


;;----------------------------------------------------------------------------
;; Define a square pinboard-object
;;----------------------------------------------------------------------------

(defclass square (capi:pinboard-object)
  ((foreground :accessor foreground :initform nil :initarg :foreground)
   (filled :accessor filled :initform nil :initarg :filled))
  (:default-initargs
   :min-width 30
   :min-height 30))

(defmethod capi:draw-pinboard-object (pinboard (square square) &key)
  (capi:with-geometry square
    (let ((filled? (filled square)))
      (gp:draw-rectangle pinboard
                         capi:%x% capi:%y%
                         (if filled? capi:%width% (1- capi:%width%))
                         (if filled? capi:%height% (1- capi:%height%))
                         :foreground (or (foreground square)
				         (capi:simple-pane-foreground pinboard))
                         :filled filled?))))

(defmethod draw-object-outline (pinboard (square square) x1 y1 x2 y2)
  (multiple-value-bind
      (x y width height)
      (x-y-width-and-height x1 y1 x2 y2)
    (with-xor (pinboard)
      (gp:draw-rectangle pinboard x y width height))))


;;----------------------------------------------------------------------------
;; Define an ellipse pinboard object
;;----------------------------------------------------------------------------

(defclass ellipse (capi:pinboard-object)
  ((foreground :accessor foreground :initform nil :initarg :foreground)
   (filled :accessor filled :initform nil :initarg :filled))
  (:default-initargs
   :min-width 30
   :min-height 30))

(defmethod capi:draw-pinboard-object (pinboard (ellipse ellipse) &key)
  (capi:with-geometry ellipse
    (let ((x-radius (floor (1- capi:%width%) 2))
          (y-radius (floor (1- capi:%height%) 2)))
      (gp:draw-ellipse pinboard
		       (+ capi:%x% x-radius)
                       (+ capi:%y% y-radius)
                       x-radius
                       y-radius
		       :foreground (or (foreground ellipse)
                                       (capi:simple-pane-foreground pinboard))
                       :filled (filled ellipse)))))

(defmethod draw-object-outline (pinboard (ellipse ellipse) x1 y1 x2 y2)
  (multiple-value-bind
      (x y width height)
      (x-y-width-and-height x1 y1 x2 y2)
    (let ((x-radius (floor width 2))
          (y-radius (floor height 2)))
      (with-xor (pinboard)
        (gp:draw-ellipse pinboard 
			 (+ x x-radius)
			 (+ y y-radius)
			 x-radius
			 y-radius)))))


;;----------------------------------------------------------------------------
;; Define a text pinboard object
;;----------------------------------------------------------------------------

(defclass text (capi:pinboard-object)
  ((foreground :accessor foreground :initform nil :initarg :foreground)
   (filled :accessor filled :initform nil :initarg :filled))
  (:default-initargs
   :min-width 30
   :min-height 30))

(defmethod capi:draw-pinboard-object (pinboard (text text) &key)
  (capi:with-geometry text
    (let ((foreground (or (foreground text) (capi:simple-pane-foreground pinboard)))
          (background (capi:simple-pane-background pinboard))
          (filled (filled text)))
      (gp:draw-x-y-adjusted-string pinboard
                                   "This is a test."
		                   capi:%x%
		                   capi:%y%
                                   :y-adjust :top
                                   :foreground (if filled background foreground)
                                   :background (if filled foreground background)
                                   :block (filled text)))))

(defmethod draw-object-outline (pinboard (text text) x1 y1 x2 y2)
  (multiple-value-bind
      (x y width height)
      (x-y-width-and-height x1 y1 x2 y2)
    (with-xor (pinboard)
      (gp:draw-rectangle pinboard x y width height))))


;;----------------------------------------------------------------------------
;; The callbacks
;;----------------------------------------------------------------------------

(defun press-button-1 (pinboard x y)
  (let* ((interface (capi:element-interface pinboard))
         (shape (pinboard-test-shape interface)))
    (setf (new-class interface) (clos:class-prototype (find-class shape)))
    (setf (start-x interface) x)
    (setf (start-y interface) y)
    (setf (last-x interface) nil)))

(defun drag-button-1 (pinboard x y)
  (let* ((interface (capi:element-interface pinboard))
         (object (new-class interface)))
    (when (last-x interface)
      (draw-object-outline pinboard object
                           (start-x interface) (start-y interface)
                           (last-x interface) (last-y interface)))
    (setf (last-x interface) x
          (last-y interface) y)
    (draw-object-outline pinboard object
                         (start-x interface) (start-y interface)
                         (last-x interface) (last-y interface))))

(defun release-button-1 (pinboard x y)
  (let* ((interface (capi:element-interface pinboard))
         (object (new-class interface))
         (old-x (start-x interface))
         (old-y (start-y interface))
         (color (pinboard-test-color interface))
         (filled (pinboard-test-filled interface))
         (width (abs (- old-x x)))
         (height (abs (- old-y y))))

    ;; Remove the outline
    (when (last-x interface)
      (draw-object-outline pinboard object
                           (start-x interface) (start-y interface)
                           (last-x interface) (last-y interface)))

    ;; Create the appropriate pinboard-object and place it into
    ;; the pinboard-layout. We append it to the end of the list so
    ;; that it appears on top.
    (when (and (> width 1)
               (> height 1))
      (setf (capi:layout-description pinboard)
            (append (capi:layout-description pinboard)
                    (list
                     (make-instance (class-of object)
                                    :foreground color
                                    :filled filled
                                    :x (min old-x x)
                                    :y (min old-y y)
                                    :min-width  width
                                    :min-height height)))))))

(defun press-button-2 (pinboard x y)
  (let ((object (capi:pinboard-object-at-position pinboard x y)))
    (when object
      (setf (capi:layout-description pinboard)
            (remove object (capi:layout-description pinboard))))))


;;----------------------------------------------------------------------------
;; The test function
;;----------------------------------------------------------------------------

(defun test-pinboard ()
  (capi:display (make-instance 'pinboard-test :display-type :local-pixmap)))