From e9bcb2192aea572c55d2f62f4bb5dac669095412 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Wed, 6 May 1992 15:38:00 +0000 Subject: [PATCH] fixes --- Makefile | 23 +- clim/accept-values.lisp | 38 +++- clim/db-stream.lisp | 164 +++++++++++--- clim/frames.lisp | 47 ++-- clim/gadget-output.lisp | 77 ++++--- clim/menus.lisp | 23 +- clim/recording-protocol.lisp | 11 +- silica/db-box.lisp | 87 +++++--- silica/db-layout.lisp | 200 ++++++++++++++---- silica/db-scroll.lisp | 5 +- silica/framem.lisp | 18 +- silica/gadgets.lisp | 38 +++- silica/layout.lisp | 43 ++-- silica/port.lisp | 5 +- test/test.lisp | 195 +++++++++++++++-- tk-silica/xm-frames.lisp | 22 +- tk-silica/xm-gadgets.lisp | 400 +++++++++++++++++++++-------------- tk-silica/xm-menus.lisp | 60 +++--- tk-silica/xt-gadgets.lisp | 16 +- tk-silica/xt-silica.lisp | 22 +- tk/callbacks.lisp | 17 +- tk/resources.lisp | 4 +- tk/xm-defs.lisp | 16 +- tk/xm-funs.lisp | 8 +- utils/packages.lisp | 14 +- 25 files changed, 1140 insertions(+), 413 deletions(-) diff --git a/Makefile b/Makefile index 3e1978ed..b4661cbb 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.24 92/04/28 09:26:11 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.25 92/04/30 09:09:48 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -6,6 +6,17 @@ CL = /vapor/usr/tech/cer/cl/src/dcl DUMP-CL = $(CL) CLOPTS = -qq +# Training +TRAIN_LISP= (load \"/net/vapor/usr/tech/cer/stuff/misc/test-clim.lisp\") \ + (clim-user::train-clim-2) \ + (exit 0) + +TRAIN_TEXT = \ + $(ECHO) "\ + $(TRAIN_LISP) \ +" | $(CLIM) $(CLOPTS) -batch \ + ; echo CLIM trained!!!! + # Info LOAD_SOURCE_FILE_INFO=t RECORD_SOURCE_FILE_INFO=t @@ -258,6 +269,9 @@ OPENLOOK-OBJS = $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS) default: all-xm +train-clim-xm: + (make all-xm train ; make clim-xm) |& mail cer + all-xm: compile-xm cat-xm clim-xm all-ol: compile-ol cat-ol clim-ol @@ -355,11 +369,8 @@ clim-small: FORCE # Training train : FORCE - $(ECHO) "\ - (load \"/net/vapor/usr/tech/cer/stuff/misc/test-clim.lisp\") \ - (clim-user::train-clim-2) \ - (exit 0) " | $(CLIM) $(CLOPTS) -batch - echo CLIM trained!!!! + $(TRAIN_TEXT) + # Misc diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 654d1be2..5b5c6ef5 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept-values.lisp,v 1.17 92/04/28 09:25:37 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.18 92/04/30 09:09:26 cer Exp Locker: cer $ (in-package :clim-internals) @@ -267,7 +267,8 @@ #+Silica (defun invoke-accepting-values (stream continuation - &key frame-class own-window exit-boxes + &key frame-class own-window + exit-boxes (resize-frame nil) (initially-select-query-identifier nil) (resynchronize-every-pass nil) (check-overlapping t) label x-position y-position width height) @@ -292,7 +293,8 @@ :initially-select-query-identifier initially-select-query-identifier :resynchronize-every-pass - resynchronize-every-pass + resynchronize-every-pass + :resize-frame resize-frame :check-overlapping check-overlapping))) ;; What do we do about sizing????? @@ -340,7 +342,7 @@ avv avv-record) (letf-globally (((stream-default-view stream) (port-dialog-view (port stream)))) - (flet ((run-continuation (stream avv-record) + (labels ((run-continuation (stream avv-record) (setf (slot-value stream 'avv-record) avv-record) (setf (slot-value stream 'avv-frame) frame) (with-output-recording-options (stream :draw nil :record t) @@ -357,6 +359,8 @@ (com-edit-avv-choice initial-query) (redisplay avv stream :check-overlapping check-overlapping)) (loop + (when (frame-resizable frame) + (size-panes-appropriately)) (let ((command (let ((command-stream (slot-value stream 'stream))) ;; While we're reading commands, restore the view @@ -380,7 +384,24 @@ (setf (slot-value avv-record 'resynchronize) nil) (when exit-button-record (redisplay exit-button-record exit-button-stream)) - (redisplay avv stream :check-overlapping check-overlapping))))) + (redisplay avv stream :check-overlapping + check-overlapping)))) + (size-panes-appropriately () + (changing-space-requirements () + ;; We really want to specify the min/max sizes of + ;; the exit-button pane also + (size-menu-appropriately + exit-button-stream + :size-fn + #'(lambda (pane w h) + (change-space-requirement pane + :width w :min-width w :max-width w + :height h :min-height h :max-height h))) + (size-menu-appropriately own-window + :width own-window-width + :height own-window-height + :right-margin own-window-right-margin + :bottom-margin own-window-bottom-margin)))) (declare (dynamic-extent #'run-continuation #'run-avv)) (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog") (setq avv @@ -401,12 +422,7 @@ (stream-default-view stream))))))) (unwind-protect (cond (own-window - (size-menu-appropriately exit-button-stream) - (size-menu-appropriately own-window - :width own-window-width - :height own-window-height - :right-margin own-window-right-margin - :bottom-margin own-window-bottom-margin) + (size-panes-appropriately) (multiple-value-bind (x y) #-Silica (stream-pointer-position-in-window-coordinates diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 0447e8b4..893146a2 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1990 by Xerox Corporations. All rights reserved. ;;; -;; $fiHeader: db-stream.lisp,v 1.13 92/04/21 16:12:58 cer Exp Locker: cer $ +;; $fiHeader: db-stream.lisp,v 1.14 92/04/30 09:09:28 cer Exp Locker: cer $ (in-package :clim-internals) @@ -116,32 +116,133 @@ ((pane clim-stream-pane) &key &allow-other-keys) (setf (sheet-transformation pane) +identity-transformation+)) +;;-- Althought the unit options are mostly applicable here I guess +;;-- other classes might want to use it also +;;-- Perhaps we add a compose-space method on pane which does this. +;;-- Perhaps the class hierarchy needs a big sort out + +(defmacro with-space-requirement ((sr &rest vars) &body body) + ;; A handy macro that makes it slightly easy to manipulate space requirements + (unless vars + (setq vars '(sr-width sr-min-width sr-max-width sr-height sr-min-height sr-max-height))) + `(multiple-value-bind + ,vars + (space-requirement-components ,sr) + (macrolet ((do-with-space-req-components (operator var vars &body body) + `(,operator + ,@(mapcar #'(lambda (a-var) + `(symbol-macrolet ((,var ,a-var)) + ,@body)) + vars))) + (make-sr () + `,'(make-space-requirement + ,@(mapcan #'list '(:width :min-width :max-width + :height :min-height :max-height) + vars)))) + ,@body))) + (defmethod compose-space ((pane clim-stream-pane) &key width height) (let ((sr (call-next-method))) - (let ((sr-components - (multiple-value-list (space-requirement-components sr)))) - (when (member :compute sr-components) - (multiple-value-bind (width height) - (let ((record - (with-output-to-output-record (pane) - (invoke-pane-redisplay-function - (pane-frame pane) pane - ;;--- Are all pane display functions prepared to - ;;--- ignore these arguments? I think not... - :max-width width - :max-height height)))) - (bounding-rectangle-size record)) - ;;--- Yabba dabba doo! - (setq sr-components (nsubstitute width :compute sr-components :end 3)) - (setq sr-components (nsubstitute height :compute sr-components :start 3))) - (setq sr (make-space-requirement - :width (pop sr-components) - :min-width (pop sr-components) - :max-width (pop sr-components) - :height (pop sr-components) - :min-height (pop sr-components) - :max-height (pop sr-components))))) - sr)) + (labels ((process-compute-space-requirements () + (with-space-requirement (sr) + (when (do-with-space-req-components + or sr-component + (sr-width sr-min-width + sr-max-width sr-height + sr-min-height sr-max-height) + (eq sr-component :compute)) + (multiple-value-bind (width height) + (let ((record + (with-output-to-output-record (pane) + (invoke-pane-redisplay-function + (pane-frame pane) pane + ;;--- Are all pane display functions prepared to + ;;--- ignore these arguments? I think not... + :max-width width + :max-height height)))) + (bounding-rectangle-size record)) + (do-with-space-req-components + progn sr-component (sr-width sr-min-width sr-max-width) + (when (eq sr-component :compute) (setq sr-component width))) + (do-with-space-req-components + progn sr-component (sr-height sr-min-height sr-max-height) + (when (eq sr-component :compute) (setq sr-component height)))) + (setq sr (make-sr))))) + (process-unit-space-requirements () + (with-space-requirement (sr) + (let ((changed nil)) + (do-with-space-req-components + progn sr-component + (sr-width sr-min-width + sr-max-width sr-height + sr-min-height sr-max-height) + (when (unit-space-requirement-p sr-component) + (setq sr-component + (process-unit-space-requirement pane sr-component) + changed t))) + (when changed + (setq sr (make-sr)))))) + (process-relative-space-requirements () + (with-space-requirement (sr) + (unless (and (numberp sr-width) + (numberp sr-height) + (do-with-space-req-components + and sr-component + ( sr-min-width + sr-max-width + sr-min-height + sr-max-height) + (or (numberp sr-component) + (relative-space-requirement-p + sr-component)))) + (error "Illegal space requirement ~S" sr)) + (let ((changed nil)) + (when (relative-space-requirement-p sr-min-width) + (setq sr-min-width (- sr-width + (process-unit-space-requirement pane (car sr-min-width))) + changed t)) + (when (relative-space-requirement-p sr-max-width) + (setq sr-max-width (+ sr-width + (process-unit-space-requirement pane (car sr-max-width))) + changed t)) + (when (relative-space-requirement-p sr-min-height) + (setq sr-min-height (- sr-height + (process-unit-space-requirement pane (car sr-min-height))) + changed t)) + (when (relative-space-requirement-p sr-max-height) + (setq sr-max-height (+ sr-height + (process-unit-space-requirement pane (car sr-max-height))) + changed t)) + (when changed + (setq sr (make-sr))))))) + (process-compute-space-requirements) + (process-unit-space-requirements) + (process-relative-space-requirements) + sr))) + +(defun relative-space-requirement-p (sr) + (and (consp sr) + (= (length sr) 2) + (or (numberp (second sr)) + (unit-space-requirement-p (second sr))))) + + +(defun unit-space-requirement-p (sr) + (and (consp sr) + (= (length sr) 2) + (member (second sr) '(:line :character :mm :point :pixel)))) + +(defun process-unit-space-requirement (pane sr) + (destructuring-bind + (number unit) sr + (let ((graft (graft pane))) + (ecase unit + (:pixel number) + (:mm (* number (/ (silica::graft-pixel-width graft) (silica::graft-mm-width graft)))) + (:point (* number (silica::graft-pixels-per-point graft))) + (:character (* number (stream-string-width pane "M"))) + (:line (+ (* number (stream-line-height pane)) + (* (1- number) (stream-vertical-spacing pane)))))))) #+ignore (defmethod note-sheet-grafted :after ((pane clim-stream-pane)) @@ -195,10 +296,13 @@ (multiple-value-bind (history-width history-height) (if (stream-current-output-record pane) (bounding-rectangle-size (stream-current-output-record pane)) - (values width height)) + (values width height)) ;; Don't ever shrink down smaller than our contents. - (apply #'call-next-method pane :width (max width history-width) - :height (max height history-height) keys))) + (if (and (numberp width) + (numberp height)) + (apply #'call-next-method pane :width (max width history-width) + :height (max height history-height) keys) + (call-next-method)))) (defclass interactor-pane (clim-stream-pane) ()) @@ -310,9 +414,7 @@ (bounding-rectangle-size (pane-viewport-region stream))) (defmethod window-set-inside-size ((stream clim-stream-sheet) width height) - (change-space-requirement stream :width width :height height) - (clear-space-requirement-caching-in-ancestors stream) - (layout-frame (pane-frame stream))) + (change-space-requirement stream :width width :height height :resize-frame t)) (defun-inline window-parent (window) (sheet-parent window)) diff --git a/clim/frames.lisp b/clim/frames.lisp index 1e0f0572..24a17704 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.16 92/04/28 09:25:40 cer Exp Locker: cer $ +;; $fiHeader: frames.lisp,v 1.17 92/04/30 09:09:29 cer Exp Locker: cer $ (in-package :clim-internals) @@ -46,9 +46,12 @@ :reader frame-pointer-documentation-p) (pointer-documentation-pane :initform nil) (properties :initform nil :initarg :properties - :accessor frame-properties)) - (:default-initargs :pointer-documentation nil - :top-level 'default-frame-top-level)) + :accessor frame-properties) + (resizable :initarg :resize-frame + :reader frame-resizable)) + (:default-initargs :pointer-documentation nil + :resize-frame nil + :top-level 'default-frame-top-level)) (defmethod port ((frame standard-application-frame)) (port (frame-manager frame))) @@ -72,7 +75,7 @@ (destructuring-bind (&key x y width height) geometry (declare (ignore x y width height))) (destructuring-bind (&key name pixmap clipping-mask) icon - (declare (ignore name pixmap clip-mask))) + (declare (ignore name pixmap clipping-mask))) (let ((frame-manager (etypecase parent @@ -406,15 +409,26 @@ (unless (and width height) (let ((sr (compose-space panes))) (setq width (space-requirement-width sr) - height (space-requirement-height sr)))) + height (space-requirement-height sr)) + (multiple-value-bind + (gw gh) (bounding-rectangle-size (graft frame)) + (minf width (* 0.9 gw)) + (minf height (* 0.9 gh))))) ;;--- Don't bother with this if the size didn't change? - (resize-sheet* - (or (frame-top-level-sheet frame) panes) - width height - ;; We need to do this because if the WM has changed the sheet - ;; then this will not change its size but we need it to start - ;; the layout stuff - :force t)))) + (let ((top (or (frame-top-level-sheet frame) panes))) + (if (and (sheet-enabled-p top) + (not (frame-resizable frame))) + (multiple-value-call + #'allocate-space + top + (bounding-rectangle-size top)) + (resize-sheet* + top + width height + ;; We need to do this because if the WM has changed the sheet + ;; then this will not change its size but we need it to start + ;; the layout stuff + :force t)))))) (defmethod (setf frame-current-layout) (nv (frame standard-application-frame)) (unless (eq (frame-current-layout frame) nv) @@ -478,6 +492,8 @@ the same time " options)) (nstring-capitalize new-string))) (defmethod enable-frame ((frame standard-application-frame)) + (unless (frame-manager frame) + (error "Cannot enabled :disowned frame ~S" frame)) (destructuring-bind (&key width height &allow-other-keys) (frame-geometry frame) (ecase (frame-state frame) @@ -501,6 +517,11 @@ the same time " options)) (frame-top-level-sheet frame))))) (note-frame-enabled (frame-manager frame) frame)))))) +(defmethod destroy-frame ((frame standard-application-frame)) + (when (eq (frame-state frame) :enabled) + (disable-frame frame)) + (disown-frame (frame-manager frame) frame)) + (defmethod disable-frame ((frame standard-application-frame)) (ecase (frame-state frame) ((:disowned :disabled)) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 97b72aed..9a88de12 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -19,13 +19,15 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gadget-output.lisp,v 1.12 92/04/28 09:25:44 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.lisp,v 1.13 92/04/30 09:09:31 cer Exp Locker: cer $ (in-package :clim-internals) ;;; Implementation of output-records that are tied to gadgets. +;;--- Need to use the commented out version of this code. + (defclass gadget-output-record (output-record-mixin output-record-element-mixin output-record) ((gadget :initform nil @@ -45,9 +47,23 @@ (stream-output-history-position stream)) (decf x abs-x) (decf y abs-y) + + #-ignore + (multiple-value-bind (cx cy) + (stream-cursor-position stream) + (declare (type coordinate cx cy)) + (with-slots (start-x start-y) rec + (setq start-x (- cx abs-x) start-y (- cy abs-y)))) + (bounding-rectangle-set-edges rec - x y (+ x (space-requirement-width sr)) (+ y (space-requirement-height sr)))) + x y (+ x (space-requirement-width sr)) + (+ y (space-requirement-height sr))) + + #-ignore + (when (output-record-parent rec) + (tree-recompute-extent rec))) + (when (output-record-stream rec) (update-gadget-position rec) (setf (sheet-enabled-p gadget) t)))) @@ -66,23 +82,28 @@ (declare (ignore a b)) (update-gadget-position rec)) +(defmethod bounding-rectangle-set-size :after ((rec gadget-output-record) a b) + (declare (ignore a b)) + (update-gadget-position rec)) + +#+ignore (defmethod update-gadget-position (record) (let ((gadget (output-record-gadget record))) (when gadget - (with-bounding-rectangle* (left top right bottom) record - (let ((xoff 0) - (yoff 0)) - (do ((parent record (output-record-parent parent))) - ((null parent)) - (multiple-value-bind (x y) - (output-record-position parent) - (incf xoff x) - (incf yoff y))) - (move-and-resize-sheet* gadget - (+ left xoff) (+ top yoff) - (- right left) (- bottom top))))))) - -#+This-almost-works-with-the-other-definition + (with-bounding-rectangle* + (left top right bottom) record + (let ((xoff 0) + (yoff 0)) + (multiple-value-setq + (xoff yoff) + (convert-from-relative-to-absolute-coordinates + (sheet-parent gadget) + record)) + (move-and-resize-sheet* gadget + (+ left xoff) (+ top yoff) + (- right left) (- bottom top))))))) + +#-ignore (defmethod update-gadget-position (record) (let ((gadget (output-record-gadget record))) (when gadget @@ -119,6 +140,7 @@ (with-look-and-feel-realization (,fm ,f) ,@body)) ,@args)))) +#+ignore (defmethod invoke-with-output-as-gadget (stream continuation &key) ;;--- (PANE-FRAME STREAM) or *APPLICATION-FRAME*? (let* ((frame (pane-frame stream)) @@ -141,7 +163,7 @@ (move-cursor-beyond-output-record stream record) (values gadget record))))) -#+This-almost-works-with-the-other-definition +#-ignore (defmethod invoke-with-output-as-gadget (stream continuation &key) (let* ((frame (pane-frame stream)) (framem (frame-manager frame))) @@ -149,15 +171,18 @@ (assert framem) (multiple-value-bind (x y) (stream-cursor-position stream) - (let* (gadget + (let* (new + gadget (record (with-new-output-record (stream 'gadget-output-record record) (unless (setq gadget (output-record-gadget record)) - (setq gadget (funcall continuation framem frame)))))) - (associate-record-and-gadget - record - gadget - stream x y) + (setq new t + gadget (funcall continuation framem frame)))))) + (when new + (associate-record-and-gadget + record + gadget + stream x y)) (move-cursor-beyond-output-record stream record) (values gadget record))))) @@ -334,11 +359,15 @@ #+ignore (setf (gadget-value gadget) default))) -;;; Integer gadget +;;;;-------------- Integer gadget +;;;; I general there should be a way of using a slider to input a real +;;;; number but I do not think it should be the default +#+ignore (define-presentation-method gadget-includes-prompt-p ((type integer) (stream t) (view gadget-view) &key) t) +#+ignore (define-presentation-method accept-present-default ((type integer) stream (view gadget-dialog-view) diff --git a/clim/menus.lisp b/clim/menus.lisp index a8482702..d0affed7 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.19 92/04/15 11:46:54 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.20 92/04/21 16:13:11 cer Exp Locker: cer $ (in-package :clim-internals) @@ -113,16 +113,21 @@ (clear-input menu)))) #+Silica -(defun size-menu-appropriately (menu &key width height (right-margin 10) (bottom-margin 10)) +(defun size-menu-appropriately (menu &key + width height + (right-margin 10) + (bottom-margin 10) + (size-fn + #'window-set-inside-size)) (with-slots (output-record) menu (with-bounding-rectangle* (minx miny maxx maxy) output-record - (let* ((graft (graft menu)) - (gw (bounding-rectangle-width (sheet-region graft))) - (gh (bounding-rectangle-height (sheet-region graft))) - (width (min gw (+ (- maxx minx) right-margin))) - (height (min gh (+ (- maxy miny) bottom-margin)))) - (window-set-inside-size menu width height) - (window-set-viewport-position menu minx miny))))) + (let* ((graft (graft menu)) + (gw (bounding-rectangle-width (sheet-region graft))) + (gh (bounding-rectangle-height (sheet-region graft))) + (width (min gw (+ (- maxx minx) right-margin))) + (height (min gh (+ (- maxy miny) bottom-margin)))) + (funcall size-fn menu width height) + (window-set-viewport-position menu minx miny))))) #-Silica (defun position-window-near-carefully (window x y) diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index e802bf57..11cdb462 100644 --- a/clim/recording-protocol.lisp +++ b/clim/recording-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: recording-protocol.lisp,v 1.8 92/04/15 11:47:13 cer Exp Locker: cer $ +;; $fiHeader: recording-protocol.lisp,v 1.9 92/04/21 16:13:14 cer Exp Locker: cer $ (in-package :clim-internals) @@ -1219,10 +1219,11 @@ (bounding-rectangle stream))))) (unless (eq clear +nowhere+) (with-sheet-medium (medium stream) - (multiple-value-call #'draw-rectangle* - medium - (bounding-rectangle* clear) - :ink +background-ink+)) + (with-bounding-rectangle* (a b c d) clear + (draw-rectangle* + medium + a b c d + :ink +background-ink+))) (stream-replay stream region)))) diff --git a/silica/db-box.lisp b/silica/db-box.lisp index aeb57686..04fe13f5 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-box.lisp,v 1.12 92/04/21 16:12:34 cer Exp Locker: cer $ +;; $fiHeader: db-box.lisp,v 1.13 92/04/30 09:09:11 cer Exp Locker: cer $ (in-package :silica) @@ -43,7 +43,12 @@ (etypecase child (number) ((member :fill)) - (pane (sheet-adopt-child pane child)))) + (pane (sheet-adopt-child pane child)) + (cons + (unless (and (typep (first child) '(or (member :fill) (real 0 1))) + (panep (second child))) + (error "Invalid box child: ~S" contents)) + (sheet-adopt-child pane (second child))))) (with-slots ((c contents)) pane (setf c contents))) @@ -60,20 +65,33 @@ minor+ minor- (minor-min 0) ;;--- is this safe? - (minor-max most-positive-fixnum)) + (minor-max most-positive-fixnum) + scale) (dolist (entry contents) (cond ((eq entry :fill) (incf major+ +fill+)) ((numberp entry) (incf major entry)) - (t + (t + (if (consp entry) + (psetf entry (second entry) + scale (let ((n (first entry))) + (if (numberp n) + (float n) n))) + (setf scale 1.0)) (let ((space-req (apply #'compose-space entry width-or-height))) - (incf major (+ (funcall fn-major space-req) space)) - (incf major+ (funcall fn-major+ space-req)) - (incf major- (funcall fn-major- space-req)) - (setq minor (max minor (funcall fn-minor space-req))) - (setq minor-min - (max minor-min (funcall fn-minor- space-req))) - (setq minor-max - (min minor-max (funcall fn-minor+ space-req))))))) + (flet ((scale (x) (if (and (numberp scale) (< x +fill+)) (/ x scale) x))) + (if (eq scale :fill) + (incf major+ +fill+) + (progn + (incf major (+ (scale (funcall fn-major space-req)) space)) + (incf major+ (if (eq scale :fill) + +fill+ + (scale (funcall fn-major+ space-req)))))) + (incf major- (scale (funcall fn-major- space-req))) + (setq minor (max minor (funcall fn-minor space-req))) + (setq minor-min + (max minor-min (funcall fn-minor- space-req))) + (setq minor-max + (min minor-max (funcall fn-minor+ space-req)))))))) (decf major space) ;; ?? These calcs lead to weirdness when fills are involved. ;;--- This looks like a leftover from the time when +/- were relative @@ -86,7 +104,6 @@ keys (list major major+ major- minor minor+ minor-))))))) - (defclass hbox-pane (box-pane) ()) (defmethod compose-space ((box-pane hbox-pane) &key width height) @@ -105,6 +122,10 @@ (with-slots (contents space space-requirement) box-pane (unless space-requirement (compose-space box-pane :width width :height height)) + (flet ((compose (x) + (cond ((atom x) (compose-space x :height height)) + ((eq (car x) :fill) :fill) + (t (make-space-requirement :height 0 :width (* (car x) width)))))) (let ((sizes (allocate-space-to-items width @@ -113,15 +134,18 @@ #'space-requirement-min-width #'space-requirement-width #'space-requirement-max-width - #'(lambda (x) (compose-space x :height height)))) + #'compose)) (x 0)) (mapc #'(lambda (sheet size) - (when (panep sheet) + (when (or (panep sheet) + (and (consp sheet) + (panep (second sheet)) + (setq sheet (second sheet)))) (move-and-resize-sheet* sheet x 0 (frob-size size width x) height)) (incf x size)) - contents sizes)))) + contents sizes))))) (defclass vbox-pane (box-pane) ()) @@ -142,23 +166,32 @@ (with-slots (contents space space-requirement) box-pane (unless space-requirement (compose-space box-pane :width width :height height)) - (let ((sizes - (allocate-space-to-items + (flet ((compose (x) + (cond ((atom x) (compose-space x :width width)) + ((eq (car x) :fill) + :fill) + (t + (make-space-requirement :width 0 :height (* (car x) height)))))) + (let ((sizes + (allocate-space-to-items height space-requirement contents #'space-requirement-min-height #'space-requirement-height #'space-requirement-max-height - #'(lambda (x) (compose-space x :width width)))) - (y 0)) - (mapc #'(lambda (sheet size) - (when (panep sheet) - (move-and-resize-sheet* sheet - 0 y - width (frob-size size height y))) - (incf y size)) - contents sizes)))) + #'compose)) + (y 0)) + (mapc #'(lambda (sheet size) + (when (or (panep sheet) + (and (consp sheet) + (panep (second sheet)) + (setq sheet (second sheet)))) + (move-and-resize-sheet* sheet + 0 y + width (frob-size size height y))) + (incf y size)) + contents sizes))))) ;;--- Yow (defun frob-size (wanted-size available where-we-are-now) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index 71d61547..f1ef68e1 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-layout.lisp,v 1.13 92/04/21 16:12:36 cer Exp Locker: cer $ +;; $fiHeader: db-layout.lisp,v 1.14 92/04/28 09:25:14 cer Exp Locker: cer $ (in-package :silica) @@ -72,12 +72,78 @@ (defmethod change-space-requirement ((pane layout-mixin) &key &allow-other-keys) nil) -(defmethod change-space-requirement :after - ((pane layout-mixin) &key resize-frame &allow-other-keys) + +;;#| + +(defmacro changing-space-requirements ((&rest options &key resize-frame) &body body) + `(flet ((changing-space-requirements-body () + ,@body)) + (declare (dynamic-extent #'changing-space-requirements-body)) + (invoke-with-changing-space-requirements + #'changing-space-requirements-body + ,@options))) + +(defvar *inside-changing-space-requirements* nil) + +(defun invoke-with-changing-space-requirements (continuation &key resize-frame) + (let ((old-inside-changing-space-requirements + *inside-changing-space-requirements*) + (*inside-changing-space-requirements* + (cons nil *inside-changing-space-requirements*))) + (multiple-value-prog1 + (funcall continuation) + (unless old-inside-changing-space-requirements + ;; Layout that frames that need to be laid out + ;; and relayout the minimal subtrees that need to be laid out + (let* ((frames (remove-duplicates + (remove-if-not + #'(lambda (x) (typep x 'application-frame)) + *inside-changing-space-requirements*))) + (panes (remove-if #'(lambda (x) + (or (not (panep x)) + (member (pane-frame x) frames))) + *inside-changing-space-requirements*))) + (mapc #'layout-frame frames) + (dolist (pane panes) + (unless (some #'(lambda (p) + (and (not (eq p pane)) + (sheet-ancestor-p pane p))) + panes) + ;; do this because the change has occurred somewhere in + ;; the tree + (clear-space-requirement-caches-in-tree pane) + (multiple-value-call #'allocate-space + pane (bounding-rectangle-size pane))))))))) + +(defmethod note-space-requirement-changed (parent child) + (multiple-value-call #'allocate-space + parent (bounding-rectangle-size parent))) + +(defmethod change-space-requirement :before ((pane space-requirement-cache-mixin) &key) + (clear-space-requirement-cache pane)) + +(defmethod change-space-requirement :around ((pane layout-mixin) &key + resize-frame + &allow-other-keys) + (call-next-method) + (if *inside-changing-space-requirements* + (push (if resize-frame (pane-frame pane) (sheet-parent pane)) + (cdr *inside-changing-space-requirements*)) + (if resize-frame + (layout-frame (pane-frame pane)) + (note-space-requirement-changed (sheet-parent pane) pane)))) + +;;|# + + + +#+ignore +(defmethod change-space-requirement :after ((pane layout-mixin) &key resize-frame &allow-other-keys) (if resize-frame (layout-frame (pane-frame pane)) (note-space-requirement-changed (sheet-parent pane) pane))) +#+ignore (defmethod note-space-requirement-changed (parent child) nil) @@ -89,18 +155,6 @@ (multiple-value-bind (width height) (bounding-rectangle-size pane) (allocate-space pane width height))) - -#|| - -(defmacro changing-space-requirements ((pane &key resize-frame) &body body) - `(progn - ,@body {translate "change-space-req" to %set-space-req} - (if resize-frame - (layout-frame frame) - (note-space-requirement-changed (sheet-parent pane) pane)))) - -||# - (defun map-space-requirement (fn req) (setf (space-requirement-width req) (funcall fn (space-requirement-width req)) (space-requirement-height req) (funcall fn (space-requirement-height req)) @@ -467,6 +521,7 @@ provided elsewhere")) ;;---- along the way, calling fix-coor on alloc helps a little but we ;;---- still end up with a gap along the bottom-right edges. +#+ignore (defun allocate-space-to-items (given wanted items min-size desired-size max-size item-size) (flet ((desired-size (x) (funcall desired-size x)) @@ -493,29 +548,100 @@ provided elsewhere")) (setq alloc 0))) (t (let* ((item-size (item-size item))) - (setq alloc (desired-size item-size)) - (when (> give 0) - (if stretch-p - (progn - (setq used (/ (* (- (max-size item-size) - (desired-size item-size)) - extra) - give)) - (incf alloc used) - (fix-coordinates alloc) - (decf give (- (max-size item-size) - (desired-size item-size)))) - (progn - (setq used (/ (* (- (desired-size item-size) - (min-size item-size)) - extra) - give)) - (decf alloc used) - (fix-coordinates alloc) - (decf give (- (desired-size item-size) - (min-size item-size))))) - (decf extra used))))) + (if (eq item-size :fill) + (if stretch-p + (progn + (setq alloc (/ (* +fill+ extra) give)) + (setq alloc (ceiling alloc)) + (fix-coordinates alloc) + (decf give +fill+)) + (setq alloc 0)) + (progn + (setq alloc (desired-size item-size)) + (when (> give 0) + (if stretch-p + (progn + (setq used (/ (* (- (max-size item-size) + (desired-size item-size)) + extra) + give)) + (incf alloc used) + (fix-coordinates alloc) + (decf give (- (max-size item-size) + (desired-size item-size)))) + (progn + (setq used (/ (* (- (desired-size item-size) + (min-size item-size)) + extra) + give)) + (decf alloc used) + (fix-coordinates alloc) + (decf give (- (desired-size item-size) + (min-size item-size))))) + (decf extra used))))))) + (push alloc sizes))) + (nreverse sizes)))) + +;;-- This new supa dupa version saves up all the fills to the end and +;;-- then divides up any leftover space equally amongst them and it +;;-- seems to work! + +(defun allocate-space-to-items (given wanted items min-size + desired-size max-size item-size) + (flet ((desired-size (x) (funcall desired-size x)) + (min-size (x) (funcall min-size x)) + (max-size (x) (funcall max-size x)) + (item-size (x) (funcall item-size x))) + (let ((stretch-p (>= given (desired-size wanted))) + (allocated 0) + extra give used sizes) + (if stretch-p + (setq give (- (max-size wanted) (desired-size wanted)) + extra (min (- given (desired-size wanted)) give)) + (setq give (- (desired-size wanted) (min-size wanted)) + extra (min (- (desired-size wanted) given) give))) + (dolist (item items) + (let (alloc) + (typecase item + ((member :fill) + (setq alloc :fill)) + (t + (let* ((item-size (item-size item))) + (if (eq item-size :fill) + (setq alloc :fill) + (progn + (setq alloc (desired-size item-size)) + (when (> give 0) + (if stretch-p + (progn + (setq used (/ (* (- (max-size item-size) + (desired-size item-size)) + extra) + give)) + (incf alloc used) + (fix-coordinates alloc) + (decf give (- (max-size item-size) + (desired-size item-size)))) + (progn + (setq used (/ (* (- (desired-size item-size) + (min-size item-size)) + extra) + give)) + (decf alloc used) + (fix-coordinates alloc) + (decf give (- (desired-size item-size) + (min-size item-size))))) + (decf extra used))))))) + (when (numberp alloc) + (incf allocated alloc)) (push alloc sizes))) + (let ((fills (count :fill sizes)) + (leftover (- given allocated))) + (when (> fills 0) + (let ((x (if (> leftover 0) + (fix-coordinate (/ leftover fills)) + 0))) + (setf sizes (nsubstitute x :fill sizes))))) (nreverse sizes)))) ;;; Most of the layout panes should inherit from this diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 897dc64a..be382508 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.17 92/04/28 09:25:17 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.18 92/04/30 09:09:13 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -554,7 +554,8 @@ (declare (values value2)) (let* ((distance1 (- max1 min1)) (fraction1 (if (zerop distance1) 0 (/ (- value1 min1) distance1)))) - (+ min2 (* (- max2 min2) fraction1)))) + (let ((x (+ min2 (* (- max2 min2) fraction1)))) + (if (integerp x) x (float x))))) (defmethod handle-event :around ((pane scroll-bar-target-pane) (event pointer-button-press-event)) diff --git a/silica/framem.lisp b/silica/framem.lisp index 6f44ada9..5e7649a0 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: framem.lisp,v 1.5 92/04/15 11:45:09 cer Exp Locker: cer $ +;; $fiHeader: framem.lisp,v 1.6 92/04/21 16:12:39 cer Exp Locker: cer $ (in-package :silica) @@ -29,6 +29,11 @@ ((port :reader port :initarg :port) (frames :accessor frame-manager-frames :initform nil))) +;;-- This is most likely wrong. + +(defmethod graft ((framem standard-frame-manager)) + (car (port-grafts (port framem)))) + (defvar *frame-managers* nil) (defun find-frame-manager (&rest options @@ -70,9 +75,18 @@ (defmethod adopt-frame :after ((framem standard-frame-manager) frame) (pushnew frame (frame-manager-frames framem))) + +(defmethod disown-frame ((framem standard-frame-manager) frame) + (let ((top (frame-top-level-sheet frame))) + (when top + (sheet-disown-child (sheet-parent top) top) + (setf (frame-top-level-sheet frame) nil + (frame-state frame) :disowned)))) + (defmethod disown-frame :after ((framem standard-frame-manager) frame) (setf (frame-manager-frames framem) - (delete frame (frame-manager-frames framem)))) + (delete frame (frame-manager-frames framem)) + (slot-value frame 'frame-manager) nil)) (defmethod note-frame-enabled :after ((framem standard-frame-manager) frame) (update-frame-settings framem frame) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 7533b8d8..11a202d0 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.18 92/04/21 16:12:40 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.19 92/04/30 09:09:14 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -94,7 +94,7 @@ (defclass oriented-gadget () ((orientation :initarg :orientation - :reader gadget-orientation)) + :accessor gadget-orientation)) (:default-initargs :orientation :horizontal)) @@ -136,13 +136,18 @@ ;;; The intent is that the real implementations inherit from these ;;; Slider + (defclass slider (value-gadget oriented-gadget range-gadget-mixin labelled-gadget) ((drag-callback :initarg :drag-callback :initform nil :reader slider-drag-callback) + (decimal-places :initarg :decimal-places + :reader slider-decimal-places) (show-value-p :initarg :show-value-p :accessor gadget-show-value-p)) - (:default-initargs :show-value-p nil)) + (:default-initargs + :decimal-places 0 + :show-value-p nil)) (defmethod drag-callback ((gadget slider) (client t) (id t) value) @@ -413,7 +418,7 @@ l (note-gadget-activated (gadget-client gadget) gadget))) (defmethod note-gadget-activated ((client t) (gadget gadget)) - (port-note-gadget-activated (port gadget) gadget)) + nil) (defmethod deactivate-gadget ((gadget gadget)) (when (gadget-active-p gadget) @@ -421,4 +426,27 @@ l (note-gadget-deactivated (gadget-client gadget) gadget))) (defmethod note-gadget-deactivated ((client t) (gadget gadget)) - (port-note-gadget-deactivated (port gadget) gadget)) + nil) + +;;; List panes and option menus + +(defclass set-gadget-mixin () + ((items :initarg :items :accessor set-gadget-items) + (name-key :initarg :name-key :accessor set-gadget-name-key) + (value-key :initarg :value-key :accessor set-gadget-value-key) + (test :initarg :test :accessor set-gadget-test)) + (:default-initargs + :items nil + :test #'eql + :value-key #'identity + :name-key #'princ-to-string)) + +(defclass list-pane (set-gadget-mixin value-gadget) + ((mode :initarg :mode :type (member :exclusive :nonexclusive) + :accessor list-pane-mode)) + (:default-initargs :mode :exclusive)) + +(defclass option-pane (set-gadget-mixin + value-gadget + labelled-gadget) + ()) diff --git a/silica/layout.lisp b/silica/layout.lisp index d7401902..4d4e8541 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: layout.lisp,v 1.13 92/04/21 16:12:42 cer Exp Locker: cer $ +;; $fiHeader: layout.lisp,v 1.14 92/04/30 09:09:16 cer Exp Locker: cer $ (in-package :silica) @@ -92,22 +92,32 @@ ;(defmethod allocate-space (sheet width height) ; (declare (ignore sheet width height))) + +(defun parse-box-contents (contents) + (mapcar #'(lambda (x) + (if (and (consp x) + (typep (car x) '(or (member :fill) number))) + `(list ,(car x) ,(second x)) + x)) + contents)) + (defmacro vertically (options &body contents) `(make-pane 'vbox-pane - :contents (list ,@contents) + :contents (list ,@(parse-box-contents contents)) ,@options)) - - (defmacro horizontally (options &body contents) `(make-pane 'hbox-pane - :contents (list ,@contents) + :contents (list ,@(parse-box-contents contents)) ,@options)) ;;;---- Should force be T -(defmethod resize-sheet* ((sheet sheet) width height &key (force t)) +(defmethod resize-sheet* ((sheet sheet) width height &key (force nil)) + (unless (and (> width 0) (> height 0)) + (error "Trying to resize sheet to zero ~S,~S,~S" + sheet width height)) (when (or width height) (with-bounding-rectangle* (minx miny maxx maxy) sheet (when (or force @@ -121,6 +131,9 @@ (defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height) (resize-sheet* sheet width height) + (move-sheet* sheet minx miny)) + +(defmethod move-sheet* ((sheet sheet) minx miny) (let ((trans (sheet-transformation sheet))) (multiple-value-bind (x y) (transform-position trans 0 0) @@ -132,18 +145,6 @@ (if minx (- minx x) 0) (if miny (- miny y) 0))))))) -(defmethod move-sheet* ((sheet sheet) minx miny) - (let ((trans (sheet-transformation sheet))) - (multiple-value-bind (x y) - (transform-position trans 0 0) - (when (or (/= x minx) - (/= y miny)) - (setf (sheet-transformation sheet) - (compose-translation-with-transformation - trans - (- minx x) - (- miny y))))))) - ;; Various @@ -315,10 +316,14 @@ (defmethod note-layout-mixin-region-changed ((pane top-level-sheet) &key port) (if port + ;; We do this because if the wm has resized us then we want to + ;; do the complete layout-frame thing including clearing caches + ;; etc etc. (multiple-value-call #'layout-frame (pane-frame pane) (bounding-rectangle-size pane)) - (call-next-method))) + ;; Otherwise just call allocate-space etc + (call-next-method))) #+++ignore (defmethod allocate-space ((sheet top-level-sheet) width height) diff --git a/silica/port.lisp b/silica/port.lisp index a055a86b..9632dfae 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: port.lisp,v 1.9 92/03/24 19:36:49 cer Exp $ +;; $fiHeader: port.lisp,v 1.10 92/04/15 11:45:18 cer Exp Locker: cer $ (in-package :silica) @@ -61,7 +61,10 @@ (defgeneric port (x) + ;;;-- Do we need this??? + #+ignore (:method ((port port)) port) + #+ignore (:method ((x t)) nil)) (defgeneric port-properties (port)) diff --git a/test/test.lisp b/test/test.lisp index 01c9b695..faae505b 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.22 92/04/28 09:26:05 cer Exp Locker: cer $ +;; $fiHeader: test.lisp,v 1.23 92/04/30 09:09:43 cer Exp Locker: cer $ (in-package :clim-user) @@ -114,7 +114,8 @@ () (window-clear *query-io*)) -(define-test-frame-command (com-quit :name t :menu t) +(define-test-frame-command (com-quit :name t + :menu ("Quit" :documentation "foo")) () (frame-exit *application-frame*)) @@ -358,6 +359,12 @@ (defun text-field-changed (tf value) (format t "~&Text field ~A changed to ~S" tf value)) +(defun option-pane-changed-callback (tf value) + (format t "~&option menu ~A changed to ~S" tf value)) + +(defun list-pane-changed-callback (tf value) + (format t "~&list pane ~A changed to ~S" tf value)) + (defclass insect () ()) (define-test-frame-command (com-make-insect :name t :menu t) @@ -451,17 +458,14 @@ (:pane (outlining () (horizontally () - (make-pane - 'xm-silica::motif-scrolling-window - :contents + (scrolling () (make-pane 'text-editor :value "lucid " :value-changed-callback 'text-field-changed :ncolumns 30 :nlines 10)) - (make-pane - 'xm-silica::motif-scrolling-window - :contents (make-pane 'text-editor + (scrolling () + (make-pane 'text-editor :value "harlqn more" :value-changed-callback 'text-field-changed :ncolumns 30 @@ -473,24 +477,158 @@ (:command-table test-frame) (:pane (vertically () - (scrolling () - (make-pane - 'xm-silica::motif-list-pane - :items '("Franz" "Lucid" - "Harlqn" "Symbolics"))) - (make-pane 'xm-silica::motif-option-pane + (horizontally () + (scrolling () + (make-pane + 'list-pane + :value "Franz" + :test 'string= + :value-changed-callback + 'list-pane-changed-callback + :items '("Franz" "Lucid" + "Harlqn" "Symbolics"))) + (scrolling () + (make-pane + 'list-pane + :value '("Lisp" "C") + :test 'string= + :mode :nonexclusive + :value-changed-callback + 'list-pane-changed-callback + :items '("C" "Cobol" "Lisp" "Ada")))) + (make-pane 'option-pane :items '("eenie" "meanie" "minie") + :value "minie" + :value-changed-callback + 'option-pane-changed-callback + :test 'string= :label "moo") (outlining () - (make-pane - 'xm-silica::motif-scrolling-window - :contents + (scrolling () (make-pane 'text-editor :value "lucid are nice guys " :value-changed-callback 'text-field-changed :ncolumns 30 :nlines 10)))))) + +(define-application-frame tf96 + () () + (:command-table test-frame) + (:panes + (a :application :width '(80 :character)) + (b :application :width '(50 :mm)) + (c :application :height '(10 :line)) + (d :application :height '(5 :line)) + (e :application :height '( 50 :mm))) + (:layout + (:default (vertically () + (horizontally () a b) + (vertically () c d e))))) + + + +(define-test-frame-command (com-frob-sizes :name t :menu t) + () + (changing-space-requirements () + (change-space-requirement + (get-frame-pane *application-frame* 'a) + :resize-frame t + :width `(,(random 60) :character)) + (change-space-requirement + (get-frame-pane *application-frame* 'b) + :resize-frame t + :width `(,(random 60) :character)) + (change-space-requirement + (get-frame-pane *application-frame* 'd) + :resize-frame t + :height `(,(random 10) :line)))) + +(define-application-frame tf95 + () () + (:command-table test-frame) + (:panes + (a :application :width '(80 :character)) + (b :application :width '(50 :mm)) + (c :application :height '(10 :line)) + (d :application :height '(5 :line)) + (e :application :height '( 50 :mm))) + (:layout + (:default (vertically + () + (1/3 (horizontally () (1/10 a) (9/10 b))) + (2/3 (vertically () (1/4 c) (1/2 d) (1/4 e))))))) + + +(define-application-frame tf94 + () () + (:command-table test-frame) + (:panes + (a :application :width '(80 :character)) + (b :application) + (c :application :height '(10 :line)) + (d :application) + (e :application :height '( 50 :mm))) + (:layout + (:default (vertically + () + (1/3 (horizontally () (1/10 a) (:fill b))) + (2/3 (vertically () (1/4 c) (:fill d) (1/4 e))))))) + +(define-application-frame tf93 + () () + (:command-table test-frame) + (:panes + (a :application) + (b :application) + (c :application) + (d :application) + (e :application)) + (:layout + (:default (vertically + () + (1/3 (horizontally () (1/10 a) (9/10 b))) + (2/3 (vertically () (1/4 c) (1/2 d) (1/4 e))))))) + +(define-application-frame tf91 + () () + (:command-table test-frame) + (:panes + (a :application) + (b :application) + (c :application) + (d :application) + (e :application)) + (:layout + (:default (vertically + () + (1/3 (horizontally () (1/10 a) (:fill b))) + (2/3 (vertically () (1/4 c) (:fill d) (1/4 e))))))) + +(define-application-frame tf92 () + () + (:pane + (make-pane 'vbox-pane + :contents + (mapcar #'(lambda (x) + (destructuring-bind + (min max &optional (decimal-places 0)) + x + (make-pane 'slider + :label (format nil "Slider ~D,~D,~D" + min max decimal-places) + :min-value min + :max-value max + :decimal-places decimal-places + :show-value-p t + :value-changed-callback 'slider-changed-callback + :drag-callback + 'slider-dragged-callback))) + '((0 100) + (50 60) + (50 60 2) + (0.0 1.0 2)))))) + (defun test-accepting-values (&optional (own-window t) (gadget-dialog-view t)) (let* ((stream *query-io*) @@ -539,3 +677,26 @@ :prompt (second (nth i ptypes-and-prompts))))) (terpri stream)))) values)) + +;; This was from a pkarp mail message + +(defun shift-output-record (stream record dx dy) + (let ((parent (output-record-parent record))) + (multiple-value-bind (x-offset y-offset) + (convert-from-relative-to-absolute-coordinates + stream + parent) + (multiple-value-bind + (x y) + (bounding-rectangle-position record) + (erase-output-record record stream) + (output-record-set-position record (+ x dx) (+ y dy)) + (replay-output-record record stream nil x-offset y-offset) + (add-output-record record parent))))) + +(define-test-frame-command (com-shift-gadget :name t :menu t) + ((weird 'some-kinda-gadget) + (dx 'integer) + (dy 'integer)) + (shift-output-record *query-io* (car weird) dx dy)) + diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 1335ee83..44a6a90a 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.14 92/04/21 20:28:30 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.15 92/04/28 09:26:24 cer Exp Locker: cer $ (in-package :xm-silica) @@ -254,7 +254,19 @@ :label-string menu :managed t :parent parent))) - (push (list item button) commands-and-buttons) + (push (list item button) + commands-and-buttons) + + (when (getf (command-menu-item-options + item) :documentation) + (tk::add-callback + button + :help-callback + 'display-motif-help + port + (getf (command-menu-item-options + item) :documentation))) + (tk::add-callback button :activate-callback @@ -269,6 +281,12 @@ ct mirror (not (flat-command-table-menu-p ct))))) mirror)) +(defun display-motif-help (widget port documentation) + (port-notify-user + port + documentation + :associated-window widget)) + (defmethod port-dialog-view ((port motif-port)) +gadget-dialog-view+) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 5768ae32..5983c87e 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.25 92/04/28 09:26:27 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.26 92/04/30 09:09:51 cer Exp Locker: cer $ (in-package :xm-silica) @@ -41,17 +41,8 @@ (clim-internals::check-box motif-check-box) (frame-pane motif-frame-pane) (top-level-sheet motif-top-level-sheet) - ;; One day - (line-editor-pane) - (label-button-pane) - (radio-button-pane) - (horizontal-divider-pane) - (vertical-divider-pane) - (label-pane) - ;; - (list-pane) - (caption-pane) - (cascade-button) + (list-pane motif-list-pane) + (option-pane motif-option-pane) )))) ;;; We now need a lot of classes that mirror the xm classes. @@ -76,13 +67,69 @@ (when (sheet-mirror gadget) (tk::set-values (sheet-mirror gadget) :value nv))) -(defmethod queue-value-changed-event (widget sheet) +(defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet))) (declare (ignore widget)) (distribute-event (port sheet) (make-instance 'value-changed-gadget-event :gadget sheet - :value (gadget-value sheet)))) + :value value))) + +;; Gadgets that have a :label initarg + +(defclass motif-labelled-gadget () ()) + +(defmethod find-widget-class-and-initargs-for-sheet + :around ((port motif-port) + (parent t) + (sheet motif-labelled-gadget)) + (multiple-value-bind + (class initargs) + (call-next-method) + (with-accessors ((alignment silica::gadget-alignment) + (label gadget-label)) sheet + (when label + (unless (getf initargs :label-string) + (setf (getf initargs :label-string) label))) + (unless (getf initargs :alignment) + (setf (getf initargs :alignment) + (ecase alignment + ((:left nil) :beginning) + (:center :center) + (:right :end))))) + (values class initargs))) + +(defmethod (setf gadget-label) :after (nv (sheet motif-labelled-gadget)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) :label-string (or nv + "")))) + +(defmethod (setf silica::gadget-alignment) :after (nv (sheet motif-labelled-gadget)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) + :alignment (ecase nv + ((:left nil) :beginning) + (:center :center) + (:right :end))))) + +;; Motif-orriented-gadget + +(defclass motif-oriented-gadget () ()) + +(defmethod find-widget-class-and-initargs-for-sheet :around ((port motif-port) + (parent t) + (sheet motif-oriented-gadget)) + (multiple-value-bind + (class initargs) + (call-next-method) + (with-accessors ((orientation gadget-orientation)) sheet + (unless (getf initargs :orientation) + (setf (getf initargs :orientation) orientation))) + (values class initargs))) + +(defmethod (setf gadget-orientation) :after (nv (gadget motif-oriented-gadget)) + (when (sheet-direct-mirror gadget) + (tk::set-values (sheet-direct-mirror gadget) :orientation nv))) ;;; Motif widgets that support the activate callback @@ -103,27 +150,19 @@ ;;; Label -(defclass motif-label-pane (xt-leaf-pane label-pane) +(defclass motif-label-pane (xt-leaf-pane motif-labelled-gadget label-pane) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-label-pane)) - (with-accessors ((label gadget-label) - (alignment silica::gadget-alignment)) sheet - (values 'tk::xm-label - (append - (list :alignment - (ecase alignment - ((:left nil) :beginning) - (:center :center) - (:right :end))) - (and label (list :label-string label)))))) + (values 'tk::xm-label nil)) ;;; Push button (defclass motif-push-button (xt-leaf-pane + motif-labelled-gadget push-button motif-action-pane) ()) @@ -133,10 +172,7 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-push-button)) - (declare (ignore port)) - (with-accessors ((label gadget-label)) sheet - (values 'tk::xm-push-button - (and label (list :label-string label))))) + (values 'tk::xm-push-button nil)) (defmethod add-sheet-callbacks ((port motif-port) (sheet t) (widget tk::xm-drawing-area)) (tk::add-callback widget @@ -219,55 +255,56 @@ (defclass motif-slider (xt-leaf-pane motif-range-pane + motif-oriented-gadget slider) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-slider)) - (with-accessors ((orientation gadget-orientation) - (label gadget-label) + (with-accessors ((label gadget-label) (show-value-p silica::gadget-show-value-p) (value gadget-value)) sheet - (values 'tk::xm-scale - (append - (and show-value-p (list :show-value show-value-p )) - (and label (list :title-string label)) - (list :orientation orientation) - (and value (list :value value)))))) - - -;;;--- It seems that motif-sliders will actually tell you how big they -;;;--- want to be. Mostly - -;(defmethod compose-space ((m motif-slider) &key width height) -; (declare (ignore width height)) -; (destructuring-bind -; (label scroll-bar) (tk::widget-children (sheet-direct-mirror m)) -; (declare (ignore scroll-bar)) -; (multiple-value-bind -; (label-x label-y label-width label-height) -; (if (gadget-label m) -; (tk::widget-best-geometry label) -; (values nil nil 0 0)) -; (declare (ignore label-x label-y)) -; ;;-- We need to estimate the space requirements for the value if -; ;;-- that is shown. -; ;;-- Life sucks and then you die. We need to determine the -; ;;-- text-extent of the biggest value we can show and incf that -; ;;-- Plus some scale margin. -; (let ((fudge 16)) -; (ecase (gadget-orientation m) -; (:vertical -; (make-space-requirement :width (+ fudge label-width) -; :min-height fudge -; :height (max (* 2 fudge) label-height) -; :max-height +fill+)) -; (:horizontal -; (make-space-requirement :height (+ fudge label-height) -; :min-width fudge -; :width (max (* 2 fudge) label-width) -; :max-width +fill+))))))) + (multiple-value-bind + (smin smax) (silica::gadget-range* sheet) + + (let ((mmin 0) + (mmax 100) + (decimal-points 0) + (decimal-places (silica::slider-decimal-places sheet))) + (cond ((and (zerop decimal-places) + (typep smin '(signed-byte 32)) + (typep smax '(signed-byte 32))) + (setq mmin smin mmax smax decimal-points 0)) + ;; Real case + (t + (setq smin (float smin) smax (float smax)) + (let ((scaling (expt 10 decimal-places))) + (setq mmin (round (* scaling smin)) + mmax (round (* scaling smax)) + decimal-points decimal-places)))) + + (assert (and (typep mmin '(signed-byte 32)) + (typep mmax '(signed-byte 32)))) + + (values 'tk::xm-scale + (append + (and show-value-p (list :show-value show-value-p )) + (and label (list :title-string label)) + (list :minimum mmin + :maximum mmax + :decimal-points decimal-points) + (and value + (list :value (silica::compute-symmetric-value + smin smax value mmin mmax))))))))) + +(defmethod (setf gadget-show-value-p) :after (nv (sheet motif-slider)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) :show-value nv))) + +(defmethod (setf gadget-label) :after (nv (sheet motif-slider)) + (when (sheet-direct-mirror sheet) + (tk::set-values (sheet-direct-mirror sheet) :title-string (or nv "")))) (defmethod compose-space ((m motif-slider) &key width height) (declare (ignore width height)) @@ -292,16 +329,14 @@ (defclass motif-scroll-bar (xt-leaf-pane - scroll-bar) + motif-oriented-gadget + scroll-bar) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-scroll-bar)) - (with-accessors ((orientation gadget-orientation)) sheet - ;;-- we should really decide what the min and max resources should be - (values 'tk::xm-scroll-bar - (list :orientation orientation)))) + (values 'tk::xm-scroll-bar nil)) (defmethod (setf silica::scroll-bar-size) (nv (sb motif-scroll-bar)) (tk::set-values (sheet-direct-mirror sb) :slider-size (floor nv)) @@ -501,6 +536,7 @@ ;;; Toggle button (defclass motif-toggle-button (xt-leaf-pane + motif-labelled-gadget motif-value-pane toggle-button) ()) @@ -509,11 +545,9 @@ (parent t) (sheet motif-toggle-button)) (with-accessors ((set gadget-value) - (label gadget-label) (indicator-type gadget-indicator-type)) sheet (values 'tk::xm-toggle-button (append (list :set set) - (and label (list :label-string label)) (list :indicator-type (ecase indicator-type (:one-of :one-of-many) @@ -528,6 +562,7 @@ (when (sheet-direct-mirror gadget) (tk::set-values (sheet-mirror gadget) :set nv))) +#+ignore (defmethod add-sheet-callbacks :after ((port motif-port) (sheet clim-stream-sheet) (widget tk::xm-drawing-area)) @@ -583,6 +618,7 @@ :resize-policy :none :scroll-bar-display-policy :static))) +#+ignore (defmethod add-sheet-callbacks :after ((port motif-port) (sheet xm-viewport) (widget tk::xm-drawing-area)) @@ -595,6 +631,7 @@ sheet)) (defclass motif-radio-box (motif-geometry-manager + motif-oriented-gadget mirrored-sheet-mixin sheet-multiple-child-mixin sheet-permanently-enabled-mixin @@ -610,9 +647,7 @@ (parent t) (sheet motif-radio-box)) - (with-accessors ((orientation gadget-orientation)) sheet - (values 'tk::xm-radio-box - (list :orientation orientation)))) + (values 'tk::xm-radio-box nil)) (defmethod value-changed-callback :after ((v gadget) (client motif-radio-box) @@ -626,6 +661,7 @@ v))) (defclass motif-check-box (motif-geometry-manager + motif-oriented-gadget mirrored-sheet-mixin sheet-multiple-child-mixin sheet-permanently-enabled-mixin @@ -641,9 +677,7 @@ (parent t) (sheet motif-check-box)) - (with-accessors ((orientation gadget-orientation)) sheet - (values 'tk::xm-row-column - (list :orientation orientation)))) + (values 'tk::xm-row-column nil)) (defmethod value-changed-callback :after ((v gadget) (client motif-check-box) @@ -681,6 +715,7 @@ ; ;;-- Is this what wrapping space mixin should do??? ; (move-and-resize-sheet* (sheet-child fr) 0 0 width height)) + (defmethod add-sheet-callbacks :after ((port motif-port) (sheet xm-frame-viewport) (widget tk::xm-drawing-area)) @@ -760,89 +795,148 @@ (sheet motif-scrolling-window)) (values 'xt::xm-scrolled-window nil)) -;;-- This needs work but we are getting there -;;-- We should make it abstract and define the interface -;;-- List of items and a unique string to appear. +;; List-pane + +(defclass motif-list-pane (list-pane xt-leaf-pane) + ()) -(defclass motif-list-pane (xt-leaf-pane) - ((items :initarg :items :accessor list-pane-items)) - (:default-initargs :items nil)) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-list-pane)) - (with-accessors ((items list-pane-items)) sheet - (values 'xt::xm-list - `( - :items ,items :item-count ,(length items))))) - -(defmethod silica::gadget-supplied-scrolling (frame-manager frame (contents motif-list-pane) &rest ignore) + (with-accessors ((items set-gadget-items) + (value gadget-value) + (value-key set-gadget-value-key) + (test set-gadget-test) + (mode list-pane-mode) + (name-key set-gadget-name-key)) sheet + (let ((selected-items + (compute-list-pane-selected-items sheet value))) + (values 'xt::xm-list + `( + ,@(and selected-items + `(:selected-item-count ,(length selected-items) + :selected-items ,selected-items)) + :selection-policy + ,(ecase mode + (:exclusive :single-select) + (:nonexclusive :multiple-select)) + :items ,(mapcar name-key items) + :item-count ,(length items)))))) + +(defun list-pane-single-selection-callback (widget item-position sheet) + (declare (ignore item-count)) + (let ((item (funcall (set-gadget-value-key sheet) + (nth (1- item-position) (set-gadget-items sheet))))) + (queue-value-changed-event + widget sheet + (and (not (funcall (set-gadget-test sheet) item (gadget-value sheet))) + item)))) + +(defun list-pane-multiple-selection-callback (widget item-positions sheet) + (declare (ignore item-count)) + (let ((items (mapcar #'(lambda (item-position) + (funcall (set-gadget-value-key sheet) + (nth (1- item-position) + (set-gadget-items sheet)))) + item-positions))) + (queue-value-changed-event + widget sheet items))) + + +(defmethod add-sheet-callbacks ((port motif-port) (sheet motif-list-pane) (widget xt::xm-list)) + (ecase (list-pane-mode sheet) + (:exclusive + (tk::add-callback widget :single-selection-callback + 'list-pane-single-selection-callback sheet)) + (:nonexclusive + (tk::add-callback widget :multiple-selection-callback + 'list-pane-multiple-selection-callback sheet)))) + +(defun compute-list-pane-selected-items (sheet value) + (with-accessors ((items set-gadget-items) + (value-key set-gadget-value-key) + (test set-gadget-test) + (mode list-pane-mode) + (name-key set-gadget-name-key)) sheet + (ecase mode + (:exclusive + (let ((x (find value items :test test :key value-key))) + (and x (list (funcall name-key x))))) + (:nonexclusive + (mapcar name-key + (remove-if-not #'(lambda (item) + (member (funcall value-key item) value :test test)) + items)))))) + +(defmethod silica::gadget-supplied-scrolling (frame-manager frame + (contents motif-list-pane) + &rest ignore) (declare (ignore ignore)) (with-look-and-feel-realization (frame-manager frame) (make-pane 'motif-scrolling-window :contents contents))) -(defmethod gadget-value ((l motif-list-pane)) - ) - -(defmethod (setf gadget-value) (nv (l motif-list-pane) &key) - ) +(defmethod (setf gadget-value) :after (nv (l motif-list-pane) &key) + (when (sheet-direct-mirror l) + (let ((selected-items + (compute-list-pane-selected-items l nv))) + (tk::set-values (sheet-direct-mirror l) + :selected-item-count (length selected-items) + :selected-items selected-items)))) ;;; Option buttons -(defclass motif-option-pane (xt-leaf-pane silica::labelled-gadget) - ((items :initarg :items :accessor option-pane-items)) - (:default-initargs :items nil)) +(defclass motif-option-pane (option-pane motif-labelled-gadget xt-leaf-pane) + ((buttons :accessor motif-option-menu-buttons))) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-option-pane)) - (with-accessors ((label gadget-label) - (items option-pane-items)) sheet + (with-accessors ((items set-gadget-items) + (name-key set-gadget-name-key) + (value-key set-gadget-value-key)) sheet (let ((pdm (make-instance 'xt::xm-pulldown-menu :managed nil :parent parent))) - (dolist (item items) - (make-instance 'tk::xm-push-button :label-string item :parent pdm)) + (setf (motif-option-menu-buttons sheet) + (mapcar #'(lambda (item) + (let ((button + (make-instance 'tk::xm-push-button + :label-string (funcall name-key item) + :parent pdm))) + (tk::add-callback + button + :activate-callback + 'option-menu-callback-function + (funcall value-key item) + sheet) + button)) + items)) (values 'xt::xm-option-menu - (append - (and label `(:label-string ,label)) - `(:sub-menu-id ,pdm)))))) - -;;--- What is the interface to this? It seems to represent one of a -;; set of N items. Does that set have a key and test and (setf) -;; gadget-value changes/returns which is the current one? - -;; There seems to be a need for various types of dialog boxes. - -;;;; Inform-user -; -;(defmethod port-inform-user ((port motif-port) message -; &rest args -; &key (title "Not some information") -; &allow-other-keys) -; (apply #'question-user-1 ' message :title title args)) -; -; -;(defmethod port-error-user ((port motif-port) message -; &rest args -; &key (title "Not an error") -; &allow-other-keys) -; (apply #'question-user-1 message :title -; title args)) -; -;(defmethod port-question-user ((port motif-port) message -; &rest args -; &key (title "Not A Question") -; &allow-other-keys) -; (apply #'question-user-1 ' message :title title args)) -; -;(defmethod port-warn-user ((port motif-port) message -; &rest args -; &key (title "Not A Warning") -; &allow-other-keys) -; (apply #'question-user-1 message :title title args)) - -;;-- Guess we want to specify text of ok,cancel and help buttons -;;-- and whether there is any help for the help-button + `(:sub-menu-id ,pdm))))) + +(defun option-menu-callback-function (widget count value sheet) + (declare (ignore count)) + (queue-value-changed-event widget sheet value)) + +(defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key) + (set-option-menu-value gadget nv)) + +(defmethod realize-mirror :around ((port motif-port) (pane motif-option-pane)) + (prog1 (call-next-method) + (set-option-menu-value pane (gadget-value pane)))) + +(defun set-option-menu-value (gadget nv) + (with-accessors ((items set-gadget-items) + (value-key set-gadget-value-key) + (test set-gadget-test) + (name-key set-gadget-name-key)) gadget + (when (sheet-direct-mirror gadget) + (let* ((x (position nv items :test test :key value-key)) + (widget (sheet-direct-mirror gadget))) + (when x + (tk::set-values widget :menu-history (nth x (motif-option-menu-buttons gadget))) + (tk::set-values (tk::intern-widget (tk::xm_option_button_gadget widget)) + :label-string (funcall name-key (nth x items)))))))) (defmethod port-notify-user ((port motif-port) message-string @@ -867,7 +961,9 @@ (:warning 'tk::xm-warning-dialog)) :dialog-style :primary-application-modal :managed nil - :parent (sheet-mirror associated-window) + :parent (if (typep associated-window 'xt::xt-root-class) + associated-window + (sheet-mirror associated-window)) :name name :dialog-title title :message-string message-string @@ -908,7 +1004,7 @@ (progn (tk::manage-child dialog) (wait-for-callback-invocation - (port associated-window) + port #'(lambda () (or result (not (tk::is-managed-p dialog)))) "Waiting for dialog")) (tk::destroy-widget dialog)) @@ -916,16 +1012,12 @@ (defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback")) - ;;-- Funnily enough if we are in the mouse process then we - ;;-- are hosed. We should process events until the - ;;-- predicate is true - ;;-- and exit sometime (if (eq mp:*current-process* (silica::port-process port)) (progn (loop (when (funcall predicate) (return nil)) (process-next-event port))) - (mp:process-wait whostate predicate))) + (mp:process-wait whostate predicate))) (defun get-message-box-child (widget &rest children) (values-list diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp index 5be5e84d..873df9fd 100644 --- a/tk-silica/xm-menus.lisp +++ b/tk-silica/xm-menus.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-menus.lisp,v 1.9 92/04/10 14:27:51 cer Exp Locker: cer $ +;; $fiHeader: xm-menus.lisp,v 1.10 92/04/21 16:13:29 cer Exp Locker: cer $ (in-package :xm-silica) @@ -125,31 +125,39 @@ :separator-type :double-line :parent menu)) (labels ((make-menu-button (item class parent &rest options) - (if simplep - (apply #'make-instance - class - :sensitive (clim-internals::menu-item-active item) - :parent parent - :managed nil - :label-string (string (menu-item-display item)) - options) - (let* ((pixmap (pixmap-from-menu-item - associated-window - item - printer - presentation-type)) - (button - (apply #'make-instance - class - :sensitive (clim-internals::menu-item-active item) - :parent parent - :label-type :pixmap - :label-pixmap pixmap - options))) - (xt::add-widget-cleanup-function - button - #'tk::destroy-pixmap pixmap) - button))) + (let ((button + (if simplep + (apply #'make-instance + class + :sensitive (clim-internals::menu-item-active item) + :parent parent + :managed nil + :label-string (string (menu-item-display item)) + options) + (let* ((pixmap (pixmap-from-menu-item + associated-window + item + printer + presentation-type)) + (button + (apply #'make-instance + class + :sensitive (clim-internals::menu-item-active item) + :parent parent + :label-type :pixmap + :label-pixmap pixmap + options))) + (xt::add-widget-cleanup-function + button + #'tk::destroy-pixmap pixmap) + button)))) + (when (clim-internals::menu-item-documentation item) + (tk::add-callback button + :help-callback + 'display-motif-help + port + (clim-internals::menu-item-documentation item))) + button)) (construct-menu-from-items (menu items) (map nil #'(lambda (item) (ecase (clim-internals::menu-item-type item) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index 91b84420..e9ffcb29 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.9 92/04/10 14:27:57 cer Exp Locker: cer $ +;; $fiHeader: xt-gadgets.lisp,v 1.10 92/04/15 11:48:52 cer Exp Locker: cer $ (in-package :xm-silica) @@ -115,11 +115,15 @@ (defclass xt-pane (pane) ()) -(defmethod allocate-space ((p xt-pane) width height) - (when (sheet-mirror p) - (tk::set-values (sheet-mirror p) - :width (floor width) - :height (floor height)))) +(defmethod port-note-gadget-activated :after ((client t) (gadget xt-pane)) + (let (m) + (when (setq m (sheet-direct-mirror gadget)) + (xt::set-sensitive m t)))) + +(defmethod note-gadget-deactivated :after ((client t) (gadget xt-pane)) + (let (m) + (when (setq m (sheet-direct-mirror gadget)) + (xt::set-sensitive m nil)))) ;(defclass xt-composite-pane () ()) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 879e583a..81e4b7c3 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.22 92/04/28 09:26:38 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.23 92/04/30 09:09:55 cer Exp Locker: cer $ (in-package :xm-silica) @@ -547,11 +547,19 @@ (find-shell-of-calling-frame sheet)) (port-application-shell port))) -(defmethod find-shell-class-and-initargs ((port xt-port) sheet) +(defmethod find-shell-class-and-initargs ((port xt-port) (sheet t)) (values 'top-level-shell ;; Need this so that an interactive pane can have children ;; but still accept the focus - '(:keyboard-focus-policy :pointer))) + `(:keyboard-focus-policy :pointer))) + +(defmethod find-shell-class-and-initargs :around ((port xt-port) (sheet pane)) + (multiple-value-bind + (class initargs) + (call-next-method) + (values class + `(:allow-shell-resize ,(clim-internals::frame-resizable (pane-frame sheet)) + ,@initargs)))) (defmethod enable-mirror ((port xt-port) sheet) (declare (ignore port)) @@ -1016,10 +1024,6 @@ (xt::set-sensitive widget nil)) widget)) -(defmethod port-note-gadget-activated ((port xt-port) gadget) - (when (sheet-mirror gadget) - (xt::set-sensitive (sheet-mirror gadget) t))) -(defmethod port-note-gadget-deactivated ((port xt-port) gadget) - (when (sheet-mirror gadget) - (xt::set-sensitive (sheet-mirror gadget) nil))) + + diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index 541ca7e0..bf1e9909 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.lisp,v 1.9 92/03/30 17:51:25 cer Exp $ +;; $fiHeader: callbacks.lisp,v 1.10 92/04/21 20:27:24 cer Exp Locker: cer $ (in-package :tk) @@ -102,10 +102,10 @@ ("applyCallback") ("okCallback") ("browseSelectionCallback") - ("singleSelectionCallback") + ("singleSelectionCallback" :single-selection) ("defaultActionCallback") ("extendedSelectionCallback") - ("multipleSelectionCallback") + ("multipleSelectionCallback" :multiple-selection) ("entryCallback") ("mapCallback") ("unmapCallback") @@ -137,3 +137,14 @@ (defmethod spread-callback-data (widget call-data (type (eql 'drawing-area))) (values (x-drawing-area-callback-window call-data) (x-drawing-area-callback-event call-data))) + +(defmethod spread-callback-data (widget call-data (type (eql :single-selection))) + (declare (ignore widget)) + (xm-list-callback-struct-item-position call-data)) + +(defmethod spread-callback-data (widget call-data (type (eql :multiple-selection))) + (declare (ignore widget)) + (let ((si (xm-list-callback-struct-selected-item-positions call-data)) + (r nil)) + (dotimes (i (xm-list-callback-struct-selected-item-count call-data) (nreverse r)) + (push (xm-selected-position-array si i) r)))) diff --git a/tk/resources.lisp b/tk/resources.lisp index a18bff3c..d52f8be5 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.17 92/04/21 20:27:41 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.18 92/04/28 09:25:04 cer Exp Locker: cer $ (in-package :tk) @@ -126,6 +126,7 @@ (x-arglist (aref arglist i) 0)) values)))) + (defmethod convert-resource-in (class type value) (cerror "Try again" "cannot convert-in resource for ~S,~S,~S" class type value) (convert-resource-in class type value)) @@ -560,6 +561,7 @@ (define-enumerated-resource visual-policy (:variable :constant)) (define-enumerated-resource scroll-bar-display-policy (:static :as-needed)) +(define-enumerated-resource selection-policy (:single-select :multiple-select :extended-select :browse-select)) (defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value) (if value diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp index 9838e9c2..51e04542 100644 --- a/tk/xm-defs.lisp +++ b/tk/xm-defs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-defs.lisp,v 1.2 92/04/21 20:27:45 cer Exp Locker: cer $ +;; $fiHeader: xm-defs.lisp,v 1.3 92/04/28 09:25:07 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -50,3 +50,17 @@ (dir-length :int) (pattern xm-string) (pattern-length xm-string)) + +(def-c-type (xm-list-callback-struct :no-defuns) :struct + (reason :int) + (event * x11:xevent) + (item xm-string) + (item-length :int) + (item-position :int) + (selection-items * xm-string) + (selected-item-count :int) + (selected-item-positions * :int) + (selection-type :int)) + +(def-c-type (xm-selected-position-array :no-defuns) 1 :int) + diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp index cecf1a2e..0378df27 100644 --- a/tk/xm-funs.lisp +++ b/tk/xm-funs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-funs.lisp,v 1.3 92/04/21 20:27:47 cer Exp Locker: cer $ +;; $fiHeader: xm-funs.lisp,v 1.4 92/04/28 09:25:09 cer Exp Locker: cer $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -69,3 +69,9 @@ (defforeign 'xm_file_selection_do_search :entry-point "_XmFileSelectionDoSearch") + +(defforeign 'xm_option_label_gadget + :entry-point "_XmOptionLabelGadget") + +(defforeign 'xm_option_button_gadget + :entry-point "_XmOptionButtonGadget") diff --git a/utils/packages.lisp b/utils/packages.lisp index 7ddf94f7..4a98b7d1 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.12 92/04/28 09:25:23 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.13 92/04/30 09:09:18 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2651,6 +2651,18 @@ gadget-value gadget-value-changed-callback gadget-show-value-p + + ;; this should go somewhere + + slider-decimal-places + set-gadget-items + set-gadget-name-key + set-gadget-value-key + set-gadget-test + list-pane + list-pane-mode + option-pane + label-pane labelled-gadget menu-bar -- GitLab