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

[mcclim-cvs] CVS update: mcclim/system.lisp
by ahefner＠common-lisp.net 31 Jan '05

31 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23128 Modified Files: system.lisp Log Message: Add method-browser to clim-examples system. Date: Sun Jan 30 22:24:58 2005 Author: ahefner Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.109 mcclim/system.lisp:1.110 --- mcclim/system.lisp:1.109 Tue Jan 18 04:20:15 2005 +++ mcclim/system.lisp Sun Jan 30 22:24:58 2005 @@ -210,6 +210,7 @@ "Examples/stream-test" "Examples/presentation-test" #+clx "Examples/gadget-test" + "Examples/method-browser" "Goatee/goatee-test" "Examples/accepting-values")

1 0

[mcclim-cvs] CVS update: mcclim/Examples/method-browser.lisp
by ahefner＠common-lisp.net 31 Jan '05

31 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv23100 Added Files: method-browser.lisp Log Message: Added method-browser app to examples. Date: Sun Jan 30 22:24:24 2005 Author: ahefner

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by ahefner＠common-lisp.net 31 Jan '05

31 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv22327 Modified Files: gadgets.lisp Log Message: Add standard-sheet-input-mixin to superclasses of generic-list-pane in order to make it work within the popup menu of the option-pane in unithreaded SBCL (and presumably other non-MP lisps). This feels like a hack. Date: Sun Jan 30 22:09:55 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.86 mcclim/gadgets.lisp:1.87 --- mcclim/gadgets.lisp:1.86 Sat Jan 1 21:25:38 2005 +++ mcclim/gadgets.lisp Sun Jan 30 22:09:55 2005 @@ -100,8 +100,6 @@ ;; - the slider needs a total overhaul -;; - OPTION-PANE needs an implmentation - ;; - TEXT-FILED, TEXT-AREA dito ;; - GADGET-COLOR-MIXIN is currently kind of dangling, we should reuse @@ -1984,6 +1982,7 @@ :documentation "A function to compare two items for equality."))) (defclass generic-list-pane (list-pane meta-list-pane + standard-sheet-input-mixin ;; Hmm.. value-changed-repaint-mixin mouse-wheel-scroll-mixin) ((highlight-ink :initform +royalblue4+ @@ -2405,22 +2404,25 @@ (multiple-value-bind (x0 y0 x1 y1) (multiple-value-call #'values (transform-position (sheet-delta-transformation parent nil) cx0 cy0) - (transform-position (sheet-delta-transformation parent nil) cx1 cy1)) - (let* ((topmost-pane (if scroll-p + (transform-position (sheet-delta-transformation parent nil) cx1 cy1)) + ;; Note: This :suggested-width/height business is really a silly hack + ;; which I could have easily worked around without adding kludges + ;; to the scroller-pane.. + (let* ((topmost-pane (if scroll-p ;list-pane (scrolling (:scroll-bar :vertical :suggest-height height ;; Doesn't appear to be working.. :suggest-width (if scroll-p (+ 30 (bounding-rectangle-width list-pane)))) list-pane) list-pane)) - (topmost-pane (outlining (:thickness 1) topmost-pane)) + (topmost-pane (outlining (:thickness 1) topmost-pane)) (composed-height (space-requirement-height (compose-space topmost-pane :width (- x1 x0) :height height))) - (menu-frame (make-menu-frame topmost-pane - :min-width (bounding-rectangle-width parent) - :left x0 - :top (if (eq position :below) - y1 - (- y0 composed-height 1))))) + (menu-frame (make-menu-frame topmost-pane + :min-width (bounding-rectangle-width parent) + :left x0 + :top (if (eq position :below) + y1 + (- y0 composed-height 1))))) (values list-pane topmost-pane menu-frame))))))) (defun popup-list-box (parent)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 30 Jan '05

30 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv12131 Modified Files: inspector.lisp Log Message: Many improvements, both to functionality and to the structure of the code. (thanks to Vincent Arkesteijn) Date: Sat Jan 29 22:02:56 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.6 mcclim/Apps/Inspector/inspector.lisp:1.7 --- mcclim/Apps/Inspector/inspector.lisp:1.6 Sat Jan 29 07:57:28 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 22:02:56 2005 @@ -25,7 +25,7 @@ (in-package :inspector) (define-application-frame inspector () - ((dico :initform (make-hash-table :test #'eq) :reader dico) + ((dico :initform (make-hash-table) :reader dico) (obj :initarg :obj :reader obj)) (:pointer-documentation t) (:panes @@ -41,6 +41,14 @@ (declare (ignore args)) (setf (gethash (obj frame) (dico frame)) t)) +(defmethod redisplay-frame-pane :after ((frame inspector) + (pane application-pane) + &key force-p) + (declare (ignore force-p)) + (change-space-requirements + pane + :height (bounding-rectangle-height (stream-output-history pane)))) + (defun inspector (obj) (let ((*print-length* 10) (*print-level* 10)) @@ -49,31 +57,24 @@ (defparameter *inspected-objects* '()) -(defun currently-viewable (obj) - (multiple-value-bind (value present) - (gethash obj (dico *application-frame*)) - (if present - value - (setf (gethash obj - (dico *application-frame*)) - (or (symbolp obj) - (numberp obj) - (stringp obj)))))) - +(defgeneric inspect-object-briefly (object pane)) (defgeneric inspect-object (object pane)) (defmethod inspect-object :around (object pane) - (cond ((not (currently-viewable object)) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (princ "..."))) - ((member object *inspected-objects*) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (princ "==="))) - (t - (let ((*inspected-objects* (cons object *inspected-objects*))) - (call-next-method))))) + (cond ((member object *inspected-objects*) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (princ "==="))) + ((not (gethash object (dico *application-frame*))) + (inspect-object-briefly object pane)) + (t + (let ((*inspected-objects* (cons object *inspected-objects*))) + (call-next-method))))) + +(defmethod inspect-object-briefly (object pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (princ "..."))) (defmethod inspect-object (object pane) (with-output-as-presentation @@ -120,27 +121,40 @@ (declare (ignore acceptably for-context-type)) (format stream "~s" (cdr object))) +(defmacro inspector-table (header &body body) + `(with-output-as-presentation + (pane object (presentation-type-of object)) + (formatting-table (pane) + (formatting-column (pane) + (formatting-cell (pane) + (surrounding-output-with-border (pane) + ,header)) + (formatting-cell (pane) + (formatting-table (pane) + ,@body)))))) + +(defmacro inspector-table-row (left right) + `(formatting-row (pane) + (formatting-cell (pane :align-x :right) + ,left) + (formatting-cell (pane) + ,right))) + +(defmethod inspect-object-briefly ((object standard-object) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (format pane "instance of ~S" (class-name (class-of object))))) (defmethod inspect-object ((object standard-object) pane) (let ((class (class-of object))) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (formatting-table (pane) - (formatting-row (pane) - (formatting-cell (pane) - (surrounding-output-with-border (pane) - (print (class-name class) pane)))) - (formatting-row (pane) - (formatting-cell (pane) - (formatting-table (pane) - (loop for slot in (reverse (class-slots class)) - do (let ((slot-name (slot-definition-name slot))) - (formatting-row (pane) - (formatting-cell (pane :align-x :right) - (with-output-as-presentation - (pane (cons object slot-name) 'settable-slot) - (format pane "~a:" slot-name))) - (formatting-cell (pane) - (inspect-object (slot-value object slot-name) pane)))))))))))) + (inspector-table + (print (class-name class) pane) + (loop for slot in (reverse (class-slots class)) + do (let ((slot-name (slot-definition-name slot))) + (inspector-table-row + (with-output-as-presentation + (pane (cons object slot-name) 'settable-slot) + (format pane "~a:" slot-name)) + (inspect-object (slot-value object slot-name) pane))))))) (defmethod inspect-object ((object cons) pane) (if (null (cdr object)) @@ -172,44 +186,135 @@ (formatting-cell (pane) (inspect-object (cdr object) pane)))))) +(defmethod inspect-object-briefly ((object hash-table) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (princ 'hash-table pane))) (defmethod inspect-object ((object hash-table) pane) + (inspector-table + (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) + (loop for key being the hash-keys of object + do (inspector-table-row + (formatting-cell (pane) + (inspect-object key pane) + (princ "=" pane)) + (inspect-object (gethash key object) pane))))) + +(defmethod inspect-object ((object generic-function) pane) + (inspector-table + (format pane "Generic Function: ~s" (generic-function-name object)) + (loop for method in (generic-function-methods object) + do (with-output-as-presentation + (pane method (presentation-type-of method)) + (formatting-row (pane) + (formatting-cell (pane) + (print (method-qualifiers method))) + (loop for specializer in (method-specializers method) + do (formatting-cell (pane) + (format pane "~s " (class-name specializer))))))))) + +(defmethod inspect-object-briefly ((object package) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (format pane "Package: ~S" (package-name object)))) +(defmethod inspect-object ((object package) pane) + (inspector-table + (format pane "Package: ~S" (package-name object)) + (inspector-table-row + (princ "Name:" pane) + (inspect-object (package-name object) pane)) + (inspector-table-row + (princ "Nicknames:" pane) + (dolist (nick (package-nicknames object)) + (inspect-object nick pane))) + (inspector-table-row + (princ "Used by:") + (dolist (used-by (package-used-by-list object)) + (inspect-object used-by pane))) + (inspector-table-row + (princ "Uses:") + (dolist (uses (package-use-list object)) + (inspect-object uses pane))))) + +(defmethod inspect-object ((object vector) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) - (formatting-column (pane) + (formatting-row (pane) (formatting-cell (pane) - (surrounding-output-with-border (pane) - (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)))) + (princ "#(" pane)) + (dotimes (i (length object)) + (formatting-cell (pane) + (inspect-object (aref object i) pane))) (formatting-cell (pane) - (formatting-table (pane) - (loop for key being the hash-keys of object - do (formatting-row (pane) - (formatting-cell (pane :align-x :right) - (inspect-object key pane) - (princ "=" pane)) - (formatting-cell (pane) - (inspect-object (gethash key object) pane)))))))))) + (princ ")" pane)))))) -(defmethod inspect-object ((object generic-function) pane) +(defmethod inspect-object-briefly ((object string) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object))) + +(defmethod inspect-object-briefly ((object number) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object))) + +(defmethod inspect-object ((object complex) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) (formatting-row (pane) - (formatting-cell (pane) - (surrounding-output-with-border (pane) - (format pane "Generic Function: ~s" (generic-function-name object))))) - (formatting-row (pane) - (formatting-cell (pane) - (formatting-table (pane) - (loop for method in (generic-function-methods object) - do (with-output-as-presentation - (pane method (presentation-type-of method)) - (formatting-row (pane) - (formatting-cell (pane) - (print (method-qualifiers method))) - (loop for specializer in (method-specializers method) - do (formatting-cell (pane) - (format pane "~s " (class-name specializer))))))))))))) + (formatting-cell (pane) + (princ "#C(" pane)) + (formatting-cell (pane) + (inspect-object (realpart object) pane)) + (formatting-cell (pane) + (inspect-object (imagpart object) pane)) + (formatting-cell (pane) + (princ ")" pane)))))) + +(defmethod inspect-object ((object float) pane) + (inspector-table + (format pane "float ~S" object) + (multiple-value-bind (significand exponent sign) + (decode-float object) + (inspector-table-row + (princ "sign:") + (inspect-object sign pane)) + (inspector-table-row + (princ "significand:") + (inspect-object significand pane)) + (inspector-table-row + (princ "exponent:") + (inspect-object exponent pane))) + (inspector-table-row + (princ "radix:") + (inspect-object (float-radix object) pane)))) + +(defmethod inspect-object-briefly ((object symbol) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object))) +(defmethod inspect-object ((object symbol) pane) + (inspector-table + (format pane "Symbol ~S" (symbol-name object)) + (inspector-table-row + (princ "value:") + (if (boundp object) + (inspect-object (symbol-value object) pane) + (princ "unbound"))) + (inspector-table-row + (princ "function:") + (if (fboundp object) + (inspect-object (symbol-function object) pane) + (princ "unbound"))) + (inspector-table-row + (princ "package:") + (inspect-object (symbol-package object) pane)) + (inspector-table-row + (princ "propery list:") + (dolist (property (symbol-plist object)) + (inspect-object property pane))))) (defun display-app (frame pane) (inspect-object (obj frame) pane))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv784 Modified Files: inspector.lisp Log Message: Slots are now presentations. Selecting a slot makes it possible to alter its value. Date: Sat Jan 29 07:57:28 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.5 mcclim/Apps/Inspector/inspector.lisp:1.6 --- mcclim/Apps/Inspector/inspector.lisp:1.5 Sat Jan 29 07:27:36 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 07:57:28 2005 @@ -110,6 +110,16 @@ #+openmcl (ccl:method-generic-function method) #-(or sbcl openmcl) (error "no MOP")) +(define-presentation-type settable-slot () + :inherit-from t) + +(define-presentation-method present (object (type settable-slot) + stream + (view textual-view) + &key acceptably for-context-type) + (declare (ignore acceptably for-context-type)) + (format stream "~s" (cdr object))) + (defmethod inspect-object ((object standard-object) pane) (let ((class (class-of object))) (with-output-as-presentation @@ -127,7 +137,7 @@ (formatting-row (pane) (formatting-cell (pane :align-x :right) (with-output-as-presentation - (pane slot (present-type-of slot)) + (pane (cons object slot-name) 'settable-slot) (format pane "~a:" slot-name))) (formatting-cell (pane) (inspect-object (slot-value object slot-name) pane)))))))))))) @@ -221,3 +231,8 @@ (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) (remove-method (method-generic-function obj) obj)) + +(define-inspector-command (com-set-slot :name t) + ((slot 'settable-slot :gesture :select :prompt "Set slot")) + (setf (slot-value (car slot) (cdr slot)) + (accept t :prompt "New slot value")))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv31723 Modified Files: inspector.lisp Log Message: slots are now presentations in preparation for a command for assigning slot values. Date: Sat Jan 29 07:27:37 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.4 mcclim/Apps/Inspector/inspector.lisp:1.5 --- mcclim/Apps/Inspector/inspector.lisp:1.4 Sat Jan 29 07:02:57 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 07:27:36 2005 @@ -126,7 +126,9 @@ do (let ((slot-name (slot-definition-name slot))) (formatting-row (pane) (formatting-cell (pane :align-x :right) - (format pane "~a:" slot-name)) + (with-output-as-presentation + (pane slot (present-type-of slot)) + (format pane "~a:" slot-name))) (formatting-cell (pane) (inspect-object (slot-value object slot-name) pane))))))))))))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv30908 Modified Files: inspector.lisp Log Message: Fixed some typos. Thanks to Vincent Arkesteijn. Date: Sat Jan 29 07:02:57 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.3 mcclim/Apps/Inspector/inspector.lisp:1.4 --- mcclim/Apps/Inspector/inspector.lisp:1.3 Sat Jan 29 06:58:29 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 07:02:57 2005 @@ -3,7 +3,7 @@ ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2005 by -;;; Vincent Arkesteij +;;; Vincent Arkesteijn ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -92,22 +92,22 @@ (defun generic-function-name (generic-function) #+sbcl (sb-mop:generic-function-name generic-function) - #+openmcl (ccl:generic-function-name slot) + #+openmcl (ccl:generic-function-name generic-function) #-(or sbcl openmcl) (error "no MOP")) (defun generic-function-methods (generic-function) #+sbcl (sb-mop:generic-function-methods generic-function) - #+openmcl (ccl:generic-function-methods slot) + #+openmcl (ccl:generic-function-methods generic-function) #-(or sbcl openmcl) (error "no MOP")) (defun method-specializers (method) #+sbcl (sb-mop:method-specializers method) - #+openmcl (ccl:method-specializers slot) + #+openmcl (ccl:method-specializers method) #-(or sbcl openmcl) (error "no MOP")) (defun method-generic-function (method) #+sbcl (sb-mop:method-generic-function method) - #+openmcl (ccl:method-generic-function slot) + #+openmcl (ccl:method-generic-function method) #-(or sbcl openmcl) (error "no MOP")) (defmethod inspect-object ((object standard-object) pane)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv30166 Modified Files: inspector.lisp Log Message: Better layout for standard-object Date: Sat Jan 29 06:58:30 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.2 mcclim/Apps/Inspector/inspector.lisp:1.3 --- mcclim/Apps/Inspector/inspector.lisp:1.2 Sat Jan 29 06:48:38 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 06:58:29 2005 @@ -119,13 +119,16 @@ (formatting-cell (pane) (surrounding-output-with-border (pane) (print (class-name class) pane)))) - (loop for slot in (reverse (class-slots class)) - do (let ((slot-name (slot-definition-name slot))) - (formatting-row (pane) - (formatting-cell (pane :align-x :right) - (format pane "~a:" slot-name)) - (formatting-cell (pane) - (inspect-object (slot-value object slot-name) pane))))))))) + (formatting-row (pane) + (formatting-cell (pane) + (formatting-table (pane) + (loop for slot in (reverse (class-slots class)) + do (let ((slot-name (slot-definition-name slot))) + (formatting-row (pane) + (formatting-cell (pane :align-x :right) + (format pane "~a:" slot-name)) + (formatting-cell (pane) + (inspect-object (slot-value object slot-name) pane)))))))))))) (defmethod inspect-object ((object cons) pane) (if (null (cdr object))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv30104 Modified Files: inspector.lisp Log Message: Better layout for generic functions. Date: Sat Jan 29 06:48:38 2005 Author: rstrandh Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.1 mcclim/Apps/Inspector/inspector.lisp:1.2 --- mcclim/Apps/Inspector/inspector.lisp:1.1 Sat Jan 29 04:10:54 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Jan 29 06:48:38 2005 @@ -182,16 +182,19 @@ (formatting-row (pane) (formatting-cell (pane) (surrounding-output-with-border (pane) - (print (generic-function-name object) pane)))) - (loop for method in (generic-function-methods object) - do (with-output-as-presentation - (pane method (presentation-type-of method)) - (formatting-row (pane) - (formatting-cell (pane) - (print (method-qualifiers method))) - (loop for specializer in (method-specializers method) - do (formatting-cell (pane) - (format pane "~s " (class-name specializer)))))))))) + (format pane "Generic Function: ~s" (generic-function-name object))))) + (formatting-row (pane) + (formatting-cell (pane) + (formatting-table (pane) + (loop for method in (generic-function-methods object) + do (with-output-as-presentation + (pane method (presentation-type-of method)) + (formatting-row (pane) + (formatting-cell (pane) + (print (method-qualifiers method))) + (loop for specializer in (method-specializers method) + do (formatting-cell (pane) + (format pane "~s " (class-name specializer))))))))))))) (defun display-app (frame pane) (inspect-object (obj frame) pane))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/INSTALL mcclim/Apps/Inspector/inspector.asd mcclim/Apps/Inspector/inspector.lisp
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv21831 Added Files: INSTALL inspector.asd inspector.lisp Log Message: Embryonic inspector application. Date: Sat Jan 29 04:10:54 2005 Author: rstrandh

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Apps/Inspector
by rstrandh＠common-lisp.net 29 Jan '05

29 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv21792/Inspector Log Message: Directory /project/mcclim/cvsroot/mcclim/Apps/Inspector added to the repository Date: Sat Jan 29 04:09:27 2005 Author: rstrandh New directory mcclim/Apps/Inspector added

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/menu-choose.lisp
by ahefner＠common-lisp.net 25 Jan '05

25 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Experimental In directory common-lisp.net:/tmp/cvs-serv30589 Modified Files: menu-choose.lisp Log Message: Remove usage of exit-window variable, which was totally wrong and made it difficult to exit via clicking outside the menu. I don't think this breaks what Tim Moore was trying to accomplish, for which switching from :presentation-button-press to :presentation-button-release should be sufficient. Note that I still think this menu implementation should go away and be replaced with the one in McCLIM/menu.lisp, if possible. :) Date: Tue Jan 25 20:29:07 2005 Author: ahefner Index: mcclim/Experimental/menu-choose.lisp diff -u mcclim/Experimental/menu-choose.lisp:1.15 mcclim/Experimental/menu-choose.lisp:1.16 --- mcclim/Experimental/menu-choose.lisp:1.15 Tue Jan 11 06:39:02 2005 +++ mcclim/Experimental/menu-choose.lisp Tue Jan 25 20:29:06 2005 @@ -266,24 +266,16 @@ :width x2 :height y2 :resize-frame t))) - ;; Eat pointer release event so it isn't fed spuriously to another - ;; command entering its own tracking-pointer loop. - (let ((*pointer-documentation-output* pointer-documentation) - (exit-menu nil)) + (let ((*pointer-documentation-output* pointer-documentation)) (tracking-pointer (menu :context-type presentation-type :multiple-window t :highlight t) - (:presentation (&key presentation) - (setq exit-menu t)) - (:pointer-button-release (&key event x y) ; Pointer clicked outside menu? - ; Close the menu. - (when exit-menu - (unless (and (sheet-ancestor-p (event-sheet event) menu) - (region-contains-position-p (sheet-region menu) x y)) - (return-from menu-choose-from-drawer (values nil))))) + (:pointer-button-press (&key event x y) ; Close if pointer clicked outside menu. + (unless (and (sheet-ancestor-p (event-sheet event) menu) + (region-contains-position-p (sheet-region menu) x y)) + (return-from menu-choose-from-drawer (values nil)))) (:presentation-button-release (&key event presentation x y) (if (and (sheet-ancestor-p (event-sheet event) menu) (region-contains-position-p (sheet-region menu) x y)) (return-from menu-choose-from-drawer (values (presentation-object presentation) event)) (return-from menu-choose-from-drawer (values nil))))))) -

1 0

[mcclim-cvs] CVS update: mcclim/medium.lisp
by afuchs＠common-lisp.net 24 Jan '05

24 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv2822 Modified Files: medium.lisp Log Message: commit a patch by Eric Marsden for a typo (http://paste.lisp.org/display/5237) squere->square Date: Mon Jan 24 15:03:45 2005 Author: afuchs Index: mcclim/medium.lisp diff -u mcclim/medium.lisp:1.53 mcclim/medium.lisp:1.54 --- mcclim/medium.lisp:1.53 Sun Mar 28 07:16:55 2004 +++ mcclim/medium.lisp Mon Jan 24 15:03:41 2005 @@ -536,7 +536,7 @@ (cap-shape :initarg :line-cap-shape :initform :butt :reader line-style-cap-shape - :type (member :butt :squere :round :no-end-point)) + :type (member :butt :square :round :no-end-point)) (dashes :initarg :line-dashes :initform nil :reader line-style-dashes

1 0

[mcclim-cvs] CVS update: mcclim/commands.lisp
by tmoore＠common-lisp.net 24 Jan '05

24 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25788 Modified Files: commands.lisp Log Message: Changes to MAKE-PARTIAL-PARSER-FUN and supporting functions. If a command argument is unspecified and there is no default specified for that argument, then don't pass any any :default argument to the corresponding call to ACCEPT. Also, don't modify the variables that hold the return values for the arguments unless the user actually changes the value; this preserves thhe unspecified argument marker. This fixes the bug show-cmd-table-arg. Date: Mon Jan 24 01:36:01 2005 Author: tmoore Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.50 mcclim/commands.lisp:1.51 --- mcclim/commands.lisp:1.50 Mon Dec 13 04:18:05 2004 +++ mcclim/commands.lisp Mon Jan 24 01:36:00 2005 @@ -575,7 +575,7 @@ "Mapping from command names to argument parsing functions.") -(defvar *unsupplied-argument-marker* (cons nil nil)) +(defvar *unsupplied-argument-marker* (gensym "UNSUPPLIED-ARGUMENT-MARKER")) (defvar *command-name-delimiters* '(command-delimiter)) @@ -614,29 +614,40 @@ ,@args) args))))))) -;;;accept for the partial command reader. Can this be refactored to share code -;;;with accept-form-for-argument? -(defun accept-form-for-argument-partial (stream ptype-arg command-arg) +;;; In the partial command reader accepting-values dialog, default +;;; values come either from the input command arguments, if a value +;;; was supplied, or from the default option for the command argument. +;;; +;;; accept for the partial command reader. Can this be refactored to +;;; share code with accept-form-for-argument? Probably not. +;;; +;;; original-command-arg is value entered by the user, or +;;; *unsupplied-argument-marker*. command-arg is the current value for the +;;; argument, originally bound to original-command-arg and now possibly +;;; changed by the user. +(defun accept-form-for-argument-partial (stream ptype-arg command-arg + original-command-arg ) (let ((accept-keys '(:default :default-type :display-default :prompt :documentation))) - (destructuring-bind (name ptype &rest key-args - &key (mentioned-default nil mentioned-default-p) - &allow-other-keys) + (destructuring-bind (name ptype &rest key-args) ptype-arg (declare (ignore name)) - (let ((accept-args-var (gensym "ACCEPT-ARGS"))) - `(let ((,accept-args-var - (list ,@(loop for (key val) on key-args by #'cddr - when (member key accept-keys) - append `(,key ,val) into args - finally (return (if mentioned-default-p - `(:default ,mentioned-default - ,@args) - args)))))) - (apply #'accept ,ptype :stream ,stream - (if (eq ,command-arg *unsupplied-argument-marker*) - ,accept-args-var - (list* :default ,command-arg ,accept-args-var)))))))) + (let ((args (loop + for (key val) on key-args by #'cddr + if (eq key :default) + append `(:default (if (eq ,command-arg + *unsupplied-argument-marker*) + ,val + ,command-arg)) + else if (member key accept-keys :test #'eq) + append `(,key ,val)))) + (if (member :default args :test #'eq) + `(accept ,ptype :stream ,stream ,@args) + `(if (eq ,original-command-arg *unsupplied-argument-marker*) + (accept ,ptype :stream ,stream ,@args) + (accept ,ptype :stream ,stream :default ,command-arg + ,@args))))))) + (defun make-keyword (sym) (intern (symbol-name sym) :keyword)) @@ -730,26 +741,38 @@ (defun make-partial-parser-fun (name required-args) (with-gensyms (command-table stream partial-command command-name command-line-name) - (let ((required-arg-names (mapcar #'car required-args))) - `(defun ,name (,command-table ,stream ,partial-command) - (destructuring-bind (,command-name ,@required-arg-names) - ,partial-command - (let ((,command-line-name (command-line-name-for-command - ,command-name - ,command-table - :errorp nil))) - (accepting-values (,stream) - (format ,stream - "You are being prompted for arguments to ~S~%" - ,command-line-name) - ,@(loop for var in required-arg-names - for parameter in required-args - append `((setq ,var - ,(accept-form-for-argument-partial stream - parameter - var)) - (terpri ,stream))))) - (list ,command-name ,@required-arg-names)))))) + (let* ((required-arg-names (mapcar #'car required-args)) + (original-args (mapcar #'(lambda (arg) + (gensym (format nil "~A-ORIGINAL" + (symbol-name arg)))) + required-arg-names))) + ;; We don't need fresh gensyms of these variables for each accept form. + (with-gensyms (value ptype changedp) + `(defun ,name (,command-table ,stream ,partial-command) + (destructuring-bind (,command-name ,@original-args) + ,partial-command + (let ((,command-line-name (command-line-name-for-command + ,command-name + ,command-table + :errorp nil)) + ,@(mapcar #'list required-arg-names original-args)) + (accepting-values (,stream) + (format ,stream + "You are being prompted for arguments to ~S~%" + ,command-line-name) + ,@(loop + for var in required-arg-names + for original-var in original-args + for parameter in required-args + append `((multiple-value-bind (,value ,ptype ,changedp) + ,(accept-form-for-argument-partial + stream parameter var original-var) + (declare (ignore ,ptype)) + (terpri ,stream) + (when ,changedp + (setq ,var ,value)))))) + (list ,command-name ,@required-arg-names)))))))) + ;;; XXX What do to about :acceptably? Probably need to wait for Goatee "buffer ;;; streams" so we can insert an accept-result-extent in the buffer for

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by tmoore＠common-lisp.net 22 Jan '05

22 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv16684 Modified Files: presentation-defs.lisp Log Message: In presentation method (present t t t textual-view), do the right thing with the :acceptably keyword argument i.e., arrange for Common Lisp to throw an error for unreadable stuff. Date: Sat Jan 22 14:31:08 2005 Author: tmoore Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.40 mcclim/presentation-defs.lisp:1.41 --- mcclim/presentation-defs.lisp:1.40 Wed Jan 19 14:44:46 2005 +++ mcclim/presentation-defs.lisp Sat Jan 22 14:31:08 2005 @@ -829,7 +829,7 @@ (with-input-position (stream) ; support for calls to replace-input (setf (values sensitizer-object sensitizer-type) (with-input-context (type) - (object object-type event options) + (object object-type event options) (with-activation-gestures ((if additional-activations-p additional-activation-gestures activation-gestures) @@ -996,8 +996,12 @@ (define-default-presentation-method present (object type stream (view textual-view) &key acceptably for-context-type) - (declare (ignore acceptably for-context-type)) - (princ object stream)) + (declare (ignore for-context-type type)) + (if acceptably + (let ((*print-readably* t)) + (prin1 object stream)) + (princ object stream))) + (defun accept-using-read (stream ptype &key ((:read-eval *read-eval*) nil)) (let* ((token (read-token stream)))

1 0

[mcclim-cvs] CVS update: mcclim/builtin-commands.lisp
by tmoore＠common-lisp.net 22 Jan '05

22 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv5050 Modified Files: builtin-commands.lisp Log Message: Remove Describe Presentation from the default right-click menu. This means that interfaces will look much quiter. Date: Sat Jan 22 00:42:40 2005 Author: tmoore Index: mcclim/builtin-commands.lisp diff -u mcclim/builtin-commands.lisp:1.17 mcclim/builtin-commands.lisp:1.18 --- mcclim/builtin-commands.lisp:1.17 Tue May 18 03:47:46 2004 +++ mcclim/builtin-commands.lisp Sat Jan 22 00:42:40 2005 @@ -63,11 +63,6 @@ (define-gesture-name :describe-presentation :pointer-button-press (:left :super)) -;;; This is defined as a command, not just as a translator to -;;; com-describe, so it can be disabled independently of -;;; com-describe. Also, it might do something different from -;;; com-describe someday. - ;;; The argument obj is not really the presentation object but the ;;; presentation itself as supplied by the translator. (define-command (com-describe-presentation :command-table global-command-table) @@ -80,7 +75,8 @@ :tester ((presentation) (not (eq presentation *null-presentation*))) :documentation "Describe Presentation" - :pointer-documentation "Describe Presentation") + :pointer-documentation "Describe Presentation" + :menu presentation-debugging) (presentation) (list presentation))

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by ahefner＠common-lisp.net 21 Jan '05

21 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv3255 Modified Files: panes.lisp Log Message: Implement label option to open-window-stream. Date: Fri Jan 21 03:01:44 2005 Author: ahefner Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.147 mcclim/panes.lisp:1.148 --- mcclim/panes.lisp:1.147 Sat Jan 1 21:26:44 2005 +++ mcclim/panes.lisp Fri Jan 21 03:01:37 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.147 2005/01/02 05:26:44 ahefner Exp $ +;;; $Id: panes.lisp,v 1.148 2005/01/21 11:01:37 ahefner Exp $ (in-package :clim-internals) @@ -2543,6 +2543,7 @@ (frame (make-application-frame 'a-window-stream :frame-event-queue input-buffer :frame-manager fm + :pretty-name (or label "") :left left :top top :right right @@ -2556,6 +2557,7 @@ (eq (frame-state frame) :shrunk)) (enable-frame frame)) ;; Start a new thread to run the event loop, if necessary. + #+CLIM-MP (unless input-buffer (clim-sys:make-process (lambda () (let ((*application-frame* frame)) (standalone-event-loop)))))

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by tmoore＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv20050 Modified Files: presentation-defs.lisp Log Message: For CLOS objects, make presentation-type-of return the name of the class if possible Date: Wed Jan 19 14:44:46 2005 Author: tmoore Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.39 mcclim/presentation-defs.lisp:1.40 --- mcclim/presentation-defs.lisp:1.39 Tue Jan 11 05:02:19 2005 +++ mcclim/presentation-defs.lisp Wed Jan 19 14:44:46 2005 @@ -87,11 +87,15 @@ (defmethod presentation-type-of ((object standard-object)) (multiple-value-bind (name lambda-list) (get-ptype-from-class-of object) - (if (and name - (or (null lambda-list) - (member (first lambda-list) lambda-list-keywords))) - name - (call-next-method)))) + (cond ((and name + (or (null lambda-list) + (member (first lambda-list) lambda-list-keywords))) + name) + (name + 'standard-object) + (t (let* ((class (class-of object)) + (class-name (class-name class))) + (or class-name class)))))) (defmethod presentation-type-of ((object structure-object)) (multiple-value-bind (name lambda-list) @@ -100,7 +104,6 @@ (member lambda-list lambda-list-keywords)) name (call-next-method)))) - (define-presentation-generic-function %map-over-presentation-type-supertypes

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by tmoore＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv15329/Backends/CLX Modified Files: medium.lisp Log Message: In method medium-gcontext ((medium clx-medium) (ink climi::transformed-design)), do return the gcontext as the value of the function. This was screwed up by me in the last commit to this file. Fixes the bug reported by Paolo Amoroso on Jan 17 2005: <integer> is not of type XLIB:GCONTEXT error when using pixmaps in Listener Date: Tue Jan 18 05:35:28 2005 Author: tmoore Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.64 mcclim/Backends/CLX/medium.lisp:1.65 --- mcclim/Backends/CLX/medium.lisp:1.64 Tue Jan 11 05:35:33 2005 +++ mcclim/Backends/CLX/medium.lisp Tue Jan 18 05:35:26 2005 @@ -301,7 +301,8 @@ (setf (xlib:gcontext-ts-x gc) gc-x (xlib:gcontext-ts-y gc) gc-y (xlib:gcontext-clip-x gc) gc-x - (xlib:gcontext-clip-y gc) gc-y)))) + (xlib:gcontext-clip-y gc) gc-y) + gc))) (t (error "You lost, we not yet implemented transforming an ~S." (type-of ink)))))) @@ -514,8 +515,6 @@ (with-transformed-position (tr left top) (with-transformed-position (tr right bottom) (with-clx-graphics (medium) - #+nil (when (typep mirror 'xlib:pixmap) - (break)) (if (< right left) (rotatef left right)) (if (< bottom top) @@ -524,14 +523,14 @@ (top (round-coordinate top)) (right (round-coordinate right)) (bottom (round-coordinate bottom))) - ;; To clip rectangles, we just need to clamp the cooridnates + ;; To clip rectangles, we just need to clamp the + ;; coordinates (xlib:draw-rectangle mirror gc (max #x-8000 (min #x7FFF left)) (max #x-8000 (min #x7FFF top)) (max 0 (min #xFFFF (- right left))) (max 0 (min #xFFFF (- bottom top))) - filled) - )))))) + filled))))))) #+CLX-EXT-RENDER (defmethod medium-draw-rectangle-using-ink* ((medium clx-medium) (ink climi::uniform-compositum)

1 0

[mcclim-cvs] CVS update: mcclim/system.lisp
by rstrandh＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv11515 Modified Files: system.lisp Log Message: Patch from Robert P. Goldman allowing the use of Allegro defsystem without a clash with mk:defsystem. Date: Tue Jan 18 04:20:16 2005 Author: rstrandh Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.108 mcclim/system.lisp:1.109 --- mcclim/system.lisp:1.108 Tue Jan 18 02:58:08 2005 +++ mcclim/system.lisp Tue Jan 18 04:20:15 2005 @@ -43,12 +43,15 @@ (pushnew :clim *features*) (pushnew :mcclim *features*) -#+mk-defsystem (use-package "MK") ++;;; I really didn't have good luck with this on Allegro, because ++;;; Allegro's CL-USER package uses it's EXCL stuff, which has its own ++;;; DEFSYSTEM. [2004/12/21:rpg] ++;;;#+mk-defsystem (use-package "MK") (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn #+mk-defsystem - (defsystem ,module + (mk:defsystem ,module :source-pathname *clim-directory* :source-extension "lisp" ,@(and depends-on `(:depends-on ,depends-on))

1 0

[mcclim-cvs] CVS update: mcclim/Examples/accepting-values.lisp mcclim/Examples/dragndrop.lisp
by tmoore＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv6742/Examples Modified Files: accepting-values.lisp dragndrop.lisp Log Message: Implemented a pop-up-menu-view for displaying the completion presentation type in a dialog. Added some documentation for the internals of accepting-values. Date: Tue Jan 18 02:58:11 2005 Author: tmoore Index: mcclim/Examples/accepting-values.lisp diff -u mcclim/Examples/accepting-values.lisp:1.1 mcclim/Examples/accepting-values.lisp:1.2 --- mcclim/Examples/accepting-values.lisp:1.1 Fri Oct 15 06:05:36 2004 +++ mcclim/Examples/accepting-values.lisp Tue Jan 18 02:58:11 2005 @@ -44,3 +44,13 @@ (setq ymin-changed nil ymax-changed nil))))) (values xmin xmax ymin ymax)) + +;;; Test of McCLIM extension + +(defun accept-popup (seq &key (stream *query-io*)) + (let ((val (elt seq 0)) + (ptype `(completion ,seq))) + (accepting-values (stream) + (setq val (accept ptype :stream stream :view climi::+pop-up-menu-view+ + :prompt "Choose one:" :default val))) + val)) \ No newline at end of file Index: mcclim/Examples/dragndrop.lisp diff -u mcclim/Examples/dragndrop.lisp:1.1 mcclim/Examples/dragndrop.lisp:1.2 --- mcclim/Examples/dragndrop.lisp:1.1 Tue Jan 11 05:35:40 2005 +++ mcclim/Examples/dragndrop.lisp Tue Jan 18 02:58:11 2005 @@ -78,4 +78,7 @@ (define-presentation-to-command-translator translator-clone-circle (circle com-clone-circle dragndrop) (object x y) - `(,object ,x ,y)) \ No newline at end of file + `(,object ,x ,y)) + +(defun drag-circles () + (run-frame-top-level (make-application-frame 'dragndrop)))

1 0

[mcclim-cvs] CVS update: mcclim/dialog-views.lisp mcclim/dialog.lisp mcclim/system.lisp
by tmoore＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv6742 Modified Files: dialog.lisp system.lisp Added Files: dialog-views.lisp Log Message: Implemented a pop-up-menu-view for displaying the completion presentation type in a dialog. Added some documentation for the internals of accepting-values. Date: Tue Jan 18 02:58:09 2005 Author: tmoore Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.16 mcclim/dialog.lisp:1.17 --- mcclim/dialog.lisp:1.16 Tue Jan 11 05:02:19 2005 +++ mcclim/dialog.lisp Tue Jan 18 02:58:08 2005 @@ -23,16 +23,49 @@ produced by accept-present-default, as well as the current value of that query, arguments that were passed to accept, etc. are stored in a query object. The stream stores all the query objects for this -invocation of accepting-values. - -The query output records are presentations with command translators -defined that directly change their value (stored in the query object) -or select them for further user input, like the default text input. +invocation of accepting-values. The record created and returned by +accept-present-default must be a subclass of updating-output-record. After the initial output records are drawn, invoke-accepting-values -blocks accepting commands. When a query's value is changed, the body -of the call to accepting-values is run, with all the values returned -by calls to accept coming from the query objects. +blocks accepting commands. The state of the dialog state machine is changed +via these commands. The commands currently are: + +COM-SELECT-QUERY query-id -- calls the method select-query with the +corresponding query object and output record object. When select-query returns +the "next" field, if any, is selected so the user can move from field to field +easily. + +COM-CHANGE-QUERY query-id value -- This command is used to directly change the +value of a query field that does not need to be selected first for input. For +example, a user would click directly on a radio button without selecting the +gadget first. + +COM-DESELECT-QUERY -- deselects the currently selected query. + +COM-QUERY-EXIT -- Exits accepting-values + +COM-QUERY-ABORT -- Aborts accepting-values + +These commands are generated in two ways. For query fields that are entirely +based on CLIM drawing commands and presentations, these are emitted by +presentation translators. There is a presentation type selectable-query that +throws com-select-query for the :select gesture. Fields that are based on +gadgets have to throw presentations from their callbacks. This can be done +using the method on p. 305 of the Franz CLIM user guide, or by using the +McCLIM function throw-object-ptype. + +After a command is executed the body of accepting-values is rerun, calling +accept-present-default again to update the fields' graphic appearance. [This +may be calling these methods too often an may change in the future]. The +values returned by the user's calls to accept are come from the query objects. + + +If a query field is selectable than it should implement the method +select-query: + +SELECT-QUERY stream query record -- Make a query field active and do any +input. This should change the query object and setf (changedp query). This +method might be interrupted at any time if the user selects another field. |# @@ -292,7 +325,8 @@ (defgeneric select-query (stream query record) (:documentation "Does whatever is needed for input (e.g., calls accept) when -a query is selected for input." )) +a query is selected for input. It is responsible for updating the + query object when a new value is entered in the query field." )) (defgeneric deselect-query (stream query record) (:documentation "Deselect a query field: turn the cursor off, turn off Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.107 mcclim/system.lisp:1.108 --- mcclim/system.lisp:1.107 Sat Jan 1 21:17:59 2005 +++ mcclim/system.lisp Tue Jan 18 02:58:08 2005 @@ -173,6 +173,7 @@ "table-formatting" "graph-formatting" "bordered-output" + "dialog-views" "dialog" ; depends on table formatting "builtin-commands" ; need dialog before commands are defined "describe" @@ -206,7 +207,8 @@ "Examples/stream-test" "Examples/presentation-test" #+clx "Examples/gadget-test" - "Goatee/goatee-test") + "Goatee/goatee-test" + "Examples/accepting-values") (clim-defsystem (:scigraph :depends-on (:clim #+clx :clim-looks))

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by tmoore＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv1478 Modified Files: incremental-redisplay.lisp Log Message: Add explicit calls to FINISH-OUTPUT in COMPUTE-NEW-OUTPUT-RECORDS and INVOKE-UPDATING-OUTPUT. The current text record was being put in different subtrees when a new updating output record was created and when an existing one was found and reused. Date: Tue Jan 18 01:16:32 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.41 mcclim/incremental-redisplay.lisp:1.42 --- mcclim/incremental-redisplay.lisp:1.41 Tue Jan 11 05:35:18 2005 +++ mcclim/incremental-redisplay.lisp Tue Jan 18 01:16:30 2005 @@ -353,9 +353,6 @@ (fixed-position :reader output-record-fixed-position :initarg :fixed-position :initform nil) (displayer :reader output-record-displayer :initarg :displayer) - (sub-record :accessor sub-record - :documentation "The actual contents of this record. All output -record operations are forwarded to this record.") ;; Start and end cursor (start-graphics-state :accessor start-graphics-state :initarg :start-graphics-state @@ -511,12 +508,18 @@ (setf (output-record-dirty r) :updating)) record nil) + (finish-output stream) + ;; Why is this binding here? We need the "environment" in this call that + ;; computes the new records of an outer updating output record to resemble + ;; that when a record's contents are computed in invoke-updating-output. (letf (((stream-current-output-record stream) (output-record-parent record))) (compute-new-output-records-1 record stream (output-record-displayer record))))) +;;; Create the sub-record that holds the new contents of the updating output +;;; record. (defun %invoke-updating (record stream displayer) (letf (((stream-current-output-record stream) record)) (with-new-output-record (stream) @@ -838,6 +841,7 @@ (parent-cache nil)) (unless *enable-updating-output* (return-from invoke-updating-output (funcall continuation stream))) + (finish-output stream) (let ((parent-cache (or parent-cache *current-updating-output* stream))) (when (eq unique-id *no-unique-id*) (setq unique-id (incf (id-counter parent-cache))))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by tmoore＠common-lisp.net 14 Jan '05

14 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv8647 Modified Files: port.lisp Log Message: Fix comment; it's confusing enough without the wrong comment! Date: Fri Jan 14 13:47:47 2005 Author: tmoore Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.104 mcclim/Backends/CLX/port.lisp:1.105 --- mcclim/Backends/CLX/port.lisp:1.104 Fri Jan 14 13:43:25 2005 +++ mcclim/Backends/CLX/port.lisp Fri Jan 14 13:47:47 2005 @@ -36,7 +36,7 @@ ;; ;; Note that CLIM defines pixel coordinates to be at the corners, ;; while in X11 they are at the centers. We don't do much about the - ;; discrepancy, but rounding down at half pixel boundaries seems to + ;; discrepancy, but rounding up at half pixel boundaries seems to ;; work well. (floor (+ x .5)))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by tmoore＠common-lisp.net 14 Jan '05

14 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv7897/Backends/CLX Modified Files: port.lisp Log Message: Change ROUND-COORDINATES back to the definition that rounds up at half pixel boundaries. When I made the previous change I didn't realize that X coordinates are at pixel centers. Date: Fri Jan 14 13:43:25 2005 Author: tmoore Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.103 mcclim/Backends/CLX/port.lisp:1.104 --- mcclim/Backends/CLX/port.lisp:1.103 Tue Jan 11 14:35:33 2005 +++ mcclim/Backends/CLX/port.lisp Fri Jan 14 13:43:25 2005 @@ -34,9 +34,11 @@ ;; Using CL:ROUND gives you "random" results. Using "mercantile ;; rounding" gives you consistent results. ;; - ;; For values at .5 we round down in order to be consistant with - ;; the CLIM and CLX definitions for pixel coverage of shapes. - (ceiling (- x .5))) + ;; Note that CLIM defines pixel coordinates to be at the corners, + ;; while in X11 they are at the centers. We don't do much about the + ;; discrepancy, but rounding down at half pixel boundaries seems to + ;; work well. + (floor (+ x .5))) ;;; CLX-PORT class

1 0