[Openmcl-cvs-notifications] r11899 - in /trunk/source/examples/cocoa/easygui: dialogs.lisp easygui.asd example/extended-demo.lisp new-cocoa-bindings.lisp package.lisp rgb.lisp views.lisp
rme at clozure.com
rme at clozure.com
Sat Apr 4 21:08:31 EDT 2009
Author: rme
Date: Sat Apr 4 21:08:31 2009
New Revision: 11899
Log:
Port r11841-r11847 (easygui enhancements) back to trunk.
Added:
trunk/source/examples/cocoa/easygui/example/extended-demo.lisp
- copied unchanged from r11847, release/1.3/source/examples/cocoa/eas=
ygui/example/extended-demo.lisp
trunk/source/examples/cocoa/easygui/rgb.lisp
- copied unchanged from r11847, release/1.3/source/examples/cocoa/eas=
ygui/rgb.lisp
Modified:
trunk/source/examples/cocoa/easygui/dialogs.lisp
trunk/source/examples/cocoa/easygui/easygui.asd
trunk/source/examples/cocoa/easygui/new-cocoa-bindings.lisp
trunk/source/examples/cocoa/easygui/package.lisp
trunk/source/examples/cocoa/easygui/views.lisp
Modified: trunk/source/examples/cocoa/easygui/dialogs.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/cocoa/easygui/dialogs.lisp (original)
+++ trunk/source/examples/cocoa/easygui/dialogs.lisp Sat Apr 4 21:08:31 20=
09
@@ -12,37 +12,42 @@
=
(defun y-or-n-dialog (message)
(let ((alert (make-instance 'ns:ns-alert)))
- (#/setMessageText: alert message)
- (#/addButtonWithTitle: alert "Yes")
- (#/addButtonWithTitle: alert "No")
+ (#/setMessageText: alert (ccl::%make-nsstring message))
+ (#/addButtonWithTitle: alert (ccl::%make-nsstring "Yes"))
+ (#/addButtonWithTitle: alert (ccl::%make-nsstring "No"))
(eql (#/runModal alert) #$NSAlertFirstButtonReturn)))
=
+(defvar *beepnsleep* t)
+
(defun choose-file-dialog (&key button-string)
- (declare (ignorable button-string))
(gui::with-autorelease-pool =
(let* ((panel (dcc (#/autorelease (dcc (#/openPanel ns:ns-open-panel=
)))))) ; allocate an NSOpenPanel
(dcc (#/setAllowsMultipleSelection: panel nil)) ; return at most o=
ne filename
- (when button-string (dcc (#/setPrompt: panel button-string)))
+ (when button-string
+ (setf button-string (ccl::%make-nsstring button-string))
+ (dcc (#/setPrompt: panel button-string)))
(when (eql #$NSOKButton
(dcc (#/runModalForDirectory:file:types: panel
- +null-ptr+ ; default to last dir used
- +null-ptr+ ; no preselected file
- ;; If not NIL below then an ObjC array containing NS=
Strings could be used
- ;; to restrict the file types we're interested in
- #$NIL)))
+ +null-ptr+ ; default to last dir used
+ +null-ptr+ ; no preselected file
+ ;; If not NIL below then an ObjC array containi=
ng NSStrings could be used
+ ;; to restrict the file types we're interested =
in
+ #$NIL)))
;; Because we told the panel to disallow multiple selection,
;; there should be exactly one object in this array, an
;; NSString describing the selected file.
- (let* ((files (dcc (#/filenames panel))))
+ (let* ((files (dcc (#/filenames panel))) thing)
(if (eql 1 (dcc (#/count files)))
- (gui::lisp-string-from-nsstring (dcc (#/objectAtIndex: files=
0)))
- (error "Don't know why we didn't get an NSArray containing e=
xactly 1 file here.")))))))
+ (progn
+ (setf thing (dcc (#/objectAtIndex: files 0)))
+ (gui::lisp-string-from-nsstring thing))
+ "Don't know why we didn't get an NSArray containing exactly =
1 file here."))))))
=
(defun choose-new-file-dialog (&key button-string)
(declare (ignorable button-string))
(gui::with-autorelease-pool =
(let* ((panel (dcc (#/autorelease (dcc (#/savePanel ns:ns-save-panel=
)))))) ; allocate an NSSavePanel
- (when button-string (dcc (#/setPrompt: panel button-string)))
+ (when button-string (dcc (#/setPrompt: panel (ccl::%make-nsstring =
button-string))))
(when (eql #$NSOKButton
(dcc (#/runModalForDirectory:file: panel
+null-ptr+ ; default to last dir used
@@ -64,18 +69,18 @@
(gui::with-autorelease-pool =
(let* ((panel (dcc (#/sharedColorPanel ns:ns-color-panel)))) ; find or=
create the NSColorPanel
(dcc (#/setPickerMode: ns:ns-color-panel #$NSWheelModeColorPanel))
- (dcc (#/setTitle: panel prompt))
+ (dcc (#/setTitle: panel (ccl::%make-nsstring prompt)))
(dcc (#/addObserver:selector:name:object: ; observe =
yourself close but
(dcc (#/defaultCenter ns:ns-notification-center)) ; sadly co=
nfound OK & CANCEL
panel
(objc:\@selector #/NSWindowWillCloseNotification)
- "NSWindowWillCloseNotification"
+ (ccl::%make-nsstring "NSWindowWillCloseNotification")
panel))
(when color (dcc (#/setColor: panel color)))
(dcc (#/runModalForWindow: (#/sharedApplication ns:ns-application) p=
anel))
(dcc (#/removeObserver:name:object: ; prevent =
pileup
(dcc (#/defaultCenter ns:ns-notification-center))
panel
- "NSWindowWillCloseNotification"
+ (ccl::%make-nsstring "NSWindowWillCloseNotification")
panel))
(dcc (#/retain (dcc (#/color panel)))))))
Modified: trunk/source/examples/cocoa/easygui/easygui.asd
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/cocoa/easygui/easygui.asd (original)
+++ trunk/source/examples/cocoa/easygui/easygui.asd Sat Apr 4 21:08:31 2009
@@ -25,12 +25,14 @@
:components ((:file "package")
(:file "new-cocoa-bindings" :depends-on ("package"))
(:file "events" :depends-on ("new-cocoa-bindings"))
+ (:file "rgb" :depends-on ("package"))
(:file "views" :depends-on ("events"))
(:file "action-targets" :depends-on ("views"))
(:file "dialogs" :depends-on ("new-cocoa-bindings"))
(:module "example"
- :depends-on ("action-targets")
+ :depends-on ("action-targets" "dialogs" "rgb")
:components
((:file "tiny")
(:file "currency-converter")
- (:file "view-hierarchy")))))
+ (:file "view-hierarchy")
+ (:file "extended-demo")))))
Modified: trunk/source/examples/cocoa/easygui/new-cocoa-bindings.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/cocoa/easygui/new-cocoa-bindings.lisp (original)
+++ trunk/source/examples/cocoa/easygui/new-cocoa-bindings.lisp Sat Apr 4 =
21:08:31 2009
@@ -119,13 +119,21 @@
=
;;; debug macro for #/ funcalls:
=
-(defvar *debug-cocoa-calls* t)
+(defvar *debug-cocoa-calls* nil)
+;; Default changed to NIL by arthur, March 2009
+
+(defparameter *cocoa-pause* nil
+"When *debug-cocoa-calls* is not NIL, then a numeric value of *cocoa-pause=
* causes
+some sleep after every message produced by the DCC macro. Useful if someth=
ing is
+causing a crash. During development it happened to me :-(")
=
(defmacro dcc (form)
+;; Trace output identifies process, and may pause: arthur, March 2009
`(progn
(when *debug-cocoa-calls*
- (format *trace-output* "Calling ~A on ~S~%"
- ',(first form) (list ,@(rest form))))
+ (format *trace-output* "[~a]Calling ~A on ~S~%"
+ (ccl::process-serial-number ccl::*current-process*) ',(firs=
t form) (list ,@(rest form)))
+ (when (and *cocoa-pause* (numberp *cocoa-pause*)) (sleep *cocoa-pau=
se*)))
,form))
=
;;; Running things on the main thread:
Modified: trunk/source/examples/cocoa/easygui/package.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/cocoa/easygui/package.lisp (original)
+++ trunk/source/examples/cocoa/easygui/package.lisp Sat Apr 4 21:08:31 20=
09
@@ -1,7 +1,7 @@
(cl:defpackage :easygui
(:use :cl)
(:import-from :ccl with-autorelease-pool @selector lisp-string-from-nsst=
ring +null-ptr+)
- (:export #:point #:range #:rectangle #:window
+ (:export #:point #:ns-point-from-point #:range #:rectangle #:window
#:point-x #:point-y #:rectangle-x #:rectangle-y #:rectangle-wid=
th
#:rectangle-height
;; cocoa stuff
@@ -10,21 +10,48 @@
#:view #:static-text-view #:text-input-view #:password-input-vi=
ew
#:push-button-view
#:form-view #:form-cell-view #:box-view #:drawing-view #:slider=
-view
+ #:check-box-view #:radio-button-view
+ #:menu-item-view #:pop-up-menu #:pull-down-menu #:contextual-me=
nu =
;; event methods
- #:mouse-down #:mouse-dragged #:mouse-up
+ #:mouse-down #:mouse-dragged #:mouse-up #:view-key-event-handl=
er
;; operators
#:cocoa-ref
- #:add-subviews #:remove-subviews #:window-show #:set-window-tit=
le
- #:content-view
+ #:add-subviews #:remove-subviews #:view-subviews
+ #:window-show #:set-window-title
+ #:content-view #:view-container
#:initialize-view #:action #:view-text
#:add-entry #:add-entries #:editable-p
#:draw-view-rectangle
#:entry-text #:cell-count #:nth-cell #:selection #:redisplay
#:string-value-of #:integer-value-of #:float-value-of
#:double-value-of
- #:y-or-n-dialog
+ #:view-named #:view-nick-name
+ #:view-size view-position
+ #:view-mouse-position
+ #:view-font #:with-focused-view
+ #:clear-page
+ #:check-box-check #:check-box-uncheck #:check-box-checked-p
+ #:radio-button-selected-p #:radio-button-select #:radio-button-=
deselect
+ #:dialog-item-enabled-p #:set-dialog-item-enabled-p
+ #:shift-key-p #:control-key-p #:alt-key-p #:command-key-p
+ #:get-fore-color #:get-back-color #:set-fore-color #:set-back-c=
olor
+ #:invalidate-view
+ #:menu-selection #:menu-items #:set-menu-item-title #:add-conte=
xtual-menu
+ #:application-main-menu
+ #:navigate-menu #:navigate-topbar #:add-topbar-item
+ #:make-rgb #:rgb-red #:rgb-green #:rgb-blue #:rgb-opacity
+ ;; canned dialogs
+ #:y-or-n-dialog #:user-pick-color
#:choose-file-dialog #:choose-new-file-dialog
- #:user-pick-color))
+ =
+ =
+ #:dcc
+ #:perform-close #:window-may-close
+ ;; variables
+ #:*debug-cocoa-calls*
+ #:*screen-flipped*
+ #:*cocoa-event*
+ #:*suppress-window-flushing*))
=
(cl:defpackage :easygui-demo
(:use :cl :easygui)
Modified: trunk/source/examples/cocoa/easygui/views.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/examples/cocoa/easygui/views.lisp (original)
+++ trunk/source/examples/cocoa/easygui/views.lisp Sat Apr 4 21:08:31 2009
@@ -1,4 +1,87 @@
(in-package :easygui)
+
+; ----------------------------------------------------------------------
+; This is the Clozure Common Lisp file named 'views.lisp', March 2009,
+; in the folder ccl/examples/cocoa/easygui/
+; It has been modified by AWSC (arthur.cater at ucd.ie), based upon
+; an earlier contribution by an unknown author, borrowing also from
+; the 'Seuss.lisp' contribution of 'KD'.
+; Permission to use, further modify, disseminate, is hereby granted.
+; No warranty is expressed or implied.
+; Suggestions for - or accomplishment of - further improvement are welcome.
+; Accompanying documentation for this and related files will be written
+; and placed in ccl/examples/cocoa/easygui/documentation.txt
+; Testing has been only with Mac OS 10.5.6 on a 32 bit PPC
+; A demo of some capabilities is in 'easygui-demo-2.lisp'
+; ----------------------------------------------------------------------
+; It extends previous work in the following principal ways:
+; - windows, views and subviews may have nicknames
+; - checkboxes and radio-buttons are provided
+; - menus (pop-up, pull-down, contextual, and main-menu) are provided
+; - MCL-like coordinates (Y increases downward) may optionally be used
+; for placing windows on the screen, placing subviews within windows,
+; and graphics within drawing views.
+; - views can generally respond to mouse entry, exit, movement
+; - static text views can respond to mouse clicks
+; - text views can have colored text and colored background
+; - windows can decline to close, and/or invoke daemons upon closing.
+; - views and windows can have specific OBJC subclassed counterparts
+; - Shift, Command, Control and Option keys may be interrogated
+; ----------------------------------------------------------------------
+
+(declaim (optimize (speed 0) (space 0) (compilation-speed 0) (safety 3) (d=
ebug 3)))
+
+(defmacro running-on-this-thread ((&key (waitp t)) &rest body)
+;; The purpose of this trivial macro is to mark places where it is thought=
possible that
+;; it may be preferable to use running-on-main-thread.
+ (declare (ignore waitp))
+ `(progn , at body))
+
+
+(defparameter *screen-flipped* nil
+"When NIL, window positions are taken as referring to their bottom right,
+as per Cocoa's native coordinate system.
+When non-NIL, window positions are taken to refer to their top left,
+as per - for instance - Digitool's MCL.
+The default orientation for graphics within a drawing view is set to
+correspond at the time of creation of that drawing view.")
+
+(defvar *cocoa-event* nil "Allows SHIFT-KEY-P & friends to operate on mous=
e clicks")
+
+(defvar *suppress-window-flushing* nil "
+When T, graphics output produced with calls to With-Focused-View will not =
be immediately
+flushed. This can reduce flicker and increase speed when there are many re=
lated uses of
+With-Focused-View. It is then necessary though to make sure that somebody =
somewhere
+calls Flush-Graphics at an appropriate time.
+The same effect can be obtained for an individual use of With-Focused-View=
by giving
+:WITHOUT-FLUSH as the first form in its body.")
+
+(defun ns-point-from-point (eg-point) ;; probably belongs in new-cocoa-bi=
ndings.lisp
+ (ns:make-ns-point (point-x eg-point) (point-y eg-point)))
+
+(defmacro with-focused-view (cocoa-view &body forms)
+;; From KD's SEUSS.LISP but with added :WITHOUT-FLUSH syntax element
+;; If the first of forms is the keyword :WITHOUT-FLUSH, or if dynamically
+;; the value of *suppress-window-flushing* is non-NIL, then graphics outpu=
t is not
+;; immediately flushed.
+ (let ((noflush (eq (first forms) ':without-flush)))
+ `(if (dcc (#/lockFocusIfCanDraw ,cocoa-view))
+ (unwind-protect
+ (progn , at forms)
+ (dcc (#/unlockFocus ,cocoa-view))
+ ,(unless noflush
+ `(unless *suppress-window-flushing* (flush-graphics ,cocoa-vie=
w)))))))
+
+(defun flush-graphics (cocoa-view)
+ (running-on-this-thread ()
+ (dcc (#/flushGraphics (#/currentContext ns:ns-graphics-context)))
+ (dcc (#/flushWindow (#/window cocoa-view)))))
+
+(defun cocoa-null (ptr)
+ (equalp ptr ccl:+null-ptr+))
+
+
+
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; view protocol
@@ -16,39 +99,71 @@
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mixins
+;;;
+;;; Some view classes have an associated 'value', which can be accessed an=
d set through
+;;; accessors STRING-VALUE-OF, INTEGER-VALUE-OF, FLOAT-VALUE-OF, DOUBLE-VA=
LUE-OF
+;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT=
-VIEW, FORM-CELL-VIEW, SLIDER-VIEW
+;;;
+;;; Some view classes have an associated 'title', accessible and settable =
through VIEW-TEXT
+;;; Such classes include WINDOW, PUSH-BUTTON-VIEW, BOX-VIEW, RADIO-BUTTON-=
VIEW, CHECK-BOX-VIEW, MENU-VIEW, MENU-ITEM-VIEW
+;;;
+;;; Some view classes have an associated 'text', also accessible and setta=
ble through VIEW-TEXT
+;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT=
-VIEW, FORM-CELL-VIEW
+;;;
+;;; Most of those, apart from STATIC-TEXT-VIEW, may be manually 'editable'.
+;;;
+;;; Some view classes have an associated 'action'.
+;;; Such classes include PUSH-BUTTON-VIEW, SLIDER-VIEW, RADIO-BUTTON-VIEW,=
CHECK-BOX-VIEW, MENU-ITEM-VIEW
+;;;
+;;; Some view classes cannot ever have a contextual menu attached to them,=
even though their superview
+;;; and their subviews (if any) possibly do.
+;;; Such classes include PUSH-BUTTON-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VI=
EW, MENU-VIEW, MENU-ITEM-VIEW
+;;; Perhaps these should be the same classes as those with actions.
+;;;
+;;; No view classes inherit from 'one-selection-mixin'
+;;; Apparently it was intended that TEXT-INPUT-VIEW might do so some day.
+;;;
+;;; Some view classes have a single 'content view'.
+;;; Such classes include WINDOW, BOX-VIEW.
+;;;
+;;; Some view classes inherit from 'background-coloring-mixin'
+;;; Such classes include STATIC-TEXT-VIEW ... for now
+;;;
=
(defclass value-mixin () ())
+
(defclass string-value-mixin (value-mixin) ())
+
(defclass numeric-value-mixin (value-mixin) ())
=
+(defclass action-view-mixin ()
+ ((action :initarg :action)
+ (enabled :accessor dialog-item-enabled-p :initarg :dialog-item-enabled-=
p :initform t)))
+
+(defclass decline-menu-mixin () ())
+
(macrolet ((def-type-accessor (class lisp-type cocoa-reader cocoa-writer
- &key new-value-form return-value-conv=
erter)
+ &key (new-value-form 'new-value) (ret=
urn-value-converter 'identity))
(let ((name (intern (format nil "~A-VALUE-OF" lisp-type))))
`(progn
(defmethod ,name ((o ,class))
- ,(if return-value-converter
- `(,return-value-converter
- (dcc (,cocoa-reader (cocoa-ref o))))
- `(dcc (,cocoa-reader (cocoa-ref o)))))
+ (,return-value-converter (dcc (,cocoa-reader (cocoa-=
ref o)))))
(defmethod (setf ,name) (new-value (o ,class))
- (dcc (,cocoa-writer (cocoa-ref o)
- ,(or new-value-form
- 'new-value))))))))
- (def-type-accessor string-value-mixin string #/stringValue #/setStringVa=
lue:
- :return-value-converter lisp-string-from-nsstring )
-
+ (dcc (,cocoa-writer (cocoa-ref o) ,new-value-form)))=
))))
+ (def-type-accessor string-value-mixin string #/stringValue #/setString=
Value:
+ :return-value-converter lisp-string-from-nsstring )
(def-type-accessor numeric-value-mixin integer #/intValue #/setIntValue:)
- (def-type-accessor numeric-value-mixin float
- #/floatValue #/setFloatValue:
+ (def-type-accessor numeric-value-mixin float #/floatValue #/setFloatVa=
lue:
:new-value-form (coerce new-value 'single-float))
- (def-type-accessor numeric-value-mixin double
- #/doubleValue #/setDoubleValue:
+ (def-type-accessor numeric-value-mixin double #/doubleValue #/setDouble=
Value:
:new-value-form (coerce new-value 'double-float)))
=
(defclass view-text-mixin ()
- ((text :initarg :text)))
+ ((text :initarg :text :initarg :dialog-item-text)))
+
(defclass view-text-via-stringvalue-mixin (view-text-mixin string-value-mi=
xin)
())
+
(defclass view-text-via-title-mixin (view-text-mixin)
((text :initarg :title)))
=
@@ -59,15 +174,20 @@
(lisp-string-from-nsstring (dcc (#/title (cocoa-ref view)))))
=
(defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixi=
n))
- (setf (string-value-of view) new-text))
+ (setf (string-value-of view) (ccl::%make-nsstring new-text)))
=
(defmethod (setf view-text) (new-text (view view-text-via-title-mixin))
- (dcc (#/setTitle: (cocoa-ref view) new-text)))
+ (dcc (#/setTitle: (cocoa-ref view) (ccl::%make-nsstring new-text)))
+ new-text)
=
(defmethod initialize-view :after ((view view-text-mixin))
(when (slot-boundp view 'text)
(setf (view-text view) (slot-value view 'text))))
=
+(defclass text-coloring-mixin () ())
+
+(defclass text-fonting-mixin () ())
+
(defclass editable-mixin () ())
=
(defmethod editable-p ((view editable-mixin))
@@ -75,12 +195,14 @@
=
(defmethod (setf editable-p) (editable-p (view editable-mixin))
(check-type editable-p boolean)
- (dcc (#/setEditable: (cocoa-ref view) editable-p)))
+ (dcc (#/setEditable: (cocoa-ref view) editable-p))
+ editable-p)
=
(defclass one-selection-mixin () ())
=
(defmethod (setf selection) (selection (view one-selection-mixin))
- (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection))))
+ (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection)))
+ selection)
=
(defmethod selection ((view one-selection-mixin))
(let ((range (dcc (#/selectedRange (cocoa-ref view)))))
@@ -90,12 +212,20 @@
(ns:ns-range-length range)))))
=
(defclass content-view-mixin ()
- (content-view))
+ ((content-view)
+ (flipped :initarg :flipped :initform *screen-flipped*)))
+
+(defclass contained-view (view)
+ ((flipped :initarg :flipped)))
=
(defmethod initialize-view :after ((view content-view-mixin))
- (setf (slot-value view 'content-view)
- (make-instance 'view
- :cocoa-ref (dcc (#/contentView (cocoa-ref view))))))
+ (unless (slot-boundp view 'content-view)
+ (let ((containee (make-instance 'contained-view
+ :cocoa-ref (dcc (#/contentView (cocoa-ref view)))
+ :view-nick-name '%CONTENT-OF-CONTENT-VIEW%
+ :flipped (slot-value view 'flipped))))
+ (setf (slot-value view 'content-view) containee
+ (slot-value containee 'parent) view))))
=
(defmethod content-view ((view content-view-mixin))
(assert (eql (cocoa-ref (slot-value view 'content-view))
@@ -104,7 +234,21 @@
=
(defmethod (setf content-view) (new-content-view (view content-view-mixin))
(setf (slot-value view 'content-view) new-content-view)
- (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view))))
+ (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view)))
+ new-content-view)
+
+(defmethod set-dialog-item-enabled-p ((view action-view-mixin) value)
+ (unless (eq (not value) (not (dialog-item-enabled-p view)))
+ (setf (dialog-item-enabled-p view) value)
+ (dcc (#/setEnabled: (cocoa-ref view) (if value #$YES #$NO)))))
+
+(defclass background-coloring-mixin ()
+ ((drawsbackground :initform t :initarg :draws-background)))
+
+(defmethod initialize-view :after ((view background-coloring-mixin))
+ (dcc (#/setDrawsBackground: (cocoa-ref view) (slot-value view 'drawsback=
ground)))
+ (when (and (cocoa-ref view) (slot-boundp view 'background))
+ (dcc (#/setBackgroundColor: (cocoa-ref view) (slot-value view 'backg=
round)))))
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the actual views (when adding a new class,
@@ -113,7 +257,25 @@
(defclass view (easy-cocoa-object)
((position :initarg :position :reader view-position)
(size :initarg :size :reader view-size)
- (frame-inited-p :initform nil)))
+ (frame-inited-p :initform nil)
+ (parent :reader view-container :initform nil)
+ (subviews :reader view-subviews :initarg :subviews :initform nil)
+ ;; When adding/removing multiple subviews, prevent multiple redraws.
+ ;; But - what code does those redraws?
+ (subviews-busy :accessor view-subviews-busy :initform nil)
+ (nickname :accessor view-nick-name :initarg :view-nick-name :initfor=
m nil)
+ (contextmenu :initarg :contextual-menu :initform nil)
+ (background :initarg :back-color :initform (#/whiteColor ns:ns-color=
))
+ (foreground :initarg :fore-color :initform (#/blackColor ns:ns-color=
))
+ (font :reader view-font :initarg :font :initarg :view-font :initform=
nil)
+ (specifically :reader view-specifically :initarg :specifically :init=
form nil)
+ (mouse-target :reader view-mouse-target :initform nil)
+ ;; Next three not yet operative
+ (tip :initarg :tip :reader view-tip :initform nil)
+ (tiptag :initform nil)
+ (mouse-enter :accessor view-mouse-enter :initarg :mouse-enter :initf=
orm nil)
+ (mouse-exit :accessor view-mouse-exit :initarg :mouse-exit :initform=
nil)
+ (mouse-move :accessor view-mouse-move :initarg :mouse-move :initform=
nil)))
=
(defclass window (content-view-mixin view-text-via-title-mixin view)
((text :initarg :title :initform "" :reader window-title)
@@ -122,11 +284,32 @@
:reader window-minimizable-p)
(resizable-p :initarg :resizable-p :initform t
:reader window-resizable-p)
- (closable-p :initarg :closable-p :initform t :reader window-closable=
-p)))
-
-(defclass static-text-view (view view-text-via-stringvalue-mixin) ())
-
-(defclass text-input-view (view editable-mixin view-text-via-stringvalue-m=
ixin
+ (closable-p :initarg :closable-p :initform t :reader window-closable=
-p)
+ (level :initarg :window-level :accessor window-level
+ :initform (dcc (#_CGWindowLevelForKey #$kCGNormalWindowLevelK=
ey)))
+ (hidden :initarg :hidden :reader window-hidden :initform nil)
+ (window-needs-display-on-show :initform t)
+ (optimized :initarg :optimized :initform t) ; Set to NIL if you anti=
cipate overlapping views in this window
+ (style :initarg :window-style :initform #$NSTitledWindowMask))
+ (:default-initargs :specifically 'cocoa-contained-view))
+
+(defmethod clear-page ((view view))
+ (let* ((cview (cocoa-ref view))
+ (rect (dcc (#/bounds cview)))
+ (color (slot-value view 'background)))
+ (with-focused-view cview
+ (dcc (#/setFill color))
+ (dcc (#_NSRectFill rect)))))
+
+(defmethod clear-page ((window content-view-mixin))
+ (clear-page (content-view window)))
+
+(defclass static-text-view (view view-text-via-stringvalue-mixin action-vi=
ew-mixin text-coloring-mixin text-fonting-mixin background-coloring-mixin)
+ ((mousedown :initform nil :initarg :mouse-down :accessor st=
atic-text-view-mouse-down)
+ (mouseup :initform nil :initarg :mouse-up :accessor st=
atic-text-view-mouse-up)
+ (mousedragged :initform nil :initarg :mouse-dragged :accessor st=
atic-text-view-mouse-dragged)))
+
+(defclass text-input-view (view editable-mixin text-coloring-mixin text-fo=
nting-mixin view-text-via-stringvalue-mixin
;; XXX: requires NSTextView, but this is an
;; NSTextField:
#+not-yet one-selection-mixin)
@@ -136,9 +319,10 @@
(defclass password-input-view (text-input-view)
())
=
-(defclass push-button-view (view view-text-via-title-mixin)
+(defclass push-button-view (view view-text-via-title-mixin action-view-mix=
in decline-menu-mixin)
((default-button-p :initarg :default-button-p :initform nil
- :reader default-button-p)))
+ :reader default-button-p)
+ (bezelstyle :reader bezel-style :initarg :bezel-style =
:initform :rounded)))
=
(defclass form-view (view)
((autosize-cells-p :initarg :autosize-cells-p :initform nil)
@@ -155,24 +339,197 @@
(
;; TODO: make this a mixin
(accept-key-events-p :initform nil :initarg :accept-key-events-p
- :accessor accept-key-events-p)))
-
-(defclass slider-view (view numeric-value-mixin)
+ :accessor accept-key-events-p)
+ (flipped :initform *screen-flipped* :initarg :flipped :r=
eader flipped-p)
+ (mousedown :initform nil :initarg :mouse-down :accessor=
drawing-view-mouse-down)
+ (mouseup :initform nil :initarg :mouse-up :accessor=
drawing-view-mouse-up)
+ (mousedragged :initform nil :initarg :mouse-dragged :accessor=
drawing-view-mouse-dragged)
+ (draw-fn :initform nil :initarg :draw-fn :accessor draw-=
fn)))
+
+(defclass slider-view (view numeric-value-mixin action-view-mixin)
((max-value :initarg :max-value)
(min-value :initarg :min-value)
(tick-mark-count :initarg :tick-mark-count)
+ (tick-mark-values :initarg :tick-mark-values)
(discrete-tick-marks-p :initarg :discrete-tick-marks-p)))
=
+; ----------------------------------------------------------------------
+; Specialisations of ns-xxx classes always begin 'cocoa-'.
+; They allow such things as
+; - finding the easygui window associated with a ns-view & easygui::view
+; - flipped windows, flipped drawing-views
+; - clickable static text, editable text fields
+; - tooltips
+; ----------------------------------------------------------------------
+
+(defun calculate-ns-tooltip (cview)
+ ;; Returns a Lisp string to bhe used as a tooltip, or NIL.
+ ;; Easygu Views may or may not be created with a specific :TIP keyword a=
rgument.
+ ;; If there is none, there will be no tooltip displayed for the correspo=
nding cocoa-view.
+ ;; Otherwise, if the argument is
+ ;; - a string, that string is used
+ ;; - a function, then if its return value is
+ ;; - a string, that string is used
+ ;; - NIL, a string informing that the tooltip is null and cocoa-d=
escribing the cocoa-view
+ ;; (possibly useful for identifying this view if it turns =
up in errors or inspector)
+ ;; - else a string naming the type of the result returned (possib=
ly useful for debugging)
+ ;; - the keyword :IDENTIFY, the cocoa-description of the cocoa-view
+ ;; - anything else, a string informing what type the argument is.
+ (let* ((egview (when (slot-boundp cview 'easygui-view) (slot-value cview=
'easygui-view)))
+ (tip (when egview (slot-value egview 'tip))))
+ (cond
+ ((stringp tip)
+ tip)
+ ((functionp tip)
+ (let ((it (funcall tip)))
+ (cond
+ ((stringp it) it)
+ ((null it) (format nil "Null tooltip for ~a" (lisp-string-fro=
m-nsstring (dcc (#/description cview)))))
+ (t (format nil "** Tooltip function returned non-string object of=
type ~s **" (type-of it))))))
+ ((eq tip :identify) (lisp-string-from-nsstring (dcc (#/description cv=
iew))))
+ ((null egview) =
+ (format nil "** Cocoa view ~s has no EasyGui-View **" cview))
+ ((null tip) (format nil "No tooltip for ~a" (lisp-string-from-nsstrin=
g (dcc (#/description cview)))))
+ (t (format nil "** Tip slot of Cocoa view ~s~%is of type ~s,~%not a s=
tring or a function or :IDENTIFY. **" cview tip)))))
+
+(defmacro define-tooltip-accessor (cocoa-class)
+ `(progn
+ #|
+ (objc:defmethod #/view:stringForToolTip:point:userData:
+ ((view ,cocoa-class)
+ (tag :<NST>ool<T>ip<T>ag)
+ (point :<NSP>oint)
+ (userdata :id))
+ (declare (ignorable tag point userdata))
+ (ccl::%make-nsstring (or (calculate-ns-tooltip view) "")))
+ |#
+ (objc:defmethod #/toolTip ((view ,cocoa-class))
+ (ccl::%make-nsstring (or (calculate-ns-tooltip view) "")))))
+
+(defclass cocoa-window (ns:ns-window)
+ ((easygui-window :reader easygui-window-of))
+ (:metaclass ns:+ns-object))
+
+(defmethod print-object ((object cocoa-window) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (let ((egview (if (slot-boundp object 'easygui-window) (easygui-window=
-of object) nil)))
+ (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egv=
iew)))))
+ object)
+
+(defmethod easygui-window-of ((eview view))
+ (if (cocoa-ref eview) (easygui-window-of (cocoa-ref eview)) nil))
+
+(defmethod easygui-window-of ((nsview ns:ns-view))
+ (let ((nswindow (dcc (#/window nsview))))
+ (if (typep nswindow 'cocoa-window) (easygui-window-of nswindow) nil)))
+
+(defclass cocoa-extension-mixin ()
+ ((easygui-view :initarg :eg-view :reader easygui-view-of)))
+
+(defmethod print-object ((object cocoa-extension-mixin) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (let ((egview (if (slot-boundp object 'easygui-view) (easygui-view-of =
object) nil)))
+ (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egv=
iew)))))
+ object)
+
+(defclass cocoa-text-field (cocoa-extension-mixin ns:ns-text-field) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-text-field)
+
+(defclass cocoa-mouseable-text-field (cocoa-text-field) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-mouseable-text-field)
+
+(defclass cocoa-contained-view (cocoa-extension-mixin ns:ns-view)
+ ((flipped :initarg :flipped :initform *screen-flipped*))
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-contained-view)
+
+(defclass cocoa-secure-text-field (cocoa-extension-mixin ns:ns-secure-text=
-field) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-secure-text-field)
+
+(defclass cocoa-button (cocoa-extension-mixin ns:ns-button) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-button)
+
+(defclass cocoa-pop-up-button (cocoa-extension-mixin ns:ns-pop-up-button) =
()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-pop-up-button)
+
+(defclass cocoa-menu-item (cocoa-extension-mixin ns:ns-menu-item) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-menu-item)
+
+(defclass cocoa-form (cocoa-extension-mixin ns:ns-form) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-form)
+
+(defclass cocoa-form-cell (cocoa-extension-mixin ns:ns-form-cell) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-form-cell)
+
+(defclass cocoa-box (cocoa-extension-mixin ns:ns-box) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-box)
+
+(defclass cocoa-drawing-view (cocoa-extension-mixin ns:ns-view)
+ ((flipped :initarg :flipped :initform *screen-flipped*))
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-drawing-view)
+
+(defclass cocoa-slider (cocoa-extension-mixin ns:ns-slider) ()
+ (:metaclass ns:+ns-object))
+
+(define-tooltip-accessor cocoa-slider)
+
(defparameter *view-class-to-ns-class-map*
- '((static-text-view . ns:ns-text-field)
- (password-input-view . ns:ns-secure-text-field)
- (text-input-view . ns:ns-text-field)
- (push-button-view . ns:ns-button)
- (form-view . ns:ns-form)
- (form-cell-view . ns:ns-form-cell)
- (box-view . ns:ns-box)
- (drawing-view . cocoa-drawing-view)
- (slider-view . ns:ns-slider)))
+ '((static-text-view . cocoa-mouseable-text-field)
+ (password-input-view . cocoa-secure-text-field)
+ (text-input-view . cocoa-text-field)
+ (push-button-view . cocoa-button)
+ (check-box-view . cocoa-button)
+ (radio-button-view . cocoa-button)
+ (menu-view . cocoa-pop-up-button)
+ (menu-item-view . cocoa-menu-item)
+ (form-view . cocoa-form)
+ (form-cell-view . cocoa-form-cell)
+ (box-view . cocoa-box)
+ (drawing-view . cocoa-drawing-view)
+ (slider-view . cocoa-slider)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Targets for mouse-enter, mouse-exit and mouse-moved handling
+
+(defclass easygui-mouse-target (ns:ns-object)
+ ((view :initarg :view :reader mouse-target-view :initform nil))
+ (:metaclass ns:+ns-object))
+
+(objc:define-objc-method ((:void :mouse-entered (:id event)) easygui-mouse=
-target)
+ (let* ((view (mouse-target-view self))
+ (fn (view-mouse-enter view)))
+ (when fn (funcall fn view :event event :allow-other-keys t))))
+
+(objc:define-objc-method ((:void :mouse-exited (:id event)) easygui-mouse-=
target)
+ (let* ((view (mouse-target-view self))
+ (fn (view-mouse-exit view)))
+ (when fn (funcall fn view :event event :allow-other-keys t))))
+
+(objc:define-objc-method ((:void :mouse-move (:id event)) easygui-mouse-ta=
rget)
+ (let* ((view (mouse-target-view self))
+ (fn (view-mouse-move view)))
+ (when fn (funcall fn view :event event :allow-other-keys t))))
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; view initialization:
@@ -184,14 +541,26 @@
(initialize-view view)))
=
(defmethod initialize-view ((view view))
- "Initializes the view via the class-to-ns-class map."
+ "Initializes the view using the class-to-ns-class map both as constraint
+on valid values of the :SPECIFICALLY initarg, and as source of default val=
ue.
+Also attaches contextual menu if there is one, and sets up mouse tracking
+rectangle if the view has any non-NIL mouse-enter, mouse-exit or mouse-mov=
e."
(when (slot-boundp view 'ref)
(return-from initialize-view nil))
(let ((ns-view-class (cdr (assoc (class-name (class-of view))
*view-class-to-ns-class-map*
- :test #'subtypep))))
- (when ns-view-class
- (setf (cocoa-ref view)
+ :test #'subtypep)))
+ (specifically (view-specifically view))
+ cocoaview)
+ (when specifically
+ (cond
+ ((not (find-class specifically nil))
+ (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICALLY=
does not name a class" specifically ns-view-class))
+ ((or (null ns-view-class) (subtypep specifically ns-view-class))
+ (setf ns-view-class specifically))
+ (t (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICAL=
LY is not a subclass of ~a" specifically ns-view-class))))
+ (if ns-view-class
+ (setf cocoaview
(cond
((and (slot-boundp view 'position)
(slot-boundp view 'size))
@@ -199,88 +568,246 @@
(make-instance ns-view-class
:with-frame (with-slots (position size) view
(ns-rect-from-points position size))))
- (t (make-instance ns-view-class)))))))
+ (t (make-instance ns-view-class)))
+ (cocoa-ref view) cocoaview)
+ (cerror "Continue with cocoa-ref unset" "No view class found for typ=
e ~a" (class-of view)))
+ (when (and cocoaview (slot-boundp view 'contextmenu))
+ (let ((menu (slot-value view 'contextmenu)))
+ (cond
+ ((null menu))
+ ((null ns-view-class))
+ ((typep menu 'menu-view)
+ (dcc (#/setMenu: cocoaview (slot-value menu 'ns-menu))))
+ (t (warn "Ignoring contextmenu value ~s for view ~s" menu view)))=
))
+ (when (and cocoaview (slot-value view 'tip))
+ (setf (slot-value view 'tiptag)
+ (dcc (#/addToolTipRect:owner:userData: cocoaview (#/bounds coco=
aview) cocoaview ccl:+null-ptr+))))
+ (when (and cocoaview (or (slot-value view 'mouse-enter) (slot-value vie=
w 'mouse-exit) (slot-value view 'mouse-move)))
+ (let ((target (make-instance 'easygui-mouse-target :view view)))
+ (dcc (#/retain target))
+ (dcc (#/addTrackingRect:owner:userData:assumeInside:
+ cocoaview
+ (dcc (#/bounds cocoaview))
+ target
+ ccl:+null-ptr+
+ #$YES))))))
+ #| OS X Leopard should allow this but ... it didn't when I said VIEW n=
ot COCOAVIEW ...:
+ (area (make-instance 'ns:ns-tracking-area
+ :with-rect (dcc (#/bounds cocoaview))
+ :options (logior #$NSTrackingMouseEnteredAndExited
+ #$NSTrackingActiveInKeyWindow
+ #$NSTrackingInVisibleRect)
+ :owner cocoaview
+ :userInfo #$NIL)))
+ (dcc (#/addTrackingArea: cocoaview area))))
+ |#
+
+(defun screen-height nil
+ (running-on-this-thread ()
+ (ns:ns-rect-height (dcc (#/frame (#/objectAtIndex: (#/screens ns:ns-sc=
reen) 0))))))
+
+(defmethod view-content-rect ((view view) &optional hidden)
+ (if hidden
+ (ns:make-ns-rect 0 0 0 0)
+ (with-slots (position size) view
+ ;(if (slot-boundp view 'size)
+ ; (format t "~&View ~s has size ~s~%" view size)
+ ; (format t "~&View ~s has size unbound~%" view))
+ (let* ((height (if (slot-boundp view 'size) (point-y size) *window-s=
ize-default-y*))
+ (stated (if (slot-boundp view 'position) (point-y position) *=
window-position-default-y*))
+ (screentop (screen-height)) ;; TODO: dtrt for multiple scree=
ns
+ (bottom (if (and *screen-flipped* (typep view 'window))
+ (- screentop height stated)
+ stated)))
+ (ns:make-ns-rect
+ (if (slot-boundp view 'position) (point-x position) *window-posit=
ion-default-x*)
+ bottom
+ (if (slot-boundp view 'size) (point-x size) *window-size-default-=
x*)
+ height)))))
=
(defmethod initialize-view ((win window))
"Initialize size, title, flags."
- (with-slots (position size) win
- (let ((content-rect
- (multiple-value-call
- #'ns:make-ns-rect
- (if (slot-boundp win 'position)
- (values (point-x position) (point-y position))
- (values *window-position-default-x*
- *window-position-default-y*))
- (if (slot-boundp win 'size)
- (values (point-x size) (point-y size))
- (values *window-size-default-x*
- *window-size-default-y*))))
- (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win))
- (flag-mask :resizable-p
- (window-resizable-p win))
- (flag-mask :minimizable-p
- (window-minimizable-p win))
- (flag-mask :closable-p
- (window-closable-p win))
- #$NSTitledWindowMask)))
- (setf (cocoa-ref win) (make-instance 'ns:ns-window
- :with-content-rect content-rect
- :style-mask style-mask
- :backing #$NSBackingStoreBuffered ; TODO?
- :defer nil)))))
+ (with-slots (level hidden optimized style flipped specifically) win
+ (unless (and (find-class specifically nil) (subtypep specifically 'coc=
oa-contained-view))
+ (cerror "Ignore ~a and create content view of type ~a"
+ "Value given for \":specifically\" is ~a which is not a subt=
ype of ~a"
+ specifically 'cocoa-contained-view)
+ (setf specifically 'cocoa-contained-view))
+ (let* ((content-rect (view-content-rect win hidden))
+ (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win))
+ (flag-mask :resizable-p (window-resizable-p win=
))
+ (flag-mask :minimizable-p (window-minimizable-p w=
in))
+ (flag-mask :closable-p (window-closable-p win))
+ (if (or (window-resizable-p win) (window-minimiza=
ble-p win) (window-closable-p win))
+ #$NSTitledWindowMask
+ 0)
+ style))
+ (c-win
+ (make-instance 'cocoa-window
+ :with-content-rect content-rect
+ :style-mask style-mask
+ :backing #$NSBackingStoreBuffered ; TODO?
+ :defer t))
+ (containee (make-instance specifically)))
+ (setf (slot-value containee 'flipped) flipped)
+ (dcc (#/setFrame: containee content-rect))
+ (dcc (#/setContentView: c-win containee))
+ (dcc (#/setDelegate: c-win c-win))
+ (dcc (#/setBackgroundColor: c-win (slot-value win 'background)))
+ (dcc (#/setLevel: c-win level))
+ (when optimized (dcc (#/useOptimizedDrawing: c-win #$YES)))
+ (setf (cocoa-ref win) c-win)
+ (setf (slot-value c-win 'easygui-window) win)
+ (if hidden
+ (dcc (#/disableFlushWindow c-win))
+ (window-show win))
+ c-win)))
=
(defmethod initialize-view :after ((view text-input-view))
- (setf (editable-p view) (not (text-input-locked-p view))))
+ (setf (editable-p view) (not (text-input-locked-p view)))
+ (setf (slot-value (cocoa-ref view) 'easygui-view) view))
=
(defmethod initialize-view :after ((view static-text-view))
(dcc (#/setEditable: (cocoa-ref view) nil))
(dcc (#/setBordered: (cocoa-ref view) nil))
(dcc (#/setBezeled: (cocoa-ref view) nil))
- (dcc (#/setDrawsBackground: (cocoa-ref view) nil)))
+ (setf (slot-value (cocoa-ref view) 'easygui-view) view))
+
+(defmethod initialize-view :after ((view action-view-mixin))
+ (when (and (slot-boundp view 'action) (slot-value view 'action))
+ (setf (action view) (slot-value view 'action)))
+ (unless (dialog-item-enabled-p view)
+ (dcc (#/setEnabled: (cocoa-ref view) #$NO))))
+
+(defparameter *bezelstyle-alist*
+ `((:round . #.#$NSRoundedBezelStyle)
+ (:square . #.#$NSRegularSquareBezelStyle)
+ (:regular-square . #.#$NSRegularSquareBezelStyle)
+ (:thick-square . #.#$NSThickSquareBezelStyle)
+ (:thicker-square . #.#$NSThickerSquareBezelStyle)
+ (:disclosure . #.#$NSDisclosureBezelStyle)
+ (:Shadowless-square . #.#$NSShadowlessSquareBezelStyle)
+ (:circular . #.#$NSCircularBezelStyle)
+ (:textured-square . #.#$NSTexturedSquareBezelStyle)
+ (:help-button . #.#$NSHelpButtonBezelStyle)
+ (:small-square . #.#$NSSmallSquareBezelStyle)
+ (:textured-rounded . #.#$NSTexturedRoundedBezelStyle)
+ (:round-rect . #.#$NSRoundRectBezelStyle)
+ (:recessed . #.#$NSRecessedBezelStyle)
+ (:rounded-disclosure . #.#$NSRoundedDisclosureBezelStyle)))
+
+(defun bezel-style-lookup (key)
+ (rest (or (assoc key *bezelstyle-alist*) (first *bezelstyle-alist*))))
+
+(defmethod (setf bezel-style) (stylename (view push-button-view))
+ (setf (slot-value view 'bezelstyle) (if (assoc stylename *bezelstyle-ali=
st*) stylename :round))
+ (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (slot-value =
view 'bezelstyle))))
+ stylename)
=
(defmethod initialize-view :after ((view push-button-view))
- (dcc (#/setBezelStyle: (cocoa-ref view) #$NSRoundedBezelStyle))
+ (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (bezel-style=
view))))
(let ((default-button-p (slot-value view 'default-button-p)))
(typecase default-button-p
(cons
- (dcc (#/setKeyEquivalent: (cocoa-ref view) (string
- (first default-button-p=
))))
+ (dcc (#/setKeyEquivalent: (cocoa-ref view) =
+ (ccl::%make-nsstring (string (first defau=
lt-button-p)))))
(dcc (#/setKeyEquivalentModifierMask:
(cocoa-ref view)
(apply #'logior (mapcar #'key-mask (cdr default-button-p))))))
(string
- (dcc (#/setKeyEquivalent: (cocoa-ref view) default-button-p)))
+ (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::%make-nsstring def=
ault-button-p))))
(null)
(t
- (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\retu=
rn))))))))
+ (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\retu=
rn)))))))
+ (setf (slot-value (cocoa-ref view) 'easygui-view) view))
+
+(defmethod initialize-view :after ((view box-view))
+ (setf (slot-value (cocoa-ref view) 'easygui-view) view))
=
(defmethod initialize-view :after ((view form-view))
(when (slot-boundp view 'interline-spacing)
(dcc (#/setInterlineSpacing: (cocoa-ref view)
- (coerce (slot-value view 'interline-spacing)
- 'double-float)))))
+ (gui::cgfloat (slot-value view 'interline-spa=
cing)))))
+ (setf (slot-value (cocoa-ref view) 'easygui-view) view))
=
(defmethod initialize-view :after ((view slider-view))
- (with-slots (discrete-tick-marks-p tick-mark-count min-value max-value) =
view
- (cond =
- #| BUG: tick-mark-values is not defined.
- ((and (not (slot-boundp view 'tick-mark-count))
- (slot-boundp view 'discrete-tick-marks-p)
- (/=3D (length tick-mark-values) tick-mark-count))
- (error "Incompatible tick mark specification: ~A doesn't match ~
- count of ~A" tick-mark-values tick-mark-values))|#
- ((or (not (slot-boundp view 'max-value))
- (not (slot-boundp view 'min-value)))
- (error "A slider view needs both :min-value and :max-value set.")))
- (dcc (#/setMinValue: (cocoa-ref view) (float min-value ns:+cgfloat-ze=
ro+)))
- (dcc (#/setMaxValue: (cocoa-ref view) (float max-value ns:+cgfloat-ze=
ro+)))
+ (with-slots (discrete-tick-marks-p tick-mark-count tick-mark-values min-=
value max-value) view
+ (cond ((and (slot-boundp view 'tick-mark-count)
+ (slot-boundp view 'discrete-tick-marks-p)
+ (slot-boundp view 'tick-mark-values)
+ (/=3D (length tick-mark-values) tick-mark-count))
+ (error "Incompatible tick mark specification: ~A doesn't match=
~
+ count of ~A" tick-mark-count tick-mark-values))
+ ((or (not (slot-boundp view 'max-value))
+ (not (slot-boundp view 'min-value)))
+ (error "A slider view needs both :min-value and :max-value set=
.")))
+ (dcc (#/setMinValue: (cocoa-ref view) (float min-value (or 1.0d0 ns:+=
cgfloat-zero+))))
+ (dcc (#/setMaxValue: (cocoa-ref view) (float max-value (or 1.0d0 ns:+=
cgfloat-zero+))))
(when (slot-boundp view 'tick-mark-count)
(dcc (#/setNumberOfTickMarks: (cocoa-ref view) tick-mark-count))
(dcc (#/setAllowsTickMarkValuesOnly:
- (cocoa-ref view) (not (not discrete-tick-marks-p)))))))
+ (cocoa-ref view) (not (not discrete-tick-marks-p))))))
+ (setf (slot-value (cocoa-ref view) 'easygui-view) view))
+
+(defmethod initialize-view :after ((view text-coloring-mixin))
+ (dcc (#/setTextColor: (cocoa-ref view) (slot-value view 'foreground))))
+
+(defmethod initialize-view :after ((view text-fonting-mixin))
+ (when (slot-value view 'font)
+ (dcc (#/setFont: (cocoa-ref view) (slot-value view 'font)))))
+
+(defmethod (setf view-font) ((new ns:ns-font) (view view))
+ (setf (slot-value view 'font) new)
+ (dcc (#/setFont: (cocoa-ref view) new)))
+
+; ----------------------------------------------------------------------
+; Modifying position / size of view / window
+; ----------------------------------------------------------------------
+
+(defmethod (setf view-position) (point (self view))
+ (running-on-main-thread ()
+ (setf (slot-value self 'position) point)
+ (when (slot-value self 'frame-inited-p)
+ (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self)))
+ (dcc (#/setNeedsDisplay (cocoa-ref self))))))
+
+(defmethod (setf view-position) (point (self window))
+ (running-on-main-thread ()
+ (setf (slot-value self 'position) point)
+ (unless (window-hidden self)
+ (let* ((contentrect (view-content-rect self nil))
+ (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) =
contentrect))))
+ (dcc (#/setFrame:display: (cocoa-ref self) framerect t))))))
+
+(defmethod (setf view-size) (point (self view))
+ (running-on-main-thread ()
+ (setf (slot-value self 'size) point)
+ (when (slot-value self 'frame-inited-p)
+ (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self)))
+ (dcc (#/setNeedsDisplay (cocoa-ref self))))))
+
+(defmethod (setf view-size) (point (self window))
+ (running-on-main-thread ()
+ (setf (slot-value self 'size) point)
+ (unless (window-hidden self)
+ (let* ((contentrect (view-content-rect self nil))
+ (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) =
contentrect))))
+ (dcc (#/setFrame:display: (cocoa-ref self) framerect t))))))
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; view hierarchies:
+
+(defmethod set-needs-display ((view view) flag)
+ (running-on-this-thread ()
+ (dcc (#/setNeedsDisplay: (cocoa-ref view) flag))))
+
+(defmethod set-needs-display ((view content-view-mixin) flag)
+ (set-needs-display (content-view view) flag))
+
+(defmethod set-needs-display ((view window) flag)
+ (if (window-hidden view)
+ (setf (slot-value view 'window-needs-display-on-show) flag)
+ (set-needs-display (content-view view) flag)))
=
(defmethod add-1-subview :around ((view view) (cw-view content-view-mixin))
(add-1-subview view (content-view cw-view)))
@@ -289,44 +816,71 @@
"Correctly initialize view positions"
(call-next-method)
(with-slots (position size frame-inited-p) view
- (unless frame-inited-p
- (dcc (#/setFrameOrigin: (cocoa-ref view)
- (ns:make-ns-point (point-x position)
- (point-y position))))
- (if (slot-boundp view 'size)
- (dcc (#/setFrameSize: (cocoa-ref view)
- (ns:make-ns-point (point-x size)
- (point-y size))))
- (dcc (#/sizeToFit (cocoa-ref view)))))
- (dcc (#/setNeedsDisplay: (cocoa-ref view) t))
- (dcc (#/setNeedsDisplay: (cocoa-ref super-view) t))))
+ (unless frame-inited-p
+ (setf frame-inited-p t)
+ (running-on-this-thread ()
+ (let ((cocoa-view (cocoa-ref view)))
+ (dcc (#/setFrameOrigin: cocoa-view (ns-point-from-point position=
)))
+ (if (slot-boundp view 'size)
+ (dcc (#/setFrameSize: cocoa-view (ns-point-from-point size)))
+ (dcc (#/sizeToFit cocoa-view))))))
+ (set-needs-display view t)
+ (unless (view-subviews-busy super-view) (set-needs-display super-view =
t))))
=
(defmethod add-1-subview ((view view) (super-view view))
- (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view))))
+ (running-on-this-thread ()
+ (setf (slot-value view 'parent) super-view)
+ (push view (slot-value super-view 'subviews))
+ (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view)))))
=
(defun add-subviews (superview subview &rest subviews)
+ (setf (view-subviews-busy superview) t)
(add-1-subview subview superview)
(dolist (subview subviews)
(add-1-subview subview superview))
+ (set-needs-display superview t)
+ (setf (view-subviews-busy superview) nil)
superview)
=
(defmethod remove-1-subview ((view view) (cw-view content-view-mixin))
(remove-1-subview view (content-view cw-view)))
=
(defmethod remove-1-subview ((view view) (super-view view))
- (assert (eql (cocoa-ref super-view) (#/superview (cocoa-ref view))))
+ (assert (eql (cocoa-ref super-view) (dcc (#/superview (cocoa-ref view)))=
))
+ (assert (member view (view-subviews super-view)))
+ (assert (eq super-view (slot-value view 'parent)))
(maybe-invalidating-object (view)
- (#/removeFromSuperview (cocoa-ref view))))
+ (setf (slot-value super-view 'subviews) (delete view (slot-value super=
-view 'subviews)))
+ (setf (slot-value view 'parent) nil)
+ (running-on-this-thread ()
+ (dcc (#/removeFromSuperview (cocoa-ref view))))))
=
(defun remove-subviews (superview subview &rest subviews)
+ (setf (view-subviews-busy superview) t)
(remove-1-subview subview superview)
(dolist (subview subviews)
(remove-1-subview subview superview))
+ (set-needs-display superview t)
+ (setf (view-subviews-busy superview) nil)
superview)
=
(defmethod window-show ((window window))
- (dcc (#/makeKeyAndOrderFront: (cocoa-ref window) nil))
- window)
+ (running-on-this-thread ()
+ (let ((cwin (cocoa-ref window)))
+ (when (window-hidden window)
+ (setf (slot-value window 'hidden) nil)
+ (let* ((contentrect (view-content-rect window nil))
+ (framerect (dcc (#/frameRectForContentRect: (cocoa-ref wind=
ow) contentrect))))
+ (dcc (#/setFrame:display: (cocoa-ref window) framerect nil)))
+ (when (dcc (#/isMiniaturized cwin)) (dcc (#/deminiaturize: cwin cw=
in)))
+ (when (slot-value window 'window-needs-display-on-show)
+ (setf (slot-value window 'window-needs-display-on-show) nil)
+ (dcc (#/setNeedsDisplay: (cocoa-ref (content-view window)) t))))
+ (dcc (#/makeKeyAndOrderFront: cwin nil))
+ (when (dcc (#/isFlushWindowDisabled cwin))
+ (dcc (#/enableFlushWindow cwin))
+ (dcc (#/flushWindow cwin)))
+ window)))
=
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -334,7 +888,7 @@
=
(defmethod add-entry (entry (view form-view))
(make-instance 'form-cell-view
- :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) entry))))
+ :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) (ccl::%make-nsstring en=
try)))))
=
(defun add-entries (view &rest entries)
(prog1 (mapcar (lambda (entry) (add-entry entry view)) entries)
@@ -357,32 +911,624 @@
(view-text (nth-cell index view)))
=
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Window closing
+ =
+(defmethod window-may-close ((w window))
+"This generic is intended to allow applications to define :BEFORE and/or :=
AFTER methods
+invoked when windows are closed. The default primary method returns T to i=
ndicate that
+the window may close. If an overriding primary method returns NIL, the win=
dow will not
+close in response to user action but will still close if the application q=
uits.
+(This is because window-may-close is called when the COCOA-WINDOW (special=
ised NS:NS-WINDOW)
+that is attached to an EASYGUI::WINDOW object receives a performClose: mes=
sage, as when
+a user clicks the close button for example.)"
+ (declare (ignore w))
+ t)
+
+(defmethod perform-close ((w window))
+"This generic is intended to allow applications to mimic the user clicking=
a window's
+close button."
+ (running-on-this-thread ()
+ (dcc (#/performClose: (cocoa-ref w) ccl:+null-ptr+))))
+
+(objc:define-objc-method ((:<BOOL> :window-should-close (:id sender)) coco=
a-window)
+ (declare (optimize (safety 0))) ; CCL v1.3 checks a faulty type declarat=
ion otherwise
+ (declare (ignore sender)) ; The cocoa-window has been set up as its own=
delegate. Naughty?
+ (if (window-may-close (easygui-window-of self)) #$YES #$NO))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Drawing:
=
-(defclass cocoa-drawing-view (ns:ns-view)
- ((easygui-view :initarg :eg-view :reader easygui-view-of))
- (:metaclass ns:+ns-view))
+(defmethod clear-page ((cocoa-view cocoa-drawing-view))
+ (let* ((view (easygui-view-of cocoa-view))
+ (rect (dcc (#/bounds cocoa-view)))
+ (color (slot-value view 'background)))
+ (with-focused-view cocoa-view
+ (dcc (#/setFill color))
+ (dcc (#_NSRectFill rect)))))
+ =
+(objc::defmethod (#/isFlipped :<BOOL>) ((self cocoa-drawing-view))
+ (if (slot-value self 'flipped) #$YES #$NO))
+
+(objc::defmethod (#/isFlipped :<BOOL>) ((self cocoa-contained-view))
+ (if (slot-value self 'flipped) #$YES #$NO))
=
(defmethod initialize-view :after ((view drawing-view))
+ (setf (slot-value (cocoa-ref view) 'flipped) (slot-value view 'flipped))
(setf (slot-value (cocoa-ref view) 'easygui-view) view))
=
(objc:defmethod (#/drawRect: :void) ((self cocoa-drawing-view)
(rect :<NSR>ect))
- (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect)))
+ (dcc (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect)=
)))
=
(objc:defmethod (#/acceptsFirstReponder: :boolean) ((view cocoa-drawing-vi=
ew))
(accept-key-events-p (easygui-view-of view)))
=
(defgeneric draw-view-rectangle (view rectangle)
(:method ((view drawing-view) rectangle)
- (declare (ignore view rectangle))
+ (declare (ignorable view rectangle))
+ (when (draw-fn view)
+ (let ((cview (cocoa-ref view)))
+ (with-focused-view cview (funcall (draw-fn view) view cview))))
nil))
=
(defmethod redisplay ((view drawing-view)
&key rect)
(setf rect (if rect
(rectangle-nsrect rect)
- (#/bounds (cocoa-ref view))))
- (#/setNeedsDisplayInRect: (cocoa-ref view) rect))
+ (dcc (#/bounds (cocoa-ref view)))))
+ (dcc (#/setNeedsDisplayInRect: (cocoa-ref view) rect)))
=
(define-useful-mouse-event-handling-routines cocoa-drawing-view)
+(define-useful-mouse-event-handling-routines cocoa-mouseable-text-field)
+
+(defmethod mouse-down ((view drawing-view) &key cocoa-event location butto=
n click-count delta)
+ (let ((mousefn (drawing-view-mouse-down view)) (*cocoa-event* cocoa-even=
t))
+ (when mousefn
+ (funcall mousefn view
+ :location location
+ :allow-other-keys t
+ :button button
+ :cocoa-event cocoa-event
+ :click-count click-count
+ :delta delta))))
+
+(defmethod mouse-up ((view drawing-view) &key cocoa-event location button =
click-count delta)
+ (let ((mousefn (drawing-view-mouse-up view)) (*cocoa-event* cocoa-event))
+ (when mousefn
+ (funcall mousefn view
+ :location location
+ :allow-other-keys t
+ :button button
+ :cocoa-event cocoa-event
+ :click-count click-count
+ :delta delta))))
+
+(defmethod mouse-dragged ((view drawing-view) &key cocoa-event location bu=
tton click-count delta)
+ (let ((mousefn (drawing-view-mouse-dragged view)) (*cocoa-event* cocoa-e=
vent))
+ (when mousefn
+ (funcall mousefn view
+ :location location
+ :allow-other-keys t
+ :button button
+ :cocoa-event cocoa-event
+ :click-count click-count
+ :delta delta))))
+
+(defmethod mouse-down ((view static-text-view) &key cocoa-event location b=
utton click-count delta)
+ (let ((mousefn (static-text-view-mouse-down view)) (*cocoa-event* cocoa-=
event))
+ (when mousefn
+ (funcall mousefn view
+ :location location
+ :allow-other-keys t
+ :button button
+ :cocoa-event cocoa-event
+ :click-count click-count
+ :delta delta))))
+
+(defmethod mouse-up ((view static-text-view) &key cocoa-event location but=
ton click-count delta)
+ (let ((mousefn (static-text-view-mouse-up view)) (*cocoa-event* cocoa-ev=
ent))
+ (when mousefn
+ (funcall mousefn view
+ :location location
+ :allow-other-keys t
+ :button button
+ :cocoa-event cocoa-event
+ :click-count click-count
+ :delta delta))))
+
+(defmethod mouse-dragged ((view static-text-view) &key cocoa-event locatio=
n button click-count delta)
+ (let ((mousefn (static-text-view-mouse-dragged view)) (*cocoa-event* coc=
oa-event))
+ (when mousefn
+ (funcall mousefn view
+ :location location
+ :allow-other-keys t
+ :button button
+ :cocoa-event cocoa-event
+ :click-count click-count
+ :delta delta))))
+
+; -------------------
+(defmethod view-named (name (view view))
+ (find name (view-subviews view) :key #'view-nick-name))
+
+(defmethod view-named (name (container content-view-mixin))
+ (view-named name (content-view container)))
+
+(defmethod view-subviews ((w content-view-mixin))
+ (view-subviews (content-view w)))
+
+; ----------------------
+
+(defmethod view-nickname-chain ((view view) &optional include-everything) "
+Yields two values:
+- a list of nicknames of containing views, starting with outermost contain=
er
+- the view or window that contains the view with the first name in the lis=
t,
+ or NIL if the first name belongs to a window.
+If include-everything is NIL (the default), the list does not contain the
+autogenerated name for content views of windows or boxes, and contains nam=
es
+of views or windows that have non-NIL names. The second value may then be
+a view or window that has no nickname of its own.
+If include-everything is T, the list does contain the autogenerated name of
+content views of windows or boxes, it does contain NIL for views named NIL,
+and the second value will always be NIL."
+ (do (chain
+ nickname
+ (outermost view (view-container outermost)))
+ ((or (null outermost)
+ (and (null (setf nickname (view-nick-name outermost)))
+ (not include-everything))) =
+ (values chain outermost))
+ (when (or include-everything (not (eq nickname '%CONTENT-OF-CONTENT-VI=
EW%)))
+ (push (view-nick-name outermost) chain))))
+
+; ----------------------
+
+(defclass check-box-view (view view-text-via-title-mixin action-view-mixin=
decline-menu-mixin)
+ ((checked :initarg :checked :initform nil)))
+
+(defmethod check-box-check ((self check-box-view) &optional perform)
+ (running-on-this-thread ()
+ (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOnState)
+ (if perform
+ (dcc (#/performClick: (cocoa-ref self) nil))
+ (dcc (#/setState: (cocoa-ref self) #$NSOnState)))
+ t)))
+
+(defmethod initialize-view :after ((view check-box-view))
+ (when (cocoa-ref view)
+ (dcc (#/setButtonType: (cocoa-ref view) #$NSSwitchButton))
+ (when (slot-value view 'checked) (check-box-check view))
+ (setf (slot-value (cocoa-ref view) 'easygui-view) view)))
+
+(defmethod check-box-uncheck ((self check-box-view) &optional perform)
+ (running-on-this-thread ()
+ (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOffState)
+ (if perform
+ (dcc (#/performClick: (cocoa-ref self) nil))
+ (dcc (#/setState: (cocoa-ref self) #$NSOffState)))
+ t)))
+
+(defmethod check-box-checked-p ((self check-box-view))
+ (eql (dcc (#/state (cocoa-ref self))) #$NSOnState))
+
+(defmethod (setf check-box-checked-p) (new (self check-box-view))
+ (if new
+ (check-box-check self)
+ (check-box-uncheck self))
+ new)
+
+; -------------------------
+(defclass radio-button-view (view view-text-via-title-mixin action-view-mi=
xin decline-menu-mixin)
+ ((selected :initarg :selected :reader radio-button-selected-p :initform =
nil)
+ (cluster :initarg :cluster :initform '#:default-cluster))
+ (:default-initargs :action #'(lambda () nil)))
+
+(defun deselect-radio-button-cohorts (radio-button-view)
+ (when (view-container radio-button-view)
+ (dolist (sibling (view-subviews (view-container radio-button-view)))
+ (when (and (not (eq sibling radio-button-view))
+ (typep sibling 'radio-button-view)
+ (eq (slot-value radio-button-view 'cluster) (slot-value s=
ibling 'cluster))
+ (eql (dcc (#/state (cocoa-ref sibling))) #$NSOnState))
+ (setf (slot-value sibling 'selected) nil)
+ (dcc (#/setState: (cocoa-ref sibling) #$NSOffState))))))
+ =
+(defmethod radio-button-select ((self radio-button-view) &optional perform)
+ (running-on-this-thread ()
+ (if perform
+ (dcc (#/performClick: (cocoa-ref self) nil))
+ (progn
+ (deselect-radio-button-cohorts self)
+ (setf (slot-value self 'selected) t)
+ (dcc (#/setState: (cocoa-ref self) #$NSOnState))))))
+
+(defmethod initialize-view :after ((self radio-button-view))
+ (when (cocoa-ref self)
+ (dcc (#/setButtonType: (cocoa-ref self) #$NSRadioButton))
+ (when (slot-value self 'selected) (radio-button-select self))
+ (setf (slot-value (cocoa-ref self) 'easygui-view) self)))
+
+(defmethod radio-button-deselect ((self radio-button-view))
+ (running-on-this-thread ()
+ (dcc (#/setState: (cocoa-ref self) #$NSOffState))
+ (prog1
+ (radio-button-selected-p self)
+ (setf (slot-value self 'selected) nil))))
+
+(defmethod (setf action) (handler (view radio-button-view))
+ (call-next-method
+ (lambda ()
+ (deselect-radio-button-cohorts view)
+ (setf (slot-value view 'selected) t)
+ (funcall handler))
+ view)
+ handler)
+
+; ----------------------------------------------------------------------
+; INVALIDATE-VIEW
+; ----------------------------------------------------------------------
+
+(defmethod invalidate-view ((view view) &optional total)
+ (declare (ignorable total))
+ (let ((cview (cocoa-ref view)))
+ (dcc (#/setNeedsDisplay: cview #$YES))))
+
+(defmethod invalidate-view ((window window) &optional total)
+ (declare (ignorable total))
+ (let* ((cocoaview (cocoa-ref window))
+ (contentview (dcc (#/contentView cocoaview))))
+ (dcc (#/setNeedsDisplay: contentview #$YES))))
+
+; ----------------------------------------------------------------------
+; Methods to GET- & SET- FORE- & BACK- COLOR
+; ----------------------------------------------------------------------
+
+(defmethod set-fore-color ((view view) (color ns:ns-color))
+ (setf (slot-value view 'foreground) color))
+
+(defmethod set-fore-color :before ((view view-text-via-stringvalue-mixin) =
(color ns:ns-color))
+ (dcc (#/setTextColor: (cocoa-ref view) color)))
+
+(defmethod set-fore-color ((view cocoa-extension-mixin) (color ns:ns-color=
))
+ (set-fore-color (easygui-view-of view) color))
+
+(defmethod set-back-color ((view view) (color ns:ns-color) &optional redis=
play-p)
+ (setf (slot-value view 'background) color)
+ (when redisplay-p (invalidate-view view)))
+
+(defmethod set-back-color :after ((view static-text-view) (color ns:ns-col=
or) &optional redisplay-p)
+ (dcc (#/setBackgroundColor: (cocoa-ref view) color))
+ (when redisplay-p (invalidate-view view)))
+
+(defmethod set-back-color ((view cocoa-extension-mixin) (color ns:ns-color=
) &optional redisplay-p)
+ (set-back-color (easygui-view-of view) color redisplay-p))
+
+(defmethod get-fore-color ((view view))
+ (slot-value view 'foreground))
+
+(defmethod get-fore-color ((view cocoa-extension-mixin))
+ (get-fore-color (easygui-view-of view)))
+
+(defmethod get-back-color ((view view))
+ (slot-value view 'background))
+
+(defmethod get-back-color ((view cocoa-extension-mixin))
+ (get-back-color (easygui-view-of view)))
+
+; --------------------- Menus Begin ---------------------
+
+(defmethod view-text ((self ns:ns-menu))
+ (lisp-string-from-nsstring (dcc (#/title self))))
+
+(defmethod (setf view-text) (new (self ns:ns-menu))
+ (running-on-this-thread ()
+ (dcc (#/setTitle: self (ccl::%make-nsstring new)))
+ new))
+
+(defclass menu-view (view view-text-via-title-mixin decline-menu-mixin)
+ ((selection :initarg :selection :reader menu-selection :initform nil)
+ (menu-kind :initarg :menu-kind :reader menu-kind :initform :pu=
ll-down-menu)
+ (menu-items :initarg :menu-items :reader menu-items :initform nil)
+ ns-menu
+ %result))
+
+(defclass menu-item-view (view view-text-via-title-mixin action-view-mixin=
decline-menu-mixin)
+ (parent-menu
+ action
+ submenu)
+ (:default-initargs :action #'(lambda () nil)))
+
+;(defmethod (setf view-text) :after (new (menu menu-view))
+; (declare (ignorable new))
+; (dcc (#/setNeedsDisplay: (cocoa-ref menu) t)))
+
+(defmethod initialize-instance :after ((self menu-view) &rest args &key me=
nu-items selection)
+ (declare (ignorable args selection))
+ (let ((ns-menu nil))
+ (if (slot-boundp self 'ns-menu)
+ (setf ns-menu (slot-value self 'ns-menu))
+ (setf ns-menu (dcc (#/menu (cocoa-ref self)))
+ (slot-value self 'ns-menu) ns-menu))
+ ;(format t "~&Initializing menu ~a with ~a items~%" self (length menu-=
items))
+ (dolist (item menu-items)
+ ;(format t "~&Adding ~a to menu ~a~%" item self)
+ (cond
+ ((typep item 'menu-view)
+ (let ((intermediary (make-instance 'menu-item-view
+ :title (view-text item))))
+ (setf (slot-value intermediary 'submenu) item)
+ (dcc (#/setSubmenu: (cocoa-ref intermediary) (slot-value item 'n=
s-menu)))
+ (dcc (#/addItem: ns-menu (cocoa-ref intermediary)))))
+ ((not (typep item 'menu-item-view))
+ (warn "Ignoring so-called menu item ~s" item))
+ ((slot-boundp item 'parent-menu)
+ (warn "Ignoring menu item ~s, which is already an item in some men=
u" item))
+ (t (let ((coco (cocoa-ref item)))
+ (dcc (#/addItem: ns-menu coco))
+ (setf (slot-value item 'parent-menu) self)))))))
+
+(defmethod (setf action) (new (menu-item menu-item-view))
+ (call-next-method
+ #'(lambda ()
+ (if (slot-boundp menu-item 'parent-menu)
+ (let ((parent (slot-value menu-item 'parent-menu)))
+ (setf (slot-value parent 'selection) menu-item)
+ (setf (slot-value parent '%result) (funcall new)))
+ (funcall new)))
+ menu-item)
+ new)
+
+(defmethod set-menu-item-title ((menu-item menu-item-view) title)
+ (running-on-this-thread ()
+ (dcc (#/setTitle: (cocoa-ref menu-item) (ccl::%make-nsstring title)))))
+
+(defmethod set-menu-item-title ((menu-item ns:ns-menu-item) title)
+ (running-on-this-thread ()
+ (dcc (#/setTitle: menu-item (ccl::%make-nsstring title)))))
+
+; -------------------
+(defclass pop-up-menu (menu-view)
+ ()
+ (:default-initargs :menu-kind :pop-up-menu))
+
+(defmethod initialize-instance :after ((self pop-up-menu) &rest args &key =
selection)
+ (declare (ignorable args))
+ (with-slots (ns-menu menu-items) self
+ (setf (view-text self)
+ (cond
+ ((null menu-items)
+ "<No Items>")
+ ((null selection)
+ (setf (slot-value self 'selection) (first menu-items))
+ (view-text (first menu-items)))
+ ((stringp selection)
+ selection)
+ ((member selection menu-items)
+ (setf (slot-value self 'selection) selection)
+ (view-text selection))
+ (t "<Selection Invalid>"))))
+ (setf (slot-value (cocoa-ref self) 'easygui-view) self))
+
+; ----------------------
+(defclass pull-down-menu (menu-view)
+ ()
+ (:default-initargs :menu-kind :pull-down-menu))
+
+(defmethod initialize-instance :after ((self pull-down-menu) &rest args &k=
ey title)
+ (declare (ignorable args))
+ (running-on-this-thread ()
+ (dcc (#/insertItemWithTitle:atIndex: (cocoa-ref self) (ccl::%make-nsst=
ring (or title "<No Title>")) 0))))
+
+(defmethod initialize-view :after ((self pull-down-menu))
+ (running-on-this-thread ()
+ (when (cocoa-ref self)
+ (dcc (#/setPullsDown: (cocoa-ref self) #$YES))
+ (setf (slot-value (cocoa-ref self) 'easygui-view) self))))
+
+; -----------------------
+(defclass contextual-menu (menu-view)
+ ()
+ (:default-initargs :menu-kind :contextual-menu))
+
+(defgeneric add-contextual-menu (container menu &optional subviews))
+
+(defmethod add-contextual-menu ((window window) (menu menu-view) &optional=
subviews)
+ (add-contextual-menu (content-view window) menu subviews))
+
+(defmethod add-contextual-menu ((view view) (menu menu-view) &optional sub=
views)
+ (running-on-this-thread ()
+ (dcc (#/setMenu: (cocoa-ref view) (slot-value menu 'ns-menu)))
+ (when subviews
+ (dolist (sub (view-subviews view))
+ (unless (or (not (cocoa-null (dcc (#/menu (cocoa-ref sub)))))
+ (typep sub 'decline-menu-mixin))
+ (add-contextual-menu sub menu subviews))))))
+
+(defmethod add-contextual-menu ((view menu-view) (refusenik decline-menu-m=
ixin) &optional subviews)
+ (declare (ignore subviews))
+ (error "Cannot add a contextual menu to a view of class ~s" (type-of ref=
usenik)))
+
+; -------------------------
+(defun application-object nil
+ (dcc (#/sharedApplication ns:ns-application)))
+
+(defun application-main-menu nil
+ (dcc (#/mainMenu (application-object))))
+
+(defgeneric navigate-menu (titles menu))
+
+(defmethod navigate-menu ((titles list) (menu menu-view))
+;; Returns NIL if the path of titles leads nowhere, when no appropriately =
titled menu-item or submenu exists;
+;; Returns a EasyGui MENU-ITEM if the path of titles leads to a leaf item;
+;; Returns a EasyGui MENU-VIEW if the path of titles leads to a submenu.
+ (cond
+ ((null titles) menu)
+ (t (let ((it (find (first titles) (menu-items menu) :test #'equalp :key=
#'view-text)))
+ (when it (navigate-menu (rest titles) it))))))
+
+(defun navigate-native-menu (titles menu)
+;; Returns a NIL or a NS:NS-MENU-ITEM or a NS:NS-MENU
+;; Returns a NS:NS-MENU when the title path leads to a submenu,
+;; Returns a NS;NS-MENU-ITEM when the title path leads to a leaf menu item,
+;; Returns NIL when the title path leads nowhere.
+ (running-on-this-thread ()
+ (if (null titles)
+ menu
+ (do ((number (dcc (#/numberOfItems menu)))
+ (index 0 (1+ index))
+ item found)
+ ((or found (>=3D index number))
+ (cond
+ ((or (null found) (null (rest titles))) found)
+ ((null (dcc (#/hasSubmenu found))) nil)
+ (t (navigate-native-menu (rest titles) (dcc (#/submenu found))=
))))
+ (setf item (dcc (#/itemAtIndex: menu index)))
+ (if (or (equalp (first titles) (lisp-string-from-nsstring (dcc (#/=
title item))))
+ ; The Apple menu item has title "" but its submenu has tit=
le "Apple", hence ...
+ (and (dcc (#/hasSubmenu item))
+ (equalp (first titles) (lisp-string-from-nsstring (dc=
c (#/title (dcc (#/submenu item))))))))
+ (setf found item))))))
+
+(defmethod navigate-topbar ((titles list))
+ (navigate-native-menu titles (application-main-menu)))
+
+(defun add-menu-item (menu titles &optional action)
+;; Adds a chain of submenus and a final leaf item with the indicated actio=
n.
+;; If the final leaf item already exists, its action will be changed. Perh=
aps this is too dangerous.
+;; The Apple submenu may not be altered; the application's submenu cannot =
be found.
+ (cond
+ ((null titles)
+ (cerror "Return NIL" "No title path supplied"))
+ ((not (and (consp titles) (stringp (first titles))))
+ (cerror "Return NIL, some empty submenus may have been created" "Title=
path is not a list of strings"))
+ ((not (typep menu 'ns:ns-menu))
+ (cerror "Return NIL" "Not a Cocoa menu: ~s" menu))
+ (t (let* ((ns-title (ccl::%make-nsstring (first titles)))
+ (item (dcc (#/itemWithTitle: menu ns-title)))
+ (ns-nullstring (ccl::%make-nsstring "")))
+ (flet ((linkup (leaf action) ;; Modelled on code in easygui/action=
-targets.lisp
+ (let ((target (make-instance 'generic-easygui-target :han=
dler (or action #'(lambda () nil)))))
+ (dcc (#/setTarget: leaf target))
+ (dcc (#/setAction: leaf (\@selector #/activateAction)))=
)))
+ (cond
+ ((equalp (first titles) "-")
+ (if (rest titles)
+ (cerror "Leave menu unchanged" "A menu separator (an item ha=
ving title \"-\") may not have a submenu")
+ (dcc (#/addItem: menu (dcc (#/separatorItem ns:ns-menu-item)=
)))))
+ ((cocoa-null item) ;; No such item, something must be added
+ (if (rest titles)
+ (let ((number (dcc (#/numberOfItems menu)))
+ (submenu (make-instance 'ns:ns-menu)))
+ (running-on-this-thread ()
+ (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-t=
itle ccl:+null-ptr+ ns-nullstring))
+ (setf item (dcc (#/itemAtIndex: menu number))) ;; That's=
where it got put
+ (dcc (#/initWithTitle: submenu ns-title))
+ (dcc (#/setSubmenu: item submenu)))
+ (add-menu-item submenu (rest titles) action))
+ (let ((number (dcc (#/numberOfItems menu))))
+ (running-on-this-thread ()
+ (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-t=
itle ccl:+null-ptr+ ns-nullstring))
+ (setf item (dcc (#/itemAtIndex: menu number))))
+ (linkup item action))))
+ ((and (null (rest titles)) (dcc (#/hasSubmenu item)))
+ (cerror "Leave menu unchanged" "An Action may not be added to =
any item with a submenu"))
+ ((and (rest titles) (dcc (#/hasSubmenu item)))
+ (add-menu-item (dcc (#/submenu item)) (rest titles) action))
+ ((rest titles)
+ (cerror "Leave menu unchanged" "An existing menu item cannot b=
e converted to have a submenu"))
+ (t (linkup item action)))))))) ;; Change the action of an exist=
ing item: desirable, or dangerous? =
+
+(defun add-topbar-item (titles &optional action)
+ (if (and (consp titles) (rest titles))
+ (add-menu-item (application-main-menu) titles action)
+ (cerror "Return NIL" "Title path must be a list with at least two elem=
ents: ~s" titles)))
+
+(defun remove-menu-item (menu titles retain-if-empty)
+ (if (not (and (consp titles) (stringp (first titles))))
+ (cerror "Return NIL" "Title path is not a list of strings")
+ (do ((number (dcc (#/numberOfItems menu)))
+ (index 0 (1+ index))
+ item found)
+ ((or found (>=3D index number))
+ (when found
+ (if (rest titles)
+ (when (dcc (#/hasSubmenu found))
+ (remove-menu-item (dcc (#/submenu found)) (rest titles) ret=
ain-if-empty)
+ (unless (or retain-if-empty (> (dcc (#/numberOfItems (dcc (=
#/submenu found)))) 0))
+ (dcc (#/removeItem: menu found))))
+ (dcc (#/removeItem: menu found)))))
+ (setf item (dcc (#/itemAtIndex: menu index)))
+ (when (equalp (first titles) (lisp-string-from-nsstring (dcc (#/titl=
e item))))
+ (setf found item)))))
+
+(defun remove-topbar-item (titles &key retain-if-empty)
+ (when (and (consp titles)
+ (not (member (first titles) '("" "Apple") :test #'equalp)))
+ (remove-menu-item (application-main-menu) titles retain-if-empty)))
+
+(defun add-application-submenu (title &rest trees) "
+Adds a menu to the topbar application-menu with the given title.
+Its menu-items names are got from the CARs of the trees.
+The CDRs of these trees may consist either of further trees, allowing arbi=
trarily
+deep menu structures, or of a one-element list that is expected to be a pa=
rameterless
+function to be used as the Action of a leaf menu item.
+Example:
+ (add-application-submenu \"Beeps\"
+ '(\"Normal\" #'normal-beep)
+ '(\"Stupid\" #'stupid-beep)
+ '(\"Choose\" (\"Custom beep 1\" #'custom-beep-1-not-implemented)
+ (\"Custom beep 2\" #'custom-beep-2-not-implemented)))
+"
+ (labels ((valid-tree (tree)
+ (and (consp tree) (stringp (first tree))))
+ (prepending (seq tree)
+ (cond
+ ((every #'valid-tree (rest tree))
+ (dolist (subtree (rest tree))
+ (prepending (append seq (list (first subtree))) (rest sub=
tree))))
+ ((and (consp tree) (stringp (first tree)) (consp (rest tree)=
) (null (cddr tree)))
+ (add-topbar-item (append seq (list (first tree))) (second t=
ree)))
+ (t (cerror "Ignore this tree" "Malformed tree ~s" tree)))))
+ (if (every #'valid-tree trees)
+ (dolist (subtree trees) (prepending (list title) subtree))
+ (cerror "Return NIL" "Malformed top-level trees"))))
+
+; ---------------
+; Keyboard input handling
+
+(defmethod view-key-event-handler ((view window) char)
+ (declare (ignorable char))
+ #| (format t "~&Window ~s got ~:[~;Control-~]~:[~;Alt-~]~:[~;Command-~]~=
:[~;Shift-~]~s~%"
+ view (control-key-p) (alt-key-p) (command-key-p) (shift-key-p)=
char))
+ |#
+ nil)
+
+(objc:define-objc-method ((:void :key-down (:id event)) cocoa-window)
+ (let ((*cocoa-event* event))
+ (view-key-event-handler
+ (easygui-window-of self)
+ (schar (lisp-string-from-nsstring (dcc (#/charactersIgnoringModifiers=
event))) 0))))
+
+(defun shift-key-p nil
+ (and *cocoa-event*
+ (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) #$NSShift=
KeyMask)))))
+
+(defun control-key-p nil
+ (and *cocoa-event*
+ (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask=
:control))))))
+
+(defun alt-key-p nil
+ (and *cocoa-event*
+ (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask=
:alt))))))
+
+(defun command-key-p nil
+ (and *cocoa-event*
+ (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask=
:command))))))
+
+(defun view-mouse-position (view)
+ (let* ((w (cocoa-ref (easygui-window-of view)))
+ (mouselocation (dcc (#/mouseLocationOutsideOfEventStream w)))
+ (cview (if (typep view 'window) (content-view view) view))
+ (nspt (dcc (#/convertPoint:fromView: (cocoa-ref cview) mouselocat=
ion #$NIL))))
+ ;; todo: check point is inside bounds, lest negative coords
+ (point (ns:ns-point-x nspt) (ns:ns-point-y nspt))))
More information about the Openmcl-cvs-notifications
mailing list