;;;; -*- Mode: Lisp; Package: CCL -*-
;;;; tiny.lisp 
;;;;
;;;; A fairly direct translation into Lisp of the Tiny application (Chapter 4) 
;;;; from "Building Cocoa Applications" by Garfinkel and Mahoney 
;;;;
;;;; The original Tiny example was meant to illustrate the programmatic use of
;;;; Cocoa without Interface Builder.  Its purpose here is to illustrate the
;;;; programmatic use of the Cocoa bridge. 
;;;;
;;;; Copyright (c) 2003 Randall D. Beer
;;;; 
;;;; This software is licensed under the terms of the Lisp Lesser GNU Public
;;;; License , known as the LLGPL.  The LLGPL consists of a preamble and 
;;;; the LGPL. Where these conflict, the preamble takes precedence.  The 
;;;; LLGPL is available online at http://opensource.franz.com/preamble.html.
;;;;
;;;; Please send comments and bug reports to <beer@eecs.cwru.edu>


;;;; Modified to animate the drawing of polygons by Raf Cavallaro 5-13-2004
;;;; Modifications  also licensed under the LLGPL.
;;;; Raf Cavallaro can be reached at <raffaelcavallaro@mac.com>

;;;; Rewritten by Gary Byers 5-2004 to handle window closing properly
;;;; and to separate drawing and timer code.

;;;; Modified by Raffael Cavallaro 10-16-07 to cycle colors while drawing
;;;; and to parameterize various options such as min and max polys,
;;;; animation timer delay, how quickly colors cycle, etc.

;;; Temporary package and module stuff 

(in-package "CCL")
(export 'animate)
(declaim
 (optimize (speed 3) (safety 0) (debug 0) (space 0) (compilation-speed 0)))

(defparameter *draw-in-main-thread* t)

(require "COCOA")

;; These parameters determine where we start and stop, and how we step
;; through the animation.
;; Don't change these until you know what you're doing -
;; specifically, min max and step need to satify the assertion below

(defparameter *min-sides* 3) ;; minimum polygon sides in animation

(defparameter *max-sides* 17) ;; maximum polygon sides in animation

(defparameter *step* 2)

(assert (= (mod (- *max-sides* *min-sides*) *step*) 0)
	(*max-sides* *min-sides* *step*)
	"~a is not a valid value for *step*
	 when *min-sides* is ~a and *max-sides* is ~a"
	*step* *min-sides* *max-sides*)


(defparameter *anim-cycles-for-full-color-wheel* 12)
;; How many full animation cycles to go through the whole color wheel

(defun color-array-size ()
  (* *anim-cycles-for-full-color-wheel* 
     (* 2 (truncate (- *max-sides* *min-sides*) *step*))))

(defparameter *color-array*
  (let ((the-color-array
	 (make-array (color-array-size) :element-type 'ns:ns-color)))
    (loop for i from 0 below (color-array-size) do
      (setf (aref the-color-array i)
	    (ccl::send (@class "NSColor")
		       :color-with-calibrated-hue
		       (coerce (/ i (color-array-size)) 'double-float)
		       :saturation 1.0d0
		       :brightness 1.0d0
		       :alpha 1.0d0)))
    the-color-array))

;; Lets start with red-orange!
(defparameter *current-color-index* (truncate (color-array-size) 160)) 


;; hue values just in case you're curious:
;; 0.0/1.0 = red
;; 0.1 = yellow-orange
;; 0.2 = lime green
;; 0.3 = neutral green
;; 0.4 = blue-green
;; 0.5 = cyan
;; 0.6 = cobalt blue
;; 0.7 = ultramarine blue
;; 0.8 = violet
;; 0.9 = magenta

(defparameter *bg-fg-color-offset-ratio* 0.45)
;; color contrast of near-complements

(defun  background-foreground-offset ()
  (truncate (* *bg-fg-color-offset-ratio* (color-array-size))))

(defun current-background-color ()
  (aref *color-array* *current-color-index*))

(defun current-foreground-color ()
  (aref *color-array*
	(mod (+ *current-color-index* (background-foreground-offset))
	     (color-array-size))))


;; at each frame we move bg color one index forward in the color array
;; until we reach the end and then cycle back to 0
;; fg color is keyed to bg color in function current-foreground-color above

(defun bump-colors ()
  (if (< *current-color-index* (1- (color-array-size)))
      (incf *current-color-index*)
      (setf *current-color-index* 0)))

;; each frame is the rendering of a n-gon with all n vertices connected
;; the foreground and background colors change with each frame

(defparameter *frames-per-second* 30) ;; animation frame rate



(defparameter *animation-timer-delay* 
  (coerce (/ *frames-per-second*) 'double-float))

(eval-when (:compile-toplevel :execute)
  (use-interface-dir :carbon)
  (use-interface-dir :cocoa))


;;; Define the AnimView class 

(defclass anim-view (ns:ns-view)
  ((max :foreign-type :int ::accessor anim-view-max)
   (min :foreign-type :int  :accessor anim-view-min)
   (step :foreign-type :int :accessor anim-view-step)
   (numsides :foreign-type :int :accessor anim-view-numsides)
   (down :foreign-type :<BOOL> :accessor anim-view-down))
  (:metaclass ns:+ns-object))

(define-objc-method ((:<BOOL> is-opaque) anim-view)
		    t)

;;; It'd be nice if we could just use :INITFORM options to initialize
;;; these slots, but that's hard to do: SHARED-INITIALIZED would generally
;;; use :INITFORMs to initialize slots that're otherwise unbound, but
;;; there isn't really a good way to tell whether a foreign slot's
;;; "unbound".

(define-objc-method ((:id :init-with-frame (:<NSR>ect r)) anim-view)
		    (let* ((v (send-super :init-with-frame r)))
		      (unless (%null-ptr-p v)
			(setf (anim-view-max v) *max-sides*
			      (anim-view-min v) *min-sides*
			      (anim-view-step v) *step*
			      (anim-view-numsides v) 3))
		      v))

(defconstant short-pi (coerce pi 'short-float))

(defclass animation-window (ns:ns-window)
  ((thread-run-loop :foreign-type :id
		    :accessor animation-window-thread-run-loop)
   (animation-timer :foreign-type :id
		    :accessor animation-window-animation-timer)
   (close-ack :initform nil :accessor animation-window-close-ack))
  (:metaclass ns:+ns-object))


;;; X, Y coordinates for cascading windows
(defparameter *next-animation-top* 100.0d0)
(defparameter *next-animation-left* 100.0d0)



;;; This does the animation, by adding the animation and close timers
;;; to the current thread's runloop and then running that runloop.
;;; The only input sources should be those timers; when the window
;;; closes, they'll be removed and the runloop will exit.

(defmethod animate-window ((self animation-window) view done)
  (setf (animation-window-close-ack self) (make-semaphore))
  (let* ((runloop (send (@class "NSRunLoop") 'current-run-loop)))
    (setf (animation-window-thread-run-loop self) runloop)
    (setf (animation-window-animation-timer self)
          (make-objc-instance 'ns:ns-timer
                              :with-fire-date
			      (send (@class "NSDate") 'distant-past)
                              :interval *animation-timer-delay*
                              :target view
                              :selector (@selector "doAnimation:")
                              :user-info (%null-ptr)
                              :repeats t))
    (with-autorelease-pool
     (send runloop
	   :add-timer
	   (animation-window-animation-timer self)
	   :for-mode #@"NSDefaultRunLoopMode")
     (signal-semaphore done)
     (send (the ns:ns-run-loop runloop) 'run))))


(defmethod start-animation ((self animation-window) view)
  (let* ((created (make-semaphore)))
    (process-run-function (format nil "Animation thread for window ~d"
				  (send self 'window-number))
			  #'animate-window
			  (%inc-ptr self 0)
			  view
			  created)
    (wait-on-semaphore created)))


;;; Define the method that the animation thread uses to draw a anim-view.
;;; NOTE: The (THE NS-COLOR ...) forms are currently necessary for full
;;;       optimization because the SET message has a nonunique type signature 
;;; NOTE: The (@class XXX) forms will probably be replaced by 
;;;       (find-class 'XXX) once ObjC objects have been integrated into CLOS

;;; Draw the demo view, constrained to the indicated rectangle.

(defmethod redraw-anim-view ((self anim-view) rect)
  (declare (ignore rect))
  (slet ((bounds (send self 'bounds)))
	(let ((width (ns-width bounds))
	      (height (ns-height bounds))
	      (numsides (anim-view-numsides self)))
	  (macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5))
		     (Y (tt) `(* (1+ (cos ,tt)) height 0.5)))
	    ;; set anti-aliasing on
	    (send (send (@class "NSGraphicsContext") "currentContext") "setShouldAntialias:" #$YES)
	    ;; Fill the view with current background color
	    (send (the ns-color 
		       ;; (send (@class ns-color) 'orange-color))
		       (current-background-color)) 'set)
	    (#_NSRectFill bounds)
	    ;; Trace two polygons with N sides and connect all of the vertices 
	    ;; with cyan lines
	    (send (the ns-color (current-foreground-color)) 'set)
	    (loop for f from 0.0 below (* 2 short-pi)
	      by (* 2 (/ short-pi numsides))
	      do
	      (loop 
		for g from 0.0 below (* 2 short-pi)
		by (* 2 (/ short-pi numsides))
		do
		(send (@class ns-bezier-path)
		      :stroke-line-from-point (ns-make-point (X f) (Y f)) 
		      :to-point (ns-make-point (X g) (Y g)))))))))

;;; The :draw-rect method should only be called on the main thread;
;;; it's called when needed by the Cocoa display mechanism, and
;;; ensures that (a) the graphics state is set up properly (b) the
;;; view is locked by the main thread.  If *DRAW-IN-MAIN-THREAD* is
;;; false, we want all drawing to occur on the animation thread, so our
;;; :draw-rect method does nothing in that case.

(define-objc-method ((:void :draw-rect (:<NSR>ect rect)) 
		     anim-view)
		    (if *draw-in-main-thread*
			(redraw-anim-view self rect)))

;;; Other threads can draw to the view, but they need to use
;;; lockFocusIfCanDraw:  to atomically lock the view if it's
;;; currently visible.
;;; If we're able to draw to the view, we have to tell the
;;; window to flush the offscreen buffer to the screen.

(defmethod draw-from-other-thread ((view anim-view) &optional
                                   (rectptr (%null-ptr)))
  (when (send view 'lock-focus-if-can-draw)
    (unwind-protect
	(progn
	  (redraw-anim-view view rectptr)
	  (send (send view 'window) 'flush-window))
      (send view 'unlock-focus))))


(define-objc-method ((:void :do-animation timer) anim-view)
		    (declare (ignore timer))
  (slet ((view-bounds (send self 'bounds)))
	(if *draw-in-main-thread*
	    ; force the main thread to redraw the view
	    (send self :set-needs-display t)
	    (draw-from-other-thread self view-bounds)) ; draw it ourselves
	(let* ((down-p (anim-view-down self))
	       (step (anim-view-step self))
	       (numsides (anim-view-numsides self)))
	  (cond ((and (eql #$YES down-p) (<= numsides (anim-view-min self)))
		 (setf (anim-view-down self) #$NO))
		((and (eql #$NO down-p) (>= numsides (anim-view-max self)))
		 (setf (anim-view-down self) #$YES))
		((eql #$NO down-p)
		 (progn
		   (setf (anim-view-numsides self) (+ numsides step))
		   (bump-colors)))
		(t
		 (progn
		   (setf (anim-view-numsides self) (- numsides step))
		   (bump-colors)))))))

(define-objc-method ((:void :stop-animation timer) animation-window)
		    (declare (ignore timer))
  (send (animation-window-animation-timer self) 'invalidate)
  (let* ((cfrunloop
          (send
	   (send (@class "NSRunLoop") 'current-run-loop) 'get-cf-run-loop)))
    (#_CFRunLoopStop cfrunloop))
  (signal-semaphore (animation-window-close-ack self)))

(define-objc-method ((:void close) animation-window)
		    (let* ((timer
			    (make-objc-instance 'ns:ns-timer
						:with-fire-date
						(send (@class "NSDate")
						      'distant-past)
						:interval 0.0d0
						:target self
						:selector
						(@selector "stopAnimation:")
						:user-info (%null-ptr)
						:repeats nil)))
		      ;; Add the timer to the animation thread's run loop
		      (send (animation-window-thread-run-loop self)
			    :add-timer timer
			    :for-mode  #@"NSDefaultRunLoopMode"))
  ;; Wait for it to acknowledge the close request
  (wait-on-semaphore (animation-window-close-ack self))
  ;; Actually close the window ...
  (send-super 'close))

(define-objc-method ((:void :key-down event) animation-window)	    
		    (send self "zoom:" self)
  (send-super "keyDown:" event))

;;; This performs the actions that would normally be performed by loading
;;; a nib file.  To avoid resource-contention errors, some of those actions
;;; need to be performed on the main Cocoa event thread.

(defun animate (&key (n 1) (delay *animation-timer-delay*))
  (declare (optimize (speed 2) (safety 1) (space 0) (compilation-speed 0)))
  (check-type n (integer 1))
  (setq delay (coerce delay 'double-float))
  (check-type delay (double-float (0.0d0)))
  (with-autorelease-pool
   (slet ((r (ns-make-rect 100.0d0 100.0d0 600.0d0 600.0d0)))
	 (let* ((*animation-timer-delay* delay))
	   (dotimes (i n)
	     (let ((w (make-instance 
		       'animation-window
		       :with-content-rect r
		       :style-mask (logior #$NSTitledWindowMask 
					   #$NSClosableWindowMask 
					   #$NSMiniaturizableWindowMask
					   #$NSResizableWindowMask)
		       :backing #$NSBackingStoreBuffered
		       :defer t)))
	       (send w :set-title #@"Animation window")
	       (slet ((origin
		       (ns-make-point
			*next-animation-left* *next-animation-top*)))
		     (slet ((new-origin
			     (send w :cascade-top-left-from-point origin)))
			   (setq *next-animation-left*
				 (pref new-origin :<NSP>oint.x)
				 *next-animation-top*
				 (pref new-origin :<NSP>oint.y)))
		     (let ((my-view (make-instance 'anim-view :with-frame r)))
		       (send w :set-content-view my-view)
		       (send w :set-delegate my-view)
		       (send w :make-key-and-order-front nil)
		       (start-animation w my-view)
	       (return (values w my-view))))))))))

;; [myAnimView enterFullScreenMode:[NSScreen mainScreen]withOptions: 
;; [NSDictionary dictionaryWithObjects:
;; [NSArray arrayWithObjects: [NSNumber numberWithInt: 0  ]
;; forKeys: [NSArray arrayWithObjects: [@"NSFullScreenModeAllScreens"


(defun full-screen-animate ()
  (let ((the-window (ccl::animate)))
    (send (send the-window "contentView")
	  "enterFullScreenMode:withOptions:"
	  (send (@class "NSScreen") "mainScreen")
	  (send (@class "NSDictionary") "dictionaryWithObject:forKey:"
		(send (@class "NSNumber") "numberWithInt:" 0)
		(send (@class "NSString")
		      "stringWithString:" "NSFullScreenModeAllScreens")))
    the-window))