1 | ;; |
---|
2 | ;; Core Animation Demo |
---|
3 | ;; |
---|
4 | ;; Author: Neil Baylis |
---|
5 | ;; |
---|
6 | ;; neil.baylis@gmail.com |
---|
7 | ;; |
---|
8 | ;; usage: |
---|
9 | ;; 1. start ccl |
---|
10 | ;; 2. (load "path to ca-demo.lisp on your system") |
---|
11 | ;; 3. (run-demo "absolute path to small image file on your system") |
---|
12 | ;; |
---|
13 | ;; Click in the window, and the image will move smoothly to the mouse point. |
---|
14 | ;; Pressing any key will toggle full-screen mode |
---|
15 | ;; |
---|
16 | ;; This demo is meant purely to illustrate various objc bridge constructs |
---|
17 | ;; as well as minimal steps to make Core Animation do something. |
---|
18 | ;; |
---|
19 | (in-package "CL-USER") |
---|
20 | |
---|
21 | (require :cocoa) |
---|
22 | |
---|
23 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
24 | (objc:load-framework "Quartz" :quartz)) |
---|
25 | |
---|
26 | ;; |
---|
27 | ;; Thanks to Raffael Cavallaro for this hack for determining OSX version |
---|
28 | ;; |
---|
29 | (defun snow-leopard-or-later-p () |
---|
30 | (#/respondsToSelector: ns:ns-operation-queue (objc::@selector "mainQueue"))) |
---|
31 | |
---|
32 | (defun nsstr (s) (make-instance 'gui::ns-lisp-string :string s)) |
---|
33 | |
---|
34 | (defparameter +standard-window-style-mask+ |
---|
35 | (logior #$NSTitledWindowMask |
---|
36 | #$NSClosableWindowMask |
---|
37 | #$NSMiniaturizableWindowMask |
---|
38 | #$NSResizableWindowMask)) |
---|
39 | |
---|
40 | (defun make-ns-window (x y &optional (title "Untitled")) |
---|
41 | (let ((nsw (make-instance 'ns:ns-window |
---|
42 | :with-content-rect (ns:make-ns-rect 0 0 x y) |
---|
43 | :style-mask +standard-window-style-mask+ |
---|
44 | :backing #$NSBackingStoreBuffered |
---|
45 | :defer t))) |
---|
46 | (#/setTitle: nsw (nsstr title)) |
---|
47 | (#/setBackgroundColor: |
---|
48 | nsw |
---|
49 | (#/colorWithDeviceRed:green:blue:alpha: ns:ns-color 0.95 1.0 0.95 1.0 )) |
---|
50 | (#/center nsw) |
---|
51 | (#/makeKeyAndOrderFront: nsw nil) |
---|
52 | nsw)) |
---|
53 | |
---|
54 | (defmacro with-focused-view (view &body forms) |
---|
55 | `(when (#/lockFocusIfCanDraw ,view) |
---|
56 | (unwind-protect (progn ,@forms) |
---|
57 | (#/unlockFocus ,view) |
---|
58 | (#/flushGraphics (#/currentContext ns:ns-graphics-context)) |
---|
59 | (#/flushWindow (#/window ,view))))) |
---|
60 | |
---|
61 | (defclass ca-demo-view (ns:ns-view) |
---|
62 | ((path :initform (make-instance ns:ns-bezier-path))) |
---|
63 | (:metaclass ns:+ns-object)) |
---|
64 | |
---|
65 | (defvar sprite) |
---|
66 | |
---|
67 | (defun set-layer-position (layer point) |
---|
68 | (let* ((pos |
---|
69 | (make-record |
---|
70 | :<CGP>oint x (ns:ns-point-x point) y (ns:ns-point-y point)))) |
---|
71 | (#/removeAllAnimations layer) |
---|
72 | (#/setPosition: layer pos) |
---|
73 | (free pos))) |
---|
74 | |
---|
75 | (ccl::define-objc-method ((:void :mouse-down (:id event)) ca-demo-view) |
---|
76 | (let* ((event-location (#/locationInWindow event)) |
---|
77 | (view-location (#/convertPoint:fromView: self event-location nil))) |
---|
78 | (set-layer-position sprite view-location))) |
---|
79 | |
---|
80 | (ccl::define-objc-method ((:void :mouse-dragged (:id event)) ca-demo-view) |
---|
81 | (let* ((event-location (#/locationInWindow event)) |
---|
82 | (view-location (#/convertPoint:fromView: self event-location nil))) |
---|
83 | (set-layer-position sprite view-location))) |
---|
84 | |
---|
85 | (ccl::define-objc-method ((:void :key-down (:id event)) ca-demo-view) |
---|
86 | (declare (ignore event)) |
---|
87 | (if (#/isInFullScreenMode self) |
---|
88 | (#/exitFullScreenModeWithOptions: self #$nil) |
---|
89 | (#/enterFullScreenMode:withOptions: self (#/mainScreen ns:ns-screen) #$nil))) |
---|
90 | |
---|
91 | (ccl::define-objc-method ((:<BOOL> accepts-first-responder) ca-demo-view) #$YES) |
---|
92 | |
---|
93 | (defun set-layer-bounds (layer rect) |
---|
94 | (let* ((o (make-record :<CGP>oint x (ns:ns-rect-x rect) y (ns:ns-rect-y rect))) |
---|
95 | (s (make-record :<CGS>ize width (ns:ns-rect-width rect) height (ns:ns-rect-height rect))) |
---|
96 | (bounds (make-record :<CGR>ect origin o size s))) |
---|
97 | (#/setBounds: layer bounds) |
---|
98 | (free bounds) |
---|
99 | (free s) |
---|
100 | (free o))) |
---|
101 | |
---|
102 | (defun make-ca-layer-10.5 (filename) |
---|
103 | (let* ((layer (#/init (make-instance 'ns:ca-layer))) |
---|
104 | (ns-img (make-instance ns:ns-image :init-with-contents-of-file (nsstr filename))) |
---|
105 | (s (#/size ns-img)) |
---|
106 | (repr (#/TIFFRepresentation ns-img)) |
---|
107 | (sr (#_CGImageSourceCreateWithData repr CCL:+NULL-PTR+)) |
---|
108 | (ir (#_CGImageSourceCreateImageAtIndex sr 0 CCL:+NULL-PTR+))) |
---|
109 | (format t "10.5 version~%") |
---|
110 | (#/setName: layer (nsstr "sprite")) |
---|
111 | (#/setContents: layer ir) |
---|
112 | (set-layer-bounds layer (ns:make-ns-rect 0 0 (pref s :ns-size.width) (pref s :ns-size.height))) |
---|
113 | (#/release ns-img) |
---|
114 | (#_CFRelease sr) |
---|
115 | (#_CGImageRelease ir) |
---|
116 | layer)) |
---|
117 | |
---|
118 | ; |
---|
119 | ; Making a layer from an image is simpler in OSX 10.6 because an NSImage can be |
---|
120 | ; assigned directly to the layer contents. |
---|
121 | ; |
---|
122 | (defun make-ca-layer-10.6 (filename) |
---|
123 | (let* ((layer (#/init (make-instance 'ns:ca-layer))) |
---|
124 | (ns-img (make-instance ns:ns-image :init-with-contents-of-file (nsstr filename))) |
---|
125 | (s (#/size ns-img))) |
---|
126 | (#/setName: layer (nsstr "sprite")) |
---|
127 | (#/setContents: layer ns-img) |
---|
128 | (set-layer-bounds layer (ns:make-ns-rect 0 0 (pref s :ns-size.width) (pref s :ns-size.height))) |
---|
129 | (#/release ns-img) |
---|
130 | layer)) |
---|
131 | |
---|
132 | (defun add-layer-to-view (view layer) |
---|
133 | (#/setDelegate: layer view) |
---|
134 | (#/addSublayer: (#/layer view) layer)) |
---|
135 | |
---|
136 | ; |
---|
137 | ; e.g. (run-demo "/foo/bar/my-image.jpg") |
---|
138 | ; |
---|
139 | ; Make a window. |
---|
140 | ; Make a view, add it to the window. |
---|
141 | ; Tell the view that it needs a CA Backing layer |
---|
142 | ; Make a CALayer using the content of the supplied image |
---|
143 | ; Add the newly created layer to the view |
---|
144 | ; |
---|
145 | (defun run-demo-10.6 (filename) |
---|
146 | (let ((window (make-ns-window 900 600 "CA Demo")) |
---|
147 | (view (make-instance 'ca-demo-view))) |
---|
148 | (#/setContentView: window view) |
---|
149 | (#/setWantsLayer: view #$YES) |
---|
150 | (setf sprite (make-ca-layer-10.6 filename)) |
---|
151 | (add-layer-to-view view sprite))) |
---|
152 | |
---|
153 | (defun run-demo-10.5 (filename) |
---|
154 | (let ((window (make-ns-window 900 600 "CA Demo")) |
---|
155 | (view (make-instance 'ca-demo-view))) |
---|
156 | (#/setWantsLayer: view #$YES) |
---|
157 | (setf sprite (make-ca-layer-10.5 filename)) |
---|
158 | (add-layer-to-view view sprite) |
---|
159 | (#/setContentView: window view))) |
---|
160 | |
---|
161 | (defun run-demo (filename) |
---|
162 | (if (snow-leopard-or-later-p) |
---|
163 | (run-demo-10.6 filename) |
---|
164 | (run-demo-10.5 filename))) |
---|