source: trunk/source/contrib/Neil Baylis/ca-demo.lisp @ 12568

Last change on this file since 12568 was 12568, checked in by rme, 11 years ago

Contributions from Glen Foy and Neil Baylis.

File size: 4.4 KB
Line 
1;;
2;; Core Animation Demo
3;;
4;; Author: Neil Baylis
5;;
6;; neil.baylis@gmail.com
7;;
8;; usage:
9;;   1. start a 64 bit version of 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(defun nsstr (s) (make-instance 'gui::ns-lisp-string :string s))
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 0.95 1.0 0.95 1.0 ))
44    (#/center nsw)
45    (#/makeKeyAndOrderFront: nsw nil)
46    nsw))
47
48(defmacro with-focused-view (view &body forms)
49  `(when (#/lockFocusIfCanDraw ,view)
50     (unwind-protect (progn ,@forms)
51       (#/unlockFocus ,view)
52       (#/flushGraphics (#/currentContext ns:ns-graphics-context))
53       (#/flushWindow (#/window ,view)))))
54
55(defclass ca-demo-view (ns:ns-view)
56  ((path :initform (make-instance ns:ns-bezier-path)))
57  (:metaclass ns:+ns-object))
58
59(defvar sprite)
60
61(defun set-layer-position (layer point)
62  (let* ((pos
63          (make-record
64           :<CGP>oint x (ns:ns-point-x point) y (ns:ns-point-y point))))
65    (#/removeAllAnimations layer)
66    (#/setPosition: layer pos)
67    (free pos)))
68
69(ccl::define-objc-method ((:void :mouse-down (:id event)) ca-demo-view)
70    (let* ((event-location (#/locationInWindow event))
71           (view-location (#/convertPoint:fromView: self event-location nil)))
72      (set-layer-position sprite view-location)))
73
74(ccl::define-objc-method ((:void :mouse-dragged (:id event)) ca-demo-view)
75    (let* ((event-location (#/locationInWindow event))
76           (view-location (#/convertPoint:fromView: self event-location nil)))
77      (set-layer-position sprite view-location)))
78
79(ccl::define-objc-method ((:void :key-down (:id event)) ca-demo-view)
80    (declare (ignore event))
81    (if (#/isInFullScreenMode self)
82        (#/exitFullScreenModeWithOptions: self #$nil)
83        (#/enterFullScreenMode:withOptions: self (#/mainScreen ns:ns-screen) #$nil)))
84
85(ccl::define-objc-method ((:<BOOL> accepts-first-responder) ca-demo-view) #$YES)
86
87(defun set-layer-bounds (layer rect)
88  (let* ((o (make-record :<CGP>oint
89                         x (ns:ns-rect-x rect)
90                         y (ns:ns-rect-y rect)))
91         (s (make-record :<CGS>ize
92                         width (ns:ns-rect-width rect)
93                         height (ns:ns-rect-height rect)))
94         (bounds (make-record :<CGR>ect origin o size s)))
95    (#/setBounds: layer bounds)
96    (free bounds)
97    (free s)
98    (free o)))
99
100(defun make-ca-layer (filename)
101  (let* ((layer (#/init (make-instance 'ns:ca-layer)))
102         (ns-img (make-instance ns:ns-image :init-with-contents-of-file (nsstr filename)))
103         (s (#/size ns-img))
104         (repr (#/TIFFRepresentation ns-img))
105         (sr (#_CGImageSourceCreateWithData repr CCL:+NULL-PTR+))
106         (ir (#_CGImageSourceCreateImageAtIndex sr 0 CCL:+NULL-PTR+))
107         )
108    (#/setName: layer (nsstr "sprite"))
109    (#/setContents: layer ir)
110    (set-layer-bounds layer (ns:make-ns-rect 0 0 (pref s :ns-size.width) (pref s :ns-size.height)))
111    (#/release ns-img)
112    (#_CFRelease sr)
113    (#_CGImageRelease ir)
114    layer))
115
116(defun add-layer-to-view (view layer)
117  (#/setDelegate: layer view)
118  (#/addSublayer: (#/layer view) sprite))
119
120;
121; e.g. (run-demo "/foo/bar/my-image.jpg")
122;
123; Make a window.
124; Make a view
125; Tell the view that it needs a CA Backing layer
126; Make a CALayer using the content of the supplied image
127; Add the newly created layer to the view
128; Add the newly created view to the window
129;
130(defun run-demo (filename)
131  (let ((w (make-ns-window 900 600 "CA Demo"))
132        (v (make-instance 'ca-demo-view)))
133    (#/setWantsLayer: v #$YES)
134    (setf sprite (make-ca-layer filename))
135    (add-layer-to-view v sprite)
136    (#/setContentView: w v)))
Note: See TracBrowser for help on using the repository browser.