source: release/1.8/cocoa-ide-contrib/baylis/ca-multilayer.lisp @ 15650

Last change on this file since 15650 was 14242, checked in by rme, 9 years ago

Updated demos from Neil Baylis.

File size: 7.0 KB
Line 
1;;
2;; Core Animation Demo to animate many layers simultaneously
3;;
4;; Author: Neil Baylis
5;;
6;; neil.baylis@gmail.com
7;;
8(in-package "CL-USER")
9
10(require :cocoa)
11
12(eval-when (:compile-toplevel :load-toplevel :execute)
13  (objc:load-framework "Quartz" :quartz))
14
15;;
16;; Thanks to Raffael Cavallaro for this hack for detecting Snow Leopard or later
17;;
18(defun snow-leopard-or-later-p ()
19   (#/respondsToSelector: ns:ns-operation-queue (objc::@selector "mainQueue")))
20
21(defun nsstr (s) (make-instance 'gui::ns-lisp-string :string s))
22
23;;
24;; Thanks to Arthur Cater for this macro to deal with varying float formats
25;;
26(defmacro cgfl (n) `(float ,n ns:+cgfloat-zero+))
27
28(defparameter +standard-window-style-mask+
29  (logior #$NSTitledWindowMask
30          #$NSClosableWindowMask
31          #$NSMiniaturizableWindowMask
32          #$NSResizableWindowMask))
33
34(defun make-ns-window (x y &optional (title "Untitled"))
35  (let ((nsw (make-instance 'ns:ns-window
36               :with-content-rect (ns:make-ns-rect 0 0 x y)
37               :style-mask +standard-window-style-mask+
38               :backing #$NSBackingStoreBuffered
39               :defer t)))
40    (#/setTitle: nsw (nsstr title))
41    (#/setBackgroundColor:
42     nsw
43     (#/colorWithDeviceRed:green:blue:alpha: ns:ns-color
44       (cgfl 0.3) (cgfl 0.3) (cgfl 0.3) (cgfl 1.0)))
45    (#/center nsw)
46    (#/makeKeyAndOrderFront: nsw nil)
47    nsw))
48
49(defmacro with-focused-view (view &body forms)
50  `(when (#/lockFocusIfCanDraw ,view)
51     (unwind-protect (progn ,@forms)
52       (#/unlockFocus ,view)
53       (#/flushGraphics (#/currentContext ns:ns-graphics-context))
54       (#/flushWindow (#/window ,view)))))
55
56(defclass ca-demo-view (ns:ns-view)
57  ((path :initform (make-instance ns:ns-bezier-path)))
58  (:metaclass ns:+ns-object))
59
60(defun radians (theta)
61  "Convert theta in degrees to radians"
62  (cgfl (* theta (/ pi 180.0))))
63
64(defun degrees (theta)
65  "Convert theta in radians to degrees"
66  (cgfl (* theta (/ 180.0 pi))))
67
68(defun mag (x y)
69  "Pythagorean distance from 0,0 to x,y"
70  (cgfl (sqrt (+ (* x x) (* y y)))))
71
72(defun set-layer-position (layer point)
73  "Move the layer to the point"
74  (let* ((pos (make-record :<CGP>oint x (ns:ns-point-x point) y (ns:ns-point-y point))))
75    (#/removeAllAnimations layer)
76    (#/begin ns:ca-transaction)
77    (#/setValue:forKey: ns:ca-transaction
78                        (#/numberWithFloat: ns:ns-number 2.S0) ;Animate for 2 seconds
79                        #&kCATransactionAnimationDuration)
80    (#/setPosition: layer pos)
81    (#/commit ns:ca-transaction)
82    (free pos)))
83
84(defun pox (point center)
85  (- (ns:ns-point-x point) (ns:ns-point-x center)))
86
87(defun poy (point center)
88  (- (ns:ns-point-y point) (ns:ns-point-y center)))
89
90(defmacro with-transaction (&body forms)
91  `(progn (#/begin ns:ca-transaction)
92          ,@forms
93          (#/commit ns:ca-transaction)))
94
95(defun set-layer-angle (layer angle)
96  (let* ((transform (ccl::make-gcable-record :<CAT>ransform3<D>)))
97    (#_CATransform3DMakeRotation transform (cgfl angle) (cgfl 0.0) (cgfl 0.0) (cgfl 1.0))
98    (#/setTransform: layer transform)))
99
100(defun place-layer (layer center theta radius)
101  (#/removeAllAnimations layer)
102  (let* ((cx (+ (ns:ns-point-x center) (* radius (cos theta))))
103         (cy (+ (ns:ns-point-y center) (* radius (sin theta))))
104         (gp (make-record :<CGP>oint x (cgfl cx) y (cgfl cy))))
105    (#/setPosition: layer gp)
106    (set-layer-angle layer (cgfl (+ theta (radians 45) (radians (/ radius 1.25)))))
107    (free gp)))
108
109(defun layout-radial (layers point center)
110  "Position the layers in a circle around the center"
111  (with-transaction
112      (#/setValue:forKey: ns:ca-transaction
113                          (#/numberWithFloat: ns:ns-number 2.S0) ;Animate for 2 seconds
114                          #&kCATransactionAnimationDuration)
115      (do* ((dx (pox point center))
116            (dy (poy point center))
117            (num-layers (length layers))
118            (n num-layers (- n 1))
119            (ll layers (cdr ll))
120            (t0 (atan dy dx))         ;Angle to center of first layer
121            (radius  (mag dx dy))             ;Radius to center of first layer
122            (dt (radians (/ 360.0 num-layers))) ;Amount to step angle
123            (theta t0 (+ t0 (* dt n))))
124          ((= n 0))
125        (place-layer (car ll) center (cgfl theta) radius))))
126
127(defun rect-cent (rect)
128  "Return point at center of rectangle"
129  (ns:make-ns-point
130   (/ (ns:ns-rect-width rect) 2.0)
131   (/ (ns:ns-rect-height rect) 2.0)))
132
133(defun sublayers (layer)
134  "Return a list of the sublayers of the layer"
135  (do* ((sublayers (#/sublayers layer))
136        (n (- (#/count sublayers) 1) (- n 1))
137        (layers (cons (#/objectAtIndex: sublayers n) nil) (cons (#/objectAtIndex: sublayers n) layers)))
138     ((= n 0) layers)))
139
140(ccl::define-objc-method ((:void :mouse-down (:id event)) ca-demo-view)
141    (let* ((event-location (#/locationInWindow event))
142           (view-location (#/convertPoint:fromView: self event-location nil))
143           (view-center (rect-cent (#/bounds self))))
144      (layout-radial
145       (sublayers (#/layer self))
146       view-location
147       view-center)))
148
149(ccl::define-objc-method ((:void :mouse-dragged (:id event)) ca-demo-view)
150    (let* ((event-location (#/locationInWindow event))
151           (view-location (#/convertPoint:fromView: self event-location nil))
152           (view-center (rect-cent (#/bounds self))))
153      (layout-radial
154       (sublayers (#/layer self))
155       view-location
156       view-center)))
157
158(ccl::define-objc-method ((:<BOOL> accepts-first-responder) ca-demo-view) #$YES)
159
160(defun set-layer-bounds (layer rect)
161  "Set the position and bounds of the layer to match the rectangle"
162  (let* ((o (make-record :<CGP>oint
163                         x (ns:ns-rect-x rect)
164                         y (ns:ns-rect-y rect)))
165         (s (make-record :<CGS>ize
166                         width (ns:ns-rect-width rect)
167                         height (ns:ns-rect-height rect)))
168         (bounds (make-record :<CGR>ect origin o size s)))
169    (#/setPosition: layer o)
170    (#/setBounds: layer bounds)
171    (free bounds)
172    (free s)
173    (free o)))
174
175(defun make-ca-layer (x y c)
176  (let* ((layer (make-instance 'ns:ca-layer)))
177    (#/setBackgroundColor: layer c)
178    (set-layer-bounds layer (ns:make-ns-rect x y 100 200))
179    layer))
180
181(defun add-layer-to-view (view layer)
182  "Make the layer a sublayer of the view's backing layer"
183  (#/setDelegate: layer view)
184  (#/addSublayer: (#/layer view) layer))
185
186;;
187;; Animates many layers at once. It's interesting to run top while dragging
188;; the mouse in this demo and see how little cpu is used to do this. Change
189;; the number of layers to increase load.
190;;
191;; e.g.(run-demo 100)
192;;
193(defun run-demo (&optional (num-layers 24))
194  (let* ((w (make-ns-window 800 800 "CA-Multilayer"))
195         (f (#/frame w))
196         (bc nil) ; Background color
197         (nt num-layers)  ; Number of layers to make
198         (v (make-instance 'ca-demo-view)))
199    (when (snow-leopard-or-later-p) (#/setContentView: w v)) 
200    (#/setWantsLayer: v #$YES)
201    (dotimes (i nt)
202      (setf bc (#_CGColorCreateGenericRGB
203        (cgfl (if (evenp (truncate (/ i 2))) 0.75 0.25))
204        (cgfl (if (evenp i) 0.75 0.25))
205        (cgfl (* (/ 0.5 nt) (+ (* i 2) 1)))
206        (cgfl 0.6)))
207      (add-layer-to-view v
208       (make-ca-layer
209        (/ (ns:ns-rect-width f) 2)
210        (/ (ns:ns-rect-height f) 2) bc))
211      (#_CGColorRelease bc))
212    (unless (snow-leopard-or-later-p) (#/setContentView: w v))))
213
214(run-demo)
Note: See TracBrowser for help on using the repository browser.