diff --git a/Makefile b/Makefile index 1107e75ab577291005a7c95c9585cb2370c29d6c..97bac99b909d042afa6eaf9388e04b9aee525a49 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,18 @@ -DIRS= . +SOMEDIRS=utils silica clim ws xm-silica +DIRS=$(SOMEDIRS) xlib tk +DEVICE=/dev/null +CL=/usr/composer2/composer2 + +default: compile + +compile : FRC + $(CL) < misc/go.cl clean : FRC find $(DIRS) -name "*.fasl" -exec $(RM) "{}" \; FRC : + + +swm-tape: + tar cf $(DEVICE) `find misc $(SOMEDIRS) '(' -name "*.cl" -o -name "*.lisp" ')' -print` diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp index df1e2a2de7d507f4eb4118c774771c40e7d15627..052fe5de8f35f74411f66f077801e8c9f4b60bf4 100644 --- a/clim/clim-defs.lisp +++ b/clim/clim-defs.lisp @@ -379,3 +379,21 @@ (push `(setf ,(first pts) (the fixnum (+ ,(first pts) ,x-delta))) forms) (push `(setf ,(second pts) (the fixnum (+ ,(second pts) ,y-delta))) forms)) (nreverse forms))))) + +(defmacro with-scaling ((medium sx &optional (sy nil sy-p)) &body body) + `(with-drawing-options (,medium + :transformation (let* ((scale-x ,sx) + (scale-y ,(if sy-p sy 'scale-x))) + (make-scaling-transformation scale-x scale-y))) + ,@body)) + +(defmacro with-translation ((medium dx dy) &body body) + `(with-drawing-options (,medium + :transformation (make-translation-transformation ,dx ,dy)) + ,@body)) + +(defmacro with-rotation ((medium angle &optional (origin nil origin-p)) &body body) + `(with-drawing-options (,medium + :transformation (make-rotation-transformation ,angle + ,@(if origin-p `(,origin) nil))) + ,@body)) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index b796dce336ef677129208f1851f8663501a3467c..cb2edb4873d6bf04981b02b4e419949092676a2d 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -82,7 +82,7 @@ ) () (:default-initargs :medium t - :max-width +fill+ :min-width +fill+ :max-height +fill+ :min-height +fill+)) + :max-width +fill+ :min-width 0 :max-height +fill+ :min-height 0)) @@ -142,13 +142,13 @@ ;;; to represent the size of the contents, but may be stretched to fill the ;;; available viewport space. -(defmethod change-space-req :around ((pane extended-stream-pane) &rest keys &key hs vs) +(defmethod silica::change-space-req :around ((pane extended-stream-pane) &rest keys &key width height) (declare (dynamic-extent keys)) - ;; Assume always called with hs vs + ;; Assume always called with width height (multiple-value-bind (history-width history-height) (bounding-rectangle-size (output-recording-stream-output-record pane)) ;; Don't ever shrink down smaller than our contents. - (apply #'call-next-method pane :hs (max hs history-width) :vs (max vs history-height) keys))) + (apply #'call-next-method pane :width (max width history-width) :height (max height history-height) keys))) (defclass basic-clim-interactor (extended-stream-pane) ((display-function :initarg :display-function diff --git a/clim/frames.lisp b/clim/frames.lisp index 8c9a736336a51f3ca51b823f219c46b90c11c404..0cfb6e9f9e0ff523cd5a6023bf9d2ff916b88aa9 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -38,8 +38,8 @@ (panes :initarg :panes :accessor frame-panes) (top-level-sheet :accessor frame-top-level-sheet :initform nil) (shell :accessor frame-shell) - (state :initform :disowned :accessor frame-state - :type (member :disowned :enable :disabled :shrunk)) + (state :initform :disabled :accessor frame-state + :type (member :disabled :enable :disabled :shrunk)) (command-table :initarg :command-table :initform (find-command-table 'user-command-table) :accessor frame-command-table) @@ -54,6 +54,9 @@ (defmethod frame-name ((frame application-frame)) (format nil "~A" (type-of frame))) +(defmethod frame-pretty-name ((frame application-frame)) + (frame-name frame)) + (defvar *frame-managers* nil) (defun find-frame-manager (&rest options) @@ -104,10 +107,8 @@ ,@(and command-table `(:command-table (clim-internals::find-command-table ',(car command-table)))))) ,@(when command-table - `((define-command-table ,(first - command-table) - ,@(and (cdr command-table) - `(:inherit-from ,(cdr command-table)))))) + `((define-command-table ,(first command-table) + ,@(cdr command-table)))) ,@(when command-definer (compute-command-definer-code name command-table)) ,@(compute-generate-panes-code name pane)))) @@ -134,9 +135,14 @@ `((defmethod generate-panes ((,f ,name) (,fm frame-manager)) (let ((*application-frame* ,f)) (setf (frame-panes ,f) - (with-look-and-feel-realization - (,fm ,f) - ,code)))))))) + (frame-wrapper + ,f ,fm + (with-look-and-feel-realization + (,fm ,f) + ,code))))))))) + +(defmethod frame-wrapper ((frame t) (framem t) pane) + pane) (defmacro with-look-and-feel-realization ((realizer frame) &rest forms) `(macrolet ((silica::realize-pane (&rest foo) @@ -164,7 +170,11 @@ (let ((sr (compose-space (frame-panes frame)))) (setq width (silica::space-req-width sr) height (silica::space-req-height sr)))) - (allocate-space (frame-panes frame) width height)) + (allocate-space (frame-panes frame) width height) + #+shouldwebedoingthiskindofthing? + (when (frame-top-level-sheet frame) + (silica::resize-sheet* (frame-top-level-sheet frame) + width height))) (defun make-application-frame (class &rest options &key enable &allow-other-keys) (with-rem-keywords (options options '(:enable)) diff --git a/clim/menus.lisp b/clim/menus.lisp index a45b0c3267b887eaa14545bdfcbda3f0196d4fdc..ed883b0db3901b52ad0a2bbde48ae5d14c96eddb 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,58 +1,31 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-INTERNALS; Base: 10 -*- -(in-package "CLIM-INTERNALS") +(in-package :clim-internals) "Copyright (c) 1988, 1989, 1990 International Lisp Associates. All rights reserved." (defparameter *default-menu-margin-components* '((margin-borders :thickness 2) (margin-white-borders :thickness 2))) -#-Silica -(defresource menu (associated-window root) - :constructor (open-window-stream :parent root ;"random" size - :left 100 :top 100 :width 1000 :height 500 - ;; :margin-components *default-menu-margin-components* - :scroll-bars ':vertical - :save-under T - ) - :deinitializer (window-clear menu) - ;; We used to have an initializer that set record-p, cleared the window, and set - ;; the size. Record-p is unnecessary because we explicitly bind it below - ;; when drawing the menu contents. (Also, it should always be T anyway.) - ;; Clearing the window is unnecessary because it's done in the deinitializer. - ;; Setting the size is also unnecessary. Any application that's formatting - ;; into a menu is required to use with-end-of-line-action and with-end-of-page-action - ;; or set the size first itself. - :initializer (initialize-menu menu associated-window) - :matcher (eql (window-parent menu) root) - ) +(define-application-frame menu-frame () + (menu) + (:pane + (with-slots (menu) *application-frame* + (silica::scrolling () + (setq menu (silica::realize-pane 'extended-stream-pane + :initial-cursor-visibility nil + )))))) -#+Silica (defun get-menu (&key server-path) - (let ((framem (find-frame-manager :server-path server-path)) - (frame (make-frame 'frame :plain t :no-message t :save-under T)) - (menu nil)) - (ws:with-look-and-feel-realization (framem frame) - (setf (frame-pane frame) - (bordering () - (spacing (:space 2) - (vscrolling (:hs+ - +fill+ :vs+ +fill+ :hs 400 :vs 300 - :subtransformationp t ) - (setq menu (make-pane 'extended-stream-pane - :initial-cursor-visibility nil - ))))))) - (adopt-frame framem frame) - ;; (enable-frame frame) - menu)) + (let ((frame (make-application-frame 'menu-frame))) + (slot-value frame 'menu))) ;;; Still requires some thought, but at least this works in an environment ;;; with multiple ports. -#+Silica -(defresource menu (associated-window root) + +(clim-utils::defresource menu (associated-window root) :constructor (let* ((port (if (null root) (find-port) ; Horrible kluge #2. (port root))) - (server-path (port-server-path port))) + (server-path (silica::port-server-path port))) (get-menu :server-path server-path)) :deinitializer (window-clear menu) ;; We used to have an initializer that set record-p, cleared the window, and set @@ -72,106 +45,49 @@ ;;; needs to be set to an X window, either one associated with the associated window ;;; or to one associated with window. In other implementations, this can do nothing. ;;; --- What class for this default method? -#+Silica -(defmethod initialize-menu ((port w::basic-port) window associated-window) - (declare (ignore window associated-window)) - ) -#-Silica -;; no window-mixin -(defmethod initialize-menu ((menu window-mixin) associated-window) - (declare (ignore associated-window)) +(defmethod initialize-menu ((port port) window associated-window) + (declare (ignore window associated-window)) ) ;;; For now, MENU-CHOOSE requires that you pass in a parent. (defmacro with-menu ((menu associated-window) &body body) (let ((ass-win (gensymbol 'associated-window))) `(let ((,ass-win ,associated-window)) ;once-only - (using-resource (,menu menu (window-top-level-window ,ass-win) (window-root ,ass-win)) + (clim-utils::using-resource (,menu menu (window-top-level-window ,ass-win) (window-root ,ass-win)) ,@body)))) -#-Silica -(defun size-menu-appropriately (menu - &key (right-margin 10) (bottom-margin 10)) - (with-slots (output-record parent) menu - (multiple-value-bind (left top right bottom) - (entity-edges output-record) - (multiple-value-bind (label-width label-height) - (window-label-size menu) - (multiple-value-bind (parent-width parent-height) - (window-inside-size parent) - (multiple-value-bind (lm tm rm bm) - (host-window-margins menu) - (entity-set-size - menu - (min (+ (max label-width (- right left)) right-margin lm rm) parent-width) - (min (+ (max label-height (- bottom top)) bottom-margin tm bm) parent-height))))) - (window-set-viewport-position menu left top) - ;; blech - (stream-clear-input menu)))) - -#+Silica + + + (defun size-menu-appropriately (menu &key (right-margin 10) (bottom-margin 10)) (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))) - ;; (vw (ws::pane-viewport menu)) + ;; (vw (pane-viewport menu)) (width (min gw (+ (- maxx minx) right-margin))) (height (min gh (+ (- maxy miny) bottom-margin)))) - (ws::change-space-req menu :hs width :vs height) + (silica::change-space-req menu :width width :height height) ;; --- Damn. How do we get this to propagate the size change up ;; the tree so that the whole frame gets re-size to the pane? ;; For now, kludge it by setting the frame size directly. ;; Allow for scroll bar width - (ws::relayout-frame (pane-frame menu) (+ width 20) height) - ;;(when vw (ws::change-space-req vw :hs width :vs height)) - ;;(resize-sheet* menu width height) + ;; (layout-frame (silica::pane-frame menu) (+ width 20) (+ 20 height)) + ;; (when vw (change-space-req vw :hs width :vs height)) + ;; (resize-sheet* menu width height) + (silica::clear-space-req-caching-in-ancestors menu) + ;; --- RR needs to fix this at some point. ;; --- It has to do with the viewport having a bad scrolling transform ;; after a resize. + #+ignore (setf (sheet-transformation (sheet-parent menu)) (make-translation-transformation - 0 0 :reuse (sheet-transformation (sheet-parent menu)))))))) - -#+Silica -(defun position-window-near-carefully (menu x y) - (let* ((frame (pane-frame menu)) - (frame-manager (frame-manager frame)) - (graft (graft frame-manager))) - ;; Make sure the menu will fit inside the graft. - (with-bounding-rectangle* (min-x min-y max-x max-y) (sheet-region graft) - (multiple-value-bind (width height) (bounding-rectangle-size (sheet-region menu)) - (setf x (max min-x (min x (- max-x width)))) - (setf y (max min-y (min y (- max-y height)))))) - (move-frame frame x y))) - -#+Ignore ;; Old version -(defun position-window-near-carefully (menu x y) - ;; --- no "carefully" for now - (let ((frame (pane-frame menu))) - (ws::move-frame frame x y))) - -#-Silica -(defun position-window-near-carefully (window x y) - ;; unfortunately, the mouse-position is in window-parent coordinates - (multiple-value-bind (width height) (entity-size window) - (multiple-value-bind (parent-width parent-height) - (window-inside-size (window-parent window)) - (let* ((left x) - (top y) - (right (+ left width)) - (bottom (+ top height))) - (when (> right parent-width) - (setq left (- parent-width width))) - (when (> bottom parent-height) - (setq top (- parent-height height))) - (entity-set-position - window - (max 0 left) (max 0 top)))))) + 0 0)))))) ;;; item-list := (item*) ;;; item := object | (name :value object) | (object . value) @@ -243,12 +159,12 @@ ;;; What are reasonable defaults for CACHE, UNIQUE-ID, CACHE-VALUE, UNIQUE-ID-TEST, and ;;; CACHE-VALUE-TEST? (defun menu-choose (item-list - &key associated-window default-item default-style - (cache nil) (unique-id item-list) (cache-value item-list) - (unique-id-test #'equal) (cache-value-test #'equal) - label - printer - presentation-type) + &key associated-window default-item default-style + (cache nil) (unique-id item-list) (cache-value item-list) + (unique-id-test #'equal) (cache-value-test #'equal) + label + printer + presentation-type) #+Genera (declare (values value chosen-item gesture)) (labels ((menu-choose (stream presentation-type) (draw-standard-menu stream presentation-type @@ -263,26 +179,25 @@ (t (print-menu-item item stream))))) (declare (dynamic-extent #'item-printer #'menu-choose)) (with-menu (menu associated-window) - #-Silica (setf (window-label menu) label) - #+Silica (reset-frame (pane-frame menu) :title label) + (reset-frame (silica::pane-frame menu) :title label) (with-text-style (default-style menu) (loop (multiple-value-bind (item gesture) (menu-choose-from-drawer - menu 'menu-item - #'menu-choose - :unique-id unique-id - :unique-id-test unique-id-test - :cache-value cache-value - :cache-value-test cache-value-test - :cache cache)) - (cond ((menu-item-item-list item) - ;; set the new item list then go back through the loop - (setq item-list (menu-item-item-list item) default-item nil) - (clear-output-history menu)) - (t (return-from menu-choose (values (menu-item-value item) - item - gesture))))))))) + menu 'menu-item + #'menu-choose + :unique-id unique-id + :unique-id-test unique-id-test + :cache-value cache-value + :cache-value-test cache-value-test + :cache cache) + (cond ((menu-item-item-list item) + ;; set the new item list then go back through the loop + (setq item-list (menu-item-item-list item) default-item nil) + (clear-output-history menu)) + (t (return-from menu-choose (values (menu-item-value item) + item + gesture)))))))))) ;(defun draw-standard-menu (menu presentation-type item-list) ; (dolist (item item-list) @@ -302,7 +217,7 @@ (let ((pres (with-output-as-presentation (:stream menu :object item :type presentation-type - :single-box T) + :single-box t) (formatting-cell (menu) (funcall item-printer item menu))))) (when (eql item default-item) (setf default-pres pres))))) @@ -311,9 +226,7 @@ (defun position-window-at-pointer (window &optional x y) (unless (and x y) (multiple-value-setq (x y) - #-Silica - (stream-pointer-position-in-window-coordinates (window-parent window)) - #+Silica + (poll-pointer (graft window)))) (position-window-near-carefully window x y)) @@ -329,7 +242,7 @@ x-position y-position ;; for use by hierarchichal-menu-choose leave-menu-visible - unique-id (cache-value T) cache + unique-id (cache-value t) cache (unique-id-test #'equal) (cache-value-test #'eql) &aux default-presentation) ;; We could make the drawer a lexical closure, but that would then @@ -356,19 +269,19 @@ (size-menu-appropriately menu) (position-window-at-pointer menu x-position y-position) (unwind-protect - (with-simple-abort-restart ("Exit the menu") + (clim-utils::with-simple-abort-restart ("Exit the menu") ;;; --- Figure out later why this is necessary... ;;; it isn't now, 'cause we set the viewport in size-menu-appropriately ;;(window-set-viewport-position menu 0 0) (window-expose menu) (when default-presentation (multiple-value-bind (left top right bottom) - (entity-edges default-presentation) + (bounding-rectangle* default-presentation) (stream-set-pointer-position* menu (floor (+ left right) 2) (floor (+ top bottom) 2)))) ;; Menus DON'T want a blinking cursor... (with-cursor-visibility (nil menu) - (with-input-context (type :override T) + (with-input-context (type :override t) (object presentation-type gesture) (loop (read-gesture :stream menu) (beep)) @@ -486,8 +399,7 @@ (t (print-menu-item item stream))))) (declare (dynamic-extent #'menu-choose #'item-printer)) (with-menu (menu associated-window) - #-Silica (setf (window-label menu) label) - #+Silica (reset-frame (pane-frame menu) :title label) + (reset-frame (silica::pane-frame menu) :title label) (with-text-style (default-style menu) (unwind-protect (multiple-value-bind (item gesture) @@ -518,3 +430,45 @@ item gesture))))) (window-set-visibility menu nil)))))) + +;;; Weird shit + +(defun window-top-level-window (win) win) +(defun window-root (win) win) + + +(defun reset-frame (frame &rest ignore) nil) +(defun poll-pointer (x) (values 500 500)) + +(defmethod window-expose ((stream extended-stream-pane)) + (setf (window-visibility stream) t)) + +(defun window-set-visibility (window visibility) + (setf (window-visibility window) visibility)) + + +(defmethod (setf window-visibility) (nv (stream extended-stream-pane)) + (if nv + (enable-frame (silica::pane-frame stream)) + (disable-frame (silica::pane-frame stream)))) + +(defun entity-edges (x) + (bounding-rectangle* x)) + + + + +(defun position-window-near-carefully (menu x y) + #+ignore + (let* ((frame (silica::pane-frame menu)) + (frame-manager (frame-manager frame)) + (graft (graft frame-manager))) + ;; Make sure the menu will fit inside the graft. + (with-bounding-rectangle* (min-x min-y max-x max-y) (sheet-region graft) + (multiple-value-bind (width height) (bounding-rectangle-size (sheet-region menu)) + (setf x (max min-x (min x (- max-x width)))) + (setf y (max min-y (min y (- max-y height)))))) + (move-frame frame x y))) + +(defmethod clim-internals::window-refresh (window) + (warn "What does this do???")) diff --git a/clim/output-recording-protocol.lisp b/clim/output-recording-protocol.lisp index 4aac8bdad18ede68098abf9bd0e04a22e9f7404d..257b810ce81a44d197e429a8ec4dbf50a110cbef 100644 --- a/clim/output-recording-protocol.lisp +++ b/clim/output-recording-protocol.lisp @@ -154,7 +154,7 @@ (defmethod output-record-set-position* ((r output-record) new-x new-y) ;; (when (and (zerop new-x)(zerop new-y)) (break "zerop")) - (when (minusp new-x) (break)) + (when (minusp new-x) (warn "Zerop new-x ~S,~S" new-x new-y)) (multiple-value-bind (old-x old-y) (output-record-position* r) @@ -190,7 +190,9 @@ ; nil) (defun replay (record stream &optional (region +everywhere+)) - (replay-output-record record stream region)) + ;; Why did the spec not suggest this? or did I misread it. + (when (stream-draw-p stream) + (replay-output-record record stream region))) (defmethod replay-output-record (record stream &optional (region +everywhere+)) (map-over-output-record-children diff --git a/clim/presentations.lisp b/clim/presentations.lisp index 8b31394147f501b6a8b0370e96c240229ab96e3c..7c0c3befbe0cae9357281b4a1bd6bc29a617f0de 100644 --- a/clim/presentations.lisp +++ b/clim/presentations.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: presentations.lisp,v 1.1 91/09/09 14:53:12 cer Exp Locker: cer $ +;; $fiHeader: presentations.lisp,v 1.1 91/11/25 10:01:12 cer Exp Locker: cer $ (in-package :clim-internals) @@ -400,7 +400,8 @@ Copyright (c) 1991, Franz Inc. All rights reserved (defun highlighted-presentation (stream &optional (prefer-pointer-window t)) (let ((history-window (if prefer-pointer-window (find-appropriate-window stream) stream))) - (when history-window + (when (and history-window + (slot-exists-p history-window 'highlighted-presentation)) (slot-value history-window 'highlighted-presentation)))) (defun set-highlighted-presentation (stream presentation &optional (prefer-pointer-window t)) diff --git a/clim/sysdcl.lisp b/clim/sysdcl.lisp index 1068d6d601538794990c8e8fd55313a73e870c3c..40053eeeb493c23a24b103db1fb76d2b23eb8307 100644 --- a/clim/sysdcl.lisp +++ b/clim/sysdcl.lisp @@ -78,10 +78,11 @@ ("db-layout") ("db-box") ("db-table") - + ;; db-border????? ("gadgets") + ("db-scroll") ("db-stream") @@ -95,7 +96,9 @@ ("accept-values" :load-before-compile ("clim-defs" "incremental-redisplay")) - + + ("menus") + ("text-formatting") ("stream-trampolines" :load-before-compile ("defprotocol" "stream-defprotocols") )) diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp index 1ea6318fb75b73da101a56881723f2b55a1ebdb8..7cb8e8f369c7566884ccc20c1b0818ec85ec5ab3 100644 --- a/clim/text-formatting.lisp +++ b/clim/text-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-formatting.lisp,v 1.8 91/08/05 14:35:42 cer Exp $ +;; $fiHeader: text-formatting.cl,v 1.1 91/12/10 18:50:29 cer Exp Locker: cer $ (in-package :clim) @@ -60,7 +60,7 @@ ;; but it does contribute to the width of the line (when prefix (stream-write-string stream prefix)) - (setq current-width (+ prefix-width (text-size stream buffer))))) + (setq current-width (+ prefix-width (silica::text-size stream buffer))))) (defmethod stream-terpri ((filling-stream filling-stream)) (with-slots (stream current-width) filling-stream @@ -76,7 +76,7 @@ (setq current-width 0)) (t (vector-push-extend char buffer) - (incf current-width (text-size stream char)) + (incf current-width (silica::text-size stream char)) ;; We need to do the FILLING-STREAM-WRITE-BUFFER for every ;; character since it needs to know as soon as output crosses ;; the fill width. @@ -135,7 +135,7 @@ (write-buffer-and-continue filling-stream #'close-current-text-output-record wrapped)) -(defresource filling-stream (stream fill-width break-characters prefix prefix-width) +(clim-utils::defresource filling-stream (stream fill-width break-characters prefix prefix-width) :constructor (make-instance 'filling-stream :buffer (make-array 100 :element-type 'extended-char :fill-pointer 0 @@ -159,10 +159,10 @@ (check-type break-characters list) (check-type after-line-break (or null string)) (let ((fill-width (process-spacing-arg stream fill-width 'filling-output ':fill-width)) - (prefix-width (if after-line-break (text-size stream after-line-break) 0))) + (prefix-width (if after-line-break (silica::text-size stream after-line-break) 0))) (assert (< prefix-width fill-width) () "The prefix string ~S is wider than the fill width" after-line-break) - (using-resource (filling-stream filling-stream + (clim-utils::using-resource (filling-stream filling-stream stream fill-width break-characters after-line-break prefix-width) (unwind-protect (progn diff --git a/draw-sheets.lisp b/draw-sheets.lisp index fc11149698b14704e9c2a06b3701e1dd83d35236..3eed2b34b353e8c5c6af42657283c5b98460466f 100644 --- a/draw-sheets.lisp +++ b/draw-sheets.lisp @@ -13,7 +13,9 @@ (defun graph-sheet (sheet &rest args) (apply #'graph-descendants - sheet + (etypecase sheet + (silica::application-frame (clim-internals::frame-top-level-sheet sheet)) + (silica::sheet sheet)) :display 'gr-sheet-display :gnode-class 'sheet-gnode :title "Sheet hierarchy" diff --git a/misc/go.lisp b/misc/go.lisp index b4d6cf503bba10a77c4912ed0aa03f67f345febf..dd3346429fa32682aa81647e70962f95801031b3 100644 --- a/misc/go.lisp +++ b/misc/go.lisp @@ -18,6 +18,9 @@ ;; applicable. ;; +(setq excl::*record-source-file-info* t + excl::*load-source-file-info* t) + (without-package-locks (load "sys/defsystem") (load "sys/sysdcl")) @@ -60,4 +63,4 @@ (load "draw-sheets.cl") ) -(load "clim/test") +(load "test/test") diff --git a/silica/db-box.lisp b/silica/db-box.lisp index 1f0ba97ab5782c35a19b0fefcceea13b98bd14dc..9dddfd63f79415a4be57a7118fb9a71f0509498a 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -30,16 +30,23 @@ (defclass box-pane (mute-input-mixin pane-background-mixin - composite-pane - list-contents-mixin + #+ignore list-contents-mixin space-req-cache-mixin) - ((space :initform 1 :initarg :space))) + ((space :initform 1 :initarg :space) + contents)) (defmethod initialize-instance :after ((pane box-pane) &key contents &allow-other-keys) - (insert-panes pane contents)) - + (dolist (child contents) + (etypecase child + (number) + (pane + (adopt-child pane child)))) + (with-slots ((c contents)) pane + (setf c contents))) + +#+ignore (defmethod insert-pane ((lcm box-pane) pane &key position batch-p &allow-other-keys) @@ -150,6 +157,28 @@ space-req-min-height) (:width :max-width :min-width :height :max-height :min-height))) + +(defmethod allocate-space ((contract hbox-pane) width height) + (with-slots (contents space space-req) contract + (unless space-req (compose-space contract)) + (let ((sizes + (allocate-space-to-items + width + space-req + contents + #'space-req-min-width + #'space-req-width + #'space-req-max-width + #'compose-space)) + (x 0)) + (mapc #'(lambda (sheet size) + (move-and-resize-sheet* + sheet x 0 (frob-size size width x) height) + (incf x size)) + contents + sizes)))) + + (defmethod allocate-space ((contract hbox-pane) width height) (flet ((move-and-resize-entry (entry min-x width height) (move-and-resize-sheet* entry min-x 0 width height))) @@ -163,7 +192,7 @@ (defclass vbox-pane (box-pane) () - (:default-initargs :reverse-p t)) + ) (defmethod compose-space ((contract vbox-pane)) (compose-box contract (space-req-height @@ -174,21 +203,31 @@ space-req-min-width) (:height :max-height :min-height :width :max-width :min-width))) -(defmethod allocate-space ((contract vbox-pane) width height &aux (oheight height)) - (flet ((move-and-resize-entry (entry min-y height width) - (move-and-resize-sheet* entry 0 min-y - width ; DREADful kludge to make - ; sure that we do not - ; make the sheet to big and - ; cause the request to fail - (min (1- (- oheight min-y)) height)))) - (allocate-box contract height width move-and-resize-entry - (space-req-height - space-req-max-height - space-req-min-height - #+ignore space-req-width - #+ignore space-req-max-width - #+ignore space-req-min-width)))) +(defmethod allocate-space ((contract vbox-pane) width height) + (with-slots (contents space space-req) contract + (unless space-req (compose-space contract)) + (let ((sizes + (allocate-space-to-items + height + space-req + contents + #'space-req-min-height + #'space-req-height + #'space-req-max-height + #'compose-space)) + (y 0)) + (mapc #'(lambda (sheet size) + (move-and-resize-sheet* sheet + 0 + y + width + (frob-size size height y)) + (incf y size)) + contents + sizes)))) + +(defun frob-size (wanted-size available where-we-are-now) + (min wanted-size (1- (- available where-we-are-now)))) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index e8925b4d233693e9d492ea5626fa8266847b3f89..69419c694106a388eeb3b64b5ac4d02d4d21f9a3 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -47,6 +47,11 @@ (defmethod allocate-space ((pane leaf-mixin) width height) (declare (ignore width height))) +(warn "boug") + +(defmethod allocate-space (pane width height) + (declare (ignore width height))) + (defmethod space-req-changed ((composite composite-pane) child) (declare (ignore child)) (space-req-changed (sheet-parent composite) composite)) @@ -74,7 +79,10 @@ ((pane layout-mixin) &key resize-frame &allow-other-keys) (if resize-frame (relayout-frame (pane-frame pane)) - (space-req-changed (sheet-parent pane) pane))) + (space-req-changed (sheet-parent pane) pane))) + +(defmethod space-req-changed (parent child) + nil) #|| @@ -177,9 +185,9 @@ (when (or width max-width min-width height max-height min-height) (setf (slot-value pane 'client-space-req) (make-space-req :width (or width 0) :height (or height 0) - :max-width (or max-width width 0) + :max-width (or max-width width +fill+) :min-width (or min-width width 0) - :max-height (or max-height height 0) + :max-height (or max-height height +fill+) :min-height (or min-height height 0))))) (defmethod compose-space ((pane client-space-req-mixin)) @@ -286,6 +294,9 @@ (defmethod clear-space-req-cache ((pane layout-mixin)) nil) +(defmethod clear-space-req-cache ((pane t)) + nil) + (defmethod clear-space-req-cache ((pane space-req-cache-mixin)) (with-slots (space-req) pane (setf space-req nil))) @@ -300,6 +311,11 @@ (clear-space-req-cache sheet)) sheet)) +(defun clear-space-req-caching-in-ancestors (menu) + (do ((parent (sheet-parent menu) (sheet-parent parent))) + ((null parent)) + (clear-space-req-cache parent))) + ;;; ;;; Wrapping Space Mixin ;;; @@ -368,3 +384,46 @@ (bounding-rectangle-height pane))) + +;;; Generally useful layout function +;;; Used all over to satisfy constraints + +(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))) + 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* ((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)) + (push alloc sizes))) + (nreverse sizes)))) diff --git a/silica/db-table.lisp b/silica/db-table.lisp index cdf99d2d5b2bf0793045bbe375879790fcf94668..b562e6d0d9fa0770bd876245bca24bf530fae402 100644 --- a/silica/db-table.lisp +++ b/silica/db-table.lisp @@ -28,198 +28,143 @@ ;;; Table ;;; -(defclass table-pane (pane-background-mixin - mute-input-mixin - composite-pane - space-req-cache-mixin) - ((contents :accessor table-contents) - (rows) - (columns) - (row-h :initform nil) - (column-w :initform nil) - ;; ??? order of space, h and heightpace initarg matters with autoconstructors - (widthpace :initform 0 :initarg :space :initarg :widthpace) - (heightpace :initform 0 :initarg :space :initarg :heightpace))) -(defmethod initialize-instance :after - ((pane table-pane) &key contents &allow-other-keys) +(defclass table-pane (mute-input-mixin + pane-background-mixin + composite-pane + space-req-cache-mixin) + (row-space-reqs column-space-reqs contents)) -;;; The space composition and allocation for tables depends on there being -;;; no empty rows or columns in the data structure; otherwise, the space -;;; request comes back with MOST-POSITIVE-FIXNUM size requirements in the -;;; direction of the empty row/column. The following two forms delete the -;;; empty rows and columns. The row deletion is easy: the data structure is -;;; set up for that purpose. The column deletetion is more complex. -;;; -- rsl 13 November 1990 - ;; Delete empty rows. - (setf contents (delete-if #'(lambda (row) (every #'null row)) - contents)) +(defmethod initialize-instance :after ((pane table-pane) &key contents) + ;; The contents should be a list of lists + (with-slots ((c contents)) pane + (setf c (make-array (list (length contents) + (length (car contents))) + :initial-contents contents))) + (dolist (c contents) + (dolist (d c) + (when d (adopt-child pane d))))) - ;; Delete empty columns when there are any; this CONSes too much otherwise. - (when (block there-is-an-empty-column - (flet ((check-for-empty-column (&rest column) - (declare (dynamic-extent column)) - (when (every #'null column) - (return-from there-is-an-empty-column t)))) - (declare (dynamic-extent #'check-for-empty-column)) - (apply #'mapc #'check-for-empty-column contents)) - nil) ;; -> No empty columns - ;; Yes, there is at least one empty column - (setf contents - (flet ((delete-column-if-empty (&rest column) - (declare (clim-utils::non-dynamic-extent column)) - (if (every #'null column) - nil ;Delete this column entirely - (list column)))) - (declare (dynamic-extent #'delete-column-if-empty)) - (apply #'mapcan #'delete-column-if-empty contents)))) - (with-slots ((table-contents contents) - rows columns) pane - (setf rows (length contents)) - (setf columns (apply #'max (mapcar #'length contents))) - (let* (i j) +(defmacro tabling (options &rest contents) + `(realize-pane 'table-pane + :contents (list ,@(mapcar #'(lambda (x) `(list ,@x)) contents)) + ,@options)) - (setf table-contents (make-array (list rows columns) - :initial-element nil)) - (setq i 0) - (dolist (row - ;; Vertical list are easier to specify top to bottom, but - ;; easier to deal with bottom to top. - (reverse contents)) - (setq j 0) - (dolist (item row) - (cond ((null item) nil) - ((panep item) (adopt-child - pane - (setf (aref table-contents i j) item))) - ((eq item :give-left) (warn "Give left not supported")) - ((eq item :give-down) (warn "Give down not supported")) - (t (error "Illegal element in table contents"))) - (incf j)) - (incf i))))) +#+ignore +(tabling (:space space) + (vscrollbar viewport) + (nil hscrollbar)) -(defmethod compose-space ((pane table-pane)) - (with-slots (rows columns contents widthpace heightpace row-h column-w) pane - (let (size - max-size - min-size - (width 0) (max-width 0) (min-width 0) - (height 0) (max-height 0) (min-height 0)) - (setf row-h (or row-h (make-array rows :initial-element 0))) - (setf column-w (or column-w (make-array columns :initial-element 0))) - (dotimes (i rows) - (setq size 0) - (setq max-size most-positive-fixnum) - (setq min-size 0) - (dotimes (j columns) - (when (aref contents i j) - (let ((space-req (compose-space (aref contents i j)))) - (setq size (max size (space-req-height space-req))) - (setq max-size (min max-size (+ (space-req-height space-req) - (space-req-max-height space-req)))) - (setq min-size (max min-size (- (space-req-height space-req) - (space-req-min-height space-req))))))) - (setf (aref row-h i) (list size - (max (- max-size size) 0) - (max (- size min-size) 0) - nil))) - (dotimes (i rows) - (let ((req (aref row-h i))) - (incf height (first req)) - (incf max-height (second req)) - (incf min-height (third req)))) - (incf height (* (1- rows) heightpace)) - - (dotimes (j columns) - (setq size 0) - (setq max-size most-positive-fixnum) - (setq min-size 0) - (dotimes (i rows) - (when (aref contents i j) - (let ((space-req (compose-space (aref contents i j)))) - (setq size (max size (space-req-width space-req))) - (setq max-size (min max-size (+ (space-req-width space-req) - (space-req-max-width space-req)))) - (setq min-size (max min-size (- (space-req-width space-req) - (space-req-min-width space-req))))))) - (setf (aref column-w j) (list size - (max (- max-size size) 0) - (max (- size min-size) 0) - nil))) - (dotimes (j columns) - (let ((req (aref column-w j))) - (incf width (first req)) - (incf max-width (second req)) - (incf min-width (third req)))) - (incf width (* (1- columns) widthpace)) - (make-space-req :width width :max-width max-width :min-width min-width :height height :max-height max-height :min-height min-height)))) - -(defmacro allocate-to-rows (contract alloc-major rows row-h accessors) - (let ((major (first accessors)) - (major+ (second accessors)) - (major- (third accessors)) - (row-major 'first) - (row-major+ 'second) - (row-major- 'third) - (row-alloc 'fourth)) - `(with-slots (space-req) ,contract - (let ((stretch-p (> ,alloc-major (,major space-req))) - give extra used) - (if stretch-p - (progn (setq give (,major+ space-req)) - (setq extra (min (- ,alloc-major (,major space-req)) - give))) - (progn (setq give (,major- space-req)) - (setq extra (min (- (,major space-req) ,alloc-major) - give)))) - (dotimes (i ,rows) - (let* ((row-space-req (aref ,row-h i)) - (alloc (,row-major row-space-req))) - (when (> give 0) - (if stretch-p - (progn (setq used (/ (* (,row-major+ row-space-req) extra) - give)) - (incf alloc used) - (decf give (,row-major+ row-space-req))) - (progn (setq used (/ (* (,row-major- row-space-req) - extra) - give)) - (decf alloc used) - (decf give (,row-major+ row-space-req)))) - (decf extra used)) - (setf (,row-alloc row-space-req) alloc))))))) +(defmethod compose-space ((x table-pane)) + (with-slots (contents) x + (let ((omin-w 0) + (omin-h 0) + (oh 0) + (ow 0) + (omax-h 0) + (omax-w 0) + row-srs + column-srs) -(defmethod allocate-space ((pane table-pane) width height) - ;; assuming that pane has been composed previously. - (with-slots (rows columns contents widthpace heightpace row-h column-w space-req) - pane - - (unless space-req (compose-space pane)) ;; ?? Depends on it being here - - (allocate-to-rows pane height rows row-h - (space-req-height - space-req-max-height space-req-min-height - space-req-width space-req-max-width space-req-min-width)) - (allocate-to-rows pane width columns column-w - (space-req-width - space-req-max-width space-req-min-width - space-req-height space-req-max-height space-req-min-height)) + ;; Iterate over the rows, determining the height of each + + (dotimes (row (array-dimension contents 0)) + (let ((min-h 0) + (h 0) + (max-h 0)) + (dotimes (column (array-dimension contents 1)) + (let ((item (aref contents row column))) + (when item + (let ((isr (compose-space item))) + ;; Max the heights + (maxf h (space-req-height isr)) + (maxf min-h (space-req-min-height isr)) + (maxf max-h (space-req-max-height isr)))))) - ;; Now we should know what to do, so let's do it. - (let (min-x min-y width height) - (setq min-y 0) - (dotimes (i rows) - (setq min-x 0) - (setq height (fourth (aref row-h i))) - (dotimes (j columns) + (push + (make-space-req + :width 0 + :min-height min-h :height h :max-height max-h) + row-srs) - (setq width (fourth (aref column-w j))) - (when (aref contents i j) - (move-and-resize-sheet* (aref contents i j) - min-x min-y width height)) - (incf min-x (+ width widthpace))) - (incf min-y (+ height heightpace)))))) + ;; Add the heights + (incf oh h) + (incf omin-h min-h) + (incf omax-h max-h))) + + (setf (slot-value x 'row-space-reqs) (nreverse row-srs)) + + ;; Iterate over the columns determing the widths of each + + (dotimes (column (array-dimension contents 1)) + (let ((min-w 0) + (w 0) + (max-w 0)) + + (dotimes (row (array-dimension contents 0)) + (let ((item (aref contents row column))) + (when item + (let ((isr (compose-space item))) + ;; Max the widths + (maxf w (space-req-width isr)) + (maxf min-w (space-req-min-width isr)) + (maxf max-w (space-req-max-width isr)))))) + + (push + (make-space-req + :min-width min-w :width w :max-width max-w + :height 0) + column-srs) + + (incf ow w) + (incf omin-w min-w) + (incf omax-w max-w))) + + + (setf (slot-value x 'column-space-reqs) (nreverse column-srs)) + + (make-space-req + :min-width omin-w :width ow :max-width omax-w + :min-height omin-h :height oh :max-height omax-h)))) +(defmethod allocate-space ((x table-pane) width height) + (with-slots (contents column-space-reqs + row-space-reqs space-req) x + (unless space-req (compose-space x)) + + (let ((row-heights + (allocate-space-to-items + height + space-req + row-space-reqs + #'space-req-min-height + #'space-req-height + #'space-req-max-height + #'identity)) + (column-widths + (allocate-space-to-items + width + space-req + column-space-reqs + #'space-req-min-width + #'space-req-width + #'space-req-max-width + #'identity)) + (y 0)) + (dotimes (row (array-dimension contents 0)) + (let ((row-height (pop row-heights)) + (column-widths column-widths) + (x 0)) + (dotimes (column (array-dimension contents 1)) + (let ((column-width (pop column-widths)) + (item (aref contents row column))) + (when item + (move-and-resize-sheet* + item x y + (min column-width (1- (- width x))) + (min row-height (1- (- height y))))) + (incf x column-width))) + (incf y row-height)))))) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 991e7ab6f8cea55dbebf83da79876fe40300070c..09f3b99e4308392d224e96086bf620c74e93477e 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -61,9 +61,6 @@ ;;; Then there is the layout stuff and scrolling macros - -(defmacro horizontally () ()) -(defmacro tabling () ()) (defmacro form () ()) (defmacro scrolling (options contents) @@ -73,13 +70,13 @@ (defmethod realize-pane-internal ((framem frame-manager) (frame application-frame) name &rest options) - (apply #'make-instance name options)) + (apply #'make-instance + name + :frame frame + :frame-manager framem + options)) + -(defmethod note-sheet-region-changed :after ((sheet gadget) &key port) - (declare (ignore port)) - (allocate-space sheet - (sheet-width sheet) - (sheet-height sheet))) ;;;;;;;; Whats the interface to different types of window: main, dialog,.. diff --git a/silica/layout.lisp b/silica/layout.lisp index f0c628cab251514e4fc14b64c64957af5b2bcb98..826f1868bb64dafc65b705259a4d264b0b9112ed 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -86,6 +86,11 @@ :contents (list ,@contents) ,@options)) +(defmacro horizontally (options &rest contents) + `(realize-pane 'hbox-pane + :contents (list ,@contents) ,@options)) + + (defmethod resize-sheet* ((sheet sheet) width height) (when (or width height) (with-bounding-rectangle* (minx miny maxx maxy) sheet @@ -119,122 +124,128 @@ standard-repainting-medium permanent-medium-sheet-output-mixin mute-repainting-mixin) - ()) + ((frame :reader pane-frame :initarg :frame) + (framem :reader pane-frame-mamager :initarg :frame-manager))) + + +(defmethod note-sheet-region-changed :after ((sheet pane) &key port) + (declare (ignore port)) + (allocate-space sheet + (sheet-width sheet) + (sheet-height sheet))) (defmethod panep ((x pane)) t) (defmethod panep ((x t)) nil) (defclass leaf-mixin (sheet-leaf-mixin) ()) (defclass composite-pane (pane sheet-multiple-child-mixin) ()) - (defclass mute-input-mixin (sheet-mute-input-mixin) ()) (defclass pane-background-mixin () ()) - -(defclass list-contents-mixin () - ((contents :initform nil) - (nslots :initform nil :initarg :nslots) - ;; Reverse-p is provided because it makes sense to let users specify - ;; vertical lists from top to bottom, but internally it is easier to deal - ;; with bottom to top, because of the lower left coordinate system. - ;; For example, a user would like to list the vbox contents from top to - ;; bottom, while y coords increases from bottom to top. Whereas with - ;; a hbox, user specifys left to right just as x coord increases left - ;; to right. - ;; - ;; A problem with reverse-p solution is that when new panes are inserted, - ;; all panes before them in the user's view of contents changes coord, - ;; but the user may expect the one's later in the list to change coords. - ;; For example in a vertical list, adding a pane to the end will - ;; reposition all of the list items. - - ;; A possible solution is to user a upper left coordinate - ;; system so that added items have absolute y values that are increasing. - ;; Once upon a time Doug told me he prefered this, but it'll have to wait - ;; for now. A deeper problem with this solution is that different panes - ;; would have different coordinate systems which maybe confusing if the - ;; coordinate system is exposed to the client in anyway. - (reverse-p :initform nil :initarg :reverse-p))) - -;;; -;;; Insertion/Deletion Protocols -;;; - -(defmethod contents ((lcm list-contents-mixin)) - (with-slots (reverse-p contents) lcm - (if reverse-p (reverse contents) - contents))) - -(defmethod (setf contents) (new-contents (lcm list-contents-mixin)) - (with-slots (reverse-p contents children) lcm - (dolist (pane contents) - (disown-child lcm pane)) - (dolist (pane new-contents) - (adopt-child lcm pane)) - (setf contents (if reverse-p (reverse new-contents) - new-contents) - ;; So that things repaint from top to bottom - ;; ??? However, it only work is you go through this method. - children (if reverse-p (nreverse children) - children)) - - (space-req-changed (sheet-parent lcm) lcm))) - - - -(defun check-position (position reverse-p contents) - (let ((len (length contents))) - (when reverse-p - (setq position (if position (- len position) 0))) - (unless position (setq position len)) - (check-type position number) - (assert (and (<= 0 position) (<= position len)) - (position) - "Position argument out of bounds") - position)) - -(defmethod insert-panes ((lcm list-contents-mixin) panes - &key position &allow-other-keys) - (with-slots (reverse-p contents) lcm - (setq position (check-position position reverse-p contents)) - (dolist (pane panes) - (insert-pane lcm pane :position position :batch-p t) - (unless reverse-p (incf position))) - (space-req-changed (sheet-parent lcm) lcm))) - -(defmethod insert-pane ((lcm list-contents-mixin) (pane pane) - &key position batch-p &allow-other-keys) - (with-slots (contents reverse-p) lcm - (unless batch-p - (setq position (check-position position reverse-p contents))) - (if (zerop position) - (push pane contents) - (let ((tail (nthcdr (1- position) contents))) - (setf (cdr tail) - (cons pane (cdr tail))))) - (adopt-child lcm pane) - (unless batch-p - (space-req-changed (sheet-parent lcm) lcm)))) - -(defmethod remove-panes ((lcm list-contents-mixin) panes) - (dolist (pane panes) - (with-slots (contents) lcm - (setf contents (delete pane contents)) - (disown-child lcm pane))) - (space-req-changed (sheet-parent lcm) lcm)) - -(defmethod remove-pane ((lcm list-contents-mixin) (pane pane) - &key batch-p &allow-other-keys) - (with-slots (contents) lcm - (setf contents (delete pane contents :test #'eq)) - (disown-child lcm pane) - (unless batch-p (space-req-changed (sheet-parent lcm) lcm)))) - -(defmethod space-req-changed :before (parent (lcm list-contents-mixin)) - #-PCL ;; PCL uses this variable for method-table cache misses, unfortunately. - (declare (ignore parent)) - (with-slots (nslots contents) lcm - (setf nslots (length contents)))) +;(defclass list-contents-mixin () +; ((contents :initform nil) +; (nslots :initform nil :initarg :nslots) +; ;; Reverse-p is provided because it makes sense to let users specify +; ;; vertical lists from top to bottom, but internally it is easier to deal +; ;; with bottom to top, because of the lower left coordinate system. +; ;; For example, a user would like to list the vbox contents from top to +; ;; bottom, while y coords increases from bottom to top. Whereas with +; ;; a hbox, user specifys left to right just as x coord increases left +; ;; to right. +; ;; +; ;; A problem with reverse-p solution is that when new panes are inserted, +; ;; all panes before them in the user's view of contents changes coord, +; ;; but the user may expect the one's later in the list to change coords. +; ;; For example in a vertical list, adding a pane to the end will +; ;; reposition all of the list items. +; +; ;; A possible solution is to user a upper left coordinate +; ;; system so that added items have absolute y values that are increasing. +; ;; Once upon a time Doug told me he prefered this, but it'll have to wait +; ;; for now. A deeper problem with this solution is that different panes +; ;; would have different coordinate systems which maybe confusing if the +; ;; coordinate system is exposed to the client in anyway. +; (reverse-p :initform nil :initarg :reverse-p))) +; +;;;; +;;;; Insertion/Deletion Protocols +;;;; +; +;(defmethod contents ((lcm list-contents-mixin)) +; (with-slots (reverse-p contents) lcm +; (if reverse-p (reverse contents) +; contents))) +; +;(defmethod (setf contents) (new-contents (lcm list-contents-mixin)) +; (with-slots (reverse-p contents children) lcm +; (dolist (pane contents) +; (disown-child lcm pane)) +; (dolist (pane new-contents) +; (adopt-child lcm pane)) +; (setf contents (if reverse-p (reverse new-contents) +; new-contents) +; ;; So that things repaint from top to bottom +; ;; ??? However, it only work is you go through this method. +; children (if reverse-p (nreverse children) +; children)) +; +; (space-req-changed (sheet-parent lcm) lcm))) +; +; +; +;(defun check-position (position reverse-p contents) +; (let ((len (length contents))) +; (when reverse-p +; (setq position (if position (- len position) 0))) +; (unless position (setq position len)) +; (check-type position number) +; (assert (and (<= 0 position) (<= position len)) +; (position) +; "Position argument out of bounds") +; position)) +; +;(defmethod insert-panes ((lcm list-contents-mixin) panes +; &key position &allow-other-keys) +; (with-slots (reverse-p contents) lcm +; (setq position (check-position position reverse-p contents)) +; (dolist (pane panes) +; (insert-pane lcm pane :position position :batch-p t) +; (unless reverse-p (incf position))) +; (space-req-changed (sheet-parent lcm) lcm))) +; +;(defmethod insert-pane ((lcm list-contents-mixin) (pane pane) +; &key position batch-p &allow-other-keys) +; (with-slots (contents reverse-p) lcm +; (unless batch-p +; (setq position (check-position position reverse-p contents))) +; (if (zerop position) +; (push pane contents) +; (let ((tail (nthcdr (1- position) contents))) +; (setf (cdr tail) +; (cons pane (cdr tail))))) +; (adopt-child lcm pane) +; (unless batch-p +; (space-req-changed (sheet-parent lcm) lcm)))) +; +;(defmethod remove-panes ((lcm list-contents-mixin) panes) +; (dolist (pane panes) +; (with-slots (contents) lcm +; (setf contents (delete pane contents)) +; (disown-child lcm pane))) +; (space-req-changed (sheet-parent lcm) lcm)) +; +;(defmethod remove-pane ((lcm list-contents-mixin) (pane pane) +; &key batch-p &allow-other-keys) +; (with-slots (contents) lcm +; (setf contents (delete pane contents :test #'eq)) +; (disown-child lcm pane) +; (unless batch-p (space-req-changed (sheet-parent lcm) lcm)))) +; +;(defmethod space-req-changed :before (parent (lcm list-contents-mixin)) +; #-PCL ;; PCL uses this variable for method-table cache misses, unfortunately. +; (declare (ignore parent)) +; (with-slots (nslots contents) lcm +; (setf nslots (length contents)))) diff --git a/silica/medium.lisp b/silica/medium.lisp index 5761d4a32ea3036af29df012c2a475d43b84e6d8..d5e7e0638d4bc8d6d763f24768c74d814c3e7282 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -69,6 +69,7 @@ (defmethod invoke-with-drawing-options ((medium medium) function &key + (line-thickness nil line-thickness-p) (ink nil ink-p) (text-style nil text-style-p) (transformation nil trans-p) @@ -79,7 +80,7 @@ (text-size nil text-size-p)) (when (or text-size-p text-face-p text-family-p line-style-p clipping-region-p) - (error "unhandled option to invoke-with-drawing-options")) + (warn "unhandled option to invoke-with-drawing-options")) (let ((old-ink (if ink-p (medium-ink medium))) (old-trans (if trans-p (medium-transformation medium))) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index ac626071c799dfcdc81f404e23b830131bf29c58..e98ad1ef77937d0dd511aefcd47c861c67c38a9c 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -178,18 +178,31 @@ (mapc #'invalidate-cached-regions (sheet-children sheet)))) +(warn "This sucks big") + +(defmethod invalidate-cached-transformations :after ((sheet mirrored-sheet-mixin)) + (when (sheet-direct-mirror sheet) + (update-mirror-region (port sheet) sheet))) + (defmethod note-sheet-region-changed :after ((sheet mirrored-sheet-mixin) &key port) (when (sheet-direct-mirror sheet) (unless port (update-mirror-region (port sheet) sheet)))) +(defmethod note-sheet-transformation-changed :after ((sheet mirrored-sheet-mixin) &key port) + (when (sheet-direct-mirror sheet) + (unless port + (update-mirror-region (port sheet) sheet)))) + + ;;; There is some confusion here about mirror-inside-edges* ;;; This actual returns coordinates in the mirrors parents space ;;; rather than (defmethod update-mirror-region ((port port) (sheet mirrored-sheet-mixin)) + ;; If the sheet-region is changed this updates the mirrors region accordingly (multiple-value-bind ;; Coordinates in parent space (target-left target-top target-right target-bottom) @@ -204,6 +217,8 @@ (update-mirror-transformation port sheet)) (defmethod update-mirror-transformation ((port port) (sheet mirrored-sheet-mixin)) + ;; Compute transformation from sheet-region to mirror cordinates. I + ;; would imagine that a lot of the time this would be identity (multiple-value-bind (mirror-left mirror-top mirror-right mirror-bottom) (mirror-inside-edges* port sheet) @@ -217,9 +232,7 @@ (- bottom top)))) (when (or (/= sc-x 1.0) (/= sc-y 1.0)) - (print (list tr-x tr-y sc-x sc-y) - excl:*initial-terminal-io*) - (warn "mirror scalling ~S" sheet)) + (warn "mirror scalling ~S, ~S" (list tr-x tr-y sc-x sc-y) sheet)) (setf (sheet-native-transformation sheet) (compose-transformations (make-translation-transformation tr-x tr-y) diff --git a/silica/pkg.lisp b/silica/pkg.lisp index eb0f1fa4e11dc9f4ab95704120271e6aab31d6df..2d039ba4af17aaa5b159860a173a9dfc3e8ab322 100644 --- a/silica/pkg.lisp +++ b/silica/pkg.lisp @@ -236,6 +236,8 @@ #:medium-merged-text-style-valid #:beep #:port-beep + #:port-server-path + #:change-space-req )) diff --git a/silica/port.lisp b/silica/port.lisp index ee4eafdf26ba0f197b38fce29942ead8b49ad43b..4df37f276824f409ee9005efde3761e96fb96aac 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -21,7 +21,7 @@ ;; Ports and grafts -(defvar *default-server-path* '(:motif :display "localhost")) +(defvar *default-server-path* '(:motif :display "localhost:0")) (defvar *ports* nil) (defvar *port-type-mapping* nil) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index aafe8569259ca17317a0d7d81534c1086d749786..2dd6cccab3223e6c40fe9c15241aee272f6ca9c1 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -31,6 +31,11 @@ (defgeneric sheet-child (sheet) ) +(defmethod sheet-child (sheet) + (let ((x (sheet-children sheet))) + (unless (and x (null (cdr x))) + (error "Not one child:~S" sheet)) + (car x))) (defgeneric adopt-child (sheet child) ) @@ -269,13 +274,17 @@ (sheet-engrafted-p parent))))) +(warn "Is this right?") + (defmethod note-sheet-region-changed :after (sheet &key port) (declare (ignore port)) - (invalidate-cached-regions sheet)) + (unless port + (invalidate-cached-regions sheet))) (defmethod note-sheet-transformation-changed :after (sheet &key port) (declare (ignore port)) - (invalidate-cached-transformations sheet)) + (unless port + (invalidate-cached-transformations sheet))) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 4b411c7316f1d0b3934df4229a0be7897f1a8f58..2380ea812bfb7d54aa69afdda16e3f6ea163dc3c 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,8 +1,8 @@ -;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM-USER; Mode: LISP; Lowercase: T -*- +;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM; Mode: LISP; Lowercase: T -*- -;; $fiHeader: test-suite.lisp,v 1.21 91/09/24 21:07:06 cer Exp $ +;; $fiHeader: test-suite.cl,v 1.1 91/12/10 16:57:32 cer Exp Locker: cer $ -(in-package :clim-user) +(in-package :clim) #| To do: @@ -33,6 +33,8 @@ What about environment issue? #-excl (declare (ignore ,i)) ,@body))) +(defun get-frame-pane (x y) (slot-value x y)) + (defun find-pane-named (pane-name) #-Silica (get-frame-pane *application-frame* pane-name) #+Silica (slot-value *frame* pane-name)) @@ -171,8 +173,7 @@ What about environment issue? ;; Try to get millimeters (defun window-mm-transformation (window) - (with-bounding-rectangle* (wl wt wr wb) #-Silica (window-viewport window) - #+Silica (sheet-region window) + (with-bounding-rectangle* (wl wt wr wb) (sheet-region window) (make-transformation 3.4 0 0 -3.4 (floor (- wr wl) 2) (floor (- wb wt) 2)))) (defmacro with-mm-transformation ((window -x -y +x +y) &body body) @@ -180,8 +181,7 @@ What about environment issue? (with-drawing-options (,window :transformation transform) (with-bounding-rectangle* (,-x ,-y ,+x ,+y) (untransform-region transform - #-Silica (window-viewport ,window) - #+Silica (bounding-rectangle + (bounding-rectangle (sheet-region ,window))) ,@body)))) @@ -2830,6 +2830,7 @@ Luke Luck licks the lakes Luke's duck likes.")) #-Silica +#+ignore (define-application-frame clim-tests () () (:command-table (clim-tests @@ -2862,6 +2863,40 @@ Luke Luck licks the lakes Luke's duck likes.")) (caption-pane 1/10) (display-pane :rest)))))) + +(define-application-frame clim-tests () + (caption-pane display-pane) + (:command-table (clim-tests + :inherit-from (graphics + output-recording + formatted-output + redisplay + presentations + menus-and-dialogs + benchmarks) + :menu (("Graphics" :menu graphics) + ("Output Recording" :menu output-recording) + ("Formatted Output" :menu formatted-output) + ("Redisplay" :menu redisplay) + ("Presentations" :menu presentations) + ("Menus and Dialogs" :menu menus-and-dialogs) + ("Benchmarks" :menu benchmarks) + ("Exit" :command (exit-clim-tests))))) + (:command-definer nil) + (:pane (with-slots (caption-pane display-pane) *application-frame* + (silica::vertically () + (silica::scrolling + () + (setf caption-pane + (silica::realize-pane + 'application-pane))) + (silica::scrolling + () + (setf display-pane + (silica::realize-pane + 'application-pane))))))) + + #-Silica (defmethod frame-standard-output ((frame clim-tests)) (get-frame-pane frame 'display-pane)) diff --git a/test/test.lisp b/test/test.lisp index 28f1ff8934190f12a076998bd10c15c898a543a7..e5b95562f8a4e17de6364c2c0c79a45ba78825f4 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -31,6 +31,55 @@ 'interactor-pane))) (realize-pane 'slider)))) +(define-application-frame test-frame2 () + (a b c) + (:command-table test-frame) + (:pane + (vertically () + (silica::tabling () + ( + (silica::horizontally + () + (realize-pane 'silica::toggle-button) + (realize-pane 'silica::toggle-button) + (realize-pane 'silica::toggle-button)) + + (realize-pane 'silica::text-field)) + ( + (realize-pane 'silica::push-button :label "hello") + (realize-pane 'slider))) + (silica::scrolling + () + (silica::realize-pane + 'interactor-pane + :display-function 'moby-display-function)) + (silica::scrolling + () + (setq aaa + (silica::realize-pane + 'interactor-pane + :width 100)))))) + +(defun moby-display-function (frame stream) + (window-clear stream) + (display-command-table-menu + (frame-command-table frame) + stream + :max-width (bounding-rectangle-width stream))) + +(define-application-frame test-frame3 () + (a b c) + (:command-table test-frame) + (:pane + (silica::scrolling + () + (setq aaa + (silica::realize-pane + 'interactor-pane + :width 300 + :height 300))))) + + (define-test-frame-command (com-square-it :name t :menu t) ((x 'integer)) @@ -38,13 +87,30 @@ *query-io*)) +(define-test-frame-command (com-double-it :name t :menu t) + ((x 'integer)) + (present (+ x x) 'integer :stream + *query-io*)) + + (define-test-frame-command (com-clear :name t :menu t) () (window-clear *query-io*)) (define-test-frame-command (com-quit :name t :menu t) () - (frame-exit *application-frame*)) + (frame-exit *application-frame*)) + +(define-test-frame-command (com-make-table :name t :menu t) + () + (formatting-table (*query-io*) + (dotimes (i 10) + (formatting-row (*query-io*) + (dotimes (j 10) + (formatting-cell (*query-io*) + (present (* i j) 'integer :stream *query-io*))))))) + + (define-test-frame-command (com-show :name t :menu t) @@ -61,3 +127,10 @@ (object) (list object)) + + +(define-presentation-to-command-translator double-int (integer + com-double-it test-frame) + + (object) + (list object)) diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index e9f09eb8356e6cd62a72519da412975a1bb0672f..ffd536c2aedb84e42d5add8e3e662cf2d2bdce8f 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -97,7 +97,7 @@ (defun convert-callback-name (x) (let ((z (assoc x *callback-name-alist*))) - (unless z (error "No such Callback: ~S" z)) + (unless z (error "No such Callback: ~S" x)) (values (or (third z) (setf (third z) (string-to-char* (second z)))) (fourth z)))) diff --git a/tk/examples.lisp b/tk/examples.lisp index 333ee77e75cab4d514f5c20e2222b8c1d52f6373..dbf46d3717bafefd5b1ba90cc936e10ec57d9517 100644 --- a/tk/examples.lisp +++ b/tk/examples.lisp @@ -23,13 +23,15 @@ (add-callback da :input-callback 'da-button-press-handler :input) (popup app4)) -(defun setup () +(defun setup (hostspec) (setq context (create-application-context)) - (setq display (make-instance 'display :context context)) + (setq display (make-instance 'display + :host hostspec + :context context)) (setq app (app-create-shell :display display :widget-class 'application-shell))) -(defun initialize-motif-toolkit (&rest ignore) - (setup) +(defun initialize-motif-toolkit (hostspec) + (setup hostspec) (values context display app)) (defvar *bitmaps* (quote ("background" "25_foreground" "50_foreground" "75_foreground" diff --git a/tk/font.lisp b/tk/font.lisp index e7c895c764bfc21384be85f4c43bed36316ff2c9..9f113bb2ab8aaf05825c59a2c7fa7fa439623844 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -26,6 +26,9 @@ (def-c-type (xcharstruct-vector :in-foreign-space) 1 x11:xcharstruct) +(defmethod font-width (font) + (x11::xfontstruct-max-bounds-width (object-handle font))) + (defmethod font-ascent (font) (x11:xfontstruct-ascent (object-handle font))) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index 857d08b1435a507b95d9eafd592351271763e71f..1cd059d31866fd2bcd1d5dd2866c3f4ac6e1a9ae 100644 --- a/tk/foreign.lisp +++ b/tk/foreign.lisp @@ -30,22 +30,27 @@ (make-instance 'application-context)) (defun open-display (&key (context (create-application-context)) - (display 0) + (host nil) (name "foo") (class "Foo") (options 0) (num-options 0) (argc 0) (argv 0)) - (with-ref-par ((argc argc)) - (open_display (object-handle context) - display - (string-to-char* name) - (string-to-char* class) - options - num-options - argc - argv))) + (let ((d (with-ref-par ((argc argc)) + (open_display (object-handle context) + (if host + (string-to-char* host) + 0) + (string-to-char* name) + (string-to-char* class) + options + num-options + argc + argv)))) + (if (zerop d) + (error "cannot open the display: ~A" host) + d))) (defclass display () ((handle :reader display-handle) @@ -53,7 +58,8 @@ -(defmethod initialize-instance :after ((d display) &rest args &key display) +(defmethod initialize-instance :after ((d display) &rest args &key + host display) (push d (application-context-displays (slot-value d 'context))) (setf (slot-value d 'handle) (or display diff --git a/tk/widget.lisp b/tk/widget.lisp index c6d0b526d77837f4ed19a539184d3fc05dc4f131..ee1c4b5b455833619ca1cb26ae34d5d52f08d7d3 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -92,10 +92,11 @@ (defforeign 'xt_window :entry-point "_XtWindow") -(defun widget-window (widget) +(defun widget-window (widget &optional (errorp t)) (let ((id (xt_window (object-handle widget)))) (if (zerop id) - (error "Invalid window id ~D for ~S" id widget) + (and errorp + (error "Invalid window id ~D for ~S" id widget)) (intern-object-xid id 'window diff --git a/utils/packages.lisp b/utils/packages.lisp index 8984b06d1c844416be852309a63f05cfc2d3189e..c3f0dd7912965824d0170f6c818eb522713ab3b7 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: packages.lisp,v 1.1 91/08/30 13:57:48 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.1 91/11/25 10:01:42 cer Exp Locker: cer $ (in-package #-ansi-90 :user #+ansi-90 :common-lisp-user) @@ -774,6 +774,7 @@ Copyright (c) 1991, Franz Inc. All rights reserved exp export expt + extended-char fboundp fceiling ffloor