(in-package :easygui) #| Changes from ccl/examples/cocoa/easygui/views.lisp Views know their parent. Views have list of subviews. Views have nicknames. Check-Box-View exists. Radio-Button-View exists. Additional symbols exported (they should be added to ccl/examples/cocoa/easygui/package.lisp) Testbed code adapted from ccl/examples/cocoa/easygui/example/view-hierarchy.lisp is included. Questionable changes have been made to the slider-view class definintion and its initialize-view method, since I was getting compiler warnings. I may have misunderstood the intent behind the original code, I don't use sliders (yet), proceed with caution! |# ; ----------------------- ; New stuff ; ; VIEW-SUBVIEWS view { Method } ; VIEW-SUBVIEWS window ; Returns a list of the views immediately contained within a view. ; Returns a list of the views immediately contained within the content-view ; of a window. ; Depends on views being added by ADD-1-SUBVIEW and removed by REMOVE-1-SUBVIEW, ; which conveniently is how ADD-SUBVIEWS and REMOVE-SUBVIEWS work. ; ; ; VIEW-NAMED nickname view { Method } ; VIEW-NAMED nickname window ; Returns the view's subview that has the given nickname. ; Returns the window's content-view's subview that has the given nickname. ; If there is currently no such subview, NIL is returned. ; If there are several, the most recently added one is returned. ; ; ; CHECK-BOX-VIEW { Class } ; A subtype of VIEW, a control that appears as a check-box, and may be on or off. ; Specific initargs: ; :CHECKED [ Generalised Boolean ] Default NIL ; Specific methods: ; CHECK-BOX-CHECKED-P checkbox ; Returns T if the checkbox is checked, NIL if not. ; CHECK-BOX-CHECK checkbox &optional perform ; CHECK-BOX-UNCHECK checkbox &optional perform ; These methods cause the checkbox to become checked/unchecked respectively. ; If the Perform argument is given and is non-nil, then if the checkbox is ; changing state any action associated it will be run. ; (SETF CHECK-BOX-CHECKED-P) checkbox ; Causes the checkbox to become checked or not, as per the new value supplied. ; Since it calls either CHECK-BOX-CHECK or CHECK-BOX-UNCHECK, subclasses of ; checkbox may specialise these methods to call-next-method with a ; non-NIL PERFORM argument if that is desired. ; ; ; ; RADIO-BUTTON-VIEW { Class } ; A subtype of VIEW, a control that appears as a radio-button, and interacts with ; other radio-buttons in the same named cluster and within the same subview ; in such a way that no more than one at a time may be selected. ; Specific initargs: ; :SELECTED [ Generalised Boolean ] Default NIL ; :CLUSTER [ Any ] Default a unique constant ; Specific methods: ; RADIO-BUTTON-SELECTED-P radiobutton ; Returns T if the radiobutton is selected, NIL otherwise. ; RADIO-BUTTON-SELECT radiobutton &optional perform ; Causes the button to be selected, all other buttons in the same cluster ; and contained in the same view become deselected. If the Perform argument is ; supplied and non-NIL, then any action associated with the button is performed. ; If there is only one cluster of buttons in a view, no name for the cluster ; need be provided. If there is more than one cluster, cluster names ; (keywords for example) should be used to identify which buttons go together. ; RADIO-BUTTON-DESELECT radiobutton &optional perform ; Causes the button to be deselected. If the Perform argument is ; supplied and non-NIL, then any action associated with the button is performed. ; It is permissible for no button of a cluster to be selected. ; Note, if several buttons are specified with :SELECTED T when added, only the ; last one added will show as selected in fact. In the process of adding it, others ; will have been deselected. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; view protocol (defgeneric initialize-view (view) (:documentation "Initializes the view with a cocoa object, sets it up according to initargs.")) (defgeneric add-1-subview (view super-view) (:documentation "Adds a subview to another view in the view hierarchy.")) (defgeneric remove-1-subview (view super-view) (:documentation "Removes a view from its superview, possibly deallocating it. To avoid deallocation, use RETAINING-OBJECTS")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mixins (defclass value-mixin () ()) (defclass string-value-mixin (value-mixin) ()) (defclass numeric-value-mixin (value-mixin) ()) (macrolet ((def-type-accessor (class lisp-type cocoa-reader cocoa-writer &key new-value-form return-value-converter) (let ((name (intern (format nil "~A-VALUE-OF" lisp-type)))) `(progn (defmethod ,name ((o ,class)) ,(if return-value-converter `(,return-value-converter (dcc (,cocoa-reader (cocoa-ref o)))) `(dcc (,cocoa-reader (cocoa-ref o))))) (defmethod (setf ,name) (new-value (o ,class)) (dcc (,cocoa-writer (cocoa-ref o) ,(or new-value-form 'new-value)))))))) (def-type-accessor string-value-mixin string #/stringValue #/setStringValue: :return-value-converter lisp-string-from-nsstring ) (def-type-accessor numeric-value-mixin integer #/intValue #/setIntValue:) (def-type-accessor numeric-value-mixin float #/floatValue #/setFloatValue: :new-value-form (coerce new-value 'single-float)) (def-type-accessor numeric-value-mixin double #/doubleValue #/setDoubleValue: :new-value-form (coerce new-value 'double-float))) (defclass view-text-mixin () ((text :initarg :text))) (defclass view-text-via-stringvalue-mixin (view-text-mixin string-value-mixin) ()) (defclass view-text-via-title-mixin (view-text-mixin) ((text :initarg :title))) (defmethod view-text ((view view-text-via-stringvalue-mixin)) (string-value-of view)) (defmethod view-text ((view view-text-via-title-mixin)) (lisp-string-from-nsstring (dcc (#/title (cocoa-ref view))))) (defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixin)) (setf (string-value-of view) new-text)) (defmethod (setf view-text) (new-text (view view-text-via-title-mixin)) (dcc (#/setTitle: (cocoa-ref view) new-text))) (defmethod initialize-view :after ((view view-text-mixin)) (when (slot-boundp view 'text) (setf (view-text view) (slot-value view 'text)))) (defclass editable-mixin () ()) (defmethod editable-p ((view editable-mixin)) (dcc (#/isEditable (cocoa-ref view)))) (defmethod (setf editable-p) (editable-p (view editable-mixin)) (check-type editable-p boolean) (dcc (#/setEditable: (cocoa-ref view) editable-p))) (defclass one-selection-mixin () ()) (defmethod (setf selection) (selection (view one-selection-mixin)) (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection)))) (defmethod selection ((view one-selection-mixin)) (let ((range (dcc (#/selectedRange (cocoa-ref view))))) (if (= (ns:ns-range-location range) #$NSNotFound) nil (range (ns:ns-range-location range) (ns:ns-range-length range))))) (defclass content-view-mixin () (content-view)) (defmethod initialize-view :after ((view content-view-mixin)) (setf (slot-value view 'content-view) (make-instance 'view :cocoa-ref (dcc (#/contentView (cocoa-ref view)))))) (defmethod content-view ((view content-view-mixin)) (assert (eql (cocoa-ref (slot-value view 'content-view)) (dcc (#/contentView (cocoa-ref view))))) (slot-value view 'content-view)) (defmethod (setf content-view) (new-content-view (view content-view-mixin)) (setf (slot-value view 'content-view) new-content-view) (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; the actual views (when adding a new class, ;;; consider *view-class-to-ns-class-map*): (defclass view (easy-cocoa-object) ((position :initarg :position :reader view-position) (size :initarg :size :reader view-size) (frame-inited-p :initform nil) (parent :reader view-container :initform nil) (subviews :reader view-subviews :initarg :subviews :initform nil) (nickname :accessor view-nick-name :initarg :view-nick-name :initform nil))) (defclass window (content-view-mixin view-text-via-title-mixin view) ((text :initarg :title :initform "" :reader window-title) (zoomable-p :initarg :zoomable-p :initform t :reader window-zoomable-p) (minimizable-p :initarg :minimizable-p :initform t :reader window-minimizable-p) (resizable-p :initarg :resizable-p :initform t :reader window-resizable-p) (closable-p :initarg :closable-p :initform t :reader window-closable-p))) (defclass static-text-view (view view-text-via-stringvalue-mixin) ()) (defclass text-input-view (view editable-mixin view-text-via-stringvalue-mixin ;; XXX: requires NSTextView, but this is an ;; NSTextField: #+not-yet one-selection-mixin) ((input-locked-p :initform nil :initarg :input-locked-p :reader text-input-locked-p))) (defclass password-input-view (text-input-view) ()) (defclass push-button-view (view view-text-via-title-mixin) ((default-button-p :initarg :default-button-p :initform nil :reader default-button-p))) (defclass form-view (view) ((autosize-cells-p :initarg :autosize-cells-p :initform nil) (interline-spacing :initarg :interline-spacing :initform 9) ;; cell width )) (defclass form-cell-view (view editable-mixin view-text-via-stringvalue-mixin) ()) (defclass box-view (content-view-mixin view-text-via-title-mixin view) ()) (defclass drawing-view (view) ( ;; TODO: make this a mixin (accept-key-events-p :initform nil :initarg :accept-key-events-p :accessor accept-key-events-p))) (defclass slider-view (view numeric-value-mixin) ((max-value :initarg :max-value) (min-value :initarg :min-value) (tick-mark-count :initarg :tick-mark-count) (tick-mark-values :initarg :tick-mark-values) (discrete-tick-marks-p :initarg :discrete-tick-marks-p))) (defparameter *view-class-to-ns-class-map* '((static-text-view . ns:ns-text-field) (password-input-view . ns:ns-secure-text-field) (text-input-view . ns:ns-text-field) (push-button-view . ns:ns-button) (check-box-view . ns:ns-button) (radio-button-view . ns:ns-button) (form-view . ns:ns-form) (form-cell-view . ns:ns-form-cell) (box-view . ns:ns-box) (drawing-view . cocoa-drawing-view) (slider-view . ns:ns-slider))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; view initialization: (defmethod shared-initialize :around ((view view) new-slots &rest initargs) (declare (ignore new-slots initargs)) (call-next-method) (running-on-main-thread () (initialize-view view))) (defmethod initialize-view ((view view)) "Initializes the view via the class-to-ns-class map." (when (slot-boundp view 'ref) (return-from initialize-view nil)) (let ((ns-view-class (cdr (assoc (class-name (class-of view)) *view-class-to-ns-class-map* :test #'subtypep)))) (when ns-view-class (setf (cocoa-ref view) (cond ((and (slot-boundp view 'position) (slot-boundp view 'size)) (setf (slot-value view 'frame-inited-p) t) (make-instance ns-view-class :with-frame (with-slots (position size) view (ns-rect-from-points position size)))) (t (make-instance ns-view-class))))))) (defmethod initialize-view ((win window)) "Initialize size, title, flags." (with-slots (position size) win (let ((content-rect (multiple-value-call #'ns:make-ns-rect (if (slot-boundp win 'position) (values (point-x position) (point-y position)) (values *window-position-default-x* *window-position-default-y*)) (if (slot-boundp win 'size) (values (point-x size) (point-y size)) (values *window-size-default-x* *window-size-default-y*)))) (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win)) (flag-mask :resizable-p (window-resizable-p win)) (flag-mask :minimizable-p (window-minimizable-p win)) (flag-mask :closable-p (window-closable-p win)) #$NSTitledWindowMask))) (setf (cocoa-ref win) (make-instance 'ns:ns-window :with-content-rect content-rect :style-mask style-mask :backing #$NSBackingStoreBuffered ; TODO? :defer nil))))) (defmethod initialize-view :after ((view text-input-view)) (setf (editable-p view) (not (text-input-locked-p view)))) (defmethod initialize-view :after ((view static-text-view)) (dcc (#/setEditable: (cocoa-ref view) nil)) (dcc (#/setBordered: (cocoa-ref view) nil)) (dcc (#/setBezeled: (cocoa-ref view) nil)) (dcc (#/setDrawsBackground: (cocoa-ref view) nil))) (defmethod initialize-view :after ((view push-button-view)) (dcc (#/setBezelStyle: (cocoa-ref view) #$NSRoundedBezelStyle)) (let ((default-button-p (slot-value view 'default-button-p))) (typecase default-button-p (cons (dcc (#/setKeyEquivalent: (cocoa-ref view) (string (first default-button-p)))) (dcc (#/setKeyEquivalentModifierMask: (cocoa-ref view) (apply #'logior (mapcar #'key-mask (cdr default-button-p)))))) (string (dcc (#/setKeyEquivalent: (cocoa-ref view) default-button-p))) (null) (t (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return)))))))) (defmethod initialize-view :after ((view form-view)) (when (slot-boundp view 'interline-spacing) (dcc (#/setInterlineSpacing: (cocoa-ref view) (coerce (slot-value view 'interline-spacing) 'double-float))))) (defmethod initialize-view :after ((view slider-view)) (with-slots (discrete-tick-marks-p tick-mark-count tick-mark-values min-value max-value) view (cond ((and (slot-boundp view 'tick-mark-count) (slot-boundp view 'discrete-tick-marks-p) (slot-boundp view 'tick-mark-values) (/= (length tick-mark-values) tick-mark-count)) (error "Incompatible tick mark specification: ~A doesn't match ~ count of ~A" tick-mark-count tick-mark-values)) ((or (not (slot-boundp view 'max-value)) (not (slot-boundp view 'min-value))) (error "A slider view needs both :min-value and :max-value set."))) (dcc (#/setMinValue: (cocoa-ref view) (float min-value ns:+cgfloat-zero+))) (dcc (#/setMaxValue: (cocoa-ref view) (float max-value ns:+cgfloat-zero+))) (when (slot-boundp view 'tick-mark-count) (dcc (#/setNumberOfTickMarks: (cocoa-ref view) tick-mark-count)) (dcc (#/setAllowsTickMarkValuesOnly: (cocoa-ref view) (not (not discrete-tick-marks-p))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; view hierarchies: (defmethod add-1-subview :around ((view view) (cw-view content-view-mixin)) (add-1-subview view (content-view cw-view))) (defmethod add-1-subview :around ((view view) (super-view view)) "Correctly initialize view positions" (call-next-method) (with-slots (position size frame-inited-p) view (unless frame-inited-p (dcc (#/setFrameOrigin: (cocoa-ref view) (ns:make-ns-point (point-x position) (point-y position)))) (if (slot-boundp view 'size) (dcc (#/setFrameSize: (cocoa-ref view) (ns:make-ns-point (point-x size) (point-y size)))) (dcc (#/sizeToFit (cocoa-ref view))))) (dcc (#/setNeedsDisplay: (cocoa-ref view) t)) (dcc (#/setNeedsDisplay: (cocoa-ref super-view) t)))) (defmethod add-1-subview ((view view) (super-view view)) (setf (slot-value view 'parent) super-view) (push view (slot-value super-view 'subviews)) (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view)))) (defun add-subviews (superview subview &rest subviews) (add-1-subview subview superview) (dolist (subview subviews) (add-1-subview subview superview)) superview) (defmethod remove-1-subview ((view view) (cw-view content-view-mixin)) (remove-1-subview view (content-view cw-view))) (defmethod remove-1-subview ((view view) (super-view view)) (assert (eql (cocoa-ref super-view) (#/superview (cocoa-ref view)))) (assert (member view (view-subviews super-view))) (assert (eq super-view (slot-value view 'parent))) (maybe-invalidating-object (view) (setf (slot-value super-view 'subviews) (delete view (slot-value super-view 'subviews))) (setf (slot-value view 'parent) nil) (#/removeFromSuperview (cocoa-ref view)))) (defun remove-subviews (superview subview &rest subviews) (remove-1-subview subview superview) (dolist (subview subviews) (remove-1-subview subview superview)) superview) (defmethod window-show ((window window)) (dcc (#/makeKeyAndOrderFront: (cocoa-ref window) nil)) window) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Forms: (defmethod add-entry (entry (view form-view)) (make-instance 'form-cell-view :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) entry)))) (defun add-entries (view &rest entries) (prog1 (mapcar (lambda (entry) (add-entry entry view)) entries) (dcc (#/setAutosizesCells: (cocoa-ref view) (slot-value view 'autosize-cells-p))))) (defmethod cell-count ((view form-view)) (dcc (#/numberOfRows (cocoa-ref view)))) (defmethod nth-cell (index view) (assert (< index (cell-count view))) (let ((cocoa-cell (dcc (#/cellAtIndex: (cocoa-ref view) index)))) (when cocoa-cell (make-instance 'form-cell-view :cocoa-ref cocoa-cell)))) (defmethod (setf entry-text) (text view index) (setf (view-text (nth-cell index view)) text)) (defmethod entry-text (view index) (view-text (nth-cell index view))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Drawing: ;(defclass cocoa-drawing-view (ns:ns-view) ; ((easygui-view :initarg :eg-view :reader easygui-view-of)) ; (:metaclass ns:+ns-view)) (defmethod initialize-view :after ((view drawing-view)) (setf (slot-value (cocoa-ref view) 'easygui-view) view)) (objc:defmethod (#/drawRect: :void) ((self cocoa-drawing-view) (rect :ect)) (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect))) (objc:defmethod (#/acceptsFirstReponder: :boolean) ((view cocoa-drawing-view)) (accept-key-events-p (easygui-view-of view))) (defgeneric draw-view-rectangle (view rectangle) (:method ((view drawing-view) rectangle) (declare (ignore view rectangle)) nil)) (defmethod redisplay ((view drawing-view) &key rect) (setf rect (if rect (rectangle-nsrect rect) (#/bounds (cocoa-ref view)))) (#/setNeedsDisplayInRect: (cocoa-ref view) rect)) (define-useful-mouse-event-handling-routines cocoa-drawing-view) ; ----------------------- ; New stuff (defmethod view-named (name (view view)) (find name (view-subviews view) :key #'view-nick-name)) (defmethod view-named (name (container content-view-mixin)) (view-named name (content-view container))) (defmethod view-subviews ((w content-view-mixin)) (view-subviews (content-view w))) (defclass check-box-view (view view-text-via-title-mixin) ((checked :initarg :checked :initform nil))) (defmethod initialize-view :after ((self check-box-view)) (when (cocoa-ref self) (dcc (#/setButtonType: (cocoa-ref self) #$NSSwitchButton)) (when (slot-value self 'checked) (check-box-check self)))) (defmethod check-box-check ((self check-box-view) &optional perform) (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOnState) (if perform (dcc (#/performClick: (cocoa-ref self) nil)) (dcc (#/setState: (cocoa-ref self) #$NSOnState))) t)) (defmethod check-box-uncheck ((self check-box-view) &optional perform) (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOffState) (if perform (dcc (#/performClick: (cocoa-ref self) nil)) (dcc (#/setState: (cocoa-ref self) #$NSOffState))) t)) (defmethod check-box-checked-p ((self check-box-view)) (eql (dcc (#/state (cocoa-ref self))) #$NSOnState)) (defmethod (setf check-box-checked-p) (new (self check-box-view)) (if new (check-box-check self) (check-box-uncheck self))) (defclass radio-button-view (view view-text-via-title-mixin) ((selected :initarg :selected :reader radio-button-selected-p :initform nil) (cluster :initarg :cluster :initform '#:default-cluster))) (defmethod initialize-view :after ((self radio-button-view)) (when (cocoa-ref self) (dcc (#/setButtonType: (cocoa-ref self) #$NSRadioButton)) (when (slot-value self 'selected) (radio-button-select self)) (unless (dcc (#/action (cocoa-ref self))) ; Ensure that radio buttons always have some action: exploit the specialised ; (setf action) so they at least have the effect of deselecting others in their cluster. (setf (action self) (lambda () nil))))) (defun deselect-radio-button-cohorts (radio-button-view) (when (view-container radio-button-view) (dolist (sibling (view-subviews (view-container radio-button-view))) (when (and (not (eq sibling radio-button-view)) (typep sibling 'radio-button-view) (eq (slot-value radio-button-view 'cluster) (slot-value sibling 'cluster)) (eql (dcc (#/state (cocoa-ref sibling))) #$NSOnState)) (setf (slot-value sibling 'selected) nil) (dcc (#/setState: (cocoa-ref sibling) #$NSOffState)) (dcc (#/setNeedsDisplay (cocoa-ref sibling))))))) (defmethod radio-button-select ((self radio-button-view) &optional perform) (if perform (dcc (#/performClick: (cocoa-ref self) nil)) (progn (deselect-radio-button-cohorts self) (setf (slot-value self 'selected) t) (dcc (#/setState: (cocoa-ref self) #$NSOnState))))) (defmethod radio-button-deselect ((self radio-button-view)) (dcc (#/setState: (cocoa-ref self) #$NSOffState)) (prog1 (radio-button-selected-p self) (setf (slot-value self 'selected) nil))) (defmethod (setf action) (handler (view radio-button-view)) (call-next-method (lambda () (deselect-radio-button-cohorts view) (setf (slot-value view 'selected) t) (funcall handler)) view)) (export '(view-named view-subviews view-nick-name check-box-view check-box-check check-box-uncheck check-box-checked-p radio-button-view radio-button-selected-p radio-button-select radio-button-deselect) "EASYGUI") #| ; --------------- ; Testbed for the new control types (defclass view-hierarchy-demo-window (window) ((with :initarg :with :initform :radio)) (:default-initargs :size (point 480 270) :position (point 125 513) :resizable-p nil :minimizable-p t :title "View tree demo") (:documentation "Shows a window with a simple view hierarchy and a button action that manipulates this hierarchy.")) (defmethod initialize-view :after ((w view-hierarchy-demo-window)) (let ((left-box (make-instance 'box-view :position (point 17 51) :size (point 208 199) :title "Left" :view-nick-name :leftbox)) (right-box (make-instance 'box-view :position (point 255 51) :size (point 208 199) :title "Right" :view-nick-name :rightbox)) (left-button (make-instance 'radio-button-view :position (point 103 12) :text "Left side" :selected t :view-nick-name :leftbutton)) (right-button (make-instance 'radio-button-view :position (point 243 12) :text "Right side" :view-nick-name :rightbutton)) (checkbox (make-instance 'check-box-view :position (point 173 12) :text "Right side" :view-nick-name :checkbox)) (text (make-instance 'static-text-view :text "Oink!" :position (point 37 112))) (leftp t)) (setf (action left-button) (lambda () (retaining-objects (text) (cond ((not leftp) (remove-subviews right-box text) (add-subviews left-box text)))) (setf leftp t))) (setf (action right-button) (lambda () (retaining-objects (text) (cond (leftp (remove-subviews left-box text) (add-subviews right-box text)))) (setf leftp nil))) (setf (action checkbox) (lambda () (retaining-objects (text) (cond ((not leftp) (remove-subviews right-box text) (add-subviews left-box text)) (leftp (remove-subviews left-box text) (add-subviews right-box text)))) (setf leftp (not leftp)))) (add-subviews w left-box right-box) (case (slot-value w 'with) (:radio (add-subviews w left-button right-button)) (:check (add-subviews w checkbox)) (otherwise (format t "~&** The WITH slot must be either :RADIO or :CHECK~%"))) (add-subviews left-box text) (window-show w))) (defparameter *w nil) ;; (setf *debug-cocoa-calls* nil) (defun new (&optional (with :radio)) (setf *w (make-instance 'view-hierarchy-demo-window :with with))) ;; (new) ;; (new :check) |# ; Without something like T below, the listener disappears when buffer is first evaluated! t