Changeset 11899


Ignore:
Timestamp:
Apr 5, 2009, 1:08:31 AM (10 years ago)
Author:
rme
Message:

Port r11841-r11847 (easygui enhancements) back to trunk.

Location:
trunk/source/examples/cocoa/easygui
Files:
5 edited
2 copied

Legend:

Unmodified
Added
Removed
  • trunk/source/examples/cocoa/easygui/dialogs.lisp

    r11801 r11899  
    1313(defun y-or-n-dialog (message)
    1414  (let ((alert (make-instance 'ns:ns-alert)))
    15     (#/setMessageText: alert message)
    16     (#/addButtonWithTitle: alert "Yes")
    17     (#/addButtonWithTitle: alert "No")
     15    (#/setMessageText: alert (ccl::%make-nsstring message))
     16    (#/addButtonWithTitle: alert (ccl::%make-nsstring "Yes"))
     17    (#/addButtonWithTitle: alert (ccl::%make-nsstring "No"))
    1818    (eql (#/runModal alert) #$NSAlertFirstButtonReturn)))
    1919
     20(defvar *beepnsleep* t)
     21
    2022(defun choose-file-dialog (&key button-string)
    21   (declare (ignorable button-string))
    2223  (gui::with-autorelease-pool
    2324      (let* ((panel (dcc (#/autorelease (dcc (#/openPanel ns:ns-open-panel)))))) ; allocate an NSOpenPanel
    2425        (dcc (#/setAllowsMultipleSelection: panel nil)) ; return at most one filename
    25         (when button-string (dcc (#/setPrompt: panel button-string)))
     26        (when button-string
     27          (setf button-string (ccl::%make-nsstring button-string))
     28          (dcc (#/setPrompt: panel button-string)))
    2629        (when (eql #$NSOKButton
    2730                   (dcc (#/runModalForDirectory:file:types: panel
    28                       +null-ptr+ ; default to last dir used
    29                       +null-ptr+ ; no preselected file
    30                       ;; If not NIL below then an ObjC array containing NSStrings could be used
    31                       ;; to restrict the file types we're interested in
    32                       #$NIL)))
     31                           +null-ptr+ ; default to last dir used
     32                           +null-ptr+ ; no preselected file
     33                           ;; If not NIL below then an ObjC array containing NSStrings could be used
     34                           ;; to restrict the file types we're interested in
     35                           #$NIL)))
    3336          ;; Because we told the panel to disallow multiple selection,
    3437          ;; there should be exactly one object in this array, an
    3538          ;; NSString describing the selected file.
    36           (let* ((files (dcc (#/filenames panel))))
     39          (let* ((files (dcc (#/filenames panel))) thing)
    3740            (if (eql 1 (dcc (#/count files)))
    38               (gui::lisp-string-from-nsstring (dcc (#/objectAtIndex: files 0)))
    39               (error "Don't know why we didn't get an NSArray containing exactly 1 file here.")))))))
     41              (progn
     42                (setf thing (dcc (#/objectAtIndex: files 0)))
     43                (gui::lisp-string-from-nsstring thing))
     44              "Don't know why we didn't get an NSArray containing exactly 1 file here."))))))
    4045
    4146(defun choose-new-file-dialog (&key button-string)
     
    4348  (gui::with-autorelease-pool
    4449      (let* ((panel (dcc (#/autorelease (dcc (#/savePanel ns:ns-save-panel)))))) ; allocate an NSSavePanel
    45         (when button-string (dcc (#/setPrompt: panel button-string)))
     50        (when button-string (dcc (#/setPrompt: panel (ccl::%make-nsstring button-string))))
    4651        (when (eql #$NSOKButton
    4752                   (dcc (#/runModalForDirectory:file: panel
     
    6570    (let* ((panel (dcc (#/sharedColorPanel ns:ns-color-panel)))) ; find or create the NSColorPanel
    6671      (dcc (#/setPickerMode: ns:ns-color-panel #$NSWheelModeColorPanel))
    67       (dcc (#/setTitle: panel prompt))
     72      (dcc (#/setTitle: panel (ccl::%make-nsstring prompt)))
    6873      (dcc (#/addObserver:selector:name:object:                 ; observe yourself close but
    6974       (dcc (#/defaultCenter ns:ns-notification-center))        ; sadly confound OK & CANCEL
    7075       panel
    7176       (objc:\@selector #/NSWindowWillCloseNotification)
    72        "NSWindowWillCloseNotification"
     77       (ccl::%make-nsstring "NSWindowWillCloseNotification")
    7378       panel))
    7479      (when color (dcc (#/setColor: panel color)))
     
    7782       (dcc (#/defaultCenter ns:ns-notification-center))
    7883       panel
    79        "NSWindowWillCloseNotification"
     84       (ccl::%make-nsstring "NSWindowWillCloseNotification")
    8085       panel))
    8186      (dcc (#/retain (dcc (#/color panel)))))))
  • trunk/source/examples/cocoa/easygui/easygui.asd

    r11801 r11899  
    2626               (:file "new-cocoa-bindings" :depends-on ("package"))
    2727               (:file "events" :depends-on ("new-cocoa-bindings"))
     28               (:file "rgb" :depends-on ("package"))
    2829               (:file "views" :depends-on ("events"))
    2930               (:file "action-targets" :depends-on ("views"))
    3031               (:file "dialogs" :depends-on ("new-cocoa-bindings"))
    3132               (:module "example"
    32                         :depends-on ("action-targets")
     33                        :depends-on ("action-targets" "dialogs" "rgb")
    3334                        :components
    3435                        ((:file "tiny")
    3536                         (:file "currency-converter")
    36                          (:file "view-hierarchy")))))
     37                         (:file "view-hierarchy")
     38                         (:file "extended-demo")))))
  • trunk/source/examples/cocoa/easygui/new-cocoa-bindings.lisp

    r7802 r11899  
    120120;;; debug macro for #/ funcalls:
    121121
    122 (defvar *debug-cocoa-calls* t)
     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 :-(")
    123129
    124130(defmacro dcc (form)
     131;; Trace output identifies process, and may pause: arthur, March 2009
    125132  `(progn
    126133     (when *debug-cocoa-calls*
    127        (format *trace-output* "Calling ~A on ~S~%"
    128                ',(first form) (list ,@(rest form))))
     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*)))
    129137     ,form))
    130138
  • trunk/source/examples/cocoa/easygui/package.lisp

    r11801 r11899  
    22  (:use :cl)
    33  (:import-from :ccl with-autorelease-pool @selector lisp-string-from-nsstring +null-ptr+)
    4   (:export #:point #:range #:rectangle #:window
     4  (:export #:point #:ns-point-from-point #:range #:rectangle #:window
    55           #:point-x #:point-y #:rectangle-x #:rectangle-y #:rectangle-width
    66           #:rectangle-height
     
    1111           #:push-button-view
    1212           #:form-view #:form-cell-view #:box-view #:drawing-view #:slider-view
     13           #:check-box-view #:radio-button-view
     14           #:menu-item-view #:pop-up-menu #:pull-down-menu #:contextual-menu
    1315           ;; event methods
    14            #:mouse-down #:mouse-dragged #:mouse-up
     16           #:mouse-down #:mouse-dragged #:mouse-up  #:view-key-event-handler
    1517           ;; operators
    1618           #:cocoa-ref
    17            #:add-subviews #:remove-subviews #:window-show #:set-window-title
    18            #:content-view
     19           #:add-subviews #:remove-subviews #:view-subviews
     20           #:window-show #:set-window-title
     21           #:content-view #:view-container
    1922           #:initialize-view #:action #:view-text
    2023           #:add-entry #:add-entries #:editable-p
     
    2326           #:string-value-of #:integer-value-of #:float-value-of
    2427           #:double-value-of
    25            #:y-or-n-dialog
     28           #:view-named #:view-nick-name
     29           #:view-size view-position
     30           #:view-mouse-position
     31           #:view-font #:with-focused-view
     32           #:clear-page
     33           #:check-box-check #:check-box-uncheck #:check-box-checked-p
     34           #:radio-button-selected-p #:radio-button-select #:radio-button-deselect
     35           #:dialog-item-enabled-p #:set-dialog-item-enabled-p
     36           #:shift-key-p #:control-key-p #:alt-key-p #:command-key-p
     37           #:get-fore-color #:get-back-color #:set-fore-color #:set-back-color
     38           #:invalidate-view
     39           #:menu-selection #:menu-items #:set-menu-item-title #:add-contextual-menu
     40           #:application-main-menu
     41           #:navigate-menu #:navigate-topbar #:add-topbar-item
     42           #:make-rgb #:rgb-red #:rgb-green #:rgb-blue #:rgb-opacity
     43           ;; canned dialogs
     44           #:y-or-n-dialog #:user-pick-color
    2645           #:choose-file-dialog #:choose-new-file-dialog
    27            #:user-pick-color))
     46         
     47         
     48           #:dcc
     49           #:perform-close #:window-may-close
     50           ;; variables
     51           #:*debug-cocoa-calls*
     52           #:*screen-flipped*
     53           #:*cocoa-event*
     54           #:*suppress-window-flushing*))
    2855
    2956(cl:defpackage :easygui-demo
  • trunk/source/examples/cocoa/easygui/views.lisp

    r9793 r11899  
    11(in-package :easygui)
     2
     3; ----------------------------------------------------------------------
     4; This is the Clozure Common Lisp file named 'views.lisp', March 2009,
     5; in the folder ccl/examples/cocoa/easygui/
     6; It has been modified by AWSC (arthur.cater@ucd.ie), based upon
     7; an earlier contribution by an unknown author,  borrowing also from
     8; the 'Seuss.lisp' contribution of 'KD'.
     9; Permission to use, further modify, disseminate, is hereby granted.
     10; No warranty is expressed or implied.
     11; Suggestions for - or accomplishment of - further improvement are welcome.
     12; Accompanying documentation for this and related files will be written
     13; and placed in ccl/examples/cocoa/easygui/documentation.txt
     14; Testing has been only with Mac OS 10.5.6 on a 32 bit PPC
     15; A demo of some capabilities is in 'easygui-demo-2.lisp'
     16; ----------------------------------------------------------------------
     17; It extends previous work in the following principal ways:
     18; - windows, views and subviews may have nicknames
     19; - checkboxes and radio-buttons are provided
     20; - menus (pop-up, pull-down, contextual, and main-menu) are provided
     21; - MCL-like coordinates (Y increases downward) may optionally be used
     22;   for placing windows on the screen, placing subviews within windows,
     23;   and graphics within drawing views.
     24; - views can generally respond to mouse entry, exit, movement
     25; - static text views can respond to mouse clicks
     26; - text views can have colored text and colored background
     27; - windows can decline to close, and/or invoke daemons upon closing.
     28; - views and windows can have specific OBJC subclassed counterparts
     29; - Shift, Command, Control and Option keys may be interrogated
     30; ----------------------------------------------------------------------
     31
     32(declaim (optimize (speed 0) (space 0) (compilation-speed 0) (safety 3) (debug 3)))
     33
     34(defmacro running-on-this-thread ((&key (waitp t)) &rest body)
     35;; The purpose of this trivial macro is to mark places where it is thought possible that
     36;; it may be preferable to use running-on-main-thread.
     37  (declare (ignore waitp))
     38  `(progn ,@body))
     39
     40
     41(defparameter *screen-flipped* nil
     42"When NIL, window positions are taken as referring to their bottom right,
     43as per Cocoa's native coordinate system.
     44When non-NIL, window positions are taken to refer to their top left,
     45as per - for instance - Digitool's MCL.
     46The default orientation for graphics within a drawing view is set to
     47correspond at the time of creation of that drawing view.")
     48
     49(defvar *cocoa-event* nil "Allows SHIFT-KEY-P & friends to operate on mouse clicks")
     50
     51(defvar *suppress-window-flushing* nil "
     52When T, graphics output produced with calls to With-Focused-View will not be immediately
     53flushed. This can reduce flicker and increase speed when there are many related uses of
     54With-Focused-View. It is then necessary though to make sure that somebody somewhere
     55calls Flush-Graphics at an appropriate time.
     56The same effect can be obtained for an individual use of With-Focused-View by giving
     57:WITHOUT-FLUSH as the first form in its body.")
     58
     59(defun ns-point-from-point (eg-point)  ;; probably belongs in new-cocoa-bindings.lisp
     60  (ns:make-ns-point (point-x eg-point) (point-y eg-point)))
     61
     62(defmacro with-focused-view (cocoa-view &body forms)
     63;; From KD's SEUSS.LISP but with added :WITHOUT-FLUSH syntax element
     64;; If the first of forms is the keyword :WITHOUT-FLUSH, or if dynamically
     65;; the value of *suppress-window-flushing* is non-NIL, then graphics output is not
     66;; immediately flushed.
     67  (let ((noflush (eq (first forms) ':without-flush)))
     68    `(if (dcc (#/lockFocusIfCanDraw ,cocoa-view))
     69       (unwind-protect
     70           (progn ,@forms)
     71         (dcc (#/unlockFocus ,cocoa-view))
     72         ,(unless noflush
     73            `(unless *suppress-window-flushing* (flush-graphics ,cocoa-view)))))))
     74
     75(defun flush-graphics (cocoa-view)
     76  (running-on-this-thread ()
     77    (dcc (#/flushGraphics (#/currentContext ns:ns-graphics-context)))
     78    (dcc (#/flushWindow (#/window cocoa-view)))))
     79
     80(defun cocoa-null (ptr)
     81  (equalp ptr ccl:+null-ptr+))
     82
     83
     84
    285
    386;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    17100;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    18101;;; mixins
     102;;;
     103;;; Some view classes have an associated 'value', which can be accessed and set through
     104;;; accessors STRING-VALUE-OF, INTEGER-VALUE-OF, FLOAT-VALUE-OF, DOUBLE-VALUE-OF
     105;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT-VIEW, FORM-CELL-VIEW, SLIDER-VIEW
     106;;;
     107;;; Some view classes have an associated 'title', accessible and settable through VIEW-TEXT
     108;;; Such classes include WINDOW, PUSH-BUTTON-VIEW, BOX-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-VIEW, MENU-ITEM-VIEW
     109;;;
     110;;; Some view classes have an associated 'text', also accessible and settable through VIEW-TEXT
     111;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT-VIEW, FORM-CELL-VIEW
     112;;;
     113;;; Most of those, apart from STATIC-TEXT-VIEW, may be manually 'editable'.
     114;;;
     115;;; Some view classes have an associated 'action'.
     116;;; Such classes include PUSH-BUTTON-VIEW, SLIDER-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-ITEM-VIEW
     117;;;
     118;;; Some view classes cannot ever have a contextual menu attached to them, even though their superview
     119;;; and their subviews (if any) possibly do.
     120;;; Such classes include PUSH-BUTTON-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-VIEW, MENU-ITEM-VIEW
     121;;; Perhaps these should be the same classes as those with actions.
     122;;;
     123;;; No view classes inherit from 'one-selection-mixin'
     124;;; Apparently it was intended that TEXT-INPUT-VIEW might do so some day.
     125;;;
     126;;; Some view classes have a single 'content view'.
     127;;; Such classes include WINDOW, BOX-VIEW.
     128;;;
     129;;; Some view classes inherit from 'background-coloring-mixin'
     130;;; Such classes include STATIC-TEXT-VIEW ... for now
     131;;;
    19132
    20133(defclass value-mixin () ())
     134
    21135(defclass string-value-mixin (value-mixin) ())
     136
    22137(defclass numeric-value-mixin (value-mixin) ())
    23138
     139(defclass action-view-mixin ()
     140  ((action :initarg :action)
     141   (enabled :accessor dialog-item-enabled-p :initarg :dialog-item-enabled-p :initform t)))
     142
     143(defclass decline-menu-mixin () ())
     144
    24145(macrolet ((def-type-accessor (class lisp-type cocoa-reader cocoa-writer
    25                                      &key new-value-form return-value-converter)
     146                                     &key (new-value-form 'new-value) (return-value-converter 'identity))
    26147               (let ((name (intern (format nil "~A-VALUE-OF" lisp-type))))
    27148                 `(progn
    28149                    (defmethod ,name ((o ,class))
    29                       ,(if return-value-converter
    30                            `(,return-value-converter
    31                              (dcc (,cocoa-reader (cocoa-ref o))))
    32                            `(dcc (,cocoa-reader (cocoa-ref o)))))
     150                      (,return-value-converter (dcc (,cocoa-reader (cocoa-ref o)))))
    33151                    (defmethod (setf ,name) (new-value (o ,class))
    34                       (dcc (,cocoa-writer (cocoa-ref o)
    35                                           ,(or new-value-form
    36                                                'new-value))))))))
    37   (def-type-accessor string-value-mixin string #/stringValue #/setStringValue:
    38                      :return-value-converter lisp-string-from-nsstring )
    39 
     152                      (dcc (,cocoa-writer (cocoa-ref o) ,new-value-form)))))))
     153  (def-type-accessor string-value-mixin string   #/stringValue #/setStringValue:
     154    :return-value-converter lisp-string-from-nsstring )
    40155  (def-type-accessor numeric-value-mixin integer #/intValue #/setIntValue:)
    41   (def-type-accessor numeric-value-mixin float
    42     #/floatValue #/setFloatValue:
     156  (def-type-accessor numeric-value-mixin float   #/floatValue #/setFloatValue:
    43157    :new-value-form (coerce new-value 'single-float))
    44   (def-type-accessor numeric-value-mixin double
    45     #/doubleValue #/setDoubleValue:
     158  (def-type-accessor numeric-value-mixin double  #/doubleValue #/setDoubleValue:
    46159    :new-value-form (coerce new-value 'double-float)))
    47160
    48161(defclass view-text-mixin ()
    49      ((text :initarg :text)))
     162     ((text :initarg :text :initarg :dialog-item-text)))
     163
    50164(defclass view-text-via-stringvalue-mixin (view-text-mixin string-value-mixin)
    51165     ())
     166
    52167(defclass view-text-via-title-mixin (view-text-mixin)
    53168     ((text :initarg :title)))
     
    60175
    61176(defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixin))
    62   (setf (string-value-of view) new-text))
     177  (setf (string-value-of view) (ccl::%make-nsstring new-text)))
    63178
    64179(defmethod (setf view-text) (new-text (view view-text-via-title-mixin))
    65   (dcc (#/setTitle: (cocoa-ref view) new-text)))
     180  (dcc (#/setTitle: (cocoa-ref view) (ccl::%make-nsstring new-text)))
     181  new-text)
    66182
    67183(defmethod initialize-view :after ((view view-text-mixin))
     
    69185    (setf (view-text view) (slot-value view 'text))))
    70186
     187(defclass text-coloring-mixin () ())
     188
     189(defclass text-fonting-mixin () ())
     190
    71191(defclass editable-mixin () ())
    72192
     
    76196(defmethod (setf editable-p) (editable-p (view editable-mixin))
    77197  (check-type editable-p boolean)
    78   (dcc (#/setEditable: (cocoa-ref view) editable-p)))
     198  (dcc (#/setEditable: (cocoa-ref view) editable-p))
     199  editable-p)
    79200
    80201(defclass one-selection-mixin () ())
    81202
    82203(defmethod (setf selection) (selection (view one-selection-mixin))
    83   (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection))))
     204  (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection)))
     205  selection)
    84206
    85207(defmethod selection ((view one-selection-mixin))
     
    91213
    92214(defclass content-view-mixin ()
    93      (content-view))
     215  ((content-view)
     216   (flipped :initarg :flipped :initform *screen-flipped*)))
     217
     218(defclass contained-view (view)
     219  ((flipped :initarg :flipped)))
    94220
    95221(defmethod initialize-view :after ((view content-view-mixin))
    96   (setf (slot-value view 'content-view)
    97         (make-instance 'view
    98            :cocoa-ref (dcc (#/contentView (cocoa-ref view))))))
     222  (unless (slot-boundp view 'content-view)
     223    (let ((containee (make-instance 'contained-view
     224                       :cocoa-ref (dcc (#/contentView (cocoa-ref view)))
     225                       :view-nick-name '%CONTENT-OF-CONTENT-VIEW%
     226                       :flipped (slot-value view 'flipped))))
     227      (setf (slot-value view 'content-view) containee
     228            (slot-value containee 'parent) view))))
    99229
    100230(defmethod content-view ((view content-view-mixin))
     
    105235(defmethod (setf content-view) (new-content-view (view content-view-mixin))
    106236  (setf (slot-value view 'content-view) new-content-view)
    107   (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view))))
     237  (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view)))
     238  new-content-view)
     239
     240(defmethod set-dialog-item-enabled-p ((view action-view-mixin) value)
     241  (unless (eq (not value) (not (dialog-item-enabled-p view)))
     242    (setf (dialog-item-enabled-p view) value)
     243    (dcc (#/setEnabled: (cocoa-ref view) (if value #$YES #$NO)))))
     244
     245(defclass background-coloring-mixin ()
     246  ((drawsbackground     :initform t :initarg :draws-background)))
     247
     248(defmethod initialize-view :after ((view background-coloring-mixin))
     249  (dcc (#/setDrawsBackground: (cocoa-ref view) (slot-value view 'drawsbackground)))
     250  (when (and (cocoa-ref view) (slot-boundp view 'background))
     251      (dcc (#/setBackgroundColor: (cocoa-ref view) (slot-value view 'background)))))
    108252
    109253;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    114258     ((position :initarg :position :reader view-position)
    115259      (size :initarg :size :reader view-size)
    116       (frame-inited-p :initform nil)))
     260      (frame-inited-p :initform nil)
     261      (parent :reader view-container :initform nil)
     262      (subviews :reader view-subviews :initarg :subviews :initform nil)
     263      ;; When adding/removing multiple subviews, prevent multiple redraws.
     264      ;; But - what code does those redraws?
     265      (subviews-busy :accessor view-subviews-busy :initform nil)
     266      (nickname :accessor view-nick-name :initarg :view-nick-name :initform nil)
     267      (contextmenu :initarg :contextual-menu :initform nil)
     268      (background :initarg :back-color :initform (#/whiteColor ns:ns-color))
     269      (foreground :initarg :fore-color :initform (#/blackColor ns:ns-color))
     270      (font :reader view-font :initarg :font :initarg :view-font :initform nil)
     271      (specifically :reader view-specifically :initarg :specifically :initform nil)
     272      (mouse-target :reader view-mouse-target :initform nil)
     273      ;; Next three not yet operative
     274      (tip :initarg :tip :reader view-tip :initform nil)
     275      (tiptag :initform nil)
     276      (mouse-enter :accessor view-mouse-enter :initarg :mouse-enter :initform nil)
     277      (mouse-exit :accessor view-mouse-exit :initarg :mouse-exit :initform nil)
     278      (mouse-move :accessor view-mouse-move :initarg :mouse-move :initform nil)))
    117279
    118280(defclass window (content-view-mixin view-text-via-title-mixin view)
     
    123285      (resizable-p :initarg :resizable-p :initform t
    124286                   :reader window-resizable-p)
    125       (closable-p :initarg :closable-p :initform t :reader window-closable-p)))
    126 
    127 (defclass static-text-view (view view-text-via-stringvalue-mixin) ())
    128 
    129 (defclass text-input-view (view editable-mixin view-text-via-stringvalue-mixin
     287      (closable-p :initarg :closable-p :initform t :reader window-closable-p)
     288      (level :initarg :window-level :accessor window-level
     289             :initform (dcc (#_CGWindowLevelForKey #$kCGNormalWindowLevelKey)))
     290      (hidden :initarg :hidden :reader window-hidden :initform nil)
     291      (window-needs-display-on-show :initform t)
     292      (optimized :initarg :optimized :initform t) ; Set to NIL if you anticipate overlapping views in this window
     293      (style :initarg :window-style :initform #$NSTitledWindowMask))
     294  (:default-initargs :specifically 'cocoa-contained-view))
     295
     296(defmethod clear-page ((view view))
     297  (let* ((cview (cocoa-ref view))
     298         (rect (dcc (#/bounds cview)))
     299         (color (slot-value view 'background)))
     300    (with-focused-view cview
     301      (dcc (#/setFill color))
     302      (dcc (#_NSRectFill rect)))))
     303
     304(defmethod clear-page ((window content-view-mixin))
     305  (clear-page (content-view window)))
     306
     307(defclass static-text-view (view view-text-via-stringvalue-mixin action-view-mixin text-coloring-mixin text-fonting-mixin background-coloring-mixin)
     308  ((mousedown           :initform nil :initarg :mouse-down    :accessor static-text-view-mouse-down)
     309   (mouseup             :initform nil :initarg :mouse-up      :accessor static-text-view-mouse-up)
     310   (mousedragged        :initform nil :initarg :mouse-dragged :accessor static-text-view-mouse-dragged)))
     311
     312(defclass text-input-view (view editable-mixin text-coloring-mixin text-fonting-mixin view-text-via-stringvalue-mixin
    130313                                ;; XXX: requires NSTextView, but this is an
    131314                                ;; NSTextField:
     
    137320     ())
    138321
    139 (defclass push-button-view (view view-text-via-title-mixin)
     322(defclass push-button-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin)
    140323     ((default-button-p :initarg :default-button-p :initform nil
    141                         :reader default-button-p)))
     324                        :reader default-button-p)
     325      (bezelstyle       :reader bezel-style        :initarg :bezel-style      :initform :rounded)))
    142326
    143327(defclass form-view (view)
     
    156340      ;; TODO: make this a mixin
    157341      (accept-key-events-p :initform nil :initarg :accept-key-events-p
    158                            :accessor accept-key-events-p)))
    159 
    160 (defclass slider-view (view numeric-value-mixin)
     342                           :accessor accept-key-events-p)
     343      (flipped             :initform *screen-flipped* :initarg :flipped :reader flipped-p)
     344      (mousedown           :initform nil :initarg :mouse-down    :accessor drawing-view-mouse-down)
     345      (mouseup             :initform nil :initarg :mouse-up      :accessor drawing-view-mouse-up)
     346      (mousedragged        :initform nil :initarg :mouse-dragged :accessor drawing-view-mouse-dragged)
     347      (draw-fn             :initform nil :initarg :draw-fn :accessor draw-fn)))
     348
     349(defclass slider-view (view numeric-value-mixin action-view-mixin)
    161350     ((max-value :initarg :max-value)
    162351      (min-value :initarg :min-value)
    163352      (tick-mark-count :initarg :tick-mark-count)
     353      (tick-mark-values :initarg :tick-mark-values)
    164354      (discrete-tick-marks-p :initarg :discrete-tick-marks-p)))
    165355
     356; ----------------------------------------------------------------------
     357; Specialisations of ns-xxx classes always begin 'cocoa-'.
     358; They allow such things as
     359; - finding the easygui window associated with a ns-view & easygui::view
     360; - flipped windows, flipped drawing-views
     361; - clickable static text, editable text fields
     362; - tooltips
     363; ----------------------------------------------------------------------
     364
     365(defun calculate-ns-tooltip (cview)
     366  ;; Returns a Lisp string to bhe used as a tooltip, or NIL.
     367  ;; Easygu Views may or may not be created with a specific :TIP keyword argument.
     368  ;; If there is none, there will be no tooltip displayed for the corresponding cocoa-view.
     369  ;; Otherwise, if the argument is
     370  ;;   - a string, that string is used
     371  ;;   - a function, then if its return value is
     372  ;;        - a string, that string is used
     373  ;;        - NIL, a string informing that the tooltip is null and cocoa-describing the cocoa-view
     374  ;;               (possibly useful for identifying this view if it turns up in errors or inspector)
     375  ;;        - else a string naming the type of the result returned (possibly useful for debugging)
     376  ;;   - the keyword :IDENTIFY, the cocoa-description of the cocoa-view
     377  ;;   - anything else, a string informing what type the argument is.
     378  (let* ((egview (when (slot-boundp cview 'easygui-view) (slot-value cview 'easygui-view)))
     379         (tip (when egview (slot-value egview 'tip))))
     380    (cond
     381     ((stringp tip)
     382      tip)
     383     ((functionp tip)
     384      (let ((it (funcall tip)))
     385        (cond
     386         ((stringp it)  it)
     387         ((null it)     (format nil "Null tooltip for ~a" (lisp-string-from-nsstring (dcc (#/description cview)))))
     388         (t (format nil "** Tooltip function returned non-string object of type ~s **" (type-of it))))))
     389     ((eq tip :identify) (lisp-string-from-nsstring (dcc (#/description cview))))
     390     ((null egview)
     391      (format nil "** Cocoa view ~s has no EasyGui-View **" cview))
     392     ((null tip) (format nil "No tooltip for ~a" (lisp-string-from-nsstring (dcc (#/description cview)))))
     393     (t (format nil "** Tip slot of Cocoa view ~s~%is of type ~s,~%not a string or a function or :IDENTIFY. **" cview tip)))))
     394
     395(defmacro define-tooltip-accessor (cocoa-class)
     396  `(progn
     397     #|
     398     (objc:defmethod #/view:stringForToolTip:point:userData:
     399                     ((view ,cocoa-class)
     400                      (tag :<NST>ool<T>ip<T>ag)
     401                      (point :<NSP>oint)
     402                      (userdata :id))
     403       (declare (ignorable tag point userdata))
     404       (ccl::%make-nsstring (or (calculate-ns-tooltip view) "")))
     405     |#
     406     (objc:defmethod #/toolTip ((view ,cocoa-class))
     407       (ccl::%make-nsstring (or (calculate-ns-tooltip view) "")))))
     408
     409(defclass cocoa-window (ns:ns-window)
     410  ((easygui-window :reader easygui-window-of))
     411  (:metaclass ns:+ns-object))
     412
     413(defmethod print-object ((object cocoa-window) stream)
     414  (print-unreadable-object (object stream :type t :identity t)
     415    (let ((egview (if (slot-boundp object 'easygui-window) (easygui-window-of object) nil)))
     416      (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egview)))))
     417  object)
     418
     419(defmethod easygui-window-of ((eview view))
     420  (if (cocoa-ref eview) (easygui-window-of (cocoa-ref eview)) nil))
     421
     422(defmethod easygui-window-of ((nsview ns:ns-view))
     423  (let ((nswindow (dcc (#/window nsview))))
     424    (if (typep nswindow 'cocoa-window) (easygui-window-of nswindow) nil)))
     425
     426(defclass cocoa-extension-mixin ()
     427  ((easygui-view :initarg :eg-view :reader easygui-view-of)))
     428
     429(defmethod print-object ((object cocoa-extension-mixin) stream)
     430  (print-unreadable-object (object stream :type t :identity t)
     431    (let ((egview (if (slot-boundp object 'easygui-view) (easygui-view-of object) nil)))
     432      (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egview)))))
     433  object)
     434
     435(defclass cocoa-text-field (cocoa-extension-mixin ns:ns-text-field) ()
     436  (:metaclass ns:+ns-object))
     437
     438(define-tooltip-accessor cocoa-text-field)
     439
     440(defclass cocoa-mouseable-text-field (cocoa-text-field) ()
     441  (:metaclass ns:+ns-object))
     442
     443(define-tooltip-accessor cocoa-mouseable-text-field)
     444
     445(defclass cocoa-contained-view (cocoa-extension-mixin ns:ns-view)
     446  ((flipped :initarg :flipped :initform *screen-flipped*))
     447  (:metaclass ns:+ns-object))
     448
     449(define-tooltip-accessor cocoa-contained-view)
     450
     451(defclass cocoa-secure-text-field (cocoa-extension-mixin ns:ns-secure-text-field) ()
     452  (:metaclass ns:+ns-object))
     453
     454(define-tooltip-accessor cocoa-secure-text-field)
     455
     456(defclass cocoa-button (cocoa-extension-mixin ns:ns-button) ()
     457  (:metaclass ns:+ns-object))
     458
     459(define-tooltip-accessor cocoa-button)
     460
     461(defclass cocoa-pop-up-button (cocoa-extension-mixin ns:ns-pop-up-button) ()
     462  (:metaclass ns:+ns-object))
     463
     464(define-tooltip-accessor cocoa-pop-up-button)
     465
     466(defclass cocoa-menu-item (cocoa-extension-mixin ns:ns-menu-item) ()
     467  (:metaclass ns:+ns-object))
     468
     469(define-tooltip-accessor cocoa-menu-item)
     470
     471(defclass cocoa-form (cocoa-extension-mixin ns:ns-form) ()
     472  (:metaclass ns:+ns-object))
     473
     474(define-tooltip-accessor cocoa-form)
     475
     476(defclass cocoa-form-cell (cocoa-extension-mixin ns:ns-form-cell) ()
     477  (:metaclass ns:+ns-object))
     478
     479(define-tooltip-accessor cocoa-form-cell)
     480
     481(defclass cocoa-box (cocoa-extension-mixin ns:ns-box) ()
     482  (:metaclass ns:+ns-object))
     483
     484(define-tooltip-accessor cocoa-box)
     485
     486(defclass cocoa-drawing-view (cocoa-extension-mixin ns:ns-view)
     487  ((flipped :initarg :flipped :initform *screen-flipped*))
     488  (:metaclass ns:+ns-object))
     489
     490(define-tooltip-accessor cocoa-drawing-view)
     491
     492(defclass cocoa-slider (cocoa-extension-mixin ns:ns-slider) ()
     493  (:metaclass ns:+ns-object))
     494
     495(define-tooltip-accessor cocoa-slider)
     496
    166497(defparameter *view-class-to-ns-class-map*
    167               '((static-text-view . ns:ns-text-field)
    168                 (password-input-view . ns:ns-secure-text-field)
    169                 (text-input-view . ns:ns-text-field)
    170                 (push-button-view . ns:ns-button)
    171                 (form-view . ns:ns-form)
    172                 (form-cell-view . ns:ns-form-cell)
    173                 (box-view . ns:ns-box)
    174                 (drawing-view . cocoa-drawing-view)
    175                 (slider-view . ns:ns-slider)))
     498              '((static-text-view     . cocoa-mouseable-text-field)
     499                (password-input-view  . cocoa-secure-text-field)
     500                (text-input-view      . cocoa-text-field)
     501                (push-button-view     . cocoa-button)
     502                (check-box-view       . cocoa-button)
     503                (radio-button-view    . cocoa-button)
     504                (menu-view            . cocoa-pop-up-button)
     505                (menu-item-view       . cocoa-menu-item)
     506                (form-view            . cocoa-form)
     507                (form-cell-view       . cocoa-form-cell)
     508                (box-view             . cocoa-box)
     509                (drawing-view         . cocoa-drawing-view)
     510                (slider-view          . cocoa-slider)))
     511
     512;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     513;;; Targets for mouse-enter, mouse-exit and mouse-moved handling
     514
     515(defclass easygui-mouse-target (ns:ns-object)
     516  ((view :initarg :view :reader mouse-target-view :initform nil))
     517  (:metaclass ns:+ns-object))
     518
     519(objc:define-objc-method ((:void :mouse-entered (:id event)) easygui-mouse-target)
     520  (let* ((view (mouse-target-view self))
     521         (fn (view-mouse-enter view)))
     522    (when fn (funcall fn view :event event :allow-other-keys t))))
     523
     524(objc:define-objc-method ((:void :mouse-exited (:id event)) easygui-mouse-target)
     525  (let* ((view (mouse-target-view self))
     526         (fn (view-mouse-exit view)))
     527    (when fn (funcall fn view :event event :allow-other-keys t))))
     528
     529(objc:define-objc-method ((:void :mouse-move (:id event)) easygui-mouse-target)
     530  (let* ((view (mouse-target-view self))
     531         (fn (view-mouse-move view)))
     532    (when fn (funcall fn view :event event :allow-other-keys t))))
    176533
    177534;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    185542
    186543(defmethod initialize-view ((view view))
    187   "Initializes the view via the class-to-ns-class map."
     544  "Initializes the view using the class-to-ns-class map both as constraint
     545on valid values of the :SPECIFICALLY initarg, and as source of default value.
     546Also attaches contextual menu if there is one, and sets up mouse tracking
     547rectangle if the view has any non-NIL mouse-enter, mouse-exit or mouse-move."
    188548  (when (slot-boundp view 'ref)
    189549    (return-from initialize-view nil))
    190550  (let ((ns-view-class (cdr (assoc (class-name (class-of view))
    191551                                   *view-class-to-ns-class-map*
    192                                    :test #'subtypep))))
    193     (when ns-view-class
    194       (setf (cocoa-ref view)
     552                                   :test #'subtypep)))
     553        (specifically (view-specifically view))
     554        cocoaview)
     555    (when specifically
     556      (cond
     557       ((not (find-class specifically nil))
     558        (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICALLY does not name a class" specifically ns-view-class))
     559       ((or (null ns-view-class) (subtypep specifically ns-view-class))
     560        (setf ns-view-class specifically))
     561       (t (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICALLY is not a subclass of ~a" specifically ns-view-class))))
     562    (if ns-view-class
     563      (setf cocoaview
    195564            (cond
    196565              ((and (slot-boundp view 'position)
     
    200569                  :with-frame (with-slots (position size) view
    201570                                 (ns-rect-from-points position size))))
    202               (t (make-instance ns-view-class)))))))
     571              (t (make-instance ns-view-class)))
     572            (cocoa-ref view) cocoaview)
     573      (cerror "Continue with cocoa-ref unset" "No view class found for type ~a" (class-of view)))
     574    (when (and cocoaview (slot-boundp view 'contextmenu))
     575      (let ((menu (slot-value view 'contextmenu)))
     576        (cond
     577         ((null menu))
     578         ((null ns-view-class))
     579         ((typep menu 'menu-view)
     580          (dcc (#/setMenu: cocoaview (slot-value menu 'ns-menu))))
     581         (t (warn "Ignoring contextmenu value ~s for view ~s" menu view)))))
     582   (when (and cocoaview (slot-value view 'tip))
     583     (setf (slot-value view 'tiptag)
     584           (dcc (#/addToolTipRect:owner:userData: cocoaview (#/bounds cocoaview) cocoaview ccl:+null-ptr+))))
     585   (when (and cocoaview (or (slot-value view 'mouse-enter) (slot-value view 'mouse-exit) (slot-value view 'mouse-move)))
     586      (let ((target (make-instance 'easygui-mouse-target :view view)))
     587        (dcc (#/retain target))
     588        (dcc (#/addTrackingRect:owner:userData:assumeInside:
     589         cocoaview
     590         (dcc (#/bounds cocoaview))
     591         target
     592         ccl:+null-ptr+
     593         #$YES))))))
     594    #| OS X Leopard should allow this but ... it didn't when I said VIEW not COCOAVIEW ...:
     595     (area (make-instance 'ns:ns-tracking-area
     596                    :with-rect (dcc (#/bounds cocoaview))
     597                    :options (logior #$NSTrackingMouseEnteredAndExited
     598                                     #$NSTrackingActiveInKeyWindow
     599                                     #$NSTrackingInVisibleRect)
     600                    :owner cocoaview
     601                    :userInfo #$NIL)))
     602        (dcc (#/addTrackingArea: cocoaview area))))
     603    |#
     604
     605(defun screen-height nil
     606  (running-on-this-thread ()
     607    (ns:ns-rect-height (dcc (#/frame (#/objectAtIndex: (#/screens ns:ns-screen) 0))))))
     608
     609(defmethod view-content-rect ((view view) &optional hidden)
     610  (if hidden
     611    (ns:make-ns-rect 0 0 0 0)
     612    (with-slots (position size) view
     613      ;(if (slot-boundp view 'size)
     614      ;  (format t "~&View ~s has size ~s~%" view size)
     615      ;  (format t "~&View ~s has size unbound~%" view))
     616      (let* ((height (if (slot-boundp view 'size) (point-y size) *window-size-default-y*))
     617             (stated (if (slot-boundp view 'position) (point-y position) *window-position-default-y*))
     618             (screentop (screen-height))  ;; TODO: dtrt for multiple screens
     619             (bottom (if (and *screen-flipped* (typep view 'window))
     620                       (- screentop height stated)
     621                       stated)))
     622        (ns:make-ns-rect
     623         (if (slot-boundp view 'position) (point-x position) *window-position-default-x*)
     624         bottom
     625         (if (slot-boundp view 'size) (point-x size) *window-size-default-x*)
     626         height)))))
    203627
    204628(defmethod initialize-view ((win window))
    205629  "Initialize size, title, flags."
    206   (with-slots (position size) win
    207      (let ((content-rect
    208             (multiple-value-call
    209                 #'ns:make-ns-rect
    210               (if (slot-boundp win 'position)
    211                   (values (point-x position) (point-y position))
    212                   (values *window-position-default-x*
    213                           *window-position-default-y*))
    214               (if (slot-boundp win 'size)
    215                   (values (point-x size) (point-y size))
    216                   (values *window-size-default-x*
    217                           *window-size-default-y*))))
    218            (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win))
    219                         (flag-mask :resizable-p
    220                                    (window-resizable-p win))
    221                         (flag-mask :minimizable-p
    222                                    (window-minimizable-p win))
    223                         (flag-mask :closable-p
    224                                    (window-closable-p win))
    225                         #$NSTitledWindowMask)))
    226        (setf (cocoa-ref win) (make-instance 'ns:ns-window
    227                                 :with-content-rect content-rect
    228                                 :style-mask style-mask
    229                                 :backing #$NSBackingStoreBuffered ; TODO?
    230                                 :defer nil)))))
     630  (with-slots (level hidden optimized style flipped specifically) win
     631    (unless (and (find-class specifically nil) (subtypep specifically 'cocoa-contained-view))
     632      (cerror "Ignore ~a and create content view of type ~a"
     633              "Value given for \":specifically\" is ~a which is not a subtype of ~a"
     634              specifically 'cocoa-contained-view)
     635      (setf specifically 'cocoa-contained-view))
     636     (let* ((content-rect (view-content-rect win hidden))
     637            (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win))
     638                         (flag-mask :resizable-p   (window-resizable-p win))
     639                         (flag-mask :minimizable-p (window-minimizable-p win))
     640                         (flag-mask :closable-p    (window-closable-p win))
     641                         (if (or (window-resizable-p win) (window-minimizable-p win) (window-closable-p win))
     642                           #$NSTitledWindowMask
     643                           0)
     644                         style))
     645            (c-win
     646             (make-instance 'cocoa-window
     647               :with-content-rect content-rect
     648               :style-mask style-mask
     649               :backing #$NSBackingStoreBuffered ; TODO?
     650               :defer t))
     651            (containee (make-instance specifically)))
     652       (setf (slot-value containee 'flipped) flipped)
     653       (dcc (#/setFrame: containee content-rect))
     654       (dcc (#/setContentView: c-win containee))
     655       (dcc (#/setDelegate: c-win c-win))
     656       (dcc (#/setBackgroundColor: c-win (slot-value win 'background)))
     657       (dcc (#/setLevel: c-win level))
     658       (when optimized (dcc (#/useOptimizedDrawing: c-win #$YES)))
     659       (setf (cocoa-ref win) c-win)
     660       (setf (slot-value c-win 'easygui-window) win)
     661       (if hidden
     662         (dcc (#/disableFlushWindow c-win))
     663         (window-show win))
     664       c-win)))
    231665
    232666(defmethod initialize-view :after ((view text-input-view))
    233   (setf (editable-p view) (not (text-input-locked-p view))))
     667  (setf (editable-p view) (not (text-input-locked-p view)))
     668  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
    234669
    235670(defmethod initialize-view :after ((view static-text-view))
     
    237672  (dcc (#/setBordered: (cocoa-ref view) nil))
    238673  (dcc (#/setBezeled: (cocoa-ref view) nil))
    239   (dcc (#/setDrawsBackground: (cocoa-ref view) nil)))
     674  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
     675
     676(defmethod initialize-view :after ((view action-view-mixin))
     677  (when (and (slot-boundp view 'action) (slot-value view 'action))
     678    (setf (action view) (slot-value view 'action)))
     679  (unless (dialog-item-enabled-p view)
     680    (dcc (#/setEnabled: (cocoa-ref view) #$NO))))
     681
     682(defparameter *bezelstyle-alist*
     683  `((:round                    . #.#$NSRoundedBezelStyle)
     684    (:square                   . #.#$NSRegularSquareBezelStyle)
     685    (:regular-square           . #.#$NSRegularSquareBezelStyle)
     686    (:thick-square             . #.#$NSThickSquareBezelStyle)
     687    (:thicker-square           . #.#$NSThickerSquareBezelStyle)
     688    (:disclosure               . #.#$NSDisclosureBezelStyle)
     689    (:Shadowless-square        . #.#$NSShadowlessSquareBezelStyle)
     690    (:circular                 . #.#$NSCircularBezelStyle)
     691    (:textured-square          . #.#$NSTexturedSquareBezelStyle)
     692    (:help-button              . #.#$NSHelpButtonBezelStyle)
     693    (:small-square             . #.#$NSSmallSquareBezelStyle)
     694    (:textured-rounded         . #.#$NSTexturedRoundedBezelStyle)
     695    (:round-rect               . #.#$NSRoundRectBezelStyle)
     696    (:recessed                 . #.#$NSRecessedBezelStyle)
     697    (:rounded-disclosure       . #.#$NSRoundedDisclosureBezelStyle)))
     698
     699(defun bezel-style-lookup (key)
     700  (rest (or (assoc key *bezelstyle-alist*) (first *bezelstyle-alist*))))
     701
     702(defmethod (setf bezel-style) (stylename (view push-button-view))
     703  (setf (slot-value view 'bezelstyle) (if (assoc stylename *bezelstyle-alist*) stylename :round))
     704  (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (slot-value view 'bezelstyle))))
     705  stylename)
    240706
    241707(defmethod initialize-view :after ((view push-button-view))
    242   (dcc (#/setBezelStyle: (cocoa-ref view) #$NSRoundedBezelStyle))
     708  (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (bezel-style view))))
    243709  (let ((default-button-p (slot-value view 'default-button-p)))
    244710    (typecase default-button-p
    245711      (cons
    246        (dcc (#/setKeyEquivalent: (cocoa-ref view) (string
    247                                                    (first default-button-p))))
     712       (dcc (#/setKeyEquivalent: (cocoa-ref view)
     713                                 (ccl::%make-nsstring (string (first default-button-p)))))
    248714       (dcc (#/setKeyEquivalentModifierMask:
    249715         (cocoa-ref view)
    250716         (apply #'logior (mapcar #'key-mask (cdr default-button-p))))))
    251717      (string
    252        (dcc (#/setKeyEquivalent: (cocoa-ref view) default-button-p)))
     718       (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::%make-nsstring default-button-p))))
    253719      (null)
    254720      (t
    255        (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return))))))))
     721       (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return)))))))
     722  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
     723
     724(defmethod initialize-view :after ((view box-view))
     725  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
    256726
    257727(defmethod initialize-view :after ((view form-view))
    258728  (when (slot-boundp view 'interline-spacing)
    259729    (dcc (#/setInterlineSpacing: (cocoa-ref view)
    260                              (coerce (slot-value view 'interline-spacing)
    261                                      'double-float)))))
     730                             (gui::cgfloat (slot-value view 'interline-spacing)))))
     731  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
    262732
    263733(defmethod initialize-view :after ((view slider-view))
    264   (with-slots (discrete-tick-marks-p tick-mark-count min-value max-value) view
    265      (cond
    266        #| BUG: tick-mark-values is not defined.
    267        ((and (not (slot-boundp view 'tick-mark-count))
    268        (slot-boundp view 'discrete-tick-marks-p)
    269        (/= (length tick-mark-values) tick-mark-count))
    270        (error "Incompatible tick mark specification: ~A doesn't match ~
    271        count of ~A" tick-mark-values tick-mark-values))|#
    272        ((or (not (slot-boundp view 'max-value))
    273             (not (slot-boundp view 'min-value)))
    274         (error "A slider view needs both :min-value and :max-value set.")))
    275      (dcc (#/setMinValue: (cocoa-ref view) (float min-value ns:+cgfloat-zero+)))
    276      (dcc (#/setMaxValue: (cocoa-ref view) (float max-value ns:+cgfloat-zero+)))
     734  (with-slots (discrete-tick-marks-p tick-mark-count tick-mark-values min-value max-value) view
     735     (cond ((and (slot-boundp view 'tick-mark-count)
     736                 (slot-boundp view 'discrete-tick-marks-p)
     737                 (slot-boundp view 'tick-mark-values)
     738                 (/= (length tick-mark-values) tick-mark-count))
     739            (error "Incompatible tick mark specification: ~A doesn't match ~
     740                     count of ~A" tick-mark-count tick-mark-values))
     741           ((or (not (slot-boundp view 'max-value))
     742                (not (slot-boundp view 'min-value)))
     743            (error "A slider view needs both :min-value and :max-value set.")))
     744     (dcc (#/setMinValue: (cocoa-ref view) (float min-value (or 1.0d0 ns:+cgfloat-zero+))))
     745     (dcc (#/setMaxValue: (cocoa-ref view) (float max-value (or 1.0d0 ns:+cgfloat-zero+))))
    277746     (when (slot-boundp view 'tick-mark-count)
    278747       (dcc (#/setNumberOfTickMarks: (cocoa-ref view) tick-mark-count))
    279748       (dcc (#/setAllowsTickMarkValuesOnly:
    280              (cocoa-ref view) (not (not discrete-tick-marks-p)))))))
     749             (cocoa-ref view) (not (not discrete-tick-marks-p))))))
     750  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
     751
     752(defmethod initialize-view :after ((view text-coloring-mixin))
     753  (dcc (#/setTextColor: (cocoa-ref view) (slot-value view 'foreground))))
     754
     755(defmethod initialize-view :after ((view text-fonting-mixin))
     756  (when (slot-value view 'font)
     757    (dcc (#/setFont: (cocoa-ref view) (slot-value view 'font)))))
     758
     759(defmethod (setf view-font) ((new ns:ns-font) (view view))
     760  (setf (slot-value view 'font) new)
     761  (dcc (#/setFont: (cocoa-ref view) new)))
     762
     763; ----------------------------------------------------------------------
     764; Modifying position / size    of    view / window
     765; ----------------------------------------------------------------------
     766
     767(defmethod (setf view-position) (point (self view))
     768  (running-on-main-thread ()
     769    (setf (slot-value self 'position) point)
     770    (when (slot-value self 'frame-inited-p)
     771      (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self)))
     772      (dcc (#/setNeedsDisplay (cocoa-ref self))))))
     773
     774(defmethod (setf view-position) (point (self window))
     775  (running-on-main-thread ()
     776    (setf (slot-value self 'position) point)
     777    (unless (window-hidden self)
     778      (let* ((contentrect (view-content-rect self nil))
     779             (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) contentrect))))
     780        (dcc (#/setFrame:display: (cocoa-ref self) framerect t))))))
     781
     782(defmethod (setf view-size) (point (self view))
     783  (running-on-main-thread ()
     784    (setf (slot-value self 'size) point)
     785    (when (slot-value self 'frame-inited-p)
     786      (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self)))
     787      (dcc (#/setNeedsDisplay (cocoa-ref self))))))
     788
     789(defmethod (setf view-size) (point (self window))
     790  (running-on-main-thread ()
     791    (setf (slot-value self 'size) point)
     792    (unless (window-hidden self)
     793      (let* ((contentrect (view-content-rect self nil))
     794             (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) contentrect))))
     795        (dcc (#/setFrame:display: (cocoa-ref self) framerect t))))))
    281796
    282797;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    283798;;; view hierarchies:
     799
     800(defmethod set-needs-display ((view view) flag)
     801  (running-on-this-thread ()
     802    (dcc (#/setNeedsDisplay: (cocoa-ref view) flag))))
     803
     804(defmethod set-needs-display ((view content-view-mixin) flag)
     805  (set-needs-display (content-view view) flag))
     806
     807(defmethod set-needs-display ((view window) flag)
     808  (if (window-hidden view)
     809    (setf (slot-value view 'window-needs-display-on-show) flag)
     810    (set-needs-display (content-view view) flag)))
    284811
    285812(defmethod add-1-subview :around ((view view) (cw-view content-view-mixin))
     
    290817  (call-next-method)
    291818  (with-slots (position size frame-inited-p) view
    292      (unless frame-inited-p
    293        (dcc (#/setFrameOrigin: (cocoa-ref view)
    294                                (ns:make-ns-point (point-x position)
    295                                                  (point-y position))))
    296        (if (slot-boundp view 'size)
    297            (dcc (#/setFrameSize: (cocoa-ref view)
    298                                  (ns:make-ns-point (point-x size)
    299                                                    (point-y size))))
    300            (dcc (#/sizeToFit (cocoa-ref view)))))
    301      (dcc (#/setNeedsDisplay: (cocoa-ref view) t))
    302      (dcc (#/setNeedsDisplay: (cocoa-ref super-view) t))))
     819    (unless frame-inited-p
     820      (setf frame-inited-p t)
     821      (running-on-this-thread ()
     822        (let ((cocoa-view (cocoa-ref view)))
     823          (dcc (#/setFrameOrigin: cocoa-view (ns-point-from-point position)))
     824          (if (slot-boundp view 'size)
     825            (dcc (#/setFrameSize: cocoa-view (ns-point-from-point size)))
     826            (dcc (#/sizeToFit cocoa-view))))))
     827    (set-needs-display view t)
     828    (unless (view-subviews-busy super-view) (set-needs-display super-view t))))
    303829
    304830(defmethod add-1-subview ((view view) (super-view view))
    305   (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view))))
     831  (running-on-this-thread ()
     832    (setf (slot-value view 'parent) super-view)
     833    (push view (slot-value super-view 'subviews))
     834    (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view)))))
    306835
    307836(defun add-subviews (superview subview &rest subviews)
     837  (setf (view-subviews-busy superview) t)
    308838  (add-1-subview subview superview)
    309839  (dolist (subview subviews)
    310840    (add-1-subview subview superview))
     841  (set-needs-display superview t)
     842  (setf (view-subviews-busy superview) nil)
    311843  superview)
    312844
     
    315847
    316848(defmethod remove-1-subview ((view view) (super-view view))
    317   (assert (eql (cocoa-ref super-view) (#/superview (cocoa-ref view))))
     849  (assert (eql (cocoa-ref super-view) (dcc (#/superview (cocoa-ref view)))))
     850  (assert (member view (view-subviews super-view)))
     851  (assert (eq super-view (slot-value view 'parent)))
    318852  (maybe-invalidating-object (view)
    319     (#/removeFromSuperview (cocoa-ref view))))
     853    (setf (slot-value super-view 'subviews) (delete view (slot-value super-view 'subviews)))
     854    (setf (slot-value view 'parent) nil)
     855    (running-on-this-thread ()
     856      (dcc (#/removeFromSuperview (cocoa-ref view))))))
    320857
    321858(defun remove-subviews (superview subview &rest subviews)
     859  (setf (view-subviews-busy superview) t)
    322860  (remove-1-subview subview superview)
    323861  (dolist (subview subviews)
    324862    (remove-1-subview subview superview))
     863  (set-needs-display superview t)
     864  (setf (view-subviews-busy superview) nil)
    325865  superview)
    326866
    327867(defmethod window-show ((window window))
    328   (dcc (#/makeKeyAndOrderFront: (cocoa-ref window) nil))
    329   window)
     868  (running-on-this-thread ()
     869    (let ((cwin (cocoa-ref window)))
     870      (when (window-hidden window)
     871        (setf (slot-value window 'hidden) nil)
     872        (let* ((contentrect (view-content-rect window nil))
     873               (framerect (dcc (#/frameRectForContentRect: (cocoa-ref window) contentrect))))
     874          (dcc (#/setFrame:display: (cocoa-ref window) framerect nil)))
     875        (when (dcc (#/isMiniaturized cwin)) (dcc (#/deminiaturize: cwin cwin)))
     876        (when (slot-value window 'window-needs-display-on-show)
     877          (setf (slot-value window 'window-needs-display-on-show) nil)
     878          (dcc (#/setNeedsDisplay: (cocoa-ref (content-view window)) t))))
     879      (dcc (#/makeKeyAndOrderFront: cwin nil))
     880      (when (dcc (#/isFlushWindowDisabled cwin))
     881        (dcc (#/enableFlushWindow cwin))
     882        (dcc (#/flushWindow cwin)))
     883      window)))
    330884
    331885
     
    335889(defmethod add-entry (entry (view form-view))
    336890  (make-instance 'form-cell-view
    337      :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) entry))))
     891     :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) (ccl::%make-nsstring entry)))))
    338892
    339893(defun add-entries (view &rest entries)
     
    358912
    359913;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     914;;; Window closing
     915         
     916(defmethod window-may-close ((w window))
     917"This generic is intended to allow applications to define :BEFORE and/or :AFTER methods
     918invoked when windows are closed. The default primary method returns T to indicate that
     919the window may close. If an overriding primary method returns NIL, the window will not
     920close in response to user action but will still close if the application quits.
     921(This is because window-may-close is called when the COCOA-WINDOW (specialised NS:NS-WINDOW)
     922that is attached to an EASYGUI::WINDOW object receives a performClose: message, as when
     923a user clicks the close button for example.)"
     924  (declare (ignore w))
     925  t)
     926
     927(defmethod perform-close ((w window))
     928"This generic is intended to allow applications to mimic the user clicking a window's
     929close button."
     930  (running-on-this-thread ()
     931    (dcc (#/performClose: (cocoa-ref w)  ccl:+null-ptr+))))
     932
     933(objc:define-objc-method ((:<BOOL> :window-should-close (:id sender)) cocoa-window)
     934  (declare (optimize (safety 0))) ; CCL v1.3 checks a faulty type declaration otherwise
     935  (declare (ignore sender))  ; The cocoa-window has been set up as its own delegate. Naughty?
     936  (if (window-may-close (easygui-window-of self)) #$YES #$NO))
     937
     938;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    360939;;; Drawing:
    361940
    362 (defclass cocoa-drawing-view (ns:ns-view)
    363      ((easygui-view :initarg :eg-view :reader easygui-view-of))
    364   (:metaclass ns:+ns-view))
     941(defmethod clear-page ((cocoa-view cocoa-drawing-view))
     942  (let* ((view (easygui-view-of cocoa-view))
     943         (rect (dcc (#/bounds cocoa-view)))
     944         (color (slot-value view 'background)))
     945    (with-focused-view cocoa-view
     946      (dcc (#/setFill color))
     947      (dcc (#_NSRectFill rect)))))
     948         
     949(objc::defmethod (#/isFlipped :<BOOL>) ((self cocoa-drawing-view))
     950  (if (slot-value self 'flipped) #$YES #$NO))
     951
     952(objc::defmethod (#/isFlipped :<BOOL>) ((self cocoa-contained-view))
     953  (if (slot-value self 'flipped) #$YES #$NO))
    365954
    366955(defmethod initialize-view :after ((view drawing-view))
     956  (setf (slot-value (cocoa-ref view) 'flipped) (slot-value view 'flipped))
    367957  (setf (slot-value (cocoa-ref view) 'easygui-view) view))
    368958
    369959(objc:defmethod (#/drawRect: :void) ((self cocoa-drawing-view)
    370960                                     (rect :<NSR>ect))
    371   (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect)))
     961  (dcc (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect))))
    372962
    373963(objc:defmethod (#/acceptsFirstReponder: :boolean) ((view cocoa-drawing-view))
     
    376966(defgeneric draw-view-rectangle (view rectangle)
    377967  (:method ((view drawing-view) rectangle)
    378     (declare (ignore view rectangle))
     968    (declare (ignorable view rectangle))
     969    (when (draw-fn view)
     970      (let ((cview (cocoa-ref view)))
     971        (with-focused-view cview (funcall (draw-fn view) view cview))))
    379972    nil))
    380973
     
    383976  (setf rect (if rect
    384977                 (rectangle-nsrect rect)
    385                  (#/bounds (cocoa-ref view))))
    386   (#/setNeedsDisplayInRect: (cocoa-ref view) rect))
     978                 (dcc (#/bounds (cocoa-ref view)))))
     979  (dcc (#/setNeedsDisplayInRect: (cocoa-ref view) rect)))
    387980
    388981(define-useful-mouse-event-handling-routines cocoa-drawing-view)
     982(define-useful-mouse-event-handling-routines cocoa-mouseable-text-field)
     983
     984(defmethod mouse-down ((view drawing-view) &key cocoa-event location button click-count delta)
     985  (let ((mousefn (drawing-view-mouse-down view)) (*cocoa-event* cocoa-event))
     986    (when mousefn
     987      (funcall mousefn view
     988               :location location
     989               :allow-other-keys t
     990               :button button
     991               :cocoa-event cocoa-event
     992               :click-count click-count
     993               :delta delta))))
     994
     995(defmethod mouse-up ((view drawing-view) &key cocoa-event location button click-count delta)
     996  (let ((mousefn (drawing-view-mouse-up view)) (*cocoa-event* cocoa-event))
     997    (when mousefn
     998      (funcall mousefn view
     999               :location location
     1000               :allow-other-keys t
     1001               :button button
     1002               :cocoa-event cocoa-event
     1003               :click-count click-count
     1004               :delta delta))))
     1005
     1006(defmethod mouse-dragged ((view drawing-view) &key cocoa-event location button click-count delta)
     1007  (let ((mousefn (drawing-view-mouse-dragged view)) (*cocoa-event* cocoa-event))
     1008    (when mousefn
     1009      (funcall mousefn view
     1010               :location location
     1011               :allow-other-keys t
     1012               :button button
     1013               :cocoa-event cocoa-event
     1014               :click-count click-count
     1015               :delta delta))))
     1016
     1017(defmethod mouse-down ((view static-text-view) &key cocoa-event location button click-count delta)
     1018  (let ((mousefn (static-text-view-mouse-down view)) (*cocoa-event* cocoa-event))
     1019    (when mousefn
     1020      (funcall mousefn view
     1021               :location location
     1022               :allow-other-keys t
     1023               :button button
     1024               :cocoa-event cocoa-event
     1025               :click-count click-count
     1026               :delta delta))))
     1027
     1028(defmethod mouse-up ((view static-text-view) &key cocoa-event location button click-count delta)
     1029  (let ((mousefn (static-text-view-mouse-up view)) (*cocoa-event* cocoa-event))
     1030    (when mousefn
     1031      (funcall mousefn view
     1032               :location location
     1033               :allow-other-keys t
     1034               :button button
     1035               :cocoa-event cocoa-event
     1036               :click-count click-count
     1037               :delta delta))))
     1038
     1039(defmethod mouse-dragged ((view static-text-view) &key cocoa-event location button click-count delta)
     1040  (let ((mousefn (static-text-view-mouse-dragged view)) (*cocoa-event* cocoa-event))
     1041    (when mousefn
     1042      (funcall mousefn view
     1043               :location location
     1044               :allow-other-keys t
     1045               :button button
     1046               :cocoa-event cocoa-event
     1047               :click-count click-count
     1048               :delta delta))))
     1049
     1050; -------------------
     1051(defmethod view-named (name (view view))
     1052  (find name (view-subviews view) :key #'view-nick-name))
     1053
     1054(defmethod view-named (name (container content-view-mixin))
     1055  (view-named name (content-view container)))
     1056
     1057(defmethod view-subviews ((w content-view-mixin))
     1058  (view-subviews (content-view w)))
     1059
     1060; ----------------------
     1061
     1062(defmethod view-nickname-chain ((view view) &optional include-everything) "
     1063Yields two values:
     1064- a list of nicknames of containing views, starting with outermost container
     1065- the view or window that contains the view with the first name in the list,
     1066  or NIL if the first name belongs to a window.
     1067If include-everything is NIL (the default), the list does not contain the
     1068autogenerated name for content views of windows or boxes, and contains names
     1069of views or windows that have non-NIL names. The second value may then be
     1070a view or window that has no nickname of its own.
     1071If include-everything is T, the list does contain the autogenerated name of
     1072content views of windows or boxes, it does contain NIL for views named NIL,
     1073and the second value will always be NIL."
     1074  (do (chain
     1075       nickname
     1076       (outermost view (view-container outermost)))
     1077      ((or (null outermost)
     1078           (and (null (setf nickname (view-nick-name outermost)))
     1079                (not include-everything)))               
     1080       (values chain outermost))
     1081    (when (or include-everything (not (eq nickname '%CONTENT-OF-CONTENT-VIEW%)))
     1082      (push (view-nick-name outermost) chain))))
     1083
     1084; ----------------------
     1085
     1086(defclass check-box-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin)
     1087  ((checked :initarg :checked :initform nil)))
     1088
     1089(defmethod check-box-check ((self check-box-view) &optional perform)
     1090  (running-on-this-thread ()
     1091    (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOnState)
     1092      (if perform
     1093        (dcc (#/performClick: (cocoa-ref self) nil))
     1094        (dcc (#/setState: (cocoa-ref self) #$NSOnState)))
     1095      t)))
     1096
     1097(defmethod initialize-view :after ((view check-box-view))
     1098  (when (cocoa-ref view)
     1099    (dcc (#/setButtonType: (cocoa-ref view) #$NSSwitchButton))
     1100    (when (slot-value view 'checked) (check-box-check view))
     1101    (setf (slot-value (cocoa-ref view) 'easygui-view) view)))
     1102
     1103(defmethod check-box-uncheck ((self check-box-view) &optional perform)
     1104  (running-on-this-thread ()
     1105    (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOffState)
     1106      (if perform
     1107        (dcc (#/performClick: (cocoa-ref self) nil))
     1108        (dcc (#/setState: (cocoa-ref self) #$NSOffState)))
     1109      t)))
     1110
     1111(defmethod check-box-checked-p ((self check-box-view))
     1112  (eql (dcc (#/state (cocoa-ref self))) #$NSOnState))
     1113
     1114(defmethod (setf check-box-checked-p) (new (self check-box-view))
     1115  (if new
     1116    (check-box-check self)
     1117    (check-box-uncheck self))
     1118  new)
     1119
     1120; -------------------------
     1121(defclass radio-button-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin)
     1122  ((selected :initarg :selected :reader radio-button-selected-p :initform nil)
     1123   (cluster  :initarg :cluster  :initform '#:default-cluster))
     1124  (:default-initargs :action #'(lambda () nil)))
     1125
     1126(defun deselect-radio-button-cohorts (radio-button-view)
     1127  (when (view-container radio-button-view)
     1128    (dolist (sibling (view-subviews (view-container radio-button-view)))
     1129      (when (and (not (eq sibling radio-button-view))
     1130                 (typep sibling 'radio-button-view)
     1131                 (eq (slot-value radio-button-view 'cluster) (slot-value sibling 'cluster))
     1132                 (eql (dcc (#/state (cocoa-ref sibling))) #$NSOnState))
     1133        (setf (slot-value sibling 'selected) nil)
     1134        (dcc (#/setState: (cocoa-ref sibling) #$NSOffState))))))
     1135 
     1136(defmethod radio-button-select ((self radio-button-view) &optional perform)
     1137  (running-on-this-thread ()
     1138    (if perform
     1139      (dcc (#/performClick: (cocoa-ref self) nil))
     1140      (progn
     1141        (deselect-radio-button-cohorts self)
     1142        (setf (slot-value self 'selected) t)
     1143        (dcc (#/setState: (cocoa-ref self) #$NSOnState))))))
     1144
     1145(defmethod initialize-view :after ((self radio-button-view))
     1146  (when (cocoa-ref self)
     1147    (dcc (#/setButtonType: (cocoa-ref self) #$NSRadioButton))
     1148    (when (slot-value self 'selected) (radio-button-select self))
     1149    (setf (slot-value (cocoa-ref self) 'easygui-view) self)))
     1150
     1151(defmethod radio-button-deselect ((self radio-button-view))
     1152  (running-on-this-thread ()
     1153    (dcc (#/setState: (cocoa-ref self) #$NSOffState))
     1154    (prog1
     1155      (radio-button-selected-p self)
     1156      (setf (slot-value self 'selected) nil))))
     1157
     1158(defmethod (setf action) (handler (view radio-button-view))
     1159  (call-next-method
     1160   (lambda ()
     1161     (deselect-radio-button-cohorts view)
     1162     (setf (slot-value view 'selected) t)
     1163     (funcall handler))
     1164   view)
     1165  handler)
     1166
     1167; ----------------------------------------------------------------------
     1168; INVALIDATE-VIEW
     1169; ----------------------------------------------------------------------
     1170
     1171(defmethod invalidate-view ((view view) &optional total)
     1172  (declare (ignorable total))
     1173  (let ((cview (cocoa-ref view)))
     1174    (dcc (#/setNeedsDisplay: cview #$YES))))
     1175
     1176(defmethod invalidate-view ((window window) &optional total)
     1177  (declare (ignorable total))
     1178  (let* ((cocoaview (cocoa-ref window))
     1179         (contentview (dcc (#/contentView cocoaview))))
     1180    (dcc (#/setNeedsDisplay: contentview #$YES))))
     1181
     1182; ----------------------------------------------------------------------
     1183; Methods to    GET- & SET-    FORE- & BACK-    COLOR
     1184; ----------------------------------------------------------------------
     1185
     1186(defmethod set-fore-color ((view view) (color ns:ns-color))
     1187  (setf (slot-value view 'foreground) color))
     1188
     1189(defmethod set-fore-color :before ((view view-text-via-stringvalue-mixin) (color ns:ns-color))
     1190  (dcc (#/setTextColor: (cocoa-ref view) color)))
     1191
     1192(defmethod set-fore-color ((view cocoa-extension-mixin) (color ns:ns-color))
     1193  (set-fore-color (easygui-view-of view) color))
     1194
     1195(defmethod set-back-color ((view view) (color ns:ns-color) &optional redisplay-p)
     1196  (setf (slot-value view 'background) color)
     1197  (when redisplay-p (invalidate-view view)))
     1198
     1199(defmethod set-back-color :after ((view static-text-view) (color ns:ns-color) &optional redisplay-p)
     1200  (dcc (#/setBackgroundColor: (cocoa-ref view) color))
     1201  (when redisplay-p (invalidate-view view)))
     1202
     1203(defmethod set-back-color ((view cocoa-extension-mixin) (color ns:ns-color) &optional redisplay-p)
     1204  (set-back-color (easygui-view-of view) color redisplay-p))
     1205
     1206(defmethod get-fore-color ((view view))
     1207  (slot-value view 'foreground))
     1208
     1209(defmethod get-fore-color ((view cocoa-extension-mixin))
     1210  (get-fore-color (easygui-view-of view)))
     1211
     1212(defmethod get-back-color ((view view))
     1213  (slot-value view 'background))
     1214
     1215(defmethod get-back-color ((view cocoa-extension-mixin))
     1216  (get-back-color (easygui-view-of view)))
     1217
     1218; --------------------- Menus Begin ---------------------
     1219
     1220(defmethod view-text ((self ns:ns-menu))
     1221  (lisp-string-from-nsstring (dcc (#/title self))))
     1222
     1223(defmethod (setf view-text) (new (self ns:ns-menu))
     1224  (running-on-this-thread ()
     1225    (dcc (#/setTitle: self (ccl::%make-nsstring new)))
     1226    new))
     1227
     1228(defclass menu-view (view view-text-via-title-mixin decline-menu-mixin)
     1229  ((selection   :initarg :selection   :reader menu-selection :initform nil)
     1230   (menu-kind   :initarg :menu-kind   :reader menu-kind      :initform :pull-down-menu)
     1231   (menu-items  :initarg :menu-items  :reader menu-items     :initform nil)
     1232   ns-menu
     1233   %result))
     1234
     1235(defclass menu-item-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin)
     1236  (parent-menu
     1237   action
     1238   submenu)
     1239  (:default-initargs :action #'(lambda () nil)))
     1240
     1241;(defmethod (setf view-text) :after (new (menu menu-view))
     1242;  (declare (ignorable new))
     1243;  (dcc (#/setNeedsDisplay: (cocoa-ref menu) t)))
     1244
     1245(defmethod initialize-instance :after ((self menu-view) &rest args &key menu-items selection)
     1246  (declare (ignorable args selection))
     1247  (let ((ns-menu nil))
     1248    (if (slot-boundp self 'ns-menu)
     1249      (setf ns-menu (slot-value self 'ns-menu))
     1250      (setf ns-menu (dcc (#/menu (cocoa-ref self)))
     1251            (slot-value self 'ns-menu) ns-menu))
     1252    ;(format t "~&Initializing menu ~a with ~a items~%" self (length menu-items))
     1253    (dolist (item menu-items)
     1254      ;(format t "~&Adding ~a to menu ~a~%" item self)
     1255      (cond
     1256       ((typep item 'menu-view)
     1257        (let ((intermediary (make-instance 'menu-item-view
     1258                              :title (view-text item))))
     1259          (setf (slot-value intermediary 'submenu) item)
     1260          (dcc (#/setSubmenu: (cocoa-ref intermediary) (slot-value item 'ns-menu)))
     1261          (dcc (#/addItem: ns-menu (cocoa-ref intermediary)))))
     1262       ((not (typep item 'menu-item-view))
     1263        (warn "Ignoring so-called menu item ~s" item))
     1264       ((slot-boundp item 'parent-menu)
     1265        (warn "Ignoring menu item ~s, which is already an item in some menu" item))
     1266       (t (let ((coco (cocoa-ref item)))
     1267            (dcc (#/addItem: ns-menu coco))
     1268            (setf (slot-value item 'parent-menu) self)))))))
     1269
     1270(defmethod (setf action) (new (menu-item menu-item-view))
     1271  (call-next-method
     1272   #'(lambda ()
     1273       (if (slot-boundp menu-item 'parent-menu)
     1274         (let ((parent (slot-value menu-item 'parent-menu)))
     1275           (setf (slot-value parent 'selection) menu-item)
     1276           (setf (slot-value parent '%result) (funcall new)))
     1277         (funcall new)))
     1278   menu-item)
     1279  new)
     1280
     1281(defmethod set-menu-item-title ((menu-item menu-item-view) title)
     1282  (running-on-this-thread ()
     1283    (dcc (#/setTitle: (cocoa-ref menu-item) (ccl::%make-nsstring title)))))
     1284
     1285(defmethod set-menu-item-title ((menu-item ns:ns-menu-item) title)
     1286  (running-on-this-thread ()
     1287    (dcc (#/setTitle: menu-item (ccl::%make-nsstring title)))))
     1288
     1289; -------------------
     1290(defclass pop-up-menu (menu-view)
     1291  ()
     1292  (:default-initargs :menu-kind :pop-up-menu))
     1293
     1294(defmethod initialize-instance :after ((self pop-up-menu) &rest args &key selection)
     1295  (declare (ignorable args))
     1296  (with-slots (ns-menu menu-items) self
     1297    (setf (view-text self)
     1298          (cond
     1299           ((null menu-items)
     1300            "<No Items>")
     1301           ((null selection)
     1302            (setf (slot-value self 'selection) (first menu-items))
     1303            (view-text (first menu-items)))
     1304           ((stringp selection)
     1305            selection)
     1306           ((member selection menu-items)
     1307            (setf (slot-value self 'selection) selection)
     1308            (view-text selection))
     1309           (t "<Selection Invalid>"))))
     1310  (setf (slot-value (cocoa-ref self) 'easygui-view) self))
     1311
     1312; ----------------------
     1313(defclass pull-down-menu (menu-view)
     1314  ()
     1315  (:default-initargs :menu-kind :pull-down-menu))
     1316
     1317(defmethod initialize-instance :after ((self pull-down-menu) &rest args &key title)
     1318  (declare (ignorable args))
     1319  (running-on-this-thread ()
     1320    (dcc (#/insertItemWithTitle:atIndex: (cocoa-ref self) (ccl::%make-nsstring (or title "<No Title>")) 0))))
     1321
     1322(defmethod initialize-view :after ((self pull-down-menu))
     1323  (running-on-this-thread ()
     1324    (when (cocoa-ref self)
     1325      (dcc (#/setPullsDown: (cocoa-ref self) #$YES))
     1326      (setf (slot-value (cocoa-ref self) 'easygui-view) self))))
     1327
     1328; -----------------------
     1329(defclass contextual-menu (menu-view)
     1330  ()
     1331  (:default-initargs :menu-kind :contextual-menu))
     1332
     1333(defgeneric add-contextual-menu (container menu &optional subviews))
     1334
     1335(defmethod add-contextual-menu ((window window) (menu menu-view) &optional subviews)
     1336  (add-contextual-menu (content-view window) menu subviews))
     1337
     1338(defmethod add-contextual-menu ((view view) (menu menu-view) &optional subviews)
     1339  (running-on-this-thread ()
     1340    (dcc (#/setMenu: (cocoa-ref view) (slot-value menu 'ns-menu)))
     1341    (when subviews
     1342      (dolist (sub (view-subviews view))
     1343        (unless (or (not (cocoa-null (dcc (#/menu (cocoa-ref sub)))))
     1344                    (typep sub 'decline-menu-mixin))
     1345          (add-contextual-menu sub menu subviews))))))
     1346
     1347(defmethod add-contextual-menu ((view menu-view) (refusenik decline-menu-mixin) &optional subviews)
     1348  (declare (ignore subviews))
     1349  (error "Cannot add a contextual menu to a view of class ~s" (type-of refusenik)))
     1350
     1351; -------------------------
     1352(defun application-object nil
     1353  (dcc (#/sharedApplication ns:ns-application)))
     1354
     1355(defun application-main-menu nil
     1356  (dcc (#/mainMenu (application-object))))
     1357
     1358(defgeneric navigate-menu (titles menu))
     1359
     1360(defmethod navigate-menu ((titles list) (menu menu-view))
     1361;; Returns NIL if the path of titles leads nowhere, when no appropriately titled menu-item or submenu exists;
     1362;; Returns a EasyGui MENU-ITEM if the path of titles leads to a leaf item;
     1363;; Returns a EasyGui MENU-VIEW if the path of titles leads to a submenu.
     1364  (cond
     1365   ((null titles) menu)
     1366   (t (let ((it (find (first titles) (menu-items menu) :test #'equalp :key #'view-text)))
     1367        (when it (navigate-menu (rest titles) it))))))
     1368
     1369(defun navigate-native-menu (titles menu)
     1370;; Returns a NIL or a NS:NS-MENU-ITEM or a NS:NS-MENU
     1371;; Returns a NS:NS-MENU when the title path leads to a submenu,
     1372;; Returns a NS;NS-MENU-ITEM when the title path leads to a leaf menu item,
     1373;; Returns NIL when the title path leads nowhere.
     1374  (running-on-this-thread ()
     1375    (if (null titles)
     1376      menu
     1377      (do ((number (dcc (#/numberOfItems menu)))
     1378           (index 0 (1+ index))
     1379           item found)
     1380          ((or found (>= index number))
     1381           (cond
     1382            ((or (null found) (null (rest titles))) found)
     1383            ((null (dcc (#/hasSubmenu found))) nil)
     1384            (t (navigate-native-menu (rest titles) (dcc (#/submenu found))))))
     1385        (setf item (dcc (#/itemAtIndex: menu index)))
     1386        (if (or (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title item))))
     1387                ; The Apple menu item has title "" but its submenu has title "Apple", hence ...
     1388                (and (dcc (#/hasSubmenu item))
     1389                     (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title (dcc (#/submenu item))))))))
     1390          (setf found item))))))
     1391
     1392(defmethod navigate-topbar ((titles list))
     1393  (navigate-native-menu titles (application-main-menu)))
     1394
     1395(defun add-menu-item (menu titles &optional action)
     1396;; Adds a chain of submenus and a final leaf item with the indicated action.
     1397;; If the final leaf item already exists, its action will be changed. Perhaps this is too dangerous.
     1398;; The Apple submenu may not be altered; the application's submenu cannot be found.
     1399  (cond
     1400   ((null titles)
     1401    (cerror "Return NIL" "No title path supplied"))
     1402   ((not (and (consp titles) (stringp (first titles))))
     1403    (cerror "Return NIL, some empty submenus may have been created" "Title path is not a list of strings"))
     1404   ((not (typep menu 'ns:ns-menu))
     1405    (cerror "Return NIL" "Not a Cocoa menu: ~s" menu))
     1406   (t (let* ((ns-title (ccl::%make-nsstring (first titles)))
     1407             (item (dcc (#/itemWithTitle: menu ns-title)))
     1408             (ns-nullstring (ccl::%make-nsstring "")))
     1409        (flet ((linkup (leaf action) ;; Modelled on code in easygui/action-targets.lisp
     1410                 (let ((target (make-instance 'generic-easygui-target :handler (or action #'(lambda () nil)))))
     1411                   (dcc (#/setTarget: leaf target))
     1412                   (dcc (#/setAction: leaf (\@selector #/activateAction))))))
     1413          (cond
     1414           ((equalp (first titles) "-")
     1415            (if (rest titles)
     1416              (cerror "Leave menu unchanged" "A menu separator (an item having title \"-\") may not have a submenu")
     1417              (dcc (#/addItem: menu (dcc (#/separatorItem ns:ns-menu-item))))))
     1418           ((cocoa-null item) ;; No such item, something must be added
     1419            (if (rest titles)
     1420              (let ((number (dcc (#/numberOfItems menu)))
     1421                    (submenu (make-instance 'ns:ns-menu)))
     1422                (running-on-this-thread ()
     1423                  (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-title ccl:+null-ptr+ ns-nullstring))
     1424                  (setf item (dcc (#/itemAtIndex: menu number))) ;; That's where it got put
     1425                  (dcc (#/initWithTitle: submenu ns-title))
     1426                  (dcc (#/setSubmenu: item submenu)))
     1427                (add-menu-item submenu (rest titles) action))
     1428              (let ((number (dcc (#/numberOfItems menu))))
     1429                (running-on-this-thread ()
     1430                  (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-title ccl:+null-ptr+ ns-nullstring))
     1431                  (setf item (dcc (#/itemAtIndex: menu number))))
     1432                (linkup item action))))
     1433           ((and (null (rest titles)) (dcc (#/hasSubmenu item)))
     1434            (cerror "Leave menu unchanged" "An Action may not be added to any item with a submenu"))
     1435           ((and (rest titles) (dcc (#/hasSubmenu item)))
     1436            (add-menu-item (dcc (#/submenu item)) (rest titles) action))
     1437           ((rest titles)
     1438            (cerror "Leave menu unchanged" "An existing menu item cannot be converted to have a submenu"))
     1439           (t (linkup item action)))))))) ;; Change the action of an existing item: desirable, or dangerous?           
     1440
     1441(defun add-topbar-item (titles &optional action)
     1442  (if (and (consp titles) (rest titles))
     1443    (add-menu-item (application-main-menu) titles action)
     1444    (cerror "Return NIL" "Title path must be a list with at least two elements: ~s" titles)))
     1445
     1446(defun remove-menu-item (menu titles retain-if-empty)
     1447  (if (not (and (consp titles) (stringp (first titles))))
     1448    (cerror "Return NIL" "Title path is not a list of strings")
     1449    (do ((number (dcc (#/numberOfItems menu)))
     1450         (index 0 (1+ index))
     1451         item found)
     1452        ((or found (>= index number))
     1453         (when found
     1454           (if (rest titles)
     1455             (when (dcc (#/hasSubmenu found))
     1456               (remove-menu-item (dcc (#/submenu found)) (rest titles) retain-if-empty)
     1457               (unless (or retain-if-empty (> (dcc (#/numberOfItems (dcc (#/submenu found)))) 0))
     1458                 (dcc (#/removeItem: menu found))))
     1459             (dcc (#/removeItem: menu found)))))
     1460      (setf item (dcc (#/itemAtIndex: menu index)))
     1461      (when (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title item))))
     1462        (setf found item)))))
     1463
     1464(defun remove-topbar-item (titles &key retain-if-empty)
     1465  (when (and (consp titles)
     1466             (not (member (first titles) '("" "Apple") :test #'equalp)))
     1467    (remove-menu-item (application-main-menu) titles retain-if-empty)))
     1468
     1469(defun add-application-submenu (title &rest trees) "
     1470Adds a menu to the topbar application-menu with the given title.
     1471Its menu-items names are got from the CARs of the trees.
     1472The CDRs of these trees may consist either of further trees, allowing arbitrarily
     1473deep menu structures, or of a one-element list that is expected to be a parameterless
     1474function to be used as the Action of a leaf menu item.
     1475Example:
     1476  (add-application-submenu \"Beeps\"
     1477     '(\"Normal\" #'normal-beep)
     1478     '(\"Stupid\" #'stupid-beep)
     1479     '(\"Choose\" (\"Custom beep 1\" #'custom-beep-1-not-implemented)
     1480                (\"Custom beep 2\" #'custom-beep-2-not-implemented)))
     1481"
     1482  (labels ((valid-tree (tree)
     1483             (and (consp tree) (stringp (first tree))))
     1484           (prepending (seq tree)
     1485             (cond
     1486              ((every #'valid-tree (rest tree))
     1487               (dolist (subtree (rest tree))
     1488                 (prepending (append seq (list (first subtree))) (rest subtree))))
     1489              ((and (consp tree) (stringp (first tree)) (consp (rest tree)) (null (cddr tree)))
     1490               (add-topbar-item (append seq (list (first tree))) (second tree)))
     1491              (t (cerror "Ignore this tree" "Malformed tree ~s" tree)))))
     1492    (if (every #'valid-tree trees)
     1493      (dolist (subtree trees) (prepending (list title) subtree))
     1494      (cerror "Return NIL" "Malformed top-level trees"))))
     1495
     1496; ---------------
     1497; Keyboard input handling
     1498
     1499(defmethod view-key-event-handler ((view window) char)
     1500  (declare (ignorable char))
     1501  #| (format t "~&Window ~s got ~:[~;Control-~]~:[~;Alt-~]~:[~;Command-~]~:[~;Shift-~]~s~%"
     1502            view (control-key-p) (alt-key-p) (command-key-p) (shift-key-p) char))
     1503  |#
     1504  nil)
     1505
     1506(objc:define-objc-method ((:void :key-down (:id event)) cocoa-window)
     1507  (let ((*cocoa-event* event))
     1508    (view-key-event-handler
     1509     (easygui-window-of self)
     1510     (schar (lisp-string-from-nsstring (dcc (#/charactersIgnoringModifiers event))) 0))))
     1511
     1512(defun shift-key-p nil
     1513  (and *cocoa-event*
     1514       (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) #$NSShiftKeyMask)))))
     1515
     1516(defun control-key-p nil
     1517  (and *cocoa-event*
     1518       (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask :control))))))
     1519
     1520(defun alt-key-p nil
     1521  (and *cocoa-event*
     1522       (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask :alt))))))
     1523
     1524(defun command-key-p nil
     1525  (and *cocoa-event*
     1526       (not (zerop (logand (dcc (#/modifierFlags *cocoa-event*)) (key-mask :command))))))
     1527
     1528(defun view-mouse-position (view)
     1529  (let* ((w (cocoa-ref (easygui-window-of view)))
     1530         (mouselocation (dcc (#/mouseLocationOutsideOfEventStream w)))
     1531         (cview (if (typep view 'window) (content-view view) view))
     1532         (nspt (dcc (#/convertPoint:fromView: (cocoa-ref cview) mouselocation #$NIL))))
     1533    ;; todo: check point is inside bounds, lest negative coords
     1534    (point (ns:ns-point-x nspt) (ns:ns-point-y nspt))))
Note: See TracChangeset for help on using the changeset viewer.