(defpackage :seuss (:use :common-lisp :ccl))
;; This is sort of the Dr. Seuss of graphics packages: just a few simple primitives to hopefully
;; help people get started using the OpenMCL-Cocoa Bridge.

;; All this does is allow you to open a window, which contains an "ns-view" object, subclassed
;; as a "cocoa-view".  You can then draw various simple things on the view.  The view 
;; maintains its picture when the window moves, but not when the window is miniaturized
;; and then restored to normal size.  For the view contents to get redrawn everytime the window is
;; occluded or resized, you need to include the drawing code in the view's drawRect method (see drawRect below).

;; The main point of this file is to provide the primitive drawing routines that might save
;; people some digging through COCOA and Objective-C manuals, as well as through the
;; Cocoa Bridge documentation.  Or at least it will give you some indication of WHERE
;; to dig if you want to draw a rectangle, for example.

;; Obviously, there is no claim of optimality with any of this stuff.  It does seem
;; to get the job done for my very primitive graphic needs on the 64-bit Mac.  So if you have similarly
;; primitive needs, this may get you started.

(in-package :SEUSS)

;; *** GLOBAL VARIABLES ***

;;   ** Line Styles **
(defvar *kd-solid-line-style* nil)
(defvar *kd-dotted-line-style* nil)
(defvar *kd-dashed-line-style* nil)
(defvar *kd-dash-dot-line-style* nil)
(defvar *kd-dash-dot-dot-line-style* nil)
(defvar *kd-line-styles* nil)

;;  ** Colors **

(defvar *kd-black-color*  (#/ blackColor ns:ns-color) )
(defvar *kd-white-color*  (#/ whiteColor ns:ns-color))
(defvar *kd-red-color*  (#/ redColor ns:ns-color))
(defvar *kd-green-color*  (#/ greenColor ns:ns-color))
(defvar *kd-blue-color*  (#/ blueColor ns:ns-color) )
(defvar *kd-yellow-color*  (#/ yellowColor ns:ns-color) )
(defvar *kd-gray-color*  (#/ grayColor ns:ns-color) )
(defvar *kd-orange-color*  (#/ orangeColor ns:ns-color))
(defvar *kd-brown-color*  (#/ brownColor ns:ns-color) )

;; *** Macros ****

(defmacro with-focused-view (view &body forms)
  `(when (#/lockFocusIfCanDraw ,view)
     (unwind-protect
	  (progn ,@forms)
       (#/unlockFocus ,view)
       (#/flushGraphics (#/currentContext ns:ns-graphics-context))
       (#/flushWindow (#/window ,view)))))

;; **** CLASSES ****

(defclass cocoa-window ()
  ((cocoa-view :accessor cocoa-view)
   (ns-window :accessor ns-window))
  (:documentation "This could include more, such as the window dimensions, background color, etc., etc."))


(defclass cocoa-view (ns:ns-view)
  ((cocoa-window :accessor cocoa-window :initarg :cocoa-window)
   (draw-func :accessor draw-func :initarg :draw-func :initform nil))  ;; Code that draws all contents of the view
  (:metaclass ns:+ns-object
	      :documentation "The only view within a cocoa window"))

(defclass line-style-spec ()
  ((lisp-array :initarg :lisp-array :accessor lisp-array)
   (cocoa-array :accessor cocoa-array) ;; OpenMCL wants us to keep both the C array and the pointer for ease of deallocation
   (cocoa-array-ptr :accessor cocoa-array-ptr)  ;; Same array in objective c
  ))




;; ******* UTILITY FUNCTIONS *****

;; Most items that are drawn are part of a bezier path.

(defun create-bezier-path () (#/bezierPath ns:ns-bezier-path))

;; Convert a lisp string into a cocoa string
(defun make-cocoa-string (s) (make-instance 'ns:ns-string :init-with-string s))

;; Before doing most drawing operations, call this to set the color, line style, etc.

(defun set-cocoa-line-specs (path &key (width 1.0) (line-style *kd-solid-line-style*) (line-color *kd-black-color*)
                                  (fill-color *kd-black-color*))

   (#/setLineWidth: path width) ;; These 2 calls change the current colors of the stroke (line) and fill.
   (#/setStroke line-color)    ;;  They apply to all paths.
   (if (equal (type-of line-style) 'line-style-spec)
       (#/setLineDash:count:phase: path (cocoa-array-ptr line-style)  (length (lisp-array line-style)) 0.0))
   (if fill-color (#/setFill fill-color))
)  

;; Paints the entire view a single color
(defun kd-flood-cocoa-view (view &key (color *kd-white-color*))
  (with-focused-view view
  (let ((rect (#/bounds view)))
    (#/setFill color)
    (#_NSRectFill rect))))

(defun kdwait (secs)
   (let* ((target (+ (round (* secs internal-time-units-per-second)) (get-internal-real-time))))
     (loop while (< (get-internal-real-time) target))))


(defun kdwait (secs)
   (sleep secs)
)


;; ****** LINE TYPES ******
;; In Cocoa, the line types are coded as arrays of alternating lengths (line-segment gap line-segment gap).  Here, I define these
;; arrays in LISP first and then generate the corresponding objective-C arrays.  It is these obj-C arrays that are then sent to the
;; drawing routines.



(defun create-kd-line-styles ()
  (let ((specs nil))
    (labels ((make-spec (elems) 
               (let ((spec (make-instance 'line-style-spec :lisp-array (make-array (length elems) :element-type 'integer :initial-contents elems))))
                 (push spec specs)
                 spec)))
       (setf *kd-solid-line-style* (make-spec '(10 0)))
       (setf *kd-dotted-line-style* (make-spec '(3 4)))
       (setf *kd-dashed-line-style* (make-spec '(50 30)))
       (setf *kd-dash-dot-line-style* (make-spec '(32 8 6 8)))
       (setf *kd-dash-dot-dot-line-style* (make-spec '(32 8 6 8 6 8)))
       (setf *kd-line-styles* (nreverse specs))
       (gen-cocoa-line-style-arrays *kd-line-styles*))))


(defun gen-cocoa-line-style-arrays (line-specs)
  (dolist (spec line-specs)
    (let* ((a1 (lisp-array spec)))
      (multiple-value-bind (a2 a2-ptr)
           (make-heap-ivector (length a1) '(double-float * *))
         (setf (cocoa-array spec) a2)
         (setf (cocoa-array-ptr spec) a2-ptr)
         (dotimes (i (length a1))
             (setf (aref a2 i) (float (aref a1 i) 0.0d0 )))))))

;; **** COLORS ****


;; This actually creates the rgb objects
(defun kd-create-rgb (r g b &key (opacity 1.0)) (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color r g b opacity))

(defun kd-rgb-red (color) (#/redComponent color))
(defun kd-rgb-green (color) (#/greenComponent color))
(defun kd-rgb-blue (color) (#/blueComponent color))

(create-kd-line-styles) ;; Create the line types when the file is loaded

;; *** 2D POINTS *****

(defun kd-make-pt (x y) (ns:make-ns-point (float x) (float y)))

(defun kd-make-rounded-pt (x y) (ns:make-ns-point (float (round x)) (float (round y))))

(defun kd-point-x (pt)  (ns:ns-point-x pt))

(defun kd-point-y (pt) (ns:ns-point-y pt))


;; ****** BASIC WINDOW OPERATIONS *****

;; This gets called everytime the ns-view object gets redrawn.  So this is the obvious place to insert code
;; for drawing the contents of a view.

(objc:defmethod (#/drawRect: :void) ((self cocoa-view) (rect :<NSR>ect))
  (if (draw-func self) 
    (with-focused-view self
           (funcall (draw-func self) self))))


(defmethod initialize-instance ((Self cocoa-window) &rest Initargs)
  (declare (ignore Initargs))
  (call-next-method)
  (ccl::with-autorelease-pool
   (setf (ns-window Self) (make-instance 'ns:ns-window
			    :with-content-rect (ns:make-ns-rect 0 0 300 300)
			    :style-mask (logior #$NSTitledWindowMask
						#$NSClosableWindowMask
						#$NSResizableWindowMask
					       #$NSMiniaturizableWindowMask
						#$NSMiniaturizableWindowMask)
			    :backing #$NSBackingStoreBuffered
			    :defer t))
   (setf (cocoa-view Self) (make-instance 'cocoa-view :cocoa-window Self))
   (#/setContentView: (ns-window Self) (#/autorelease (cocoa-view Self)))
   (#/center (ns-window Self))
   (#/orderFront: (ns-window Self) nil)
   (#/contentView (ns-window Self))))


;; The simple window is really just the cocoa-view object within the window.  For our purposes, we shouldn't have to deal
;; with the window at all, just the view.  When we need the window itself, the call (#/window view) provides it.

(defun kd-make-simple-window ()
  (cocoa-view (make-instance 'cocoa-window)))

;; Now we're just working with the view object

(defun kd-window-clear (cview &key (background-color *kd-white-color*))
   (kd-flood-cocoa-view cview :color background-color))

(defun kd-window-move (cview x y)
  (with-focused-view cview (#/setFrameOrigin: (#/window cview) (kd-make-pt x y))))

(defun kd-window-resize (cview width height)
  (with-focused-view cview
      (let ((new-rect (ns:make-ns-rect (ns:ns-rect-x (#/frame (#/window cview))) (ns:ns-rect-y (#/frame (#/window cview))) width height)))
        (#/setFrame:display: (#/window cview) new-rect t))))

(defun kd-window-close (cview)
  (#/close (#/window cview)))

;; Getting the size of the view

(defun kd-window-inside-width (cview)
  (ns:ns-rect-width (#/bounds cview)))

(defun kd-window-inside-height (cview)
   (ns:ns-rect-height (#/bounds cview)))


;; *********** DRAWING PRIMITIVES ************

;; All of these are wrapped with with-focused-view in case you want to call them directly from the listener.  Otherwise, they are
;; automatically wrapped in the drawRect method.

;; All of these receive the cocoa-view object (cocoa-view) and direct their output to it via with-focused-view.  In COCOA, the origin point, (0,0), of a view is in the
;; bottom left corner.

(defun kd-draw-line* (cview x1 y1 x2 y2 
                        &key (ink *kd-black-color*) (label nil) (thickness 1.0)
                             (line-style *kd-solid-line-style*)) ;; options = :solid, :dot, :dash, :dash-dot, 
                                                   ;; :double-dot, :long-dash, :dash-double-dot
        (with-focused-view cview
          (let ((path (create-bezier-path)))
            (set-cocoa-line-specs path :width thickness :line-color ink :line-style line-style :fill-color nil)
	    (#/moveToPoint: path (kd-make-pt x1 y1))
	    (#/lineToPoint: path (kd-make-pt x2 y2))
	    (#/stroke path))
       

       (if label (kd-draw-text* cview label (round (/ (+ x1 x2) 2)) (round (/ (+ y1 y2) 2))))))

;; x and y are coordinates of the LOWER LEFT corner.  
(defun kd-draw-rectangle* (cview x y width height
                            &key (ink *kd-black-color*) (thickness 1.0)
                             (line-style *kd-solid-line-style*)
                             (filled nil) (fill-color *kd-black-color* fill-supplied?))
(with-focused-view cview
  (if (and filled (not fill-supplied?))
      (setf fill-color ink))

    (let ((rect (ns:make-ns-rect x y width height))
	  (path (create-bezier-path)))
       (set-cocoa-line-specs path :width thickness :line-color ink :line-style line-style :fill-color fill-color)
      (#/appendBezierPathWithRect: path rect)
      (#/stroke path)
       (if (and filled fill-color) (#/fill path)))))

  


;; This draws hexagons with the top and bottom edges as horizontal.  The height and width are between the top and
;; bottom horizontal lines, and between the leftmost and rightmost points, respectively.  The edge sizes need not be
;; the same, but all internal angles are 120-degrees.

(defun kd-draw-hexagon* (cview x y width height
                            &key (ink *kd-black-color*)
                             (line-style *kd-solid-line-style*)
                             (filled nil) (fill-color *kd-black-color* fill-supplied?))

  (if (and filled (not fill-supplied?))
      (setf fill-color ink))
  (let* ((h2 (/ height 2))
         (w2 (- (/ width 2) (* h2 0.5773502691)))  ;; half the width of the top/base horiz line.  0.577.. = tan(30-degrees)        
         (pts
           (list (kd-make-rounded-pt (+ x w2) (+ y h2)) (kd-make-rounded-pt (+ x (/ width 2)) y) 
                 (kd-make-rounded-pt (+ x w2) (- y h2)) (kd-make-rounded-pt (- x w2) (- y h2)) 
                 (kd-make-rounded-pt (- x (/ width 2)) y) (kd-make-rounded-pt (- x w2) (+ y h2)))))
         
   (kd-draw-polygon cview pts :ink ink :line-style line-style :closed t :filled filled :fill-color fill-color)
))
   

(defun kd-draw-circle (cview center radius
                        &key (ink *kd-black-color* )
                             (line-style *kd-solid-line-style*) (thickness 1.0)
                             (filled nil) (fill-color *kd-black-color* fill-supplied?))

  (if (and filled (not fill-supplied?))
         (setf fill-color ink))
 (with-focused-view cview
    (let* ((path (create-bezier-path))
           (width (* 2 radius))
	   (rect (ns:make-ns-rect (- (kd-point-x center) radius) (- (kd-point-y center) radius) width width)))

      (#/appendBezierPathWithOvalInRect: path rect)
      (set-cocoa-line-specs path :width thickness :line-color ink :line-style line-style :fill-color fill-color)      
      (#/stroke path)
       (if (and filled fill-color) (#/fill path)))))


(defun kd-draw-circle* (cview x y radius &rest key-args)
   (apply #'kd-draw-circle cview (kd-make-pt x y) radius key-args))


(defun kd-draw-polygon (cview points
                        &key (ink *kd-black-color*) 
                             (line-style *kd-solid-line-style*)
                             (filled nil) (fill-color *kd-black-color* fill-supplied?) (thickness 1.0)
                             (closed t))
    (if (and filled (not fill-supplied?))
          (setf fill-color ink))
(with-focused-view cview
     (let ((start (first points))
	   (path (create-bezier-path)))
       (set-cocoa-line-specs path :width thickness :line-color ink :line-style line-style :fill-color fill-color)
       (#/moveToPoint: path start)
       (dolist (pt (cdr points))
	 (#/lineToPoint: path pt))
       (if closed (#/lineToPoint: path start))
       (#/stroke path)
       (if (and closed filled) (#/fill path)))))




;;  The x and y sent to to this function denote the BOTTOM LEFT corner of the text box. The string argument is just a standard CL string.

(defun kd-draw-text* (cview string x y)
  (with-focused-view cview
  (let ((cocoa-string (make-cocoa-string string)))
    (#/drawAtPoint:withAttributes: cocoa-string (kd-make-pt x y) +null-ptr+))))

;;********* A simple test case.  *********
;;  Give this a few seconds to run, since it has a few built-in delays.

; (thing-1)

(defun thing-1 ()
  (let* ((w (kd-make-simple-window))) 
    (setf (draw-func w) #'draw-thing1)
    (kd-window-resize w 500 400)   
    (kdwait 2)
    (kd-window-move w 200 200)
    (kdwait 2)
    (kd-window-move w 300 300)
    (kdwait 1)
    (kd-window-resize w 500 400)   
    (kdwait 1)
    (kd-window-move w 100 600)
    (kdwait 3)
    (kd-window-close w)
))

(defun draw-thing1 (w)
  (labels ((make-pts (points) (loop for p in points collect (kd-make-pt (first p) (second p)))))
    (kd-window-clear w :background-color *kd-blue-color*)
    (kd-draw-circle* w 150 150 100 :ink *kd-yellow-color* :filled t)  ;; face
    (kd-draw-circle* w 100 200 25 :ink *kd-green-color* :filled t)  ;; left eye
    (kd-draw-circle* w 100 200 10 :ink *kd-white-color* :filled t)  ;; left pupil
    (kd-draw-circle* w 200 200 25 :ink *kd-orange-color* :thickness 5.0) ;; right eye
    (kd-draw-circle* w 200 200 10 :filled t) ;; right pupil
    (kd-draw-polygon w (make-pts '((135 130) (150 150) (165 135) (170 170) (155 160) (133 158)))
                         :filled t :ink *kd-brown-color*)  ;; nose
     
    (kd-draw-polygon w (make-pts '((110 253) (100 225) (160 250) (120 270) (140 255) (173 255) (195 235) (150 273)))
            :closed nil :thickness 3.0 :ink *kd-black-color*)  ;; hair

    (kd-draw-rectangle* w 80 100 140 20 :ink *kd-red-color* 
                        :thickness 3.0 :line-style *kd-dotted-line-style*)  ;; mouth
    (kd-draw-hexagon* w 110 145 30 30 :filled t :ink (kd-create-rgb .1 .2 .8 :opacity 1.0))
    (kd-draw-hexagon* w 100 100 20 20 :filled t :ink (kd-create-rgb .1 .2 .8 :opacity .5))
    (kd-draw-hexagon* w 90 60 15 15 :filled t :ink (kd-create-rgb .1 .8 .2 :opacity .3))
    (kd-draw-hexagon* w 75 20 8 8 :filled t :ink (kd-create-rgb .9 .1 .1 :opacity .1))
    (kd-draw-line* w 150 110 320 80  :line-style *kd-dash-dot-line-style* :thickness 2.0)
    (kd-draw-text* w "Have a Common (Lisp) Day" 330 80)
 ))