;;; -*- 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-command command command-area command-control-area command-default-accept command-default-cancel dialog-default-control )) (defconstant *default-accept-label* "OK") (defconstant *default-cancel-label* "Cancel") ;;;----------------------------------------------------------------------------+ ;;; | ;;; command | ;;; | ;;;----------------------------------------------------------------------------+ (defcontact command (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) (command-area :type (or function list) :initform nil) (control-area :type (or function list) :initform nil) (default-accept :type (or (member :on :off) string) :initform :on) (default-cancel :type (or (member :on :off) string) :initform :on) (default-control :type symbol :initform nil)) (:documentation "A dialog which presents a set of related values and a set of commands.")) (defmethod (setf contact-foreground) :after (new-value (self command)) (setf (contact-foreground (car (composite-children self))) new-value)) (defun make-command (&rest initargs &key &allow-other-keys) "Creates and returns a command instance." (declare (values command)) (apply #'make-contact 'command initargs)) (defmethod command-area ((self command)) "Returns the command area of the COMMAND." (with-slots (children) (first (slot-value self 'children)) (find :area children :key #'contact-name))) (defmethod command-control-area ((self command)) "Returns the command control of the COMMAND." (with-slots (children) (first (slot-value self 'children)) (find :control children :key #'contact-name))) (defmethod dialog-accept ((self command)) "Invokes :accept callback function and pops down the dialogue" (if (callback-p self :accept) (apply-callback self :accept) (with-slots ((members children)) (command-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 command)) "Invokes :cancel callback function and pops down the dialogue." (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)) (command-area self) (dolist (member members) (apply-callback member :cancel))))) (defmethod shell-mapped ((self command)) "Invokes :initialize callback function." (with-slots (children) self (setf (display-text-source (find :footer (composite-children (first children)) :key 'contact-name)) "") (apply-callback self :map) (apply-callback-else (self :initialize) (with-slots ((members children)) (command-area self) (dolist (member members) (apply-callback member :initialize)))))) (defmethod (setf contact-state) :after ((new-state (eql :mapped)) (self command)) ;; 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 display control-default) self (let ((control-def (or control-default (first (composite-children (command-control-area self)))))) ;; Ensure realized. (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-def (pixel-round (contact-width control-def) 2) (- (contact-height control-def) 2))) ;; Ensure realized. (t (update-state display))) ))) (defmethod shell-unmapped :before ((self command)) (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 command) 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)))) (flet ((find-default-accept (command) (find :accept (composite-children (command-control-area command)) :key #'contact-name :test #'eq)) (find-default-cancel (command) (find :cancel (composite-children (command-control-area command)) :key #'contact-name :test #'eq)) (command-verify (command) (multiple-value-bind (verified-p message field) (or (not (callback-p command :verify)) (apply-callback command :verify)) (if verified-p (dialog-accept command) (dialog-warn command message field))))) (defmethod command-default-accept ((self command)) (let ((control (find-default-accept self))) (if (and control (eq (contact-state control) :mapped)) :on :off))) (defmethod command-default-cancel ((self command)) (let ((control (find-default-cancel self))) (if (and control (eq (contact-state control) :mapped)) :on :off))) (defmethod (setf command-default-accept) (new-value (self command)) (check-type new-value (or (member :on :off) string) "one of :ON, :OFF, or a string.") (let ((control (find-default-accept self))) (case new-value (:on (if control (setf (contact-state control) :mapped) (add-callback (make-action-button :parent (command-control-area self) :name :accept :label *default-accept-label*) :release #'command-verify self))) (:off (when control (setf (contact-state control) :withdrawn))) (otherwise (cond (control (setf (button-label control) new-value) (setf (contact-state control) :mapped)) (t (add-callback (make-action-button :parent (command-control-area self) :name :accept :label new-value) :release #'command-verify self)))))) new-value) (defmethod (setf command-default-cancel) (new-value (self command)) (check-type new-value (or (member :on :off) string) "one of :ON, :OFF, or a string.") (let ((control (find-default-cancel self))) (case new-value (:on (if control (setf (contact-state control) :mapped) (add-callback (make-action-button :parent (command-control-area self) :name :cancel :label *default-cancel-label*) :release #'dialog-cancel self))) (:off (when control (setf (contact-state control) :withdrawn))) (otherwise (cond (control (setf (button-label control) new-value) (setf (contact-state control) :mapped)) (t (add-callback (make-action-button :parent (command-control-area self) :name :cancel :label new-value) :release #'dialog-cancel self)))))) new-value) (defmethod dialog-default-control ((self command)) (with-slots (control-default) self (let ((default (or control-default (first (composite-children (command-control-area self)))))) (when default (contact-name default))))) (defmethod (setf dialog-default-control) (new-value (command command)) (check-type new-value symbol) (with-slots (control-default) command (when control-default (setf (choice-item-highlight-default-p control-default) nil)) (or (and (setf control-default (find-if #'(lambda (c) (and (mapped-p c) (eq new-value (contact-name c)))) (composite-children (command-control-area command)))) (setf (choice-item-highlight-default-p control-default) t)) (setf control-default new-value)) new-value))) (defmethod initialize-instance :after ((self command) &key command-area control-area default-accept default-cancel default-control &allow-other-keys) (multiple-value-bind (command-constructor command-area-initargs) (etypecase command-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 command-area) (list (values (first command-area) (rest command-area)))) (multiple-value-bind (control-constructor control-area-initargs) (etypecase control-area (null (let ((space (point-pixels (contact-screen self) (getf *dialog-point-spacing* (contact-scale self))))) (values 'make-table `( :columns :maximum :column-alignment :center :same-height-in-row :on :horizontal-space ,space :vertical-space ,space)))) (function control-area) (list (values (first control-area) (rest control-area)))) (with-slots (width height) self ;; Create the sheet (let ((sheet (make-contact 'command-sheet :name :sheet :parent self :x 0 :y 0 :width width :height height :border-width 0))) ;; Create the command area (assert (typep (apply command-constructor :name :area :parent sheet :x 0 :y 0 :width width :height height :border-width 0 command-area-initargs) 'composite) nil "Command area is not a composite.") ;; Create the control area (assert (typep (apply control-constructor :name :control :parent sheet :x 0 :y 0 :width width :height height :border-width 0 control-area-initargs) 'composite) nil "Control area is not a composite.") (add-event (command-control-area self) :enter-notify #'(lambda (controls) (with-slots (parent) (the contact (contact-parent controls)) (with-slots (previous-pointer-x) (the command 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 command (when (eq kind :inferior) (setf previous-pointer-x nil))))))) ;; Create footer area - display-text-field (make-display-text-field :parent sheet :name :footer :source " " :alignment :left :display-gravity :west) ;; Create default controls (setf (command-default-accept self) default-accept) (setf (command-default-cancel self) default-cancel) (when default-control (setf (dialog-default-control self) default-control) )))))) ;;;----------------------------------------------------------------------------+ ;;; | ;;;; command-sheet | ;;; | ;;;----------------------------------------------------------------------------+ (defcontact command-sheet (core composite) ((compress-exposures :initform :on)) (:resources (event-mask :initform #.(make-event-mask :exposure))) (:documentation "The geometry manager for command and control areas.")) (defmethod change-layout ((self command-sheet) &optional newly-managed) (declare (ignore newly-managed)) (with-slots (width height parent) self ;; Initialize default control instance, if necessary. (with-slots (control-default) parent (let* ((controls (composite-children (command-control-area parent))) (instance (cond ((null control-default) (first controls)) ((symbolp control-default) (find control-default controls :key #'contact-name))))) (when instance (setf (choice-item-highlight-default-p (setf control-default instance)) t)))) ;; Ensure big enough for command/control areas 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 ((self command-sheet)) (with-slots (width height children) self (let* ((space (point-pixels (contact-screen self) (getf *dialog-point-spacing* (contact-scale (contact-parent self))))) (control-area (find :control children :key #'contact-name)) (command-area (find :area children :key #'contact-name)) (footer (find :footer children :key #'contact-name)) (footer-height (contact-height footer))) ;; Adjust footer geometry. (resize footer width footer-height (contact-border-width footer)) (move footer 0 (- height footer-height)) ;; Adjust control area geometry: preferred size if possible, but ;; no more than available width and no more than half available height. (multiple-value-bind (pw ph) (preferred-size control-area :width 0 :height 0) (let* ((caw (min (- width space space) pw)) (avh (- height footer-height 1)) (cah (min (pixel-round avh 2) ph)) (cay (- avh cah space))) (resize control-area caw cah 0) (move control-area (max space (pixel-round (- width caw) 2)) cay) ;; Adjust command area geometry: preferred size if possible, but ;; no more than available space. (multiple-value-bind (pw ph) (preferred-size command-area :width 0 :height 0) (let ((caw (min (- width space space) pw)) (cah (min (- cay space space) ph))) (resize command-area caw cah 0) ;;Center command-area within available space. (move command-area (max space (pixel-round (- width caw) 2)) (max space (pixel-round (- cay cah) 2)))))))))) (defmethod display ((manager command-sheet) &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 (1- width)) (max 1 (- height (contact-height footer) 1)) ) )))) (defmethod manage-geometry ((command-sheet command-sheet) 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 (command-sheet) (multiple-value-bind (p-w p-h p-b-w) (preferred-size command-sheet) (change-geometry command-sheet :width p-w :height p-h :border-width p-b-w :accept-p t)))) ;; 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 command-sheet) &key width height border-width) (declare (ignore width height border-width)) (with-slots (children) self (let ((space (point-pixels (contact-screen self) (getf *dialog-point-spacing* (contact-scale (contact-parent self))))) (area (find :area children :key 'contact-name)) (control (find :control children :key 'contact-name)) (footer (find :footer children :key 'contact-name))) (multiple-value-bind (area-width area-height) (preferred-size area) (multiple-value-bind (control-width control-height) (preferred-size control) (multiple-value-bind (footer-width footer-height) (preferred-size footer) (declare (ignore footer-width)) (values (+ space (max area-width control-width) space) (+ 1 space area-height space control-height space footer-height 1) 0))))))) (defmethod resize :after ((self command-sheet) width height border-width) (declare (ignore width height border-width)) (adjust-layout self))