source: trunk/ccl/examples/cocoa/easygui/new-cocoa-bindings.lisp @ 7641

Last change on this file since 7641 was 7641, checked in by af, 13 years ago

Improve easygui view hierarchy handling.

From Ron Garret's list of things: implement remove-subviews.

  • Add an example, example/view-hierarchy.lisp.
  • Move the other examples into example/ as well.
  • Implement a few memory management helpers: functions retain-object, release-object, and macro retaining-objects.
  • Allow box-views to have a title.
File size: 4.6 KB
Line 
1(in-package :easygui)
2
3;;; Helper types:
4
5;;; point:
6(defclass eg-point ()
7     ((x :initarg :x :reader point-x)
8      (y :initarg :y :reader point-y)))
9
10(defun point (x y)
11  (assert (>= x 0))
12  (assert (>= y 0))
13  (make-instance 'eg-point :x x :y y))
14
15(defmethod print-object ((o eg-point) s)
16  (print-unreadable-object (o s :identity nil :type t)
17    (format s "(~,2,F/~,2,F)" (point-x o) (point-y o))))
18
19;;; range:
20(defclass eg-range ()
21     ((start :initarg :start :reader range-start)
22      (end :initarg :end :reader range-end)))
23
24(defun range (start end)
25  (assert (>= end start))
26  (make-instance 'eg-range :start start :end end))
27
28(defun range-nsrange (range)
29  (ns:make-ns-range (range-start range) (range-end range)))
30
31(defclass eg-rectangle ()
32     ((x :initarg :x :reader rectangle-x)
33      (y :initarg :y :reader rectangle-y)
34      (width :initarg :width :reader rectangle-width)
35      (height :initarg :height :reader rectangle-height)))
36
37(defun rectangle (x y width height)
38  (assert (>= x 0))
39  (assert (>= y 0))
40  (assert (>= width 0))
41  (assert (>= height 0))
42  (make-instance 'eg-rectangle :x x :y y :width width :height height))
43
44(defun rectangle-nsrect (r)
45  (ns:make-ns-rect (rectangle-x r) (rectangle-y r)
46                   (rectangle-width r) (rectangle-height r)))
47
48(defun nsrect-rectangle (r)
49  (rectangle (ns:ns-rect-x r) (ns:ns-rect-y r)
50             (ns:ns-rect-width r) (ns:ns-rect-height r)))
51
52;;; Base class for all Cocoa-based Easygui objects:
53(defclass easy-cocoa-object ()
54     ((ref :initarg :cocoa-ref)
55      (ref-valid-p :initform t :accessor cocoa-ref-valid-p)))
56
57(defgeneric cocoa-ref (eg-object)
58  (:method ((eg-object easy-cocoa-object))
59     (if (cocoa-ref-valid-p eg-object)
60         (slot-value eg-object 'ref)
61         (error "Attempting to access an invalidated Cocoa object on ~A!"
62                eg-object))))
63 
64(defgeneric (setf cocoa-ref) (new eg-object)
65  (:method (new (eg-object easy-cocoa-object))
66     (setf (cocoa-ref-valid-p eg-object) t
67           (slot-value eg-object 'ref) new)))
68
69(defvar *window-position-default-x* 200)
70(defvar *window-position-default-y* 200)
71(defvar *window-size-default-x* 200)
72(defvar *window-size-default-y* 200)
73
74(defun ns-rect-from-points (posn size)
75  (ns:make-ns-rect (point-x posn) (point-y posn)
76                   (point-x size) (point-y size)))
77
78(defparameter *flag-to-mask-alist*
79              `( ;; (:zoomable-p . #$NSZoomableWindowMask) ; doesn't work
80                (:minimizable-p . ,#$NSMiniaturizableWindowMask)
81                (:resizable-p . ,#$NSResizableWindowMask)
82                (:closable-p . ,#$NSClosableWindowMask)))
83
84(defun flag-mask (keyword enabled-p)
85  (if enabled-p
86      (or (cdr (assoc keyword *flag-to-mask-alist*)) 0)
87      0))
88
89(defparameter *key-to-mask-alist*
90              `((:control . ,#$NSControlKeyMask)
91                (:alt     . ,#$NSAlternateKeyMask)
92                (:command . ,#$NSCommandKeyMask)))
93
94(defun key-mask (keyword)
95  (or (cdr (assoc keyword *key-to-mask-alist*)) 0))
96
97;;; Memory management helpers:
98
99(defmacro maybe-invalidating-object ((eg-object) &body body)
100  `(if (= 1 (#/retainCount (cocoa-ref ,eg-object)))
101       (multiple-value-prog1 (progn ,@body)
102                             (setf (cocoa-ref-valid-p ,eg-object) nil))
103       (progn ,@body)))
104
105(defmethod retain-object ((o easy-cocoa-object))
106  (#/retain (cocoa-ref o)))
107
108(defmethod release-object ((o easy-cocoa-object))
109  (#/release (cocoa-ref o)))
110
111(defmacro retaining-objects ((&rest eg-objects) &body body)
112  "Retains EG-OBJECTS, runs BODY forms and releases them after control
113has left BODY."
114  (let ((objects (gensym)))
115    `(let ((,objects (list ,@eg-objects)))
116       (mapc #'retain-object ,objects)
117       (unwind-protect (progn ,@body)
118         (mapc #'release-object ,objects)))))
119
120;;; debug macro for #/ funcalls:
121
122(defvar *debug-cocoa-calls* t)
123
124(defmacro dcc (form)
125  `(progn
126     (when *debug-cocoa-calls*
127       (format *trace-output* "Calling ~A on ~S~%"
128               ',(first form) (list ,@(rest form))))
129     ,form))
130
131;;; Running things on the main thread:
132
133(defclass cocoa-thunk (ns:ns-object)
134     ((thunk :accessor thunk-of))
135  (:metaclass ns:+ns-object))
136
137(objc:defmethod (#/run :void) ((self cocoa-thunk))
138  (funcall (thunk-of self)))
139
140(defun run-on-main-thread (waitp thunk)
141  (let ((thunk* (make-instance 'cocoa-thunk)))
142    (setf (thunk-of thunk*) thunk)
143    (#/performSelectorOnMainThread:withObject:waitUntilDone:
144     thunk*
145     (@selector #/run)
146     +null-ptr+
147     (not (not waitp)))))
148
149(defmacro running-on-main-thread ((&key (waitp t)) &body body)
150  `(run-on-main-thread ,waitp (lambda () ,@body)))
151
152;;; Getting views from objc objects:
153
154(defgeneric easygui-view-of (cocoa-view))
Note: See TracBrowser for help on using the repository browser.