;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*- ;;;----------------------------------------------------------------------------------+ ;;; | ;;; TEXAS INSTRUMENTS INCORPORATED | ;;; P.O. BOX 149149 | ;;; AUSTIN, TEXAS 78714 | ;;; | ;;; Copyright (C) 1989, 1990 Texas Instruments Incorporated. | ;;; | ;;; Permission is granted to any individual or institution to use, copy, modify, and | ;;; distribute this software, provided that this complete copyright and permission | ;;; notice is maintained, intact, in all copies and supporting documentation. | ;;; | ;;; Texas Instruments Incorporated provides this software "as is" without express or | ;;; implied warranty. | ;;; | ;;;----------------------------------------------------------------------------------+ (in-package "CLIO-OPEN") (export '(make-property-sheet property-sheet property-sheet-area dialog-accept dialog-cancel )) ;;;----------------------------------------------------------------------------+ ;;; | ;;; property-sheet | ;;; | ;;;----------------------------------------------------------------------------+ (defcontact property-sheet (core core-wm-shell transient-shell) ((previous-pointer-x :type (or null int16) :initform nil) (previous-pointer-y :type (or null int16) :initform nil) (control-default :type (or null contact) :initform nil)) (:resources (border-width :initform 1) (property-area :type (or function list) :initform nil) (default-control :type (member :accept :cancel) :initform :accept) ) (:documentation "A dialog which presents a set of related values for user editing.")) ;;;----------------------------------------------------------------------------+ ;;; | ;;; Accessors | ;;; | ;;;----------------------------------------------------------------------------+ (defmethod (setf contact-foreground) :after (new-value (self property-sheet)) (setf (contact-foreground (car (composite-children self))) new-value)) (defmethod property-sheet-area ((self property-sheet)) "Returns the property area of the PROPERTY-SHEET." (with-slots (children) (first (slot-value self 'children)) (find :area children :key #'contact-name))) (defmethod dialog-default-control ((property-sheet property-sheet)) (with-slots (control-default) property-sheet (contact-name control-default))) (defmethod (setf dialog-default-control) (new-value (property-sheet property-sheet)) (check-type new-value (member :accept :cancel) "one of :ACCEPT or :CANCEL") (with-slots (control-default) property-sheet (when control-default (setf (choice-item-highlight-default-p control-default) nil)) (setf control-default (find new-value (composite-children (first (composite-children property-sheet))) :key 'contact-name)) (setf (choice-item-highlight-default-p control-default) t) new-value)) (defmethod dialog-accept ((self property-sheet)) "Invokes :accept callback function and pops down the dialog" (if (callback-p self :accept) (apply-callback self :accept) (with-slots ((members children)) (property-sheet-area self) (dolist (member members) (apply-callback member :accept)))) (with-slots (pinned-p) self (unless pinned-p (setf (contact-state self) :withdrawn)))) (defmethod dialog-cancel ((self property-sheet)) "Invokes :cancel callback function and pops down the dialog." (with-slots (pinned-p) self (unless pinned-p (setf (contact-state self) :withdrawn))) (if (callback-p self :cancel) (apply-callback self :cancel) (with-slots ((members children)) (property-sheet-area self) (dolist (member members) (apply-callback member :cancel))))) (defmethod shell-mapped ((self property-sheet)) "Invokes :initialize callback function." (let ((footer (find :footer (composite-children (car (composite-children self))) :key 'contact-name))) (setf (display-text-source footer) " ")) (apply-callback self :map) (apply-callback-else (self :initialize) (with-slots ((members children)) (property-sheet-area self) (dolist (member members) (apply-callback member :initialize))))) (defmethod (setf contact-state) :after ((new-state (eql :mapped)) (self property-sheet)) ;; Pointer warping must occur after :map-notify received, in case root-relative ;; positions have been changed by window manager redirection. (with-slots (previous-pointer-x previous-pointer-y control-default display) self (cond ((realized-p self) ;; Store position for pointer unwarping later.... (multiple-value-setq (previous-pointer-x previous-pointer-y) (pointer-position self)) (warp-pointer control-default (pixel-round (contact-width control-default) 2) (- (contact-height control-default) 2))) (t ;; Ensure realized. (update-state display)) ))) (defmethod shell-unmapped :before ((self property-sheet)) (with-slots (previous-pointer-x previous-pointer-y) self ;; Unwarp pointer to original position, if necessary. (when previous-pointer-x (warp-pointer self previous-pointer-x previous-pointer-y)))) (defmethod dialog-warn ((self property-sheet) message field) "Display a warning for verification error." (assert (or (null field) (typep field 'contact)) nil "~s is not a contact." field) (let* ((footer (find :footer (composite-children (car (composite-children self))) :key #'contact-name)) (actual-message (or message "These values cannot be accepted.")) (tw (text-width (display-text-font footer) actual-message))) (if (>= tw (contact-width footer)) (confirm-p :message actual-message :near (or field (slot-value self 'control-default)) :parent self :accept-only :on ) (setf (display-text-source footer) actual-message)))) ;;;----------------------------------------------------------------------------+ ;;; | ;;; Initialization | ;;; | ;;;----------------------------------------------------------------------------+ (defun make-property-sheet (&rest initargs &key default-control &allow-other-keys) "Creates and returns a property-sheet instance." (declare (values property-sheet)) (when default-control (assert (symbolp default-control) nil "~s is not a symbol name.")) (apply #'make-contact 'property-sheet initargs)) (defmethod initialize-instance :after ((self property-sheet) &key property-area (default-control :accept) &allow-other-keys) (multiple-value-bind (area-constructor area-initargs) (etypecase property-area (null (let ((space (ab-height (getf *button-dimensions-by-scale* (contact-scale self))))) (values 'make-table `( :columns 2 :column-alignment :right :same-width-in-column :on :same-height-in-row :on :horizontal-space ,space :vertical-space ,space)))) (function property-area) (list (values (first property-area) (rest property-area)))) (with-slots (width height) self ;; Create the manager (let ((manager (make-contact 'property-sheet-manager :name :manager :parent self :x 0 :y 0 :width width :height height :border-width 0))) ;; Create the property area (assert (typep (apply area-constructor :name :area :parent manager :x 0 :y 0 :width width :height height :border-width 0 area-initargs) 'composite) nil "Property area is not a composite." ) (labels ((verify (property-sheet) (multiple-value-bind (verified-p message field) (or (not (callback-p property-sheet :verify)) (apply-callback property-sheet :verify)) (if verified-p (dialog-accept property-sheet) (dialog-warn property-sheet message field)))) (menu-accept (property-sheet) (verify property-sheet) (throw :menu nil)) (menu-cancel (property-sheet) (dialog-cancel property-sheet) (throw :menu nil))) ;; Create buttons for command area (add-callback (make-action-button :parent manager :name :accept :label "Apply") :release #'verify self) (add-callback (make-action-button :parent manager :name :cancel :label "Reset") :release #'dialog-cancel self) ;; Create footer area - display-text-field (make-display-text-field :parent manager :name :footer :alignment :left :display-gravity :west) ;; Create settings menu (let ((choice (menu-choice (make-menu :parent self :title "Settings")))) (add-callback (make-action-item :parent choice :name :accept :label "Apply") :release #'menu-accept self) (add-callback (make-action-item :parent choice :name :cancel :label "Reset") :release #'menu-cancel self)) ;; Set default control (setf (dialog-default-control self) default-control)))))) ;;;----------------------------------------------------------------------------+ ;;; | ;;; property-sheet-manager | ;;; | ;;;----------------------------------------------------------------------------+ (defcontact property-sheet-manager (core composite) ((compress-exposures :initform :on)) (:resources (event-mask :initform #.(make-event-mask :exposure))) (:documentation "The geometry manager for property sheet component areas.")) (defmethod change-layout ((self property-sheet-manager) &optional newly-managed) (declare (ignore newly-managed)) (with-slots (width height parent) self ;; Ensure big enough for property area if possible. (multiple-value-bind (pw ph) (preferred-size self) ;; Let window mgr know new preferred minimum height. (with-wm-properties (parent) (setf (wm-min-width parent) pw (wm-min-height parent) ph)) (let ((rw (when (< width pw) pw)) (rh (when (< height ph) ph))) (when (or ;; Don't need to request larger size? (not (or rw rh)) ;; Request for larger size rejected? (multiple-value-bind (approved-p nx ny nw nh) (change-geometry self :width rw :height rh :accept-p t) (declare (ignore nx ny)) (and (not approved-p) (eql nw width) (eql nh height)))) ;; Yes, adjust child layout for current size. (adjust-layout self)))))) (defmethod adjust-layout ((psm property-sheet-manager)) (with-slots (width height children) psm (let* ((space (point-pixels (contact-screen psm) (getf *dialog-point-spacing* (contact-scale (contact-parent psm))))) (accept-button (find :accept children :key #'contact-name)) (abw (contact-border-width accept-button)) (awidth (+ abw abw (contact-width accept-button))) (aheight (+ abw abw (contact-height accept-button))) (cancel-button (find :cancel children :key #'contact-name)) (cbw (contact-border-width cancel-button)) (cwidth (+ cbw cbw (contact-width cancel-button))) (cheight (+ cbw cbw (contact-height cancel-button))) (property-area (find :area children :key #'contact-name)) (footer (find :footer children :key #'contact-name)) (footer-height (contact-height footer)) (button-y (- height (+ (max aheight cheight) space footer-height 1))) (button-x (pixel-round (- width (+ awidth cwidth space 1)) 2))) ;; Adjust footer geometry. (resize footer width footer-height (contact-border-width footer)) (move footer 0 (- height footer-height)) ;; Adjust button geometry. Make their top edges align. (move accept-button button-x button-y) (move cancel-button (+ button-x (+ awidth space)) button-y) ;; Adjust property-area geometry: preferred size if possible, but ;; no more than available space. (multiple-value-bind (pw ph) (preferred-size property-area :width 0 :height 0) (let ((paw (min (max 1 (- width space space)) pw)) (pah (min (max 1 (- height space space)) ph))) (resize property-area paw pah 0) ;;Center property-area within available space. (move property-area (max space (pixel-round (- width paw) 2)) (max space (pixel-round (- button-y pah) 2)))))))) (defmethod display ((manager property-sheet-manager) &optional x y width height &key) (declare (ignore x y height width)) (with-slots (width height children foreground) manager (let ((footer (find :footer children :key 'contact-name))) (using-gcontext (gcontext :drawable manager :background (contact-current-background-pixel manager) :foreground foreground :subwindow-mode :include-inferiors) (draw-rectangle manager gcontext 0 0 (max 1 (- width 1)) (max 1 (- height (contact-height footer) 1)) ) )))) (defmethod rescale :after ((contact property-sheet)) (when (realized-p contact) (refresh contact))) ;;; ;;; When the Property Area or one of the Buttons wants to change its geometry we must let it. ;;; A change in scale will change the sizes of our children. ;;; (defmethod manage-geometry ((self property-sheet-manager) child x y width height border-width &key) (let (success-p) (if (or (and width (> width (contact-width child))) (and height (> height (contact-height child))) ) (setf success-p #'(lambda (self) (multiple-value-bind (p-w p-h p-b-w) (preferred-size self) (cond ((and width (< (contact-width self) p-w)) (change-geometry self :width p-w :border-width p-b-w :accept-p t)) ((and height (< (contact-height self) p-h)) (change-geometry self :height p-h :border-width p-b-w :accept-p t)) (t (change-layout self)))))) ;; else... (setf success-p t)) (values success-p (or x (contact-x child)) (or y (contact-y child)) (or width (contact-width child)) (or height (contact-height child)) (or border-width (contact-border-width child))))) (defmethod preferred-size ((self property-sheet-manager) &key width height border-width) (declare (ignore width height border-width)) (with-slots (children) self (let* ((accumulated-width 0) (highest 0) (area (find :area children :key #'contact-name)) (FOOTER (FIND :FOOTER CHILDREN :KEY #'CONTACT-NAME)) (buttons (REMOVE FOOTER (remove area children))) (screen (contact-screen self)) (scale (contact-scale (contact-parent self))) (pixel (getf *dialog-point-spacing* scale)) (hspace (point-pixels screen pixel :horizontal)) (vspace (point-pixels screen pixel :vertical))) ;;Find out how much space the buttons will need. ;;Remember: buttons are in a row, so we're interested in combined width ;; and the maximum height (multiple-value-bind (pwidth1 pheight1 pbw1) (preferred-size (first buttons)) (multiple-value-bind (pwidth2 pheight2 pbw2) (preferred-size (second buttons)) (setf accumulated-width (+ pwidth1 pbw1 pbw1 hspace pwidth2 pbw2 pbw2) highest (max (+ pheight1 pbw1 pbw1) (+ pheight2 pbw2 pbw2))))) ;;We can ignore the preferred border-width because property-sheet-manager ;;geometry management forces a zero-width border. (multiple-value-bind (pwidth pheight) (preferred-size area :width 0 :height 0) (MULTIPLE-VALUE-BIND (f-pwidth F-PHEIGHT) (PREFERRED-SIZE FOOTER) (declare (ignore f-pwidth)) (values (+ (max pwidth accumulated-width) hspace hspace 2) (+ pheight highest F-PHEIGHT vspace vspace vspace 2) ;; add two for rectangle 0)))))) ;; drawn around property-area (defmethod resize :after ((self property-sheet-manager) width height border-width) (declare (ignore width height border-width)) (adjust-layout self)) ;;;----------------------------------------------------------------------------+ ;;; | ;;; Actions | ;;; | ;;;----------------------------------------------------------------------------+ (defevent property-sheet-manager :enter-notify property-sheet-forget-warp) (defevent property-sheet (:button-press :button-3) property-sheet-display-menu) (defun property-sheet-forget-warp (property-sheet-manager) (with-slots (parent) (the property-sheet-manager property-sheet-manager) (with-slots (previous-pointer-x) (the property-sheet parent) (with-event (kind) ;; Entering from a child? The first time this happens the child must be ;; the default control. Open Look GUI thus dictates that pointer will not ;; warp to original position after exiting the property-sheet (when (eq kind :inferior) (setf previous-pointer-x nil)))))) (defun property-sheet-display-menu (property-sheet) (let ((menu (first (composite-shells property-sheet))) (display (contact-display property-sheet))) ;; Pop up settings menu (present-dialog menu :button :button-3 :state (with-event (state) state)) (catch :menu (loop (process-next-event display))) ;; Pop down settings menu (setf (contact-state menu) :withdrawn)))