source: release/1.8/cocoa-ide-contrib/baylis/ca-demo.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: 5.6 KB
Line 
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)))
Note: See TracBrowser for help on using the repository browser.