source: trunk/contrib/baylis/ca-multilayer.lisp @ 14242

;;
;; Core Animation Demo to animate many layers simultaneously
;;
;; 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))

;;
;; Thanks to Raffael Cavallaro for this hack for detecting Snow Leopard or later
;;
(defun snow-leopard-or-later-p ()
   (#/respondsToSelector: ns:ns-operation-queue (objc::@selector "mainQueue")))

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

;;
;; Thanks to Arthur Cater for this macro to deal with varying float formats
;;
(defmacro cgfl (n) `(float ,n ns:+cgfloat-zero+))

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

(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.3) (cgfl 0.3) (cgfl 0.3) (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 radians (theta)
  "Convert theta in degrees to radians"
  (cgfl (* theta (/ pi 180.0))))

(defun degrees (theta)
  "Convert theta in radians to degrees"
  (cgfl (* theta (/ 180.0 pi))))

(defun mag (x y)
  "Pythagorean distance from 0,0 to x,y"
  (cgfl (sqrt (+ (* x x) (* y y)))))

(defun set-layer-position (layer point)
  "Move the layer to the 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.S0) ;Animate for 2 seconds
                        #&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-layer-angle (layer angle)
  (let* ((transform (ccl::make-gcable-record :<CAT>ransform3<D>)))
    (#_CATransform3DMakeRotation transform (cgfl angle) (cgfl 0.0) (cgfl 0.0) (cgfl 1.0))
    (#/setTransform: layer transform)))

(defun place-layer (layer center theta radius)
  (#/removeAllAnimations layer)
  (let* ((cx (+ (ns:ns-point-x center) (* radius (cos theta))))
         (cy (+ (ns:ns-point-y center) (* radius (sin theta))))
         (gp (make-record :<CGP>oint x (cgfl cx) y (cgfl cy))))
    (#/setPosition: layer gp)
    (set-layer-angle layer (cgfl (+ theta (radians 45) (radians (/ radius 1.25)))))
    (free gp)))

(defun layout-radial (layers point center)
  "Position the layers in a circle around the center"
  (with-transaction
      (#/setValue:forKey: ns:ca-transaction
                          (#/numberWithFloat: ns:ns-number 2.S0) ;Animate for 2 seconds
                          #&kCATransactionAnimationDuration)
      (do* ((dx (pox point center))
            (dy (poy point center))
            (num-layers (length layers))
            (n num-layers (- n 1))
            (ll layers (cdr ll))
            (t0 (atan dy dx))         ;Angle to center of first layer
            (radius  (mag dx dy))             ;Radius to center of first layer
            (dt (radians (/ 360.0 num-layers))) ;Amount to step angle
            (theta t0 (+ t0 (* dt n))))
          ((= n 0))
        (place-layer (car ll) center (cgfl theta) radius))))

(defun rect-cent (rect)
  "Return point at center of rectangle"
  (ns:make-ns-point
   (/ (ns:ns-rect-width rect) 2.0)
   (/ (ns:ns-rect-height rect) 2.0)))

(defun sublayers (layer)
  "Return a list of the sublayers of the layer"
  (do* ((sublayers (#/sublayers layer))
        (n (- (#/count sublayers) 1) (- n 1))
        (layers (cons (#/objectAtIndex: sublayers n) nil) (cons (#/objectAtIndex: sublayers n) layers)))
     ((= n 0) layers)))

(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))))
      (layout-radial
       (sublayers (#/layer self))
       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))))
      (layout-radial
       (sublayers (#/layer self))
       view-location
       view-center)))

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

(defun set-layer-bounds (layer rect)
  "Set the position and bounds of the layer to match the rectangle"
  (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 (x y c)
  (let* ((layer (make-instance 'ns:ca-layer)))
    (#/setBackgroundColor: layer c)
    (set-layer-bounds layer (ns:make-ns-rect x y 100 200))
    layer))

(defun add-layer-to-view (view layer)
  "Make the layer a sublayer of the view's backing layer"
  (#/setDelegate: layer view)
  (#/addSublayer: (#/layer view) layer))

;;
;; Animates many layers at once. It's interesting to run top while dragging
;; the mouse in this demo and see how little cpu is used to do this. Change
;; the number of layers to increase load.
;;
;; e.g.(run-demo 100)
;;
(defun run-demo (&optional (num-layers 24))
  (let* ((w (make-ns-window 800 800 "CA-Multilayer"))
         (f (#/frame w))
         (bc nil) ; Background color
         (nt num-layers)  ; Number of layers to make
         (v (make-instance 'ca-demo-view)))
    (when (snow-leopard-or-later-p) (#/setContentView: w v))  
    (#/setWantsLayer: v #$YES)
    (dotimes (i nt)
      (setf bc (#_CGColorCreateGenericRGB
        (cgfl (if (evenp (truncate (/ i 2))) 0.75 0.25))
        (cgfl (if (evenp i) 0.75 0.25))
        (cgfl (* (/ 0.5 nt) (+ (* i 2) 1)))
        (cgfl 0.6)))
      (add-layer-to-view v
       (make-ca-layer
        (/ (ns:ns-rect-width f) 2)
        (/ (ns:ns-rect-height f) 2) bc))
      (#_CGColorRelease bc))
    (unless (snow-leopard-or-later-p) (#/setContentView: w v))))

(run-demo)