;;
;; Core Animation Demo
;;
;; Author: Neil Baylis
;;
;; neil.baylis@gmail.com
;;
(in-package "CL-USER")

(require :cocoa)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (objc:load-framework "Quartz" :quartz))

(defun nsstr (s) (make-instance 'gui::ns-lisp-string :string s))

(defparameter +standard-window-style-mask+
  (logior #$NSTitledWindowMask
          #$NSClosableWindowMask
          #$NSMiniaturizableWindowMask
          #$NSResizableWindowMask))

(defmacro cgfl (n) `(float ,n ccl::+cgfloat-zero+))

(defun make-ns-window (x y &optional (title "Untitled"))
  (let ((nsw (make-instance 'ns:ns-window
               :with-content-rect (ns:make-ns-rect 0 0 x y)
               :style-mask +standard-window-style-mask+
               :backing #$NSBackingStoreBuffered
               :defer t)))
    (#/setTitle: nsw (nsstr title))
    (#/setBackgroundColor:
     nsw
     (#/colorWithDeviceRed:green:blue:alpha: ns:ns-color
                                             (cgfl 0.7) (cgfl 0.7) (cgfl 0.7) (cgfl 1.0)))
    (#/center nsw)
    (#/makeKeyAndOrderFront: nsw nil)
    nsw))

(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)))))

(defclass ca-demo-view (ns:ns-view)
  ((path :initform (make-instance ns:ns-bezier-path)))
  (:metaclass ns:+ns-object))


(defun set-layer-position (layer point)
  (let* ((pos (make-record :<CGP>oint x (ns:ns-point-x point) y (ns:ns-point-y point))))
    (#/removeAllAnimations layer)
    (#/begin ns:ca-transaction)
    (#/setValue:forKey: ns:ca-transaction
			(#/numberWithFloat: ns:ns-number 2.0)
			#&kCATransactionAnimationDuration)
    (#/setPosition: layer pos)
    (#/commit ns:ca-transaction)
    (free pos)))

(defun pox (point center)
  (- (ns:ns-point-x point) (ns:ns-point-x center)))

(defun poy (point center)
  (- (ns:ns-point-y point) (ns:ns-point-y center)))

(defmacro with-transaction (&body forms)
  `(progn (#/begin ns:ca-transaction) ,@forms (#/commit ns:ca-transaction)))

(defun set-layers-symmetric (layers point center)
  (let* ((l1 (the ns:ca-layer (nth 0 layers)))
	 (l2 (the ns:ca-layer (nth 1 layers)))
	 (l3 (the ns:ca-layer (nth 2 layers)))
	 (l4 (the ns:ca-layer (nth 3 layers)))
	 (dx (pox point center))
	 (dy (poy point center))
	 (cx (ns:ns-point-x center))
	 (cy (ns:ns-point-y center))
	 (p1 (make-record :<CGP>oint x (+ cx dx) y (+ cy dy)))
	 (p2 (make-record :<CGP>oint x (- cx dx) y (+ cy dy)))
	 (p3 (make-record :<CGP>oint x (+ cx dx) y (- cy dy)))
	 (p4 (make-record :<CGP>oint x (- cx dx) y (- cy dy))))

    (mapc #'#/removeAllAnimations layers)
    
    (with-transaction
	(#/setValue:forKey: ns:ca-transaction
			    (#/numberWithFloat: ns:ns-number 0.5)
			    #&kCATransactionAnimationDuration)
    
      (#/setPosition: l1 p1)
      (#/setPosition: l2 p2)
      (#/setPosition: l3 p3)
      (#/setPosition: l4 p4))

    (free p1) (free p2) (free p3) (free p4)))

(defun rect-cent (rect)
  (ns:make-ns-point
   (/ (ns:ns-rect-width rect) 2.0)
   (/ (ns:ns-rect-height rect) 2.0)))

(ccl::define-objc-method ((:void :mouse-down (:id event)) ca-demo-view)
    (let* ((event-location (#/locationInWindow event))
	   (view-location (#/convertPoint:fromView: self event-location nil))
	   (view-center (rect-cent (#/bounds self))))
      (set-layers-symmetric
       (list (#/objectAtIndex: (#/sublayers (#/layer self)) 0)
	     (#/objectAtIndex: (#/sublayers (#/layer self)) 1)
	     (#/objectAtIndex: (#/sublayers (#/layer self)) 2)
	     (#/objectAtIndex: (#/sublayers (#/layer self)) 3))
       view-location
       view-center
      )))

(ccl::define-objc-method ((:void :mouse-dragged (:id event)) ca-demo-view)
    (let* ((event-location (#/locationInWindow event))
	   (view-location (#/convertPoint:fromView: self event-location nil))
	   (view-center (rect-cent (#/bounds self))))
      (set-layers-symmetric
       (list (#/objectAtIndex: (#/sublayers (#/layer self)) 0)
	     (#/objectAtIndex: (#/sublayers (#/layer self)) 1)
	     (#/objectAtIndex: (#/sublayers (#/layer self)) 2)
	     (#/objectAtIndex: (#/sublayers (#/layer self)) 3))
       view-location
       view-center
      )))


(ccl::define-objc-method ((:<BOOL> accepts-first-responder) ca-demo-view) #$YES)

(defun set-layer-bounds (layer rect)
  (let* ((o (make-record :<CGP>oint
			 x (ns:ns-rect-x rect)
			 y (ns:ns-rect-y rect)))
	 (s (make-record :<CGS>ize
			 width (ns:ns-rect-width rect)
			 height (ns:ns-rect-height rect)))
	 (bounds (make-record :<CGR>ect origin o size s)))
    (#/setPosition: layer o)
    (#/setBounds: layer bounds)
    (free bounds)
    (free s)
    (free o)))

(defun make-ca-layer (layer-name x y bc)
  (let* ((layer (make-instance 'ns:ca-layer)))
    (#/setName: layer (nsstr layer-name))
    (#/setBackgroundColor: layer bc)
    (set-layer-bounds layer (ns:make-ns-rect x y 100 100))
    (#_CGColorRelease bc)
    layer))

(defun rgba (r g b a) 
  (#_CGColorCreateGenericRGB (cgfl r) (cgfl g) (cgfl b) (cgfl a)))

(defun add-layer-to-view (view layer)
  (#/setDelegate: layer view)
  (#/addSublayer: (#/layer view) layer))

(defun run-demo ()
  (let* ((w (make-ns-window 800 800 "CA Demo"))
	 (f (#/frame w))
        (v (make-instance 'ca-demo-view)))
    (#/setWantsLayer: v #$YES)
    (add-layer-to-view v (make-ca-layer "s1" (/ (ns:ns-rect-width f) 2) (/ (ns:ns-rect-height f) 2) (rgba 0.4 0.7 0.9 0.5)))
    (add-layer-to-view v (make-ca-layer "s2" (/ (ns:ns-rect-width f) 2) (/ (ns:ns-rect-height f) 2) (rgba 0.7 0.9 0.4 0.5)))
    (add-layer-to-view v (make-ca-layer "s3" (/ (ns:ns-rect-width f) 2) (/ (ns:ns-rect-height f) 2) (rgba 0.9 0.4 0.7 0.5)))
    (add-layer-to-view v (make-ca-layer "s4" (/ (ns:ns-rect-width f) 2) (/ (ns:ns-rect-height f) 2) (rgba 0.1 0.6 0.6 0.8)))    
    (#/setContentView: w v)))

(run-demo)