November 2005 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv31917 Modified Files: port.lisp Log Message: EVENT-HANDLER We also deliver :graphics-exposure events as CLIM repaint events. Date: Mon Nov 28 15:21:45 2005 Author: gbaumann Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.113 mcclim/Backends/CLX/port.lisp:1.114 --- mcclim/Backends/CLX/port.lisp:1.113 Mon Nov 28 13:58:18 2005 +++ mcclim/Backends/CLX/port.lisp Mon Nov 28 15:21:45 2005 @@ -766,7 +766,7 @@ :modifier-state modifier-state :timestamp time))))) ;; - ((:exposure :display) + ((:exposure :display :graphics-exposure) ;; Notes: ;; . Do not compare count with 0 here, last rectangle in an ;; :exposure event sequence does not cover the whole region.

1 0

[mcclim-cvs] CVS update: mcclim/frames.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv29697 Modified Files: frames.lisp Log Message: EXECUTE-FRAME-COMMAND When called from another process, pass command as EXECUTE-COMMAND-EVENT to the frame. So that commands are always executed in sync with the command loop. However, my method to check for being in frame process is far from perfect. Date: Mon Nov 28 14:51:06 2005 Author: gbaumann Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.109 mcclim/frames.lisp:1.110 --- mcclim/frames.lisp:1.109 Thu Oct 27 03:21:33 2005 +++ mcclim/frames.lisp Mon Nov 28 14:51:05 2005 @@ -588,8 +588,25 @@ #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) +(defclass execute-command-event (window-manager-event) + ((sheet :initarg :sheet :reader event-sheet) + (command :initarg :command :reader execute-command-event-command))) + (defmethod execute-frame-command ((frame application-frame) command) - (apply (command-name command) (command-arguments command))) + ;; ### FIXME: I'd like a different method than checking for + ;; *application-frame* to decide, which process processes which + ;; frames command loop. Perhaps looking ath the process slot? + ;; --GB 2005-11-28 + (cond ((eq *application-frame* frame) + (apply (command-name command) (command-arguments command))) + (t + (let ((eq (sheet-event-queue (frame-top-level-sheet frame)))) + (event-queue-append eq (make-instance 'execute-command-event + :sheet frame + :command command)))))) + +(defmethod handle-event ((frame application-frame) (event execute-command-event)) + (execute-frame-command frame (execute-command-event-command event))) (defmethod command-enabled (command-name (frame standard-application-frame)) (and (command-accessible-in-command-table-p command-name

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv27504 Modified Files: panes.lisp Log Message: TABLE-PANE The table pane now recognizes x-spacing and y-spacing, but units are not tested. Date: Mon Nov 28 14:23:55 2005 Author: gbaumann Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.156 mcclim/panes.lisp:1.157 --- mcclim/panes.lisp:1.156 Thu Oct 27 03:21:33 2005 +++ mcclim/panes.lisp Mon Nov 28 14:23:53 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.156 2005/10/27 01:21:33 rstrandh Exp $ +;;; $Id: panes.lisp,v 1.157 2005/11/28 13:23:53 gbaumann Exp $ (in-package :clim-internals) @@ -1471,59 +1471,67 @@ (defmethod compose-space ((pane table-pane) &key width height) (declare (ignore width height)) - (with-slots (array) pane + (with-slots (array x-spacing y-spacing) pane ; ---v our problem is here. + ; Which problem? --GB (let ((rsrs (loop for i from 0 below (array-dimension array 0) collect (table-pane-row-space-requirement pane i))) (csrs (loop for j from 0 below (array-dimension array 1) - collect (table-pane-col-space-requirement pane j)))) + collect (table-pane-col-space-requirement pane j))) + (xs (* x-spacing (1- (array-dimension array 1)))) + (ys (* y-spacing (1- (array-dimension array 0))))) (let ((r (stack-space-requirements-vertically rsrs)) (c (stack-space-requirements-horizontally csrs))) (let ((res (make-space-requirement - :width (space-requirement-width r) - :min-width (space-requirement-min-width r) - :max-width (space-requirement-max-width r) - :height (space-requirement-height c) - :min-height (space-requirement-min-height c) - :max-height (space-requirement-max-height c)))) + :width (+ (space-requirement-width r) xs) + :min-width (+ (space-requirement-min-width r) xs) + :max-width (+ (space-requirement-max-width r) xs) + :height (+ (space-requirement-height c) ys) + :min-height (+ (space-requirement-min-height c) ys) + :max-height (+ (space-requirement-max-height c) ys)))) #+nil (format *trace-output* "~%;;; TABLE-PANE sr = ~S." res) res))))) -(defmethod allocate-space ((pane table-pane) width height &aux rsrs csrs) - (declare (ignorable rsrs csrs)) - (with-slots (array) pane - ;; allot rows - (let ((rows (allot-space-vertically - (setq rsrs (loop for i from 0 below (array-dimension array 0) - collect (table-pane-row-space-requirement pane i))) - height)) - (cols (allot-space-horizontally - (setq csrs (loop for j from 0 below (array-dimension array 1) - collect (table-pane-col-space-requirement pane j))) - width))) - #+nil - (progn - (format T "~&;; row space requirements = ~S." rsrs) - (format T "~&;; col space requirements = ~S." csrs) - (format T "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) - (format T "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) - (format T "~&;; align-x = ~S, align-y ~S~%" - (pane-align-x pane) - (pane-align-y pane))) - ;; now finally layout each child - (loop - for y = 0 then (+ y h) - for h in rows - for i from 0 - do (loop - for x = 0 then (+ x w) - for w in cols - for j from 0 - do (layout-child (aref array i j) (pane-align-x pane) (pane-align-y pane) - x y w h)))))) - +(defmethod allocate-space ((pane table-pane) width height) + (let (rsrs csrs) + (declare (ignorable rsrs csrs)) + (with-slots (array x-spacing y-spacing) pane + ;; allot rows + (let* ((xs (* x-spacing (1- (array-dimension array 1)))) + (ys (* y-spacing (1- (array-dimension array 0)))) + (rows (allot-space-vertically + (setq rsrs (loop for i from 0 below (array-dimension array 0) + collect (table-pane-row-space-requirement pane i))) + (- height ys))) + (cols (allot-space-horizontally + (setq csrs (loop for j from 0 below (array-dimension array 1) + collect (table-pane-col-space-requirement pane j))) + (- width xs)))) + #+nil + (progn + (format T "~&;; row space requirements = ~S." rsrs) + (format T "~&;; col space requirements = ~S." csrs) + (format T "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) + (format T "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) + (format T "~&;; align-x = ~S, align-y ~S~%" + (pane-align-x pane) + (pane-align-y pane))) + ;; now finally layout each child + (loop + for y = 0 then (+ y h y-spacing) + for h in rows + for i from 0 + do (loop + for x = 0 then (+ x w x-spacing) + for w in cols + for j from 0 + do (let ((child (aref array i j))) + (layout-child child + (pane-align-x pane) + (pane-align-y pane) + x y w h)))))))) (defun table-pane-p (pane) (typep pane 'table-pane))

1 0

[mcclim-cvs] CVS update: mcclim/text-selection.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26311 Modified Files: text-selection.lisp Log Message: FETCH-SELECTION: - We pad out selection we get from tables and similar things with spaces now. Date: Mon Nov 28 14:04:55 2005 Author: gbaumann Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.6 mcclim/text-selection.lisp:1.7 --- mcclim/text-selection.lisp:1.6 Tue Mar 22 13:31:18 2005 +++ mcclim/text-selection.lisp Mon Nov 28 14:04:55 2005 @@ -403,18 +403,27 @@ ;; FIXME: Non-text target conversions.. (?) (defun fetch-selection (pane) - (let (old-y2) + (let (old-y2 old-x2) (with-output-to-string (bag) -; (let ((bag *trace-output*)) (map nil (lambda (m) (with-slots (record styled-string start end) m - (with-standard-rectangle* (:y1 y1 :y2 y2) record - (if (and old-y2 (>= y1 old-y2)) - (progn - (setf old-y2 nil) - (terpri bag)) - (setf old-y2 (max y2 (or old-y2 y2))))) - (princ (subseq (styled-string-string styled-string) start end) bag))) + (with-standard-rectangle* + (:x1 x1 :x2 x2 :y1 y1 :y2 y2) record + (cond ((and old-y2 (>= y1 old-y2)) + (setf old-y2 nil + old-x2 0 ;<-- ### we should use the minimum of all x1 coordinates. + ) + (terpri bag)) + (t + (setf old-y2 (max y2 (or old-y2 y2))))) + (when old-x2 + (loop repeat (round + (- x1 old-x2) + (text-style-width (slot-value styled-string 'text-style) + pane)) + do + (princ " " bag))) + (setf old-x2 x2) + (princ (subseq (styled-string-string styled-string) start end) bag)))) (slot-value pane 'markings))))) -

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv26265 Modified Files: medium.lisp Log Message: MEDIUM-COPY-AREA (CLX-MEDIUM T T T T CLX-MEDIUM T T): - we transform width and height too now. Date: Mon Nov 28 14:01:59 2005 Author: gbaumann Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.69 mcclim/Backends/CLX/medium.lisp:1.70 --- mcclim/Backends/CLX/medium.lisp:1.69 Mon Nov 28 12:53:41 2005 +++ mcclim/Backends/CLX/medium.lisp Mon Nov 28 14:01:59 2005 @@ -359,12 +359,14 @@ from-x from-y) (with-transformed-position ((sheet-native-transformation (medium-sheet to-drawable)) to-x to-y) - (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) - (medium-gcontext from-drawable +background-ink+) - (round-coordinate from-x) (round-coordinate from-y) - (round width) (round height) - (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable))) - (round-coordinate to-x) (round-coordinate to-y))))) + (multiple-value-bind (width height) (transform-distance (medium-transformation from-drawable) + width height) + (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) + (medium-gcontext from-drawable +background-ink+) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) + (or (medium-buffer to-drawable) (sheet-direct-mirror (medium-sheet to-drawable))) + (round-coordinate to-x) (round-coordinate to-y)))))) (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height (to-drawable pixmap) to-x to-y)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv25198 Modified Files: port.lisp Log Message: SEND-SELECTION: selection slot of ;selection-notify event now matches selection event. Date: Mon Nov 28 13:58:18 2005 Author: gbaumann Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.112 mcclim/Backends/CLX/port.lisp:1.113 --- mcclim/Backends/CLX/port.lisp:1.112 Thu Jun 16 11:27:49 2005 +++ mcclim/Backends/CLX/port.lisp Mon Nov 28 13:58:18 2005 @@ -1431,8 +1431,7 @@ ;;; TODO: INCR property? ;;; ;;; FIXME: per ICCCM we MUST support :MULTIPLE -(defmethod send-selection - ((port clx-port) (event clx-selection-request-event) string) +(defmethod send-selection ((port clx-port) (event clx-selection-request-event) string) (let ((requestor (selection-event-requestor event)) (property (selection-event-property event)) (target (selection-event-target event)) @@ -1447,17 +1446,17 @@ ;; debugging output, but the KDE Klipper client turns out ;; to poll other clients for selection, which means it ;; would be bad to print at every request. - #+nil + #+nil (format *trace-output* - "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A.~%" + "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A. time ~S~%" (selection-event-target event) target - property) + property time) (xlib:send-event requestor :selection-notify nil :window requestor :event-window requestor - :selection :primary + :selection (climi::selection-event-selection event) :target target :property property :time time)))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by gbaumann＠common-lisp.net 28 Nov '05

28 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv20807 Modified Files: medium.lisp Log Message: TEXT-SIZE, CLIMI::TEXT-BOUNDING-RECTANGLE* end argument was not handled properly in case of multi-line strings Date: Mon Nov 28 12:53:42 2005 Author: gbaumann Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.68 mcclim/Backends/CLX/medium.lisp:1.69 --- mcclim/Backends/CLX/medium.lisp:1.68 Thu Oct 27 03:21:35 2005 +++ mcclim/Backends/CLX/medium.lisp Mon Nov 28 12:53:41 2005 @@ -795,7 +795,7 @@ (cond ((= start end) (values 0 0 0 0 0)) (t - (let ((position-newline (position #\newline string :start start))) + (let ((position-newline (position #\newline string :start start :end end))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction @@ -834,7 +834,7 @@ (cond ((= start end) (values 0 0 0 0)) (t - (let ((position-newline (position #\newline string :start start))) + (let ((position-newline (position #\newline string :start start :end end))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction @@ -875,7 +875,7 @@ (cond ((= start end) (values 0 0 0 0 0)) (t - (let ((position-newline (position #\newline string :start start))) + (let ((position-newline (position #\newline string :start start :end end))) (cond ((not (null position-newline)) (multiple-value-bind (width ascent descent left right font-ascent font-descent direction

1 0

[mcclim-cvs] CVS update: mcclim/Extensions/conditional-commands/creating-assoc.lisp
by mretzlaff＠common-lisp.net 24 Nov '05

24 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands In directory common-lisp.net:/tmp/cvs-serv13488 Modified Files: creating-assoc.lisp Log Message: Remove the old and uncommented versions of CREATING-ASSOC. Date: Thu Nov 24 19:37:12 2005 Author: mretzlaff Index: mcclim/Extensions/conditional-commands/creating-assoc.lisp diff -u mcclim/Extensions/conditional-commands/creating-assoc.lisp:1.1 mcclim/Extensions/conditional-commands/creating-assoc.lisp:1.2 --- mcclim/Extensions/conditional-commands/creating-assoc.lisp:1.1 Thu Nov 24 19:35:34 2005 +++ mcclim/Extensions/conditional-commands/creating-assoc.lisp Thu Nov 24 19:37:12 2005 @@ -1,80 +1,5 @@ (in-package :creating-assoc) -;;; Doesn't work: -;;; -;;; (defun creating-assoc (item alist) -;;; "assoc that creates the requested alist item on-the-fly if not yet existing" -;;; (let ((item-assoc (assoc item alist))) -;;; (unless item-assoc -;;; (let ((new-item (list item))) -;;; (push new-item alist) -;;; (setf item-assoc new-item))))) - -;;; Doesn't work: -;;; -;;; (defmacro creating-assoc (item alist) -;;; "assoc that creates the requested alist item on-the-fly if not yet existing" -;;; (let ((entry (gensym "entry-")) -;;; (new-item (gensym "new-item-")) -;;; (the-item (gensym "the-item-")) -;;; (the-alist (gensym "the-alist-"))) -;;; `(let* ((,the-item ,item) -;;; (,the-alist ,alist) -;;; (,entry (assoc ,the-item ,the-alist))) -;;; (unless ,entry -;;; (let ((,new-item (list ,the-item))) -;;; (push ,new-item ,the-alist) -;;; (setf ,entry ,new-item)))))) - -;;; Does work, but ALIST will be evaluated twice: -;;; -;;; (defmacro creating-assoc (item alist) -;;; "assoc that creates the requested alist item on-the-fly if not yet existing" -;;; (let ((entry (gensym "entry-")) -;;; (new-item (gensym "new-item-")) -;;; (the-item (gensym "the-item-"))) -;;; `(let* ((,the-item ,item) -;;; (,entry (assoc ,the-item ,alist))) -;;; (unless ,entry -;;; (let ((,new-item (list ,the-item))) -;;; (push ,new-item ,alist) -;;; (setf ,entry ,new-item)))))) - -;;; From SBCL source, uses GET-SETF-METHOD, a relic from pre-ANSI Common Lisp: -;;; -;;; (defmacro-mundanely push (obj place &environment env) -;;; #!+sb-doc -;;; "Takes an object and a location holding a list. Conses the object onto -;;; the list, returning the modified list. OBJ is evaluated before PLACE." -;;; (multiple-value-bind (dummies vals newval setter getter) -;;; (get-setf-method place env) -;;; (let ((g (gensym))) -;;; `(let* ((,g ,obj) -;;; ,@(mapcar #'list dummies vals) -;;; (,(car newval) (cons ,g ,getter))) -;;; ,setter)))) - -;;; Example CLHS page on GET-SETF-EXPANSION: -;;; (Notice that there is an error, "(if (cdr new)" should be replaced by "(if (cdr ,(car new))".) -;;; -;;; (defmacro xpop (place &environment env) -;;; (multiple-value-bind (dummies vals new setter getter) -;;; (get-setf-expansion place env) -;;; `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter)) -;;; (if (cdr new) (error "Can't expand this.")) -;;; (prog1 (car ,(car new)) -;;; (setq ,(car new) (cdr ,(car new))) -;;; ,setter)))) - -;;; New version, still does not work: -;;; -;;; (defun creating-assoc (item alist) -;;; "assoc that creates the requested alist item on-the-fly if not yet existing" -;;; (or (assoc item alist) -;;; (first (push (list item) alist)))) - -;;; Macro based on the new (not-working) defun, works and is nice: -;;; (defmacro creating-assoc (item alist &environment env) "assoc that creates the requested alist item on-the-fly if not yet existing" (multiple-value-bind (dummies vals new setter getter)

1 0

[mcclim-cvs] CVS update: mcclim/Extensions/conditional-commands/README mcclim/Extensions/conditional-commands/command-and-command-table-utilities.lisp mcclim/Extensions/conditional-commands/conditional-commands-example.lisp mcclim/Extensions/conditional-commands/conditional-commands.asd mcclim/Extensions/conditional-commands/creating-assoc.lisp mcclim/Extensions/conditional-commands/entity-enabledness-handling.lisp mcclim/Extensions/conditional-commands/package.lisp
by mretzlaff＠common-lisp.net 24 Nov '05

24 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands In directory common-lisp.net:/tmp/cvs-serv13435 Added Files: README command-and-command-table-utilities.lisp conditional-commands-example.lisp conditional-commands.asd creating-assoc.lisp entity-enabledness-handling.lisp package.lisp Log Message: Add the Conditional Commands (And Sheets) Extension. Date: Thu Nov 24 19:35:34 2005 Author: mretzlaff

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Extensions/conditional-commands
by mretzlaff＠common-lisp.net 24 Nov '05

24 Nov '05

Update of /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands In directory common-lisp.net:/tmp/cvs-serv13412/conditional-commands Log Message: Directory /project/mcclim/cvsroot/mcclim/Extensions/conditional-commands added to the repository Date: Thu Nov 24 19:32:17 2005 Author: mretzlaff New directory mcclim/Extensions/conditional-commands added

1 0