source: release/1.3/source/examples/cocoa/easygui/new-cocoa-bindings.lisp @ 11845

Last change on this file since 11845 was 11845, checked in by cater, 11 years ago

Change EASYGUI DCC macro, & default to quiet

File size: 5.1 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* nil)
123;; Default changed to NIL by arthur, March 2009
124
125(defparameter *cocoa-pause* nil
126"When *debug-cocoa-calls* is not NIL, then a numeric value of *cocoa-pause* causes
127some sleep after every message produced by the DCC macro. Useful if something is
128causing a crash. During development it happened to me :-(")
129
130(defmacro dcc (form)
131;; Trace output identifies process, and may pause: arthur, March 2009
132  `(progn
133     (when *debug-cocoa-calls*
134       (format *trace-output* "[~a]Calling ~A on ~S~%"
135               (ccl::process-serial-number ccl::*current-process*) ',(first form) (list ,@(rest form)))
136       (when (and *cocoa-pause* (numberp *cocoa-pause*)) (sleep *cocoa-pause*)))
137     ,form))
138
139;;; Running things on the main thread:
140
141(defclass cocoa-thunk (ns:ns-object)
142     ((thunk :accessor thunk-of))
143  (:metaclass ns:+ns-object))
144
145(objc:defmethod (#/run :void) ((self cocoa-thunk))
146  (funcall (thunk-of self)))
147
148(defun run-on-main-thread (waitp thunk)
149  (let ((thunk* (make-instance 'cocoa-thunk)))
150    (setf (thunk-of thunk*) thunk)
151    (#/performSelectorOnMainThread:withObject:waitUntilDone:
152     thunk*
153     (@selector #/run)
154     +null-ptr+
155     (not (not waitp)))))
156
157(defmacro running-on-main-thread ((&key (waitp t)) &body body)
158  `(run-on-main-thread ,waitp (lambda () ,@body)))
159
160;;; Getting views from objc objects:
161
162(defgeneric easygui-view-of (cocoa-view))
Note: See TracBrowser for help on using the repository browser.