From cf492b0accd8e4da71993d638f4a70239226a6e6 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Tue, 21 Apr 1992 16:13:39 +0000 Subject: [PATCH] cerfixes --- clim/accept-values.lisp | 4 +- clim/db-stream.lisp | 13 +- clim/frames.lisp | 56 ++++-- clim/gadget-output.lisp | 43 ++-- clim/input-protocol.lisp | 11 +- clim/menus.lisp | 2 +- clim/pixmap-streams.lisp | 12 +- clim/recording-protocol.lisp | 11 +- silica/db-box.lisp | 18 +- silica/db-layout.lisp | 65 +++--- silica/db-scroll.lisp | 176 +++++++++------- silica/framem.lisp | 8 +- silica/gadgets.lisp | 66 +++--- silica/layout.lisp | 5 +- silica/mirror.lisp | 30 ++- silica/sheet.lisp | 12 +- test/test-suite.lisp | 30 +-- test/test.lisp | 103 ++++++---- tk-silica/xm-frames.lisp | 100 +++++++--- tk-silica/xm-gadgets.lisp | 375 ++++++++++++++++++++++++++++++----- tk-silica/xm-menus.lisp | 33 +-- tk-silica/xm-silica.lisp | 6 +- tk-silica/xt-frames.lisp | 9 +- tk-silica/xt-graphics.lisp | 31 ++- tk-silica/xt-silica.lisp | 48 ++++- tk/convenience.lisp | 50 +---- tk/foreign-obj.lisp | 6 +- tk/gcontext.lisp | 18 +- tk/make-classes.lisp | 9 +- tk/resources.lisp | 38 +++- tk/widget.lisp | 35 ++-- tk/xlib.lisp | 18 +- tk/xm-funs.lisp | 5 +- utils/regions.lisp | 13 +- 34 files changed, 999 insertions(+), 460 deletions(-) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index af35ea63..43dbb3ee 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.14 92/04/14 15:29:50 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.15 92/04/15 11:46:02 cer Exp Locker: cer $ (in-package :clim-internals) @@ -187,7 +187,7 @@ (with-slots (stream own-window exit-button-stream) *application-frame* (vertically () (outlining () - (scrolling (:scroll-bars :dynamic) + (scrolling (:scroll-bars :dynamic) (progn (setq stream (make-instance 'accept-values-stream diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 64b8a432..d7db2919 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.11 92/04/10 14:26:58 cer Exp Locker: cer $ +;; $fiHeader: db-stream.lisp,v 1.12 92/04/15 11:46:23 cer Exp Locker: cer $ (in-package :clim-internals) @@ -102,7 +102,16 @@ :reader pane-display-time :initarg :display-time :initform :command-loop :type (member nil :command-loop t)))) - + +(defmethod pane-needs-redisplay ((pane clim-stream-pane)) + (with-slots (display-time) pane + (ecase display-time + ((t) (setq display-time nil) t) + ((nil) nil) + (:command-loop t)))) + +(defmethod pane-needs-redisplay ((pane pane)) nil) + (defmethod initialize-instance :after ((pane clim-stream-pane) &key &allow-other-keys) (setf (sheet-transformation pane) +identity-transformation+)) diff --git a/clim/frames.lisp b/clim/frames.lisp index c2643c77..173a38bf 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.11 92/03/24 19:37:49 cer Exp $ +;; $fiHeader: frames.lisp,v 1.14 92/04/15 11:46:30 cer Exp Locker: cer $ (in-package :clim-internals) @@ -39,7 +39,8 @@ (top-level :initarg :top-level :accessor frame-top-level) (current-layout :initarg :default-layout :initform nil :reader frame-current-layout) - (default-size :initform nil :initarg :default-size) + (geometry :initform nil :initarg :geometry :reader frame-geometry) + (icon :initform nil :initarg :icon :reader frame-icon) (shell :accessor frame-shell) (pointer-documentation-p :initarg :pointer-documentation :reader frame-pointer-documentation-p) @@ -63,8 +64,16 @@ (defmethod initialize-instance :after ((frame standard-application-frame) &rest args &key frame-manager + geometry + icon (parent frame-manager)) (declare (ignore args)) + + (destructuring-bind (&key x y width height) geometry + (declare (ignore x y width height))) + (destructuring-bind (&key name pixmap clip-mask) icon + (declare (ignore name pixmap clip-mask))) + (let ((frame-manager (etypecase parent (null (find-frame-manager)) @@ -97,7 +106,8 @@ #+Genera (declare (zwei:indentation 1 25 2 3 3 1)) (with-warnings-for-definition name define-application-frame (let (pane panes layout top-level menu-bar pointer-documentation - command-definer command-table disabled-commands) + command-definer command-table disabled-commands + icon geometry default-initargs) (macrolet ((extract (name keyword default &optional (pair t)) `(let ((entry (assoc ',keyword options))) (cond ((null entry) @@ -120,7 +130,10 @@ (extract pointer-documentation :pointer-documentation nil) (extract command-definer :command-definer t) (extract command-table :command-table t) - (extract disabled-commands :disabled-commands nil)) + (extract disabled-commands :disabled-commands nil) + (extract default-initargs :default-initargs nil nil) + (extract icon :icon nil nil) + (extract geometry :geometry nil nil)) (check-type name symbol) (check-type superclasses list) (check-type slots list) @@ -171,7 +184,10 @@ ,@(and command-table `(:command-table ',(car command-table))) ,@(and top-level `(:top-level ',top-level)) ,@(and panes `(:pane-constructors ,pane-constructors)) - ,@(and layout `(:default-layout ',(caar layout))))) + ,@(and layout `(:default-layout ',(caar layout))) + ,@(and icon `(:icon (list ,@icon))) + ,@(and geometry `(:geometry (list ,@geometry))) + ,@default-initargs)) ,@(when command-definer `((defmacro ,command-definer (command-name arguments &body body) #+Genera (declare (zwei:indentation 1 3 2 1)) @@ -402,22 +418,30 @@ (defun make-application-frame (frame-name &rest options &key frame-class enable pretty-name - width height + x y width height save-under &allow-other-keys) (declare (dynamic-extent options)) (check-type pretty-name (or null string)) (when (null frame-class) (setq frame-class frame-name)) + (when (or x y width height) + (when (getf options :geometry) + (error "Cannot specify :geometry and :x,:y,:width or :height at ~ +the same time " options)) + (setf (getf options :geometry) + (append (and x `(:x ,x)) + (and y `(:y ,y)) + (and width `(:width ,width)) + (and height `(:height ,height))))) (with-keywords-removed (options options '(:frame-class :pretty-name - :enable :width :height :save-under)) + :enable :x :y :width :height :save-under)) (let ((frame (apply #'make-instance frame-class :name frame-name + ;;-- Perhaps this should be a default-initarg? :pretty-name (or pretty-name (title-capitalize (string frame-name))) - :default-size (when (or width height) - (list width height)) :properties `(:save-under ,save-under) options))) (when enable @@ -431,7 +455,8 @@ (nstring-capitalize new-string))) (defmethod enable-frame ((frame standard-application-frame)) - (with-slots (default-size) frame + (destructuring-bind + (&key width height &allow-other-keys) (frame-geometry frame) (ecase (frame-state frame) (:enabled) ((:disabled :disowned) @@ -445,8 +470,8 @@ frame (ecase old (:disowned - (if default-size - (values (first default-size) (second default-size)) + (if (and width height) + (values width height) (values))) (:disabled (bounding-rectangle-size @@ -644,6 +669,7 @@ ;;--- What about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc? ;;--- What about CLIM 1.0's :DISPLAY-AFTER-COMMANDS :NO-CLEAR? + (defun redisplay-frame-pane (frame pane &key force-p) (when (symbolp pane) (setq pane (get-frame-pane frame pane))) @@ -675,7 +701,7 @@ (redisplay-p (redisplay redisplay-record pane :check-overlapping check-overlapping)) - (t + ((pane-needs-redisplay pane) (invoke-pane-display-function frame pane)))))))))) (force-p ;;-- Is there anything else we need to do? @@ -822,9 +848,9 @@ (defmethod frame-maintain-presentation-histories ((frame standard-application-frame)) (not (null (find-frame-pane-of-type frame 'interactor-pane)))) -(defmethod notify-user (frame format-string &rest format-arguments) +(defmethod notify-user (frame message &rest options) (declare (dynamic-extent format-arguments)) - (apply #'port-notify-user (port frame) frame format-string format-arguments)) + (apply #'port-notify-user (port frame) message :frame frame options)) ;;; Pointer documentation diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index f8818839..1e238471 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gadget-output.lisp,v 1.9 92/04/10 14:27:02 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.lisp,v 1.10 92/04/15 11:46:32 cer Exp Locker: cer $ (in-package :clim-internals) @@ -226,13 +226,16 @@ (declare (ignore present-p)) ;; value-key, test, sequence (with-output-as-gadget (stream) - (let* ((gadget - (make-pane 'radio-box - :label (and (stringp prompt) prompt) - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier)))) + (let* (gadget frame-pane) + (setq frame-pane + (outlining () + (setq gadget + (make-pane 'radio-box + :label (and (stringp prompt) prompt) + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier))))) (dolist (element sequence) (make-pane 'toggle-button :label (princ-to-string element) @@ -242,7 +245,7 @@ (funcall value-key default))) :id element :parent gadget)) - gadget))) + frame-pane))) ;;; Boolean gadget @@ -257,8 +260,10 @@ present-p query-identifier &key (prompt t)) (declare (ignore default-supplied-p present-p)) - (let ((gadget - (with-output-as-gadget (stream) + (let (gadget) + (with-output-as-gadget (stream) + (outlining () + (setq gadget (make-pane 'toggle-button :label (and (stringp prompt) prompt) :value default @@ -269,6 +274,9 @@ ;;--- We end up not making a new gadget sometimes, I think because ;;--- we find a gadget already in the record so we need to modify ;;--- the value! + ;;--- I am no longer sure that this is true cos the graphics + ;;--- dialog seems to work fine. + #+ignore (setf (gadget-value gadget) default))) ;;; Integer gadget @@ -284,13 +292,14 @@ &key (prompt t)) (declare (ignore present-p)) (with-output-as-gadget (stream) - (make-pane 'slider - :label (and (stringp prompt) prompt) - :value (if default-supplied-p default 0) - :client stream :id query-identifier - :value-changed-callback + (outlining () + (make-pane 'slider + :label (and (stringp prompt) prompt) + :value (if default-supplied-p default 0) + :client stream :id query-identifier + :value-changed-callback (make-accept-values-value-changed-callback - stream query-identifier)))) + stream query-identifier))))) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 094fd504..4a329553 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-protocol.lisp,v 1.10 92/03/30 17:52:30 cer Exp $ +;; $fiHeader: input-protocol.lisp,v 1.11 92/04/15 11:46:49 cer Exp Locker: cer $ (in-package :clim-internals) @@ -425,7 +425,14 @@ (defmethod receive-gesture ((stream input-protocol-mixin) (gesture event)) (process-event-locally stream gesture) nil) - + +;;;--- This is horrible + +(defmethod receive-gesture + ((stream input-protocol-mixin) (gesture pointer-button-release-event)) + ;; don't translate it + gesture) + (defmethod receive-gesture ((stream input-protocol-mixin) gesture) ;; don't translate it diff --git a/clim/menus.lisp b/clim/menus.lisp index b294d6b3..a8482702 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.18 92/04/10 14:27:04 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.19 92/04/15 11:46:54 cer Exp Locker: cer $ (in-package :clim-internals) diff --git a/clim/pixmap-streams.lisp b/clim/pixmap-streams.lisp index bbaa0b3a..814eb669 100644 --- a/clim/pixmap-streams.lisp +++ b/clim/pixmap-streams.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pixmap-streams.lisp,v 1.2 92/02/24 13:08:10 cer Exp $ +;; $fiHeader: pixmap-streams.lisp,v 1.3 92/03/04 16:22:06 cer Exp Locker: cer $ (in-package :clim-internals) @@ -46,12 +46,17 @@ (defmethod initialize-instance :after ((stream pixmap-stream) &key port pixmap - width height) + width + height + sheet) (setf (sheet-direct-mirror stream) pixmap (port stream) port (sheet-transformation stream) +identity-transformation+ (sheet-region stream) (make-bounding-rectangle 0 0 width - height))) + height)) + ;;-- What about text style + (setf (medium-foreground stream) (medium-foreground sheet) + (medium-background stream) (medium-background sheet))) ;; Interface to this stuff @@ -75,6 +80,7 @@ (defmethod allocate-pixmap-stream (sheet pixmap width height) (make-instance 'pixmap-stream + :sheet sheet :default-text-margin width :pixmap pixmap :width width diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index 6adb3eff..e802bf57 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.7 92/04/14 15:29:55 cer Exp Locker: cer $ +;; $fiHeader: recording-protocol.lisp,v 1.8 92/04/15 11:47:13 cer Exp Locker: cer $ (in-package :clim-internals) @@ -665,11 +665,18 @@ (map-over-output-records-overlapping-region #'replay-1 record region (- x-offset) (- y-offset) - (+ x-offset xoff) (+ y-offset yoff))) + (+ x-offset xoff) (+ y-offset yoff)) + ;;--- Nasty hack to get around nasty bug + (note-output-record-replayed record stream region x-offset y-offset)) (replay-output-record record stream region x-offset y-offset)))) (declare (dynamic-extent #'replay-1)) (replay-1 record x-offset y-offset))) +(defmethod note-output-record-replayed ((record output-record-mixin) stream + &optional region x-offset y-offset) + (declare (ignore stream region x-offset y-offset)) + nil) + (defun move-cursor-beyond-output-record (stream record) (multiple-value-bind (x-offset y-offset) (convert-from-relative-to-absolute-coordinates diff --git a/silica/db-box.lisp b/silica/db-box.lisp index 839978ab..7f1b1e61 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.10 92/04/10 14:26:25 cer Exp Locker: cer $ +;; $fiHeader: db-box.lisp,v 1.11 92/04/15 11:44:59 cer Exp Locker: cer $ (in-package :silica) @@ -81,7 +81,7 @@ (setq minor- (max 0 (- minor minor-min))) (setq minor+ (max 0 (- minor-max minor))) (apply #'make-space-requirement - (mapcan #'(lambda (key val) (list key val)) + (mapcan #'list keys (list major major+ major- minor minor+ minor-))))))) @@ -115,9 +115,10 @@ #'(lambda (x) (compose-space x :height height)))) (x 0)) (mapc #'(lambda (sheet size) - (move-and-resize-sheet* sheet - x 0 - (frob-size size width x) height) + (when (panep sheet) + (move-and-resize-sheet* sheet + x 0 + (frob-size size width x) height)) (incf x size)) contents sizes)))) @@ -151,9 +152,10 @@ #'(lambda (x) (compose-space x :width width)))) (y 0)) (mapc #'(lambda (sheet size) - (move-and-resize-sheet* sheet - 0 y - width (frob-size size height y)) + (when (panep sheet) + (move-and-resize-sheet* sheet + 0 y + width (frob-size size height y))) (incf y size)) contents sizes)))) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index b6b76ce9..7e816855 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.11 92/03/30 17:52:01 cer Exp $ +;; $fiHeader: db-layout.lisp,v 1.12 92/04/15 11:45:02 cer Exp Locker: cer $ (in-package :silica) @@ -463,6 +463,9 @@ provided elsewhere")) ;;; Generally useful layout function ;;; Used all over to satisfy constraints +;;--- I think that since coordinates are ultimately integers we loose +;;---- along the way, calling fix-coor on alloc helps a little but we +;;---- still end up with a gap along the bottom-right edges. (defun allocate-space-to-items (given wanted items min-size desired-size max-size item-size) @@ -475,30 +478,43 @@ provided elsewhere")) (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))) + (setq give (- (desired-size wanted) (min-size wanted)) + extra (min (- (desired-size wanted) given) give))) (dolist (item items) - (let* ((item-size (item-size item)) - (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) - (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) - (decf give (- (desired-size item-size) - (min-size item-size))))) - (decf extra used)) + (let (alloc) + (typecase item + ((member :fill) + (if stretch-p + (progn + (setq alloc (/ (* +fill+ extra) give)) + (setq alloc (ceiling alloc)) + (fix-coordinates alloc) + (decf give +fill+)) + (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))))) (push alloc sizes))) (nreverse sizes)))) @@ -524,3 +540,4 @@ provided elsewhere")) (resize-sheet* child (space-requirement-width space-req) (space-requirement-height space-req))))) + diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index e92bf898..e0128018 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.13 92/04/14 15:29:31 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.14 92/04/15 11:45:04 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -15,9 +15,12 @@ (defclass scroller-pane (client-space-requirement-mixin wrapping-space-mixin layout-pane) - ((scroll-bars :initarg :scroll-bars) - vertical-scroll-bar - horizontal-scroll-bar + ((scroll-bars :initarg :scroll-bars :reader scroller-pane-scroll-bar-policy) + (vertical-scroll-bar :initform nil :accessor scroller-pane-vertical-scroll-bar) + (horizontal-scroll-bar :accessor + scroller-pane-horizontal-scroll-bar + :initform nil) + (scrolling-supplied-by-gadget :initform nil) contents viewport) (:default-initargs :scroll-bars :both)) @@ -38,93 +41,128 @@ 'scroller-pane) (sheet-parent (sheet-parent (sheet-parent x))))) -(defmethod gadget-supplies-scroll-bars-p ((gadget t)) +(defmethod gadget-supplied-scrolling (frame-manager frame contents &rest ignore) + (declare (ignore frame-manager frame ignore contents)) nil) +(defmethod allocate-space :before ((sp scroller-pane) width height) + (declare (ignore width height)) + ;; Adjust the status of the scrollbars + (multiple-value-bind + (changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p) + (compute-dynamic-scroll-bar-values sp) + (if changedp + (update-dynamic-scroll-bars + sp + changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p)))) + +(defmethod compose-space ((sp scroller-pane) &key width height) + (declare (ignore width height)) + (let ((sr (copy-space-requirement (call-next-method)))) + (maxf (space-requirement-width sr) 50) + (maxf (space-requirement-height sr) 50) + sr)) + ;;--- Ideally we should use a toolkit scrolling window. This will look ;;--- exactly right and will deal with user specified placement of scroll-bars. ;;--- However the geometry management problems are quite huge. + (defmethod initialize-instance :after ((pane scroller-pane) &key contents frame-manager frame scroll-bars) - (if (gadget-supplies-scroll-bars-p contents) - (sheet-adopt-child pane contents) - (progn - (check-type scroll-bars - (member :both :dynamic :vertical :horizontal)) - (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane - (with-look-and-feel-realization (frame-manager frame) - (let ((verticalp - (member scroll-bars '(:both :dynamic :vertical))) - (horizontalp - (member scroll-bars '(:both :dynamic :horizontal)))) - (setf vertical-scroll-bar - (and verticalp - (make-pane 'scroll-bar - :orientation :vertical - :client pane - :id :vertical)) - horizontal-scroll-bar - (and horizontalp - (make-pane 'scroll-bar - :id :horizontal - :client pane - :orientation :horizontal)) - c contents - viewport (make-pane 'viewport)) - (sheet-adopt-child pane - (cond ((and horizontalp verticalp) - (tabling () - (viewport vertical-scroll-bar) - (horizontal-scroll-bar - nil))) - (verticalp - (horizontally () + (let ((x (gadget-supplied-scrolling frame-manager frame contents :scroll-bars scroll-bars))) + (if x + (progn + (sheet-adopt-child pane x) + (setf (slot-value pane 'scrolling-supplied-by-gadget) t) + x) + (progn + (check-type scroll-bars + (member :both :dynamic :vertical :horizontal)) + (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane + (with-look-and-feel-realization (frame-manager frame) + (let ((verticalp + (member scroll-bars '(:both :dynamic :vertical))) + (horizontalp + (member scroll-bars '(:both :dynamic :horizontal)))) + (setf vertical-scroll-bar + (and verticalp + (make-pane 'scroll-bar + :orientation :vertical + :client pane + :id :vertical)) + horizontal-scroll-bar + (and horizontalp + (make-pane 'scroll-bar + :id :horizontal + :client pane + :orientation :horizontal)) + c contents + viewport (make-pane 'viewport)) + (sheet-adopt-child pane + (cond ((and horizontalp verticalp) + (tabling () + (viewport vertical-scroll-bar) + (horizontal-scroll-bar + nil))) + (verticalp + (horizontally () + viewport + vertical-scroll-bar)) + (horizontalp + (vertically () viewport - vertical-scroll-bar)) - (horizontalp - (vertically () - viewport - horizontal-scroll-bar)) - (t - (error "Should not have got here")))) - - (sheet-adopt-child viewport c) - ;;-- Add callbacks - )))))) + horizontal-scroll-bar)) + (t + (error "Should not have got here")))) + + (sheet-adopt-child viewport c) + ;;-- Add callbacks + ))))))) (defun update-scroll-bars (vp) ;;-- This is not the most efficient thing in the world - (multiple-value-call - #'update-dynamic-scroll-bars - vp (compute-dynamic-scroll-bar-values vp)) + (multiple-value-bind + (changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar + vscroll-bar-enabled-p) + (compute-dynamic-scroll-bar-values (sheet-parent (sheet-parent vp))) + (update-dynamic-scroll-bars + (sheet-parent (sheet-parent vp)) + changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar + vscroll-bar-enabled-p t)) + ;;; (with-bounding-rectangle* (minx miny maxx maxy) - (let ((c (sheet-child vp))) - ;;--- This is a major kludge - (if (typep c 'clim-internals::output-recording-mixin) - (stream-output-history c) - c)) + (viewport-contents-extent vp) (with-bounding-rectangle* (vminx vminy vmaxx vmaxy) - (viewport-viewport-region vp) - (with-slots (horizontal-scroll-bar vertical-scroll-bar) - (sheet-parent (sheet-parent vp)) + (viewport-viewport-region vp) + (with-accessors ((horizontal-scroll-bar scroller-pane-horizontal-scroll-bar) + (vertical-scroll-bar scroller-pane-vertical-scroll-bar)) + (sheet-parent (sheet-parent vp)) (update-scroll-bar vertical-scroll-bar - miny maxy vminy vmaxy) + miny maxy vminy vmaxy) (update-scroll-bar horizontal-scroll-bar - minx maxx vminx vmaxx))))) + minx maxx vminx vmaxx))))) ;;--- In the case where the viewport is bigger than the window this ;;--- code gets things wrong. Check out the thinkadot demo. It's ;;--- because (- (--) (- vmin)) is negative. + (defun update-scroll-bar (scroll-bar min max vmin vmax) (declare (optimize (safety 0) (speed 3))) - (with-slots (current-size current-value) scroll-bar + (let ((current-size (scroll-bar-current-size scroll-bar)) + (current-value (scroll-bar-current-value scroll-bar))) ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size ;; before, and the viewport is bigger than the extent, don't bother with ;; the fancy math. - (let ((range (float (gadget-range scroll-bar) 0.0s0))) - (declare (type single-float range)) + (let* ((gmin (float (gadget-min-value scroll-bar) 0s0)) + (gmax (float (gadget-max-value scroll-bar) 0s0)) + (range (- gmax gmin))) + (declare (type single-float range gmin gmax)) (if (and (and current-size (= (the single-float current-size) range)) (> (- vmax vmin) (- max min))) (return-from update-scroll-bar)) @@ -153,8 +191,8 @@ current-value (= current-size size) (= current-value value)) - (setf current-size size - current-value value) + (setf (scroll-bar-current-size scroll-bar) size + (scroll-bar-current-value scroll-bar) value) (change-scroll-bar-values scroll-bar :slider-size size :value value)))))) @@ -176,9 +214,7 @@ size) (with-slots (viewport contents) client ;;--- This TYPEP stuff is a major kludge - (let* ((extent (if (typep contents 'clim-internals::output-recording-mixin) - (stream-output-history contents) - contents)) + (let* ((extent (viewport-contents-extent viewport)) (vp viewport) (viewport (viewport-viewport-region vp))) (case id diff --git a/silica/framem.lisp b/silica/framem.lisp index 4a623792..6f44ada9 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.4 92/04/10 14:26:31 cer Exp Locker: cer $ +;; $fiHeader: framem.lisp,v 1.5 92/04/15 11:45:09 cer Exp Locker: cer $ (in-package :silica) @@ -75,10 +75,14 @@ (delete frame (frame-manager-frames framem)))) (defmethod note-frame-enabled :after ((framem standard-frame-manager) frame) - ;; Perhaps we want to resize the top level sheet if there is one + (update-frame-settings framem frame) + ;;--- Perhaps we want to resize the top level sheet if there is one (when (frame-top-level-sheet frame) (setf (sheet-enabled-p (frame-top-level-sheet frame)) t))) +(defmethod update-frame-settings ((framem standard-frame-manager) (frame t)) + nil) + (defmethod note-frame-disabled :after ((framem standard-frame-manager) frame) (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 70db1fdd..26f792b1 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.16 92/04/14 15:29:37 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.17 92/04/15 11:45:10 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -148,10 +148,11 @@ ;; Scroll bar + (defclass scroll-bar (value-gadget range-gadget-mixin oriented-gadget) - ((current-value :initform nil) - (current-size :initform nil) + ((current-value :initform nil :accessor scroll-bar-current-value) + (current-size :initform nil :accessor scroll-bar-current-size) (drag-callback :initarg :drag-callback :initform nil :reader scroll-bar-drag-callback))) @@ -278,51 +279,34 @@ ;;--- Work on this - -(defmethod note-sheet-region-changed :around ((viewport viewport) &key port-did-it) - (declare (ignore port-did-it)) - (multiple-value-bind - (changedp - hscroll-bar hscroll-bar-enabled-p - vscroll-bar vscroll-bar-enabled-p) - (compute-dynamic-scroll-bar-values viewport) - (if changedp - (update-dynamic-scroll-bars - viewport - changedp - hscroll-bar hscroll-bar-enabled-p - vscroll-bar vscroll-bar-enabled-p) - (call-next-method)))) - - -(defun update-dynamic-scroll-bars (viewport - changedp - hscroll-bar hscroll-bar-enabled-p - vscroll-bar vscroll-bar-enabled-p) +(defun update-dynamic-scroll-bars (sp + changedp + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p + &optional relayout) (when changedp (when hscroll-bar (setf (sheet-enabled-p hscroll-bar) hscroll-bar-enabled-p)) (when vscroll-bar (setf (sheet-enabled-p vscroll-bar) vscroll-bar-enabled-p)) - (let ((table (sheet-parent viewport))) - (clear-space-requirement-caches-in-tree table) - (multiple-value-call - #'allocate-space - table - (bounding-rectangle-size table))))) - -(defun compute-dynamic-scroll-bar-values (viewport) - (with-slots ((hscroll-bar horizontal-scroll-bar ) - (vscroll-bar vertical-scroll-bar) - (scroll-bar-policy scroll-bars)) - (sheet-parent (sheet-parent viewport)) + (clear-space-requirement-caches-in-tree sp) + (when relayout + (multiple-value-bind + (w h) + (bounding-rectangle-size sp) + (allocate-space sp w h))))) + +(defun compute-dynamic-scroll-bar-values (sp) + (let* ((hscroll-bar (scroller-pane-horizontal-scroll-bar sp)) + (vscroll-bar (scroller-pane-vertical-scroll-bar sp)) + (scroll-bar-policy (scroller-pane-scroll-bar-policy sp))) (if (eq scroll-bar-policy :dynamic) (multiple-value-bind - (vwidth vheight) (bounding-rectangle-size viewport) + (vwidth vheight) (bounding-rectangle-size sp) (multiple-value-bind (cwidth cheight) (bounding-rectangle-size - (viewport-contents-extent viewport)) + (viewport-contents-extent (slot-value sp 'viewport))) (let ((ohenp (sheet-enabled-p hscroll-bar)) (ovenp (sheet-enabled-p vscroll-bar)) (nhenp (> cwidth vwidth)) @@ -338,12 +322,10 @@ (defun viewport-contents-extent (viewport) (let ((c (sheet-child viewport))) - (if (typep c 'clim-internals::output-recording-mixin) - (stream-output-history c) - c))) + (stream-output-history c))) ;;--- Need something in update-scroll-bars also. - +l ;;; Then there is the layout stuff and scrolling macros (defmacro scrolling (options &body contents) diff --git a/silica/layout.lisp b/silica/layout.lisp index 4fa0521d..6e7edc9d 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.11 92/04/10 14:26:34 cer Exp Locker: cer $ +;; $fiHeader: layout.lisp,v 1.12 92/04/15 11:45:13 cer Exp Locker: cer $ (in-package :silica) @@ -105,8 +105,9 @@ ,@options)) +;;;---- Should force be T -(defmethod resize-sheet* ((sheet sheet) width height &key force) +(defmethod resize-sheet* ((sheet sheet) width height &key (force t)) (when (or width height) (with-bounding-rectangle* (minx miny maxx maxy) sheet (when (or force diff --git a/silica/mirror.lisp b/silica/mirror.lisp index bc51723c..92b1fcd9 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: mirror.lisp,v 1.14 92/03/30 17:52:06 cer Exp $ +;; $fiHeader: mirror.lisp,v 1.15 92/04/15 11:45:16 cer Exp Locker: cer $ (in-package :silica) @@ -66,9 +66,11 @@ (defgeneric sheet-device-transformation (sheet)) (defmethod sheet-device-transformation ((sheet sheet)) - (compose-transformations - (sheet-transformation sheet) - (sheet-device-transformation (sheet-parent sheet)))) + (or (sheet-cached-device-transformation sheet) + (setf (sheet-cached-device-transformation sheet) + (compose-transformations + (sheet-transformation sheet) + (sheet-device-transformation (sheet-parent sheet)))))) (defmethod sheet-device-transformation :around ((sheet mirrored-sheet-mixin)) (if (sheet-direct-mirror sheet) @@ -95,12 +97,15 @@ (sheet-native-region sheet)) ;;--- This assumes that sheet siblings do not overlap... + (defmethod sheet-device-region (sheet) - (region-intersection - (transform-region - (sheet-device-transformation sheet) - (sheet-region sheet)) - (sheet-device-region (sheet-parent sheet)))) + (or (sheet-cached-device-region sheet) + (setf (sheet-cached-device-region sheet) + (region-intersection + (transform-region + (sheet-device-transformation sheet) + (sheet-region sheet)) + (sheet-device-region (sheet-parent sheet)))))) ;;;; Mirror region stuff @@ -157,7 +162,14 @@ (setf (sheet-direct-mirror sheet) (call-next-method))))) (setf (gethash mirror (port-mirror->sheet-table port)) sheet) + ;;--- What is the right thing do here. + ;;--- In the motif port we note specify the width and height of + ;;--- widgets when we make them. We rely on the layout protocol - + ;;--- ??? to take care of all of that, ie. to go in and change + ;;--- the size + #+ignore (update-mirror-transformation port sheet) + (setf (sheet-native-transformation sheet) +identity-transformation+) mirror)) (defmethod destroy-mirror :around ((port port) (sheet mirrored-sheet-mixin)) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index b8bbd381..31592d59 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: sheet.lisp,v 1.9 92/03/30 17:52:08 cer Exp $ +;; $fiHeader: sheet.lisp,v 1.10 92/04/15 11:45:19 cer Exp Locker: cer $ (in-package :silica) @@ -264,14 +264,18 @@ nil)) (defgeneric invalidate-cached-transformations (sheet) - (:method ((sheet t)) nil) + (:method ((sheet t)) + (setf (sheet-cached-device-region sheet) nil) + (setf (sheet-cached-device-transformation sheet) nil)) (:method :after ((sheet sheet-parent-mixin)) (mapc #'invalidate-cached-transformations (sheet-children sheet)))) (defgeneric invalidate-cached-regions (sheet) - (:method ((sheet t)) nil) + (:method ((sheet t)) + (setf (sheet-cached-device-region sheet) nil) + (setf (sheet-cached-device-transformation sheet) nil)) (:method :after ((sheet sheet-parent-mixin)) - (mapc #'invalidate-cached-regions (sheet-children sheet)))) + (mapc #'invalidate-cached-regions (sheet-children sheet)))) (defmethod note-sheet-region-changed :before (sheet &key port-did-it) (declare (ignore port-did-it)) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 6ad6dd10..dd1e4ffc 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.15 92/04/10 14:27:18 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.16 92/04/15 11:47:40 cer Exp Locker: cer $ (in-package :clim-user) @@ -780,7 +780,7 @@ people, shall not perish from the earth. (circle 100 50 40 1) (circle 75 100 40 2) (circle 125 100 40 3)) - (stream-set-cursor-position* stream 0 150) + (stream-set-cursor-position stream 0 150) (format stream "~S" (accept 'integer :stream stream))) (define-test (ordering-test-2a output-recording) (stream) @@ -791,7 +791,7 @@ people, shall not perish from the earth. (rect 50 50 150 150 1) (rect 0 0 100 100 2) (rect 25 25 125 125 3)) - (stream-set-cursor-position* stream 0 160) + (stream-set-cursor-position stream 0 160) (format stream "~S" (accept 'integer :stream stream))) (define-test (ordering-test-2b output-recording) (stream) @@ -802,7 +802,7 @@ people, shall not perish from the earth. (rect 125 125 225 225 1) (rect 0 0 100 100 2) (rect 50 50 150 150 3)) - (stream-set-cursor-position* stream 0 240) + (stream-set-cursor-position stream 0 240) (format stream "~S" (accept 'integer :stream stream))) (define-test (cursorpos-table output-recording) (stream) @@ -814,7 +814,7 @@ people, shall not perish from the earth. (multiple-value-bind (x y) (stream-cursor-position stream) (dotimes (i 11) - (stream-set-cursor-position* stream x y) + (stream-set-cursor-position stream x y) (write-string (format nil "~1$" (float (/ i 10))) stream) (incf x (+ rect-width spacing)))) (terpri stream) @@ -941,7 +941,7 @@ people, shall not perish from the earth. (define-test (checkerboard formatted-output) (stream) "This should produce a checkerboard pattern." - (stream-set-cursor-position* stream 10 10) + (stream-set-cursor-position stream 10 10) (surrounding-output-with-border (stream) (formatting-table (stream :y-spacing 0 :x-spacing 0) (dotimes (i 8) @@ -965,13 +965,13 @@ people, shall not perish from the earth. (define-test (simple-borders formatted-output) (stream) "Show the three types of canned borders." - (stream-set-cursor-position* stream 10 10) + (stream-set-cursor-position stream 10 10) (surrounding-output-with-border (stream :shape :rectangle) (write-string "a rectangle" stream)) - (stream-set-cursor-position* stream 10 30) + (stream-set-cursor-position stream 10 30) (surrounding-output-with-border (stream :shape :drop-shadow) (write-string "a dropshadow" stream)) - (stream-set-cursor-position* stream 10 50) + (stream-set-cursor-position stream 10 50) (surrounding-output-with-border (stream :shape :underline) (write-string "an underline" stream))) @@ -1018,7 +1018,7 @@ people, shall not perish from the earth. (define-test (offset-table formatted-output) (stream) "Draw a table offset in the window. After refreshing, it should look the same." - (stream-set-cursor-position* stream 20 20) + (stream-set-cursor-position stream 20 20) (formatting-table (stream) (dotimes (i 10) (formatting-row (stream) @@ -1034,7 +1034,7 @@ people, shall not perish from the earth. (define-test (offset-graph formatted-output) (stream) "Draw a graph offset in the window. After refreshing, it should look the same." (let ((orientation :horizontal)) - (stream-set-cursor-position* stream 20 20) + (stream-set-cursor-position stream 20 20) (macrolet ((make-node (&key name children) `(list* ,name ,children))) (flet ((node-name (node) @@ -1128,7 +1128,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (write-string doc-string documentation) (write-string caption documentation) (force-output documentation)) - (stream-set-cursor-position* stream 30 30) + (stream-set-cursor-position stream 30 30) (funcall continuation stream) (draw-line* stream 30 15 30 45 :ink +green+) (draw-line* stream 15 30 45 30 :ink +green+) @@ -1248,7 +1248,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (draw-rectangle* stream left top right bottom :filled nil :ink +cyan+)))) (define-table-cell-test set-cursor-position* "move the cursor, output some text" - (stream-set-cursor-position* stream 50 50) + (stream-set-cursor-position stream 50 50) (write-string ">Wally<" stream)) (define-test (comprehensive-table-tests formatted-output) (stream) @@ -1366,7 +1366,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (updating-output (stream) (updating-output (stream :unique-id 'test :cache-value tick) - (stream-set-cursor-position* stream 10 10) + (stream-set-cursor-position stream 10 10) (surrounding-output-with-border (stream) (format stream "Tick ~A" value)))))) (repeat 5 @@ -1474,7 +1474,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (draw-line* stream 0 0 20 20 :line-thickness 0) (draw-circle* stream 50 10 10))) (incf delta-y 30)) - (stream-set-cursor-position* stream 0 delta-y))) + (stream-set-cursor-position stream 0 delta-y))) (loop (accept 'integer :stream stream) (fresh-line stream))) diff --git a/test/test.lisp b/test/test.lisp index 44f236db..057ba633 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.19 92/04/10 14:27:21 cer Exp Locker: cer $ +;; $fiHeader: test.lisp,v 1.20 92/04/15 11:47:45 cer Exp Locker: cer $ (in-package :clim-user) @@ -49,7 +49,17 @@ (:command-table test-frame) (:pane (scrolling () - (make-pane 'interactor-pane)))) + (make-pane 'interactor-pane))) + + (:icon :name "foo" + :pixmap (make-pattern + (let ((x (make-array '(48 48)))) + (dotimes (i 48) + (dotimes (j 48) + (setf (aref x i j) (random 2)))) + x) + (list +red+ +green+))) + (:geometry :width 100 :height 200)) (define-application-frame test-frame01 () () @@ -401,12 +411,14 @@ :activate-callback 'push-button-callback) (make-pane 'push-button :label "B2" - :activate-callback 'push-button-callback))) + :activate-callback 'push-button-callback) + :fill)) (outlining () (horizontally () (make-pane 'toggle-button :label "T1" :value-changed-callback 'toggle-button-callback) + :fill (make-pane 'toggle-button :label "T2" :value-changed-callback @@ -435,47 +447,50 @@ (define-application-frame tf98 () () - (:command-table test-frame) - (:pane - (vertically () - (outlining () - (horizontally () - (make-pane 'push-button - :label "B1" - :activate-callback 'push-button-callback) - (make-pane 'push-button - :label "B2" - :activate-callback 'push-button-callback))) - (outlining () - (horizontally () - (make-pane 'toggle-button - :label "T1" - :value-changed-callback 'toggle-button-callback) - (make-pane 'toggle-button - :label "T2" - :value-changed-callback - 'toggle-button-callback))) - (outlining () - (horizontally () - (scrolling () - (make-pane 'text-editor - :value "lucid sucks" - :value-changed-callback 'text-field-changed - :ncolumns 30 - :nlines 10)) - (scrolling () - (make-pane 'text-editor - :value "harlqn sucks more" - :value-changed-callback 'text-field-changed - :ncolumns 30 - :nlines 10)))) - (outlining () - (spacing () - (make-pane 'slider - :label "Slider" - :show-value-p t - :value-changed-callback 'slider-changed-callback - :drag-callback 'slider-dragged-callback)))))) + (:command-table test-frame) + (:pane + (outlining () + (horizontally () + (make-pane + 'xm-silica::motif-scrolling-window + :contents + (make-pane 'text-editor + :value "lucid sucks" + :value-changed-callback 'text-field-changed + :ncolumns 30 + :nlines 10)) + (make-pane + 'xm-silica::motif-scrolling-window + :contents (make-pane 'text-editor + :value "harlqn sucks more" + :value-changed-callback 'text-field-changed + :ncolumns 30 + :nlines 10)))))) + + +(define-application-frame tf97 + () () + (: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 + :items '("eenie" "meanie" "minie") + :label "moo") + (outlining () + (make-pane + 'xm-silica::motif-scrolling-window + :contents + (make-pane 'text-editor + :value + "lucid are nice guys " + :value-changed-callback 'text-field-changed + :ncolumns 30 + :nlines 10)))))) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index d54a1ee4..8392f14a 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.11 92/03/09 17:41:25 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.12 92/04/10 14:27:49 cer Exp Locker: cer $ (in-package :xm-silica) @@ -140,10 +140,26 @@ ((command-table :initarg :command-table))) (defmethod find-widget-class-and-initargs-for-sheet - ((port motif-port) (parent t) (sheet motif-menu-bar)) - (values 'tk::xm-menu-bar - (list :resize-height t - :resize-width t))) + ((port motif-port) (parent t) (sheet motif-menu-bar)) + (if (flat-command-table-menu-p (slot-value sheet 'command-table)) + (values 'xt::xm-row-column + ;;--- It makes sense to be able to specify the orientation + ;;--- of the command menu + (list :orientation :horizontal)) + (values + 'tk::xm-menu-bar + (list :resize-height t + :resize-width t)))) + +(defun flat-command-table-menu-p (ct) + (map-over-command-table-menu-items + #'(lambda (menu keystroke item) + (declare (ignore keystroke menu)) + (let ((type (command-menu-item-type item))) + (when (eq type :menu) (return-from flat-command-table-menu-p nil)))) + ct) + t) + ;;; If would be nice if we could abstract this and use it for the OLIT ;;; port @@ -188,20 +204,20 @@ (let* ((ct (find-command-table (second item))) (tick (slot-value ct 'clim-internals::menu-tick))) (tk::add-callback (tk::widget-parent submenu) - :popup-callback - #'(lambda (ignore) - (declare (ignore ignore)) - (let ((children - (tk::widget-children submenu))) - (when (or (null children) - (/= tick - (setq tick - (slot-value ct 'clim-internals::menu-tick)))) - (mapc #'tk::destroy-widget children) - (make-menu-for-command-table - ct - submenu - nil)))))))) + :popup-callback + #'(lambda (ignore) + (declare (ignore ignore)) + (let ((children + (tk::widget-children submenu))) + (when (or (null children) + (/= tick + (setq tick + (slot-value ct 'clim-internals::menu-tick)))) + (mapc #'tk::destroy-widget children) + (make-menu-for-command-table + ct + submenu + nil)))))))) (make-menu-for-command-table-1 (command-table parent top) ;; Unless we are at the top level we want to have a ;; map-before callback that sets the sensitivity of @@ -248,19 +264,57 @@ command-table) commands-and-buttons))) - (make-menu-for-command-table - (slot-value sheet 'command-table) - mirror - t)) + (let ((ct (slot-value sheet 'command-table))) + (make-menu-for-command-table + ct mirror (not (flat-command-table-menu-p ct))))) mirror)) (defmethod port-dialog-view ((port motif-port)) +gadget-dialog-view+) ;;--- Should "ungray" the command button, if there is one +;;--- If the command button is visible, right now since everything is +;;--- in a menu we do not have a problem with this. + (defmethod note-command-enabled ((framem motif-frame-manager) frame command) (declare (ignore frame command))) ;;--- Should "gray" the command button, if there is one (defmethod note-command-disabled ((framem motif-frame-manager) frame command) (declare (ignore frame command))) + +(defmethod silica::update-frame-settings ((framem motif-frame-manager) (frame t)) + ;;--- Lets see how this works out + (let ((shell (sheet-shell (frame-top-level-sheet frame)))) + (let ((sr (compose-space (frame-top-level-sheet frame)))) + (tk::set-values shell + :min-width (fix-coordinate (space-requirement-min-width sr)) + :min-height + (fix-coordinate (space-requirement-min-height sr)))) + (let ((geo (clim-internals::frame-geometry frame))) + (destructuring-bind + (&key x y width height &allow-other-keys) geo + ;;-- what about width and height + (when (and width height) + (tk::set-values shell :width width :height height)) + (when (and x y) + (tk::set-values shell + :x (fix-coordinate x) + :y (fix-coordinate y))))) + (let ((icon (clim-internals::frame-icon frame))) + (flet ((decode-pixmap (x) + (etypecase x + (string x) + (pattern + (let ((sheet (frame-top-level-sheet frame))) + (with-sheet-medium (medium sheet) + (second + (decode-gadget-background medium sheet x)))))))) + (destructuring-bind + (&key name pixmap clip-mask) icon + (when name + (tk::set-values shell :icon-name name)) + (when pixmap + (tk::set-values shell :icon-pixmap (decode-pixmap pixmap))) + (when mask-pixmap + (tk::set-values shell :clip-mask (decode-pixmap mask-pixmap)))))))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 9ca10649..fd9aec4a 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.21 92/04/14 15:30:10 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.22 92/04/15 11:48:40 cer Exp Locker: cer $ (in-package :xm-silica) @@ -109,7 +109,7 @@ (parent t) (sheet motif-label-pane)) (with-accessors ((label gadget-label) - (alignment gadget-alignment)) sheet + (alignment silica::gadget-alignment)) sheet (values 'tk::xm-label (append (list :alignment @@ -182,19 +182,6 @@ ;; Now does nothing ) -(defmethod gadget-value ((gadget motif-value-pane)) - ;;--- We should use the scale functions to get the value - (let ((mirror (sheet-direct-mirror gadget))) - (if mirror - (tk::get-values mirror :value) - (call-next-method)))) - -(defmethod (setf gadget-value) (nv (gadget motif-value-pane) &key) - (let ((gadget (sheet-mirror gadget))) - (when gadget - (tk::set-values gadget - :value nv)))) - ;;; range pane mixin (defclass motif-range-pane (motif-value-pane) ()) @@ -248,32 +235,57 @@ (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+))))))) + (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 - (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 + (sx sy swidth sheight) + (tk::widget-best-geometry (sheet-direct-mirror m)) + (declare (ignore sx sy)) + (let ((fudge 16)) + (ecase (gadget-orientation m) + (:vertical + (make-space-requirement :width swidth + :min-height fudge + :height (* 2 fudge) + :max-height +fill+)) + (:horizontal + (make-space-requirement :height sheight + :min-width fudge + :width (max (* 2 fudge) swidth) + :max-width +fill+)))))) + ;;; Scroll-Bar @@ -455,22 +467,35 @@ (and nlines (list :rows nlines)) (and value `(:value ,value)))))) -(defmethod set-mirror-geometry (parent (sheet motif-text-editor) initargs) - (multiple-value-bind (left top right bottom) - (sheet-actual-native-edges* sheet) - (setf (getf initargs :x) (floor left) - (getf initargs :y) (floor top)) - initargs)) +;(defmethod compute-initial-mirror-geometry (parent (sheet motif-text-editor) initargs) +; (multiple-value-bind (left top right bottom) +; (sheet-actual-native-edges* sheet) +; (setf (getf initargs :x) (floor left) +; (getf initargs :y) (floor top)) +; initargs)) +; +;(defmethod compute-initial-mirror-geometry (parent (sheet motif-scrolling-window) initargs) +; (multiple-value-bind (left top right bottom) +; (sheet-actual-native-edges* sheet) +; (setf (getf initargs :x) (floor left) +; (getf initargs :y) (floor top)) +; initargs)) (defmethod compose-space ((te motif-text-editor) &key width height) (declare (ignore width height)) (let ((sr (call-next-method))) (setq sr (silica::copy-space-requirement sr)) + ;;-- What it the correct thing to do??? (setf (space-requirement-max-width sr) +fill+ (space-requirement-max-height sr) +fill+) sr)) +(defmethod silica::gadget-supplied-scrolling (frame-manager frame (contents motif-text-editor) &rest ignore) + (declare (ignore ignore)) + (with-look-and-feel-realization (frame-manager frame) + (make-pane 'motif-scrolling-window :contents contents))) + ;;; Toggle button (defclass motif-toggle-button (xt-leaf-pane @@ -598,11 +623,10 @@ (gadget-id client) id))) -;;; Lets have a frame so that it can be nice and pretty - +;; Frame-viewport that we need because a sheet can have (defclass xm-frame-viewport - (sheet-single-child-mixin + (sheet-single-child-mixin sheet-permanently-enabled-mixin silica::wrapping-space-mixin pane @@ -610,7 +634,25 @@ ()) +(defmethod find-widget-class-and-initargs-for-sheet + ((port xt-port) (parent t) (sheet xm-frame-viewport)) + (values 'xm-drawing-area + ;;--- These are duplicated + (list :margin-width 0 + :resize-policy :none + :margin-height 0))) +;(defmethod allocate-space ((fr xm-frame-viewport) width height) +; ;;-- 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)) + (tk::add-callback widget + :resize-callback + 'sheet-mirror-resized-callback + sheet)) (defclass motif-frame-pane (motif-geometry-manager mirrored-sheet-mixin @@ -623,10 +665,12 @@ (defmethod initialize-instance :after ((pane motif-frame-pane) &key frame-manager frame contents) - (let ((viewport (with-look-and-feel-realization (frame-manager frame) - (make-pane 'xm-frame-viewport)))) - (sheet-adopt-child pane viewport) - (sheet-adopt-child viewport contents))) + (if (typep contents 'mirrored-sheet-mixin) + (sheet-adopt-child pane contents) + (let ((viewport (with-look-and-feel-realization (frame-manager frame) + (make-pane 'xm-frame-viewport)))) + (sheet-adopt-child pane viewport) + (sheet-adopt-child viewport contents)))) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) @@ -644,3 +688,230 @@ ;;-- We do not need to do anything here because ;;-- the pane should resize its child ) + +;;; Scrolling Window + +(defclass motif-scrolling-window (motif-geometry-manager + ask-widget-for-size-mixin + mirrored-sheet-mixin + sheet-single-child-mixin + sheet-permanently-enabled-mixin + pane) + ;;-- probably one of the options is whether to have vertical + ;;-- and/or horizontal scrollbars + ()) + +(defmethod initialize-instance :after ((pane motif-scrolling-window) &key contents) + (sheet-adopt-child pane contents)) + +(defmethod compose-space ((fr motif-scrolling-window) &key width height) + (declare (ignore width height)) + ;;--- This is not quite right because I think scrollbars are a bit + ;;--- bigger than this. But atleast its a start + (let ((fudge-factor (+ 16 + (tk::get-values (sheet-mirror fr) + :spacing))) + (sr (silica::copy-space-requirement (compose-space + (sheet-child fr))))) + (incf (space-requirement-width sr) fudge-factor) + (incf (space-requirement-height sr) fudge-factor) + ;;--- Is this the correct thing to do??? + (setf (space-requirement-min-width sr) fudge-factor + (space-requirement-min-height sr) fudge-factor) + sr)) + +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) + (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. + +(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) + (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) + ) + +;;; Option buttons + +(defclass motif-option-pane (xt-leaf-pane silica::labelled-gadget) + ((items :initarg :items :accessor option-pane-items)) + (:default-initargs :items nil)) + +(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 + (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)) + (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 + +(defmethod port-notify-user ((port motif-port) + message-string + &key + (style :inform) + (frame *application-frame*) + (associated-window + (frame-top-level-sheet frame)) + (title "Notify user") + documentation + (name title)) + (let ((dialog (make-instance (ecase style + (:inform 'tk::xm-information-dialog) + (:error 'tk::xm-error-dialog) + (:question 'tk::xm-question-dialog) + (:warning 'tk::xm-warning-dialog)) + :parent (sheet-mirror associated-window) + :name name + :dialog-title title + :message-string message-string + )) + (result nil)) + (multiple-value-bind + (help-button) + (get-message-box-child dialog :help) + (flet ((set-it (widget r) + (declare (ignore widget)) + (setq result (list r))) + (display-help (widget ignore) + (declare (ignore widget ignore)) + (port-notif-user + port + documentation + :associated-window associated-window))) + (tk::add-callback dialog :ok-callback #'set-it t) + (tk::add-callback dialog :cancel-callback #'set-it nil) + (if documentation + (tk::add-callback help-button :activate-callback #'display-help) + (xt::set-sensitive help-button nil)) + (unwind-protect + (progn + (tk::manage-child dialog) + (wait-for-callback-invocation + (port associated-window) + #'(lambda () result) + "Waiting for dialog")) + (tk::destroy-widget dialog)) + (car result))))) + + +(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))) + +(defun get-message-box-child (widget &rest children) + (values-list + (mapcar #'(lambda (child) + (tk::convert-resource-in + widget + 'tk::widget + (tk::xm-message-box-get-child + widget + (encode-box-child child)))) + children))) + +(defun encode-box-child (child) + (let ((x (getf '( + :none 0 + :apply 1 + :cancel 2 + :default 3 + :ok 4 + :filter-label 5 + :filter-text 6 + :help 7 + :list 8 + :history-list :list + :list-label 9 + :message-label 10 + :selection-label 11 + :prompt-label :selection-label + :symbol-label 12 + :text 13 + :value-text :text + :command-text :text + :separator 14 + :dir-list 15 + :dir-list-label 16 + :file-list :list + :file-list-label :list-label + ) + child))) + (cond ((null x) + (error "cannot encode child ~S" child)) + ((symbolp x) + (encode-box-child x)) + (t x)))) + +;;;; Working diff --git a/tk-silica/xm-menus.lisp b/tk-silica/xm-menus.lisp index b25fb5c6..5be5e84d 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.8 92/04/03 12:04:53 cer Exp Locker: cer $ +;; $fiHeader: xm-menus.lisp,v 1.9 92/04/10 14:27:51 cer Exp Locker: cer $ (in-package :xm-silica) @@ -51,7 +51,7 @@ (progn (setf (port-menu-cache port) (delete x (port-menu-cache port))) - (tk::destroy-widget amenu))))))) + (tk::destroy-widget (tk::widget-parent amenu)))))))) (unless menu (multiple-value-setq @@ -81,16 +81,19 @@ (tk::manage-child menu) ;; Now we have to wait (port-force-output port) - (mp::process-wait "Returned value" #'(lambda () - ;;-- This is to deal - ;;-- with the race - ;;-- condition where - ;;-- the menu go down - ;;-- to quick - (or (funcall closure) - (not (tk::is-managed-p menu)))))) + (wait-for-callback-invocation + port + #'(lambda () + ;;-- This is to deal + ;;-- with the race + ;;-- condition where + ;;-- the menu go down + ;;-- to quick + (or (funcall closure) + (not (tk::is-managed-p menu)))) + "Returned value")) (unless cache - (tk::destroy-widget menu)) + (tk::destroy-widget (tk::widget-parent menu))) (values-list (nth-value 1 (funcall closure)))))) @@ -121,9 +124,7 @@ :managed nil :separator-type :double-line :parent menu)) - (labels ((destroy-menu-pixmap (widget) - (tk::destroy-pixmap (tk:get-values widget :label-pixmap))) - (make-menu-button (item class parent &rest options) + (labels ((make-menu-button (item class parent &rest options) (if simplep (apply #'make-instance class @@ -145,7 +146,9 @@ :label-type :pixmap :label-pixmap pixmap options))) - (tk::add-callback button :destroy-callback #'destroy-menu-pixmap) + (xt::add-widget-cleanup-function + button + #'tk::destroy-pixmap pixmap) button))) (construct-menu-from-items (menu items) (map nil #'(lambda (item) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 6235b73e..305ec3bc 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.13 92/04/10 14:27:53 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.lisp,v 1.14 92/04/15 11:48:43 cer Exp Locker: cer $ (in-package :xm-silica) @@ -80,7 +80,9 @@ about their children")) (defmethod update-geo-manager-sheet-children (geo-manager) (dolist (child (sheet-children geo-manager)) - (mirror-region-updated (port geo-manager) child))) + ;;--- Yuck! + (when (typep child 'mirrored-sheet-mixin) + (mirror-region-updated (port geo-manager) child)))) (defmethod find-shell-class-and-initargs ((port motif-port) sheet) (declare (ignore port)) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 86dc1e50..faf1acdb 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.lisp,v 1.7 92/04/10 14:27:56 cer Exp Locker: cer $ +;; $fiHeader: xt-frames.lisp,v 1.8 92/04/15 11:48:47 cer Exp Locker: cer $ (in-package :xm-silica) @@ -87,8 +87,9 @@ :sheet (frame-top-level-sheet frame) :value (second item)))) -(defmethod clim-internals::port-notify-user ((port xt-port) - frame format-string &rest format-arguments) +(defmethod port-notify-user ((port xt-port) + message-string + &key) (format excl::*initial-terminal-io* "Notify ~a~%" - (list frame format-string format-arguments))) + message-string)) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index b111efc1..477aa7df 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.15 92/04/10 14:27:58 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.16 92/04/15 11:48:57 cer Exp Locker: cer $ (in-package :xm-silica) @@ -116,6 +116,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (setf (tk::gcontext-foreground foreground-gcontext) foreground-pixel (tk::gcontext-background foreground-gcontext) background-pixel (tk::gcontext-foreground background-gcontext) background-pixel + (tk::gcontext-background background-gcontext) background-pixel (tk::gcontext-foreground flipping-gcontext) (logxor foreground-pixel background-pixel)))))) @@ -286,11 +287,13 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (multiple-value-bind (red green blue) (color-rgb ink) (tk::allocate-color - (tk::default-colormap (port-display (port (medium-sheet medium)))) - (make-instance 'tk::color - :red (truncate (* 65356 red)) - :green (truncate (* 65356 green)) - :blue (truncate (* 65356 blue)))))) + (tk::default-colormap (port-display (port + (medium-sheet medium)))) + (let ((x #.(1- (ash 1 16)))) + (make-instance 'tk::color + :red (truncate (* x red)) + :green (truncate (* x green)) + :blue (truncate (* x blue))))))) (t (multiple-value-bind (r g b) (color-rgb ink) ;; The luminance formula isn't really right. XXX @@ -556,8 +559,9 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ;; towards-point towards-x towards-y ;; transform-glyphs ) - (let ((transform (sheet-device-transformation sheet)) - (font (text-style-mapping port (medium-text-style medium)))) + (let* ((transform (sheet-device-transformation sheet)) + (font (text-style-mapping port (medium-text-style medium))) + (ascent (tk::font-ascent font))) (convert-to-device-coordinates transform x y) (when (typep string-or-char 'character) (setq string-or-char (string string-or-char))) @@ -573,9 +577,15 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (floor (text-style-height (medium-text-style medium) port) 2)))) (:baseline nil) (:top - (incf y (tk::font-ascent font)))) + (incf y ascent))) (when (medium-drawable medium) - (let ((gc (decode-ink (medium-ink medium) medium))) + (let ((gc (adjust-ink + medium + (decode-ink (medium-ink medium) medium) + (medium-ink medium) + (medium-line-style medium) + x + (- y ascent)))) (setf (tk::gcontext-font gc) font) (tk::draw-string (medium-drawable medium) @@ -587,6 +597,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (defmethod port-write-string-1 ((port xt-port) medium glyph-buffer start end x-font color x y) + (break "is this used anymore") (unless (= start end) (let* ((sheet (medium-sheet medium)) (transform (sheet-device-transformation sheet)) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 61e3e7b7..2c516896 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.18 92/04/10 14:27:59 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.19 92/04/15 11:49:06 cer Exp Locker: cer $ (in-package :xm-silica) @@ -368,18 +368,18 @@ :native-y (x11::xbuttonevent-y event)))))) (defmethod find-widget-class-and-initargs-for-sheet - ((port xt-port) (parent t) (sheet sheet)) - (values 'xm-drawing-area (list :resize-policy :grow))) + ((port xt-port) (parent t) (sheet sheet)) + (error "we should not be here")) (defmethod find-widget-class-and-initargs-for-sheet :around ((port xt-port) (parent t) (sheet sheet)) (multiple-value-bind (class initargs) (call-next-method) - (setq initargs (set-mirror-geometry parent sheet initargs)) + (setq initargs (compute-initial-mirror-geometry parent sheet initargs)) (values class initargs))) -(defmethod set-mirror-geometry (parent sheet initargs) +(defmethod compute-initial-mirror-geometry (parent sheet initargs) ;;--- Should we pass in the size of the sheet even though it is ;; liable to be quite stupid ;; We really want to just create the gadgets and then let the layout @@ -392,6 +392,8 @@ (unless (typep parent 'tk::shell) (setf (getf initargs :x) (fix-coordinate left) (getf initargs :y) (fix-coordinate top))) + ;;--- We should not do this, see realize-mirror :around in mirror + #+ignore (setf (getf initargs :width) (fix-coordinate (- right left)) (getf initargs :height) (fix-coordinate (- bottom top))))) initargs) @@ -829,3 +831,39 @@ (if (logtest x x11:mod1mask) +meta-key+ 0) (if (logtest x x11:mod2mask) +super-key+ 0) (if (logtest x x11:mod3mask) +hyper-key+ 0))) + +;;;---- This is just an experiment + +(defmethod engraft-medium :before ((medium t) (port xt-port) (pane clim-stream-pane)) + (default-from-mirror-resources port pane)) + +(defmethod engraft-medium :before ((medium t) (port xt-port) (pane top-level-sheet)) + (default-from-mirror-resources port pane)) + +;;-- What do we do about pixmap streams. I guess they should inherit +;;-- properties from the parent. + +;;--- Unless the foreground, background and default-text-style have +;;--- been set we want to query the resource database for the values +;; Either (a) ask a widget or (b) Do it directly. +;; Well it looks like we have to use a widget +;; If we wanted to get a font then we are in trouble because + +(defun default-from-mirror-resources (port pane) + (let ((w (sheet-mirror pane))) + (multiple-value-bind + (foreground background) + ;;-- What about the case when there is a pixmap + (tk::get-values w :foreground :background) + ;; Now we have to convert into CLIM colors. + (flet ((ccm (x) + (multiple-value-bind + (r g b) + (tk::query-color (tk::default-colormap (port-display port)) x) + (let ((x #.(1- (ash 1 16)))) + (make-rgb-color + (/ r x) + (/ g x) + (/ b x)))))) + (setf (medium-foreground pane) (ccm foreground) + (medium-background pane) (ccm background)))))) diff --git a/tk/convenience.lisp b/tk/convenience.lisp index 037c0fdd..eb95c716 100644 --- a/tk/convenience.lisp +++ b/tk/convenience.lisp @@ -20,52 +20,11 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: convenience.lisp,v 1.5 92/03/09 17:40:34 cer Exp $ +;; $fiHeader: convenience.lisp,v 1.6 92/03/30 17:51:29 cer Exp Locker: cer $ (in-package :tk) ; -; -; -;(defmacro define-convenience-function (name entry-point class) -; (let ((c-function-name (intern (substitute #\_ #\- (symbol-name name))))) -; `(progn -; (defforeign ',c-function-name -; :entry-point ,entry-point) -; (defun ,name (parent name &rest arglist) -; (let ((arglist (make-arglist-for-class -; (find-class ',class) -; parent -; arglist))) -; (register-handle -; (make-instance -; ',class -; :display display -; :foreign-address -; (,c-function-name -; parent -; (string-to-char* name) -; arglist -; (truncate (length arglist) 2))))))))) -; -; -;(define-convenience-function create-menu-bar -; "_XmCreateMenuBar" -; xm-row-column) -; -;(define-convenience-function create-pulldown-menu -; "_XmCreatePulldownMenu" -; xm-row-column) -; -;(define-convenience-function create-row-column -; "_XmCreateRowColumn" -; xm-row-column) -; -; -;(define-convenience-function create-radio-box -; "_XmCreateRadioBox" -; xm-row-column) - (defmacro define-convenience-class (class superclasses entry-point) (let ((c-function-name (intern (substitute #\_ #\- @@ -99,3 +58,10 @@ (define-convenience-class xm-pulldown-menu (xm-row-column) "_XmCreatePulldownMenu") (define-convenience-class xm-radio-box (xm-row-column) "_XmCreateRadioBox") (define-convenience-class xm-popup-menu (xm-row-column) "_XmCreatePopupMenu") + +(define-convenience-class xm-option-menu (xm-row-column) "_XmCreateOptionMenu") + +(define-convenience-class xm-question-dialog (xm-message-box) "_XmCreateQuestionDialog") +(define-convenience-class xm-warning-dialog (xm-message-box) "_XmCreateWarningDialog") +(define-convenience-class xm-information-dialog (xm-message-box) "_XmCreateInformationDialog") +(define-convenience-class xm-error-dialog (xm-message-box) "_XmCreateErrorDialog") diff --git a/tk/foreign-obj.lisp b/tk/foreign-obj.lisp index 98b8a686..4a190571 100644 --- a/tk/foreign-obj.lisp +++ b/tk/foreign-obj.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign-obj.lisp,v 1.7 92/03/09 17:40:41 cer Exp Locker: cer $ +;; $fiHeader: foreign-obj.lisp,v 1.8 92/04/10 14:26:15 cer Exp Locker: cer $ (in-package :tk) @@ -55,6 +55,10 @@ (setf (gethash handle *xid->object-mapping*) object) object) +(defun unregister-xid (object &optional (handle (foreign-pointer-address object))) + (remhash handle *xid->object-mapping*) + object) + (defun intern-object-address (handle class &rest initargs) (apply #'intern-object-1 *address->object-mapping* diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index 9765f84a..bd2854ae 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gcontext.lisp,v 1.9 92/03/30 17:51:35 cer Exp $ +;; $fiHeader: gcontext.lisp,v 1.10 92/04/15 11:44:44 cer Exp Locker: cer $ (in-package :tk) @@ -44,8 +44,8 @@ (font x-font) (subwindow-mode :int) (exposures :boolean) - (clip-x :int) - (clip-y :int) + (clip-x-origin :int) + (clip-y-origin :int) (clip-mask :pixmap) (dash-offset :int) (dashes :char))) @@ -54,7 +54,7 @@ '(function plane-mask foreground background line-width line-style cap-style join-style fill-style fill-rule tile stipple ts-x-origin ts-y-origin font subwindow-mode - exposures clip-x clip-y clip-mask dash-offset dashes + exposures clip-x-origin clip-y-origin clip-mask dash-offset dashes arc-mode))) @@ -89,7 +89,7 @@ cap-style join-style fill-style fill-rule arc-mode tile stipple ts-x ts-y font subwindow-mode - exposures clip-x clip-y + exposures clip-x-origin clip-y-origin clip-mask clip-ordering dash-offset dashes) @@ -119,8 +119,8 @@ (when font (setf (gcontext-font gcontext) font)) (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode)) (when exposures (setf (gcontext-exposures gcontext) exposures)) - (when clip-x (setf (gcontext-clip-x gcontext) clip-x)) - (when clip-y (setf (gcontext-clip-y gcontext) clip-y)) + (when clip-x-origin (setf (gcontext-clip-x-origin gcontext) clip-x-origin)) + (when clip-y-origin (setf (gcontext-clip-y-origin gcontext) clip-y-origin)) (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask)) (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset)) (when dashes (setf (gcontext-dashes gcontext) dashes)) @@ -244,8 +244,8 @@ (define-gc-accessor subwindow-mode (encode-enum decode-enum) '(:clip-by-children :include-inferiors)) (define-gc-accessor exposures (encode-enum decode-enum) '(:off :on)) -(define-gc-accessor clip-x (encode-int16 decode-int16)) -(define-gc-accessor clip-y (encode-int16 decode-int16)) +(define-gc-accessor clip-x-origin (encode-int16 decode-int16)) +(define-gc-accessor clip-y-origin (encode-int16 decode-int16)) (define-gc-accessor dash-offset (encode-card16 decode-card16)) (define-gc-accessor arc-mode (encode-enum decode-enum) '(:chord :pie-slice)) diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index 5458a634..dee05f8f 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-classes.lisp,v 1.12 92/04/03 12:04:03 cer Exp Locker: cer $ +;; $fiHeader: make-classes.lisp,v 1.13 92/04/15 11:44:47 cer Exp Locker: cer $ (in-package :tk) @@ -76,9 +76,14 @@ (defclass xt-root-class (display-object) ((events :initform nil :accessor widget-event-handler-data) (callbacks :initform nil :accessor widget-callback-data) - (window-cache :initform nil)) + (window-cache :initform nil) + (cleanups :initform nil :accessor widget-cleanup-functions)) (:metaclass xt-class)) +(defmethod add-widget-cleanup-function ((widget xt-root-class) fn &rest args) + (push (list* fn args) + (widget-cleanup-functions widget))) + (defmethod widget-display ((object xt-root-class)) (object-display object)) diff --git a/tk/resources.lisp b/tk/resources.lisp index c80a7551..0c781512 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.14 92/04/10 14:26:17 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.15 92/04/15 11:44:49 cer Exp Locker: cer $ (in-package :tk) @@ -157,10 +157,17 @@ (check-type value integer) value) +(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-int)) value) + (check-type value integer) + value) + (defmethod convert-resource-out ((parent t) (type (eql 'vertical-dimension)) value) value) +(defmethod convert-resource-out ((parent t) (type (eql 'vertical-int)) value) + value) + (defmethod convert-resource-out ((parent t) (type (eql 'visual-policy)) value) (ecase value (:constant 1))) @@ -201,15 +208,22 @@ (defmethod convert-resource-out ((parent t) (type (eql 'gadget-pixmap)) value) (convert-pixmap-out parent value)) +(defmethod convert-resource-out ((parent t) (type (eql 'pixmap)) value) + (convert-pixmap-out parent value)) + +(defmethod convert-resource-out ((parent t) (type (eql 'bitmap)) value) + (convert-pixmap-out parent value)) + + (defun convert-pixmap-out (parent value) (etypecase value (pixmap value) (string (let* ((display (widget-display parent)) (screen (x11:xdefaultscreenofdisplay display)) - (white (screen_white_pixel screen)) - (black (screen_black_pixel screen))) - (get_pixmap screen (string-to-char* value) white black))))) + (white (x11::xwhitepixel display 0)) + (black (x11::xblackpixel display 0))) + (get_pixmap screen (string-to-char* value) black white))))) (defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value) (if value 1 0)) @@ -542,3 +556,19 @@ (defmethod convert-resource-out (parent (type (eql 'xt::accelerator-table)) (value (eql nil))) 0) + +(define-enumerated-resource visual-policy (:variable :constant)) +(define-enumerated-resource scroll-bar-display-policy (:static :as-needed)) + +(defmethod convert-resource-out (parent (type (eql 'xm-string-table)) value) + (if value + (do* ((n (length value)) + ;;--- Malloc alert + (r (excl::malloc (* n 4))) + (v value (cdr v)) + (i 0 (1+ i))) + ((null v) + r) + (setf (x-arglist r i) + (convert-resource-out parent 'xm-string (car v)))) + 0)) diff --git a/tk/widget.lisp b/tk/widget.lisp index af9eb3d4..65ec6171 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: widget.lisp,v 1.15 92/04/10 14:26:19 cer Exp Locker: cer $ +;; $fiHeader: widget.lisp,v 1.16 92/04/15 11:44:53 cer Exp Locker: cer $ (in-package :tk) @@ -109,18 +109,19 @@ (if (typep x 'clos::class) x (find-class x))) -(defmethod widget-window (widget &optional (errorp t)) +(defmethod widget-window (widget &optional (errorp t) peek) (with-slots (window-cache) widget (or window-cache - (setf window-cache - (let ((id (xt_window widget))) - (if (zerop id) - (and errorp - (error "Invalid window id ~D for ~S" id widget)) - (intern-object-xid - id - 'window - :display (widget-display widget)))))))) + (and (not peek) + (setf window-cache + (let ((id (xt_window widget))) + (if (zerop id) + (and errorp + (error "Invalid window id ~D for ~S" id widget)) + (intern-object-xid + id + 'window + :display (widget-display widget))))))))) (defun make-clx-window (display widget) (let* ((window-id (xt_window widget))) @@ -151,6 +152,14 @@ (setf (foreign-pointer-address w) (apply #'make-widget w args)))))) +(defmethod destroy-widget-cleanup ((widget xt-root-class)) + (dolist (cleanup (widget-cleanup-functions widget)) + (apply (car cleanup) (cdr cleanup))) + ;;--- When we start using gadgets things will be fun! + (let ((w (widget-window widget nil t))) + (when w (unregister-xid w))) + (unintern-widget widget)) + (defun intern-widget (widget-address &rest args) (unless (zerop widget-address) (multiple-value-bind @@ -161,12 +170,12 @@ (widget-class-of widget-address) args) (when newp - (add-callback widget :destroy-callback #'unintern-widget)) + (add-callback widget :destroy-callback #'destroy-widget-cleanup)) widget))) (defun register-widget (widget &optional (handle (foreign-pointer-address widget))) (register-address widget handle) - (add-callback widget :destroy-callback #'unintern-widget)) + (add-callback widget :destroy-callback #'destroy-widget-cleanup)) (defun unintern-widget (widget) (unintern-object-address (foreign-pointer-address widget))) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index d0a390a9..1421cfa5 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.13 92/03/30 17:51:52 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.14 92/04/15 11:44:54 cer Exp Locker: cer $ (in-package :tk) @@ -91,6 +91,10 @@ (height :initarg :height :reader pixmap-height) (depth :initarg :depth :reader drawable-depth))) +(defun destroy-pixmap (pixmap) + (unregister-xid pixmap) + (x11:xfreepixmap (object-display pixmap) pixmap)) + (defmethod initialize-instance :after ((p pixmap) &key foreign-address width height depth drawable) (with-slots (display) p @@ -195,6 +199,18 @@ (make-instance 'color :foreign-address y))))) +(defun query-color (colormap x) + ;;--- Resource time + (let ((y (x11::make-xcolor))) + (setf (x11:xcolor-pixel y) x) + (x11:xquerycolor + (object-display colormap) + colormap + y) + (values + (x11:xcolor-red y) + (x11:xcolor-green y) + (x11:xcolor-blue y)))) (defun default-screen (display) (intern-object-address diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp index 851d7a37..3aaf2ac7 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$ +;; $fiHeader: xm-funs.lisp,v 1.1 92/03/30 17:58:42 cer Exp Locker: cer $ (in-package :tk) @@ -34,3 +34,6 @@ (defforeign 'get_pixmap :entry-point "_XmGetPixmap") + +(defforeign 'xm-message-box-get-child + :entry-point "_XmMessageBoxGetChild") diff --git a/utils/regions.lisp b/utils/regions.lisp index 2df2fa2e..97433c8c 100644 --- a/utils/regions.lisp +++ b/utils/regions.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: regions.lisp,v 1.5 92/03/04 16:20:23 cer Exp $ +;; $fiHeader: regions.lisp,v 1.6 92/04/15 11:45:37 cer Exp Locker: cer $ (in-package :clim-utils) @@ -449,17 +449,6 @@ (when (> y1 y2) (rotatef y1 y2)) (make-bounding-rectangle-1 x1 y1 x2 y2))) -#+Silica -(defun make-bounding-rectangle (x1 y1 x2 y2) - (let ((x1 (float x1 0f0)) - (y1 (float y1 0f0)) - (x2 (float x2 0f0)) - (y2 (float y2 0f0))) - (declare (type coordinate x1 y1 x2 y2)) - (when (> x1 x2) (rotatef x1 x2)) - (when (> y1 y2) (rotatef y1 y2)) - (make-bounding-rectangle-1 x1 y1 x2 y2))) - (defmethod make-load-form ((rectangle standard-bounding-rectangle)) (with-slots (left top right bottom) rectangle `(make-bounding-rectangle ,left ,top ,right ,bottom))) -- GitLab