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 26 Jan '05

26 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

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

14 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv7897 Modified Files: presentations.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:23 2005 Author: tmoore Index: mcclim/presentations.lisp diff -u mcclim/presentations.lisp:1.69 mcclim/presentations.lisp:1.70 --- mcclim/presentations.lisp:1.69 Tue Jan 11 14:02:19 2005 +++ mcclim/presentations.lisp Fri Jan 14 13:43:23 2005 @@ -45,6 +45,16 @@ (presentation-mixin standard-sequence-output-record) ()) +(defvar *print-presentation-verbose* nil) + +(defmethod print-object ((self standard-presentation) stream) + (print-unreadable-object (self stream :type t :identity t) + (with-bounding-rectangle* (x1 y1 x2 y2) + self + (format stream "~D:~D,~D:~D ~S" x1 x2 y1 y2 (presentation-type self)) + (when *print-presentation-verbose* + (format stream " ~S" (presentation-object self)))))) + (defgeneric ptype-specializer (type) (:documentation "The specializer to use for this type in a presentation method lambda list")) @@ -1757,7 +1767,7 @@ (frame *application-frame*) event modifier-state button) (find-innermost-presentation-match input-context - (stream-output-history window) + top-record frame window x y @@ -1789,6 +1799,8 @@ x y) (when ptype (funcall (cdr context) object ptype event options))))))) + +(defvar *input-context*) (defun throw-object-ptype (object type &key (input-context *input-context*) sheet)

1 0

[mcclim-cvs] CVS update: mcclim/stream-input.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23180 Modified Files: stream-input.lisp Log Message: Save the last character returned by stream-read-gesture for unreading Date: Tue Jan 11 16:33:32 2005 Author: tmoore Index: mcclim/stream-input.lisp diff -u mcclim/stream-input.lisp:1.40 mcclim/stream-input.lisp:1.41 --- mcclim/stream-input.lisp:1.40 Thu Oct 14 08:30:11 2004 +++ mcclim/stream-input.lisp Tue Jan 11 16:33:32 2005 @@ -123,7 +123,11 @@ (defclass standard-extended-input-stream (extended-input-stream) ((pointer) - (cursor :initarg :text-cursor))) + (cursor :initarg :text-cursor) + (last-gesture :accessor last-gesture :initform nil + :documentation "Holds the last gesture returned by + stream-read-gesture (not peek-p), untransformed, so it can easily be + unread."))) (defvar *input-wait-test* nil) (defvar *input-wait-handler* nil) @@ -254,7 +258,8 @@ ;; An event should be in the stream buffer now. (when (handle-non-stream-event buffer) (go wait-for-char)) - (let ((gesture (convert-to-gesture (pop-gesture buffer peek-p)))) + (let* ((raw-gesture (pop-gesture buffer peek-p)) + (gesture (convert-to-gesture raw-gesture))) ;; Sometimes key press events get generated with a key code for ;; which there is no keysym. This seems to happen on my machine ;; when keys are hit rapidly in succession. I'm not sure if this is @@ -274,7 +279,8 @@ thereis (event-matches-gesture-name-p gesture gesture-name)) (signal 'accelerator-gesture :event gesture)) - (t (return-from stream-read-gesture gesture)))) + (t (setf (last-gesture stream) raw-gesture) + (return-from stream-read-gesture gesture)))) (go wait-for-char))))) @@ -315,8 +321,12 @@ (defmethod stream-unread-gesture ((stream standard-extended-input-stream) gesture) + (declare (ignore gesture)) (with-encapsulating-stream (estream stream) - (repush-gesture gesture (stream-input-buffer estream)))) + (let ((gesture (last-gesture stream))) + (when gesture + (setf (last-gesture stream) nil) + (repush-gesture gesture (stream-input-buffer estream)))))) ;;; Standard stream methods on standard-extended-input-stream. Ignore any ;;; pointer gestures in the input buffer.

1 0

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

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Experimental In directory common-lisp.net:/tmp/cvs-serv20221/Experimental Modified Files: menu-choose.lisp Log Message: Remove some debugging code Date: Tue Jan 11 15:39:03 2005 Author: tmoore Index: mcclim/Experimental/menu-choose.lisp diff -u mcclim/Experimental/menu-choose.lisp:1.14 mcclim/Experimental/menu-choose.lisp:1.15 --- mcclim/Experimental/menu-choose.lisp:1.14 Tue Jan 11 14:14:21 2005 +++ mcclim/Experimental/menu-choose.lisp Tue Jan 11 15:39:02 2005 @@ -273,9 +273,6 @@ (tracking-pointer (menu :context-type presentation-type :multiple-window t :highlight t) (:presentation (&key presentation) - (format *trace-output* "type:~S presentation:~S~%" - presentation-type - presentation) (setq exit-menu t)) (:pointer-button-release (&key event x y) ; Pointer clicked outside menu? ; Close the menu.

1 0

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

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv16352/Examples Added Files: dragndrop.lisp Log Message: Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an argument, allocates a pixmap for that region of the screen, and sets up the sheet transformations so that drawing is done in the correct pixmap coordinates. Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example of using dragging-output. Change the definition of ROUND-COORDINATE in the CLX backend to round down from .5, not up. This should follow the CLIM pixel coverage definition for shapes more closely. Replace most uses of ROUND in the CLX backend with ROUND-COORDINATE. Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT. Date: Tue Jan 11 14:35:41 2005 Author: tmoore

1 0

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

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv16352/Backends/CLX Modified Files: medium.lisp port.lisp Log Message: Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an argument, allocates a pixmap for that region of the screen, and sets up the sheet transformations so that drawing is done in the correct pixmap coordinates. Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example of using dragging-output. Change the definition of ROUND-COORDINATE in the CLX backend to round down from .5, not up. This should follow the CLIM pixel coverage definition for shapes more closely. Replace most uses of ROUND in the CLX backend with ROUND-COORDINATE. Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT. Date: Tue Jan 11 14:35:37 2005 Author: tmoore Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.63 mcclim/Backends/CLX/medium.lisp:1.64 --- mcclim/Backends/CLX/medium.lisp:1.63 Fri Apr 23 21:29:49 2004 +++ mcclim/Backends/CLX/medium.lisp Tue Jan 11 14:35:33 2005 @@ -31,7 +31,6 @@ ;; cache. ;; --GB - ;;; CLX-MEDIUM class (defclass clx-medium (basic-medium) @@ -293,20 +292,16 @@ (error "Sorry, not yet implemented.")) ;; Bah! (typecase design - (climi::indexed-pattern - (let ((gc (design-gcontext medium design))) - (setf (xlib:gcontext-ts-x gc) (round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-ts-y gc) (round (nth-value 1 (transform-position transformation 0 0))) - (xlib:gcontext-clip-x gc)(round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-clip-y gc)(round (nth-value 1 (transform-position transformation 0 0)))) - gc)) - (climi::rectangular-tile - (let ((gc (design-gcontext medium design))) - (setf (xlib:gcontext-ts-x gc) (round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-ts-y gc) (round (nth-value 1 (transform-position transformation 0 0))) - (xlib:gcontext-clip-x gc)(round (nth-value 0 (transform-position transformation 0 0))) - (xlib:gcontext-clip-y gc)(round (nth-value 1 (transform-position transformation 0 0)))) - gc)) + ((or climi::indexed-pattern climi::rectangular-tile) + (multiple-value-bind (tx ty) + (transform-position transformation 0 0) + (let ((gc-x (round-coordinate tx)) + (gc-y (round-coordinate ty)) + (gc (design-gcontext medium design))) + (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)))) (t (error "You lost, we not yet implemented transforming an ~S." (type-of ink)))))) @@ -327,15 +322,18 @@ ; and kill them at the source... #-nil (defun clipping-region->rect-seq (clipping-region) - (loop for region in (nreverse (mapcan - (lambda (v) (unless (eq v +nowhere+) (list v))) - (region-set-regions clipping-region - :normalize :y-banding))) - as rectangle = (bounding-rectangle region) - nconcing (list (round (rectangle-min-x rectangle)) - (round (rectangle-min-y rectangle)) - (round (rectangle-width rectangle)) - (round (rectangle-height rectangle))))) + (loop + for region in (nreverse (mapcan + (lambda (v) (unless (eq v +nowhere+) (list v))) + (region-set-regions clipping-region + :normalize :y-banding))) + as rectangle = (bounding-rectangle region) + for clip-x = (round-coordinate (rectangle-min-x rectangle)) + for clip-y = (round-coordinate (rectangle-min-y rectangle)) + nconcing (list clip-x + clip-y + (- (round-coordinate (rectangle-max-x rectangle)) clip-x) + (- (round-coordinate (rectangle-max-y rectangle)) clip-y)))) (defmacro with-clx-graphics ((medium) &body body) `(let* ((port (port ,medium)) @@ -355,6 +353,8 @@ ;;; Pixmaps +;;; width and height arguments should be integers, but we'll leave the calls +;;; to round in for now. (defmethod medium-copy-area ((from-drawable clx-medium) from-x from-y width height (to-drawable clx-medium) to-x to-y) @@ -364,9 +364,10 @@ to-x to-y) (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) (medium-gcontext from-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (sheet-direct-mirror (medium-sheet to-drawable)) - (round to-x) (round to-y))))) + (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) @@ -374,9 +375,10 @@ from-x from-y) (xlib:copy-area (sheet-direct-mirror (medium-sheet from-drawable)) (medium-gcontext from-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (pixmap-mirror to-drawable) - (round to-x) (round to-y)))) + (round-coordinate to-x) (round-coordinate to-y)))) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable clx-medium) to-x to-y) @@ -384,17 +386,19 @@ to-x to-y) (xlib:copy-area (pixmap-mirror from-drawable) (medium-gcontext to-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (sheet-direct-mirror (medium-sheet to-drawable)) - (round to-x) (round to-y)))) + (round-coordinate to-x) (round-coordinate to-y)))) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) (xlib:copy-area (pixmap-mirror from-drawable) (medium-gcontext from-drawable +background-ink+) - (round from-x) (round from-y) (round width) (round height) + (round-coordinate from-x) (round-coordinate from-y) + (round width) (round height) (pixmap-mirror to-drawable) - (round to-x) (round to-y))) + (round-coordinate to-x) (round-coordinate to-y))) ;;; Medium-specific Drawing Functions @@ -405,19 +409,23 @@ x y) (with-clx-graphics (medium) (cond ((< (line-style-thickness line-style) 2) - (let ((x (floor x)) - (y (floor y))) + (let ((x (round-coordinate x)) + (y (round-coordinate y))) (when (and (typep x '(signed-byte 16)) (typep y '(signed-byte 16))) (xlib:draw-point mirror gc x y)))) (t - (let* ((radius (round (line-style-thickness line-style) 2)) - (diameter (* radius 2))) - (let ((x (floor (- x radius))) - (y (floor (- y radius)))) - (when (and (typep x '(signed-byte 16)) - (typep y '(signed-byte 16))) - (xlib:draw-arc mirror gc x y diameter diameter 0 (* 2 pi) t))))) )))) + (let* ((radius (/ (line-style-thickness line-style) 2)) + (min-x (round-coordinate (- x radius))) + (min-y (round-coordinate (- y radius))) + (max-x (round-coordinate (+ x radius))) + (max-y (round-coordinate (+ y radius)))) + (when (and (typep min-x '(signed-byte 16)) + (typep min-y '(signed-byte 16))) + (xlib:draw-arc mirror gc min-x min-y + (- max-x min-x) (- max-y min-y) + 0 (* 2 pi) t)))))))) + (defmethod medium-draw-points* ((medium clx-medium) coord-seq) (with-transformed-positions ((sheet-native-transformation @@ -426,33 +434,23 @@ (with-clx-graphics (medium) (cond ((< (line-style-thickness line-style) 2) (do-sequence ((x y) coord-seq) - (let ((x (floor x)) - (y (floor y))) + (let ((x (round-coordinate x)) + (y (round-coordinate y))) (when (and (typep x '(signed-byte 16)) (typep y '(signed-byte 16))) (xlib:draw-point mirror gc x y))))) (t - (let* ((radius (round (line-style-thickness line-style) 2)) - (diameter (* radius 2))) + (let ((radius (/ (line-style-thickness line-style) 2))) (do-sequence ((x y) coord-seq) - (let ((x (floor (- x radius))) - (y (floor (- y radius)))) - (when (and (typep x '(signed-byte 16)) - (typep y '(signed-byte 16))) - (xlib:draw-arc mirror gc x y diameter diameter 0 (* 2 pi) t)))))) )))) - -(declaim (inline round-coordinate)) -(defun round-coordinate (x) - "Function used for rounding coordinates." - ;; We use "mercantile rounding", instead of the CL round to nearest - ;; even number, when in doubt. - ;; - ;; Reason: As the CLIM drawing model is specified, you quite often - ;; want to operate with coordinates, which are multiples of 1/2. - ;; Using CL:ROUND gives you "random" results. Using "mercantile - ;; rounding" gives you consistent results. - ;; - (floor (+ x .5))) + (let ((min-x (round-coordinate (- x radius))) + (min-y (round-coordinate (- y radius))) + (max-x (round-coordinate (+ x radius))) + (max-y (round-coordinate (+ y radius)))) + (when (and (typep min-x '(signed-byte 16)) + (typep min-y '(signed-byte 16))) + (xlib:draw-arc mirror gc min-x min-y + (- max-x min-x) (- max-y min-y) + 0 (* 2 pi) t)))))))))) (defmethod medium-draw-line* ((medium clx-medium) x1 y1 x2 y2) (let ((tr (sheet-native-transformation (medium-sheet medium)))) @@ -516,6 +514,8 @@ (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) @@ -561,16 +561,23 @@ (defmethod medium-draw-rectangles* ((medium clx-medium) position-seq filled) (assert (evenp (length position-seq))) - (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) + (with-transformed-positions ((sheet-native-transformation + (medium-sheet medium)) position-seq) (with-clx-graphics (medium) - (loop for (left top right bottom) on position-seq by #'cddddr - nconcing (list (round left) (round top) - (round (- right left)) (round (- bottom top))) into points - finally (xlib:draw-rectangles mirror gc points filled))))) + (loop + for (left top right bottom) on position-seq by #'cddddr + for min-x = (round-coordinate left) + for max-x = (round-coordinate right) + for min-y = (round-coordinate top) + for max-y = (round-coordinate bottom) + nconcing (list min-x min-y (- max-x min-x) (- min-y max-y)) into points + finally (xlib:draw-rectangles mirror gc points filled))))) +;;; Round the parameters of the ellipse so that it occupies the expected pixels (defmethod medium-draw-ellipse* ((medium clx-medium) center-x center-y - radius-1-dx radius-1-dy radius-2-dx radius-2-dy + radius-1-dx radius-1-dy + radius-2-dx radius-2-dy start-angle end-angle filled) (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) (error "MEDIUM-DRAW-ELLIPSE* not yet implemented for non axis-aligned ellipses.")) @@ -581,25 +588,37 @@ (+ (* pi 2) arc-angle) arc-angle))) (with-clx-graphics (medium) - (let ((radius-dx (abs (+ radius-1-dx radius-2-dx))) - (radius-dy (abs (+ radius-1-dy radius-2-dy)))) + (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx))) + (radius-dy (abs (+ radius-1-dy radius-2-dy))) + (min-x (round-coordinate (- center-x radius-dx))) + (min-y (round-coordinate (- center-y radius-dy))) + (max-x (round-coordinate (+ center-x radius-dx))) + (max-y (round-coordinate (+ center-y radius-dy)))) + #+nil (when (typep mirror 'xlib:pixmap) + (break)) (xlib:draw-arc mirror gc - (round (- center-x radius-dx)) (round (- center-y radius-dy)) - (round (* radius-dx 2)) (round (* radius-dy 2)) + min-x min-y (- max-x min-x) (- max-y min-y) (mod start-angle (* 2 pi)) arc-angle filled)))))) -(defmethod medium-draw-circle* ((medium clx-medium) center-x center-y radius start-angle end-angle filled) - (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) +(defmethod medium-draw-circle* ((medium clx-medium) + center-x center-y radius start-angle end-angle + filled) + (with-transformed-position ((sheet-native-transformation (medium-sheet + medium)) center-x center-y) (let* ((arc-angle (- end-angle start-angle)) (arc-angle (if (< end-angle 0) (+ (* pi 2) arc-angle) - arc-angle))) + arc-angle)) + (min-x (round-coordinate (- center-x radius))) + (min-y (round-coordinate (- center-y radius))) + (max-x (round-coordinate (+ center-x radius))) + (max-y (round-coordinate (+ center-y radius)))) (with-clx-graphics (medium) (xlib:draw-arc mirror gc - (round (- center-x radius)) (round (- center-y radius)) - radius radius + min-x min-y + (- max-x min-x) (- min-y max-y) start-angle arc-angle filled))))) @@ -932,7 +951,8 @@ (with-transformed-position ((sheet-native-transformation (medium-sheet medium)) x y) (with-clx-graphics (medium) - (xlib:draw-glyph mirror gc (round x) (round y) element + (xlib:draw-glyph mirror gc (round-coordinate x) (round-coordinate y) + element :size 16 :translate #'translate)))) @@ -946,9 +966,13 @@ (xlib:display-force-output (clx-port-display (port medium)))) (defmethod medium-clear-area ((medium clx-medium) left top right bottom) - (xlib:clear-area (port-lookup-mirror (port medium) (medium-sheet medium)) - :x (round (min left right)) :y (round (min bottom top)) - :width (round (abs (- right left))) :height (round (abs (- bottom top))))) + (let ((min-x (round-coordinate (min left right))) + (min-y (round-coordinate (min top bottom))) + (max-x (round-coordinate (max left right))) + (max-y (round-coordinate (max top bottom)))) + (xlib:clear-area (port-lookup-mirror (port medium) (medium-sheet medium)) + :x min-x :y min-y + :width (- max-x min-x) :height (- max-y min-y)))) (defmethod medium-beep ((medium clx-medium)) (xlib:bell (clx-port-display (port medium)))) Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.102 mcclim/Backends/CLX/port.lisp:1.103 --- mcclim/Backends/CLX/port.lisp:1.102 Sun Jan 2 06:29:03 2005 +++ mcclim/Backends/CLX/port.lisp Tue Jan 11 14:35:33 2005 @@ -23,6 +23,21 @@ (in-package :clim-clx) +(declaim (inline round-coordinate)) +(defun round-coordinate (x) + "Function used for rounding coordinates." + ;; We use "mercantile rounding", instead of the CL round to nearest + ;; even number, when in doubt. + ;; + ;; Reason: As the CLIM drawing model is specified, you quite often + ;; want to operate with coordinates, which are multiples of 1/2. + ;; 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))) + ;;; CLX-PORT class (defclass clx-pointer (pointer) @@ -1173,11 +1188,18 @@ +pointer-wheel-down+) (t 0))) +#+nil (defmethod pointer-modifier-state ((pointer clx-pointer)) (multiple-value-bind (x y same-screen-p child mask) (xlib:query-pointer (clx-port-window (port pointer))) (declare (ignore x y same-screen-p child)) (clim-xcommon:x-event-state-modifiers (port pointer) mask))) + +(defmethod port-modifier-state ((port clx-port)) + (multiple-value-bind (x y same-screen-p child mask) + (xlib:query-pointer (clx-port-window port)) + (declare (ignore x y same-screen-p child)) + (clim-xcommon:x-event-state-modifiers port mask))) ;;; XXX Should we rely on port-pointer-sheet being correct? -- moore (defmethod synthesize-pointer-motion-event ((pointer clx-pointer))

1 0

[mcclim-cvs] CVS update: mcclim/graphics.lisp mcclim/incremental-redisplay.lisp mcclim/package.lisp mcclim/pointer-tracking.lisp mcclim/sheets.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv16352 Modified Files: graphics.lisp incremental-redisplay.lisp package.lisp pointer-tracking.lisp sheets.lisp Log Message: Rewrote WITH-DOUBLE-BUFFERING. This version takes a rectangle as an argument, allocates a pixmap for that region of the screen, and sets up the sheet transformations so that drawing is done in the correct pixmap coordinates. Use WITH-DOUBLE-BUFFERING in DRAG-OUTPUT-RECORD. Add a little example of using dragging-output. Change the definition of ROUND-COORDINATE in the CLX backend to round down from .5, not up. This should follow the CLIM pixel coverage definition for shapes more closely. Replace most uses of ROUND in the CLX backend with ROUND-COORDINATE. Allow inconsistent :ID-TEST arguments in UPDATING-OUTPUT. Date: Tue Jan 11 14:35:19 2005 Author: tmoore Index: mcclim/graphics.lisp diff -u mcclim/graphics.lisp:1.48 mcclim/graphics.lisp:1.49 --- mcclim/graphics.lisp:1.48 Mon Mar 1 13:52:29 2004 +++ mcclim/graphics.lisp Tue Jan 11 14:35:18 2005 @@ -664,10 +664,12 @@ (setf (%sheet-medium ,sheet) old-medium));is sheet a sheet-with-medium-mixin? --GB pixmap)) -; This seems to be incorrect. -; This presumes that your drawing will completely fill the bounding rectangle of the sheet -; and will effectively randomise anything that isn't draw, within it. -; FIXME +;;; XXX This seems to be incorrect. +;;; This presumes that your drawing will completely fill the bounding rectangle +;;; of the sheet and will effectively randomize anything that isn't drawn +;;; within it. +;;; FIXME +#+nil (defmacro with-double-buffering ((sheet) &body body) (let ((width (gensym)) (height (gensym)) @@ -687,6 +689,115 @@ ; in which case, we shouldn't blit it back (copy-from-pixmap ,pixmap 0 0 ,width ,height ,sheet 0 0)) (deallocate-pixmap ,pixmap))))) + +;;; Another attempt + +(defun invoke-with-double-buffering (sheet continuation x1 y1 x2 y2) + (let* ((medium (sheet-medium sheet)) + (sheet-transform (sheet-native-transformation sheet)) + (medium-transform (medium-transformation (sheet-medium sheet))) + (world-transform (compose-transformations sheet-transform + medium-transform))) + (multiple-value-bind (sheet-x1 sheet-y1) + (transform-position world-transform x1 y1) + (multiple-value-bind (sheet-x2 sheet-y2) + (transform-position world-transform x2 y2) + ;; Be conservative with the size of the pixmap, including all of + ;; the pixels at the edges. + (let* ((pixmap-x1 (floor sheet-x1)) + (pixmap-y1 (floor sheet-y1)) + (pixmap-x2 (ceiling sheet-x2)) + (pixmap-y2 (ceiling sheet-y2)) + (pixmap-width (- pixmap-x2 pixmap-x1)) + (pixmap-height (- pixmap-y2 pixmap-y1)) + (current-sheet-region (sheet-region sheet)) + (sheet-native (compose-transformation-with-translation + sheet-transform + (- pixmap-x1) + (- pixmap-y1))) + (pixmap (allocate-pixmap sheet pixmap-width pixmap-height)) + ) + (unless pixmap + (error "Couldn't allocate pixmap")) + (multiple-value-bind (user-pixmap-x1 user-pixmap-y1) + (untransform-position world-transform pixmap-x1 pixmap-y1) + (multiple-value-bind (user-pixmap-x2 user-pixmap-y2) + (untransform-position world-transform pixmap-x2 pixmap-y2) + (flet ((set-native (transform region sheet) + (%%set-sheet-native-transformation transform sheet) + (setf (slot-value sheet 'region) region) + (invalidate-cached-regions sheet) + (invalidate-cached-transformations sheet))) + ;; Assume that the scaling for the sheet-native + ;; transformation for the pixmap will be the same as that of + ;; the mirror . + (unwind-protect + (letf (((sheet-parent sheet) nil) + ((sheet-direct-mirror sheet) + (pixmap-mirror pixmap))) + (unwind-protect + (let ((pixmap-region + (make-bounding-rectangle user-pixmap-x1 + user-pixmap-y1 + user-pixmap-x2 + user-pixmap-y2))) + (set-native sheet-native pixmap-region sheet) + ;(break) + (with-drawing-options + (medium :ink (medium-background medium)) + + (medium-draw-rectangle* medium + user-pixmap-x1 + user-pixmap-y1 + user-pixmap-x2 + user-pixmap-y2 + t)) + (funcall continuation sheet + user-pixmap-x1 user-pixmap-y1 + user-pixmap-x2 user-pixmap-y2)) + (set-native sheet-transform + current-sheet-region + sheet))) + (copy-from-pixmap pixmap 0 0 + pixmap-width pixmap-height sheet + user-pixmap-x1 user-pixmap-y1) + (deallocate-pixmap pixmap)))))))))) + +(defmacro with-double-buffering (((sheet &rest bounds-args) + (&rest pixmap-args)) + &body body) + (with-gensyms (continuation) + (let ((cont-form + (case (length pixmap-args) + (1 + (with-gensyms (pixmap-x1 pixmap-y1 pixmap-x2 pixmap-y2) + `(,continuation (,sheet + ,pixmap-x1 ,pixmap-y1 ,pixmap-x2 ,pixmap-y2) + (let ((,(car pixmap-args) + (make-bounding-rectangle ,pixmap-x1 ,pixmap-y1 + ,pixmap-x2 ,pixmap-y2))) + ,@body)))) + (4 + `(,continuation (,sheet ,@pixmap-args) + ,@body)) + (otherwise (error "Invalid pixmap-args ~S" pixmap-args))))) + (case (length bounds-args) + (1 + (with-gensyms (x1 y1 x2 y2) + `(flet (,cont-form) + (declare (dynamic-extent #',continuation)) + (with-bounding-rectangle* (,x1 ,y1 ,x2 ,y2) + ,(car bounds-args) + (invoke-with-double-buffering ,sheet + #',continuation + ,x1 ,y1 ,x2 ,y2))))) + (4 + `(flet (,cont-form) + (declare (dynamic-extent #',continuation)) + (invoke-with-double-buffering ,sheet #',continuation + ,@bounds-args))) + (otherwise (error "invalid bounds-args ~S" bounds-args)))))) + ;;; Generic graphic operation methods Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.40 mcclim/incremental-redisplay.lisp:1.41 --- mcclim/incremental-redisplay.lisp:1.40 Sun Oct 24 17:47:02 2004 +++ mcclim/incremental-redisplay.lisp Tue Jan 11 14:35:18 2005 @@ -105,7 +105,9 @@ (id-counter :accessor id-counter :documentation "The counter used to assign unique ids to updating output records without one.") - (tester-function :accessor tester-function :initform 'none) + (tester-function :accessor tester-function :initform 'none + :documentation "The function used to lookup + updating output records in this map if unique; otherwise, :mismatch.") (element-count :accessor element-count :initform 0))) ;;; Complete guess... @@ -113,6 +115,8 @@ "The limit at which the id map in an updating output record switches to a hash table.") +;;; ((eq map-test-func :mismatch) +;;; nil) (defun function-matches-p (map func) (let ((map-test-func (tester-function map))) (cond ((eq map-test-func func) @@ -125,19 +129,25 @@ (eq map-test-func (symbol-value func))) (t nil)))) +(defun ensure-test (map test) + (unless (function-matches-p map test) + (explode-map-hash map) + (setf (tester-function map) :mismatch))) + (defun get-from-map (map value test) (when (eq (tester-function map) 'none) (return-from get-from-map nil)) - (if (function-matches-p map test) - (let ((map (id-map map))) - (if (hash-table-p map) - (gethash value map) - (cdr (assoc value map :test test)))) - (error "Test function ~S doesn't match ~S" test (tester-function map)))) + (ensure-test map test) + (let ((map (id-map map))) + (if (hash-table-p map) + (gethash value map) + (cdr (assoc value map :test test))))) + (defun maybe-convert-to-hash (map) (let ((test (tester-function map))) - (when (and (> (element-count map) *updating-map-threshold*) + (when (and (not (eq test :mismatch)) + (> (element-count map) *updating-map-threshold*) (or (case test ((eq eql equal equalp) t)) (eq test #'eq) @@ -150,42 +160,48 @@ do (setf (gethash key new-map) value)) (setf (id-map map) new-map))))) +(defun explode-map-hash (map) + (let ((hash-map (id-map map))) + (when (hash-table-p hash-map) + (loop + for key being each hash-key of hash-map using (hash-value record) + collect (cons key record) into alist + finally (setf (id-map map) alist))))) + (defun add-to-map (map record value test replace) - (when (eq (tester-function map) 'none) - (setf (tester-function map) test)) - (if (function-matches-p map test) - (let ((val-map (id-map map))) - (if (hash-table-p val-map) - (multiple-value-bind (existing-value in-table) - (if replace - (gethash value val-map) - (values nil nil)) - (declare (ignore existing-value)) - (setf (gethash value val-map) record) - (unless in-table - (incf (element-count map)))) - (let ((val-cons (if replace - (assoc value val-map :test test) - nil))) - (if val-cons - (setf (cdr val-cons) record) - (progn - (setf (id-map map) (acons value record val-map)) - (incf (element-count map)) - (maybe-convert-to-hash map)))))) - (error "Test function ~S doesn't match ~S" test (tester-function map)))) + (if (eq (tester-function map) 'none) + (setf (tester-function map) test) + (ensure-test map test)) + (let ((val-map (id-map map))) + (if (hash-table-p val-map) + (multiple-value-bind (existing-value in-table) + (if replace + (gethash value val-map) + (values nil nil)) + (declare (ignore existing-value)) + (setf (gethash value val-map) record) + (unless in-table + (incf (element-count map)))) + (let ((val-cons (if replace + (assoc value val-map :test test) + nil))) + (if val-cons + (setf (cdr val-cons) record) + (progn + (setf (id-map map) (acons value record val-map)) + (incf (element-count map)) + (maybe-convert-to-hash map))))))) (defun delete-from-map (map value test) - (if (function-matches-p map test) - (let ((val-map (id-map map)) - (deleted nil)) - (if (hash-table-p val-map) - (setf deleted (remhash value val-map)) - (setf (values (id-map map) deleted) - (delete-1 value val-map :test test :key #'car))) - (when deleted - (decf (element-count map)))) - (error "Test function ~S doesn't match ~S" test (tester-function map)))) + (ensure-test map test) + (let ((val-map (id-map map)) + (deleted nil)) + (if (hash-table-p val-map) + (setf deleted (remhash value val-map)) + (setf (values (id-map map) deleted) + (delete-1 value val-map :test test :key #'car))) + (when deleted + (decf (element-count map))))) (defmethod shared-initialize :after ((obj updating-output-map-mixin) slot-names &key) @@ -887,10 +903,6 @@ (setf (parent-cache record) parent-cache))) record))) -;;; &key (unique-id (gensym)) was used earlier, -;;; changed to (unique-id `',(gensym)) as per gilham's request -;;; please CHECKME and delete this comment :] -;;; ;;; The Franz user guide says that updating-output does ;;; &allow-other-keys, and some code I've encountered does mention ;;; other magical arguments, so we'll do the same. -- moore Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.46 mcclim/package.lisp:1.47 --- mcclim/package.lisp:1.46 Mon Dec 20 16:49:19 2004 +++ mcclim/package.lisp Tue Jan 11 14:35:18 2005 @@ -409,6 +409,7 @@ #:+textual-dialog-view+ ;constant #:+textual-menu-view+ ;constant #:+textual-view+ ;constant + #:+text-field-view+ ;constant (Franz User's Guide) #:+transparent-ink+ ;constant #:+white+ ;constant #:+yellow+ ;constant @@ -1104,7 +1105,6 @@ #:pointer-event-x ;generic function #:pointer-event-y ;generic function #:pointer-exit-event ;class - #:pointer-modifier-state ;generic function (in franz user guide) #:pointer-motion-event ;class #:pointer-position ;generic function #:pointer-sheet ;generic function @@ -1119,6 +1119,7 @@ #:port ;protocol class #:port ;generic function #:port-keyboard-input-focus ;generic function + #:port-modifier-state ;generic function (in franz user guide) #:port-name ;generic function #:port-pointer ;generic function (in franz user guide) #:port-properties ;generic function @@ -1456,6 +1457,7 @@ #:text-editor-pane ;class #:text-field ;class #:text-field-pane ;class + #:text-field-view ;class (Franz User's Guide) #:text-size ;generic function #:text-style ;protocol class #:text-style-ascent ;generic function Index: mcclim/pointer-tracking.lisp diff -u mcclim/pointer-tracking.lisp:1.15 mcclim/pointer-tracking.lisp:1.16 --- mcclim/pointer-tracking.lisp:1.15 Fri Nov 12 07:39:44 2004 +++ mcclim/pointer-tracking.lisp Tue Jan 11 14:35:18 2005 @@ -173,64 +173,126 @@ ;;; multiple-window is completely unsupported. ;;; window-repaint events while dragging. +(defun bound-rectangles (r1-x1 r1-y1 r1-x2 r1-y2 r2-x1 r2-y1 r2-x2 r2-y2) + (values (min r1-x1 r2-x1) (min r1-y1 r2-y1) + (max r1-x2 r2-x2) (max r1-y2 r2-y2))) + + (defgeneric drag-output-record (stream output &key repaint erase feedback finish-on-release multiple-window)) +;;; Fancy double-buffered feedback function +(defun make-buffered-feedback-function (record finish-on-release erase-final) + (multiple-value-bind (record-x record-y) + (output-record-position record) + (lambda (record stream initial-x initial-y x y event) + (flet ((simple-erase () + (when erase-final + (when (output-record-parent record) + (delete-output-record record (output-record-parent record))) + (with-double-buffering + ((stream record) (buffer-rectangle)) + (stream-replay stream buffer-rectangle))))) + (let ((dx (- record-x initial-x)) + (dy (- record-y initial-y))) + (typecase event + (null + (setf (output-record-position record) (values (+ dx x) (+ dy y))) + (stream-add-output-record stream record) + (stream-replay stream record)) + (pointer-motion-event + ;; Don't do an explicit erase. Instead, update the position of the + ;; output record and redraw the union of the old and new + ;; positions. + (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) + record + (when (output-record-parent record) + (delete-output-record record (output-record-parent record))) + (setf (output-record-position record) + (values (+ dx x) (+ dy y))) + (stream-add-output-record stream record) + (with-bounding-rectangle* (new-x1 new-y1 new-x2 new-y2) + record + (multiple-value-bind (area-x1 area-y1 area-x2 area-y2) + (bound-rectangles old-x1 old-y1 old-x2 old-y2 + new-x1 new-y1 new-x2 new-y2) + (with-double-buffering + ((stream area-x1 area-y1 area-x2 area-y2) + (buffer-rectangle)) + (stream-replay stream buffer-rectangle)))))) + (pointer-button-press-event + (unless finish-on-release + (simple-erase))) + (pointer-button-release-event + (when finish-on-release + (simple-erase))) + (t nil))))))) + +;;; If the user supplies a feedback function, create a function to +;;; call it with the simple :draw / :erase arguments. + +(defun make-simple-feedback-function + (record feedback finish-on-release erase-final) + (declare (ignore record)) + (lambda (record stream initial-x initial-y x y event) + (typecase event + (null + (funcall feedback record stream initial-x initial-y x y :draw)) + (pointer-motion-event + (funcall feedback record stream initial-x initial-y x y :erase) + (funcall feedback record stream initial-x initial-y x y :draw)) + (pointer-button-press-event + (unless finish-on-release + (when erase-final + (funcall feedback record stream initial-x initial-y x y :erase)))) + (pointer-button-release-event + (when (and finish-on-release erase-final) + (funcall feedback record stream initial-x initial-y x y :erase))) + (t nil)))) + + (defmethod drag-output-record ((stream output-recording-stream) (record output-record) &key (repaint t) (erase #'erase-output-record) feedback finish-on-release multiple-window - feedback-event) - (declare (ignore repaint multiple-window)) - (multiple-value-bind (dx dy) - (output-record-position record) - (flet ((feedback-fn (record stream initial-x initial-y x y action) - (declare (ignore initial-x initial-y)) - (if (eq action :erase) - (funcall erase record stream) - (progn - (setf (output-record-position record) - (values (+ dx x) (+ dy y))) - (stream-add-output-record stream record) - (stream-replay stream record)))) - (feedback-event-fn (record stream initial-x initial-y x y - action event) - (declare (ignore event)) - (when (or (eq action :draw) (eq action :erase)) - (funcall feedback record stream initial-x initial-y x y - action)))) - (declare (dynamic-extent #'feedback-fn #'feedback-event-fn)) - (unless feedback - (setq feedback #'feedback-fn)) - (unless feedback-event - (setq feedback-event #'feedback-event-fn)) - (setf (stream-current-output-record stream) - (stream-output-history stream)) - (let* ((pointer (port-pointer (port stream))) - (pointer-state (pointer-button-state pointer))) - (multiple-value-bind (x0 y0) - (stream-pointer-position stream) - (funcall feedback-event record stream x0 y0 x0 y0 :draw nil) - (tracking-pointer (stream) - (:pointer-motion (&key event x y) - ;; XXX What about the sheet? - (funcall feedback-event record stream x0 y0 x y :erase event) - (funcall feedback-event record stream x0 y0 x y :draw event)) - (:pointer-button-press (&key event x y) - (funcall feedback-event record stream x0 y0 x y - :button-press event) - (unless finish-on-release - (return-from drag-output-record (values x y)))) - (:pointer-button-release (&key event x y) - ;; If the button released was one of those held down on entry to - ;; drag-output-record, we're done. - (when (and finish-on-release - (not (zerop (logand pointer-state - (pointer-event-button event))))) - (funcall feedback-event record stream x0 y0 x y - :button-release event) - (return-from drag-output-record (values x y)))))))))) + feedback-event erase-final) + (declare (ignore erase repaint multiple-window)) + (let ((feedback-event-fn + (cond (feedback-event + feedback-event) + (feedback + (make-simple-feedback-function record + feedback + finish-on-release + erase-final)) + (t (make-buffered-feedback-function record + finish-on-release + erase-final))))) + (setf (stream-current-output-record stream) + (stream-output-history stream)) + (let* ((pointer (port-pointer (port stream))) + (pointer-state (pointer-button-state pointer))) + (multiple-value-bind (x0 y0) + (stream-pointer-position stream) + (funcall feedback-event-fn record stream x0 y0 x0 y0 nil) + (tracking-pointer (stream) + (:pointer-motion (&key event x y) + ;; XXX What about the sheet? + (funcall feedback-event-fn record stream x0 y0 x y event) + (funcall feedback-event-fn record stream x0 y0 x y event)) + (:pointer-button-press (&key event x y) + (unless finish-on-release + (funcall feedback-event-fn record stream x0 y0 x y event) + (return-from drag-output-record (values x y)))) + (:pointer-button-release (&key event x y) + ;; If the button released was one of those held down on entry to + ;; drag-output-record, we're done. + (when (and finish-on-release + (not (zerop (logand pointer-state + (pointer-event-button event))))) + (funcall feedback-event-fn record stream x0 y0 x y event) + (return-from drag-output-record (values x y))))))))) (defmacro dragging-output ((&optional (stream '*standard-output*) &rest args &key repaint finish-on-release multiple-window) @@ -240,7 +302,6 @@ (with-gensyms (record) `(let ((,record (with-output-to-output-record (,stream) ,@body))) - (multiple-value-prog1 - (drag-output-record ,stream ,record ,@args) - (erase-output-record ,record ,stream))))) + (drag-output-record ,stream ,record :erase-final t ,@args)))) + Index: mcclim/sheets.lisp diff -u mcclim/sheets.lisp:1.47 mcclim/sheets.lisp:1.48 --- mcclim/sheets.lisp:1.47 Sun Dec 5 20:37:52 2004 +++ mcclim/sheets.lisp Tue Jan 11 14:35:18 2005 @@ -413,11 +413,15 @@ (defmethod sheet-native-region ((sheet basic-sheet)) (with-slots (native-region) sheet (unless native-region - (setf native-region (region-intersection - (transform-region - (sheet-native-transformation sheet) - (sheet-region sheet)) - (sheet-native-region (sheet-parent sheet))))) + (let ((this-native-region (transform-region + (sheet-native-transformation sheet) + (sheet-region sheet))) + (parent (sheet-parent sheet))) + (setf native-region (if parent + (region-intersection this-native-region + (sheet-native-region + parent)) + this-native-region)))) native-region)) (defmethod sheet-device-transformation ((sheet basic-sheet)) @@ -706,15 +710,17 @@ (defmethod sheet-native-region ((sheet mirrored-sheet-mixin)) (with-slots (native-region) sheet (unless native-region - (setf native-region - (region-intersection - (transform-region - (sheet-native-transformation sheet) - (sheet-region sheet)) - (transform-region - (invert-transformation - (%sheet-mirror-transformation sheet)) - (sheet-native-region (sheet-parent sheet)))))) + (let ((this-region (transform-region (sheet-native-transformation sheet) + (sheet-region sheet))) + (parent (sheet-parent sheet))) + (setf native-region + (if parent + (region-intersection this-region + (transform-region + (invert-transformation + (%sheet-mirror-transformation sheet)) + (sheet-native-region parent))) + this-region)))) native-region)) (defmethod (setf sheet-enabled-p) :after (new-value (sheet mirrored-sheet-mixin))

1 0

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

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Experimental In directory common-lisp.net:/tmp/cvs-serv15555/Experimental Modified Files: menu-choose.lisp Log Message: Eat the pointer-release events from a menu choose action. Otherwise, they will still be around when if a command, invoked by the menu, starts looking at the event queue. Completely bypass the standard presentation translator mechanism when determining whether to call the presentation clauses in TRACKING-POINTER. Presentation translators and actions can't do anything here. Date: Tue Jan 11 14:14:21 2005 Author: tmoore Index: mcclim/Experimental/menu-choose.lisp diff -u mcclim/Experimental/menu-choose.lisp:1.13 mcclim/Experimental/menu-choose.lisp:1.14 --- mcclim/Experimental/menu-choose.lisp:1.13 Sun Oct 31 02:46:31 2004 +++ mcclim/Experimental/menu-choose.lisp Tue Jan 11 14:14:21 2005 @@ -266,15 +266,27 @@ :width x2 :height y2 :resize-frame t))) - (let ((*pointer-documentation-output* pointer-documentation)) - (tracking-pointer (menu :context-type presentation-type :multiple-window t :highlight t) - (:pointer-button-press (&key event x y) ; Pointer clicked outside menu? Close the 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-press (&key event presentation x y) + ;; 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)) + (tracking-pointer (menu :context-type presentation-type + :multiple-window t :highlight t) + (:presentation (&key presentation) + (format *trace-output* "type:~S presentation:~S~%" + presentation-type + 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))))) + (: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/frames.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15555 Modified Files: frames.lisp Log Message: Eat the pointer-release events from a menu choose action. Otherwise, they will still be around when if a command, invoked by the menu, starts looking at the event queue. Completely bypass the standard presentation translator mechanism when determining whether to call the presentation clauses in TRACKING-POINTER. Presentation translators and actions can't do anything here. Date: Tue Jan 11 14:14:19 2005 Author: tmoore Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.103 mcclim/frames.lisp:1.104 --- mcclim/frames.lisp:1.103 Fri Nov 12 07:38:50 2004 +++ mcclim/frames.lisp Tue Jan 11 14:14:18 2005 @@ -1337,23 +1337,47 @@ (cdr hilited) :unhighlight))))) +;;; Poor man's find-applicable-translators. tracking-pointer doesn't want to +;;; see any results from presentation translators. + +(defun highlight-for-tracking-pointer (frame stream x y input-context) + (let ((context-ptype (input-context-type (car input-context))) + (presentation nil) + (current-hilited (frame-hilited-presentation frame))) + (if (output-recording-stream-p stream) + (progn + (block found-presentation + (flet ((do-presentation (p) + (when (presentation-subtypep (presentation-type p) + context-ptype) + (setq presentation p) + (return-from found-presentation nil)))) + (declare (dynamic-extent #'do-presentation)) + (map-over-presentations-containing-position + #'do-presentation (stream-output-history stream) x y))) + (when (and current-hilited + (not (eq (car current-hilited) presentation))) + (highlight-presentation-1 (car current-hilited) + (cdr current-hilited) + :unhighlight)) + (if presentation + (progn + (setf (frame-hilited-presentation frame) + (cons presentation stream)) + (highlight-presentation-1 presentation stream :highlight))) + presentation)))) + (defmethod tracking-pointer-loop-step :before ((state frame-tracking-pointer-state) (event pointer-event) x y) (declare (ignore x y)) (when (highlight state) (let ((stream (event-sheet event))) (setf (applicable-presentation state) - (frame-highlight-at-position *application-frame* stream - (device-event-x event) - (device-event-y event) - (event-modifier-state event) - (input-context state) - :highlight (highlight state))) - ;;; Hmmm, probably don't want to do this - #+nil (frame-update-pointer-documentation frame - (input-context state) - stream - event)))) + (highlight-for-tracking-pointer *application-frame* stream + (device-event-x event) + (device-event-y event) + (input-context state)))))) + (macrolet ((frob (event handler) `(defmethod tracking-pointer-loop-step

1 0

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

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14709 Modified Files: presentations.lisp presentation-defs.lisp dialog.lisp views.lisp Log Message: Implement :SINGLE-BOX properly.:SINGLE-BOX NIL is the default, but McCLIM has ignored it. This changes (for the better) the behavior of applications. Implement PRESENTATION-REFINED-POSITION-TEST. If the view argument to ACCEPT is a list, apply MAKE-INSTANCE to the list to obtain the view. Fix a bug in dialogs that prevented moving on to the next text field after hitting return. Define a new view type, TEXT-FIELD-VIEW, that is used in dialogs. This view has a WIDTH parameter. Date: Tue Jan 11 14:02:29 2005 Author: tmoore Index: mcclim/presentations.lisp diff -u mcclim/presentations.lisp:1.68 mcclim/presentations.lisp:1.69 --- mcclim/presentations.lisp:1.68 Sun Nov 7 20:33:31 2004 +++ mcclim/presentations.lisp Tue Jan 11 14:02:19 2005 @@ -1107,7 +1107,8 @@ ,@lambda-list) (declare (ignorable ,(type-key-arg gf)) ,@(cdr decls)) - ,@body)))) + (block ,name + ,@body))))) ;;; Somewhat obsolete, but keep it around for apply-presentation-generic-function. (defun %funcall-presentation-generic-function (name gf type-arg-position @@ -1283,6 +1284,10 @@ &allow-other-keys) arglist &body body) + ;; null tester should be the same as no tester + (unless tester + (setq tester 'default-translator-tester) + (setq tester-definitive t)) (let* ((real-from-type (expand-presentation-type-abbreviation from-type)) (real-to-type (expand-presentation-type-abbreviation to-type))) (with-keywords-removed (translator-options @@ -1586,15 +1591,7 @@ t) -(defun presentation-contains-position (record x y) - (let ((single-box (presentation-single-box record))) - (multiple-value-bind (min-x min-y max-x max-y) - (output-record-hit-detection-rectangle* record) - (if (and (<= min-x x max-x) (<= min-y y max-y)) - (if (or (null single-box) (eq single-box :higlighting)) - (output-record-refined-position-test record x y) - t) - nil)))) +;;; presentation-contains-position moved to presentation-defs.lisp (defun map-over-presentations-containing-position (func record x y) "maps recursively over all presentations in record, including record." @@ -1799,7 +1796,8 @@ a presentation" (throw-highlighted-presentation (make-instance 'standard-presentation - :object object :type type) + :object object :type type + :single-box t) input-context (make-instance 'pointer-button-press-event :sheet sheet Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.38 mcclim/presentation-defs.lisp:1.39 --- mcclim/presentation-defs.lisp:1.38 Sun Jan 2 06:28:38 2005 +++ mcclim/presentation-defs.lisp Tue Jan 11 14:02:19 2005 @@ -647,7 +647,7 @@ (defun accept (type &rest rest-args &key (stream *standard-input*) - view + (view nil viewp) (default nil defaultp) (default-type nil default-type-p) provide-default insert-default replace-input @@ -680,6 +680,12 @@ (list* :default-type real-default-type rest-args))) (when historyp (setf rest-args (list* :history real-history-type rest-args))) + (cond ((and viewp (symbolp view)) + (setf rest-args + (list* :view (funcall #'make-instance view) rest-args))) + ((consp view) + (setf rest-args + (list* :view (apply #'make-instance view) rest-args)))) ;; Presentation type history interaction. According to the spec, ;; if provide-default is true, we take the default from the ;; presentation history. In addition, we'll implement the Genera @@ -929,6 +935,40 @@ (with-input-from-string (stream string :start start :end end) (with-keywords-removed (args (:start :end)) (apply #'stream-accept stream type :view +textual-view+ args)))) + +(define-presentation-generic-function %presentation-refined-position-test + presentation-refined-position-test + (type-key parameters options type record x y)) + +(define-default-presentation-method presentation-refined-position-test + (type record x y) + (declare (ignore type)) + ;;; output-record-hit-detection-rectangle* has already been called + (let ((single-box (presentation-single-box record))) + (if (or (eq single-box t) (eq single-box :position)) + t + (labels ((tester (record) + (typecase record + (displayed-output-record + (return-from presentation-refined-position-test t)) + (compound-output-record + (map-over-output-records-containing-position + #'tester record x y)) + (t nil)))) + (tester record) + nil)))) + +(defun presentation-contains-position (record x y) + (let ((single-box (presentation-single-box record))) + (multiple-value-bind (min-x min-y max-x max-y) + (output-record-hit-detection-rectangle* record) + (if (and (<= min-x x max-x) (<= min-y y max-y)) + (if (or (null single-box) (eq single-box :higlighting)) + (funcall-presentation-generic-function + presentation-refined-position-test + (presentation-type record) record x y) + t) + nil)))) (define-presentation-generic-function %highlight-presentation highlight-presentation Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.15 mcclim/dialog.lisp:1.16 --- mcclim/dialog.lisp:1.15 Sun Jan 2 06:24:49 2005 +++ mcclim/dialog.lisp Tue Jan 11 14:02:19 2005 @@ -318,11 +318,12 @@ (when query (setf selected-query query) (select-query *accepting-values-stream* query (record query)) - (if (cdr query-list) - (throw-object-ptype (query-identifier (cadr query-list)) - 'selectable-query) - (throw-object-ptype '(com-deselect-query) - '(command :command-table accepting-values)))))))) + (let ((command-ptype '(command :command-table accepting-values))) + (if (cdr query-list) + (throw-object-ptype `(com-select-query ,(query-identifier + (cadr query-list))) + command-ptype) + (throw-object-ptype '(com-deselect-query) command-ptype)))))))) (define-command (com-deselect-query :command-table accepting-values :name nil @@ -344,6 +345,24 @@ is called. Used to determine if any editing has been done by user"))) (defparameter *no-default-cache-value* (cons nil nil)) + +;;; Hack until more views / dialog gadgets are defined. + +(define-default-presentation-method accept-present-default + (type stream (view text-field-view) default default-supplied-p + present-p query-identifier) + (if (width view) + (multiple-value-bind (cx cy) + (stream-cursor-position stream) + (declare (ignore cy)) + (letf (((stream-text-margin stream) (+ cx (width view)))) + (funcall-presentation-generic-function accept-present-default + type + stream + +textual-dialog-view+ + default default-supplied-p + present-p + query-identifier))))) (define-default-presentation-method accept-present-default (type stream (view textual-dialog-view) default default-supplied-p Index: mcclim/views.lisp diff -u mcclim/views.lisp:1.5 mcclim/views.lisp:1.6 --- mcclim/views.lisp:1.5 Mon Nov 3 09:12:35 2003 +++ mcclim/views.lisp Tue Jan 11 14:02:19 2005 @@ -44,6 +44,11 @@ (defclass pointer-documentation-view (textual-view) ()) +;;; Views described in the Franz User manual... + +(defclass text-field-view (gadget-dialog-view) + ((width :accessor width :initarg :width :initform nil))) + (defparameter +textual-view+ (make-instance 'textual-view)) (defparameter +textual-menu-view+ (make-instance 'textual-menu-view)) @@ -58,6 +63,8 @@ (defparameter +pointer-documentation-view+ (make-instance 'pointer-documentation-view)) + +(defparameter +text-field-view+ (make-instance 'text-field-view)) (defmethod stream-default-view (stream) (declare (ignore stream))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Scigraph/scigraph/mouse.lisp
by tmoore＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph In directory common-lisp.net:/tmp/cvs-serv14169 Modified Files: mouse.lisp Log Message: Add McCLIM (in fact, portable) code to button-case Date: Tue Jan 11 13:45:38 2005 Author: tmoore Index: mcclim/Apps/Scigraph/scigraph/mouse.lisp diff -u mcclim/Apps/Scigraph/scigraph/mouse.lisp:1.5 mcclim/Apps/Scigraph/scigraph/mouse.lisp:1.6 --- mcclim/Apps/Scigraph/scigraph/mouse.lisp:1.5 Fri Aug 6 15:19:40 2004 +++ mcclim/Apps/Scigraph/scigraph/mouse.lisp Tue Jan 11 13:45:35 2005 @@ -60,7 +60,7 @@ ,@(if right `(((clim::button-press-event-matches-gesture-name ,button :menu) ,right))))) - (:clim-2 + ((and :clim-2 (not :mcclim)) `(cond ,@(if left `(((clim-internals::button-press-event-matches-gesture-name-p ,button :select) @@ -70,7 +70,18 @@ ,middle))) ,@(if right `(((clim-internals::button-press-event-matches-gesture-name-p ,button :menu) - ,right))))))) + ,right))))) + (:mcclim + `(cond + ,@(when left + `(((event-matches-gesture-name-p ,button :select) + ,left))) + ,@(when middle + `(((event-matches-gesture-name-p ,button :describe) + ,middle))) + ,@(when right + `(((event-matches-gesture-name-p ,button :menu) + ,right))))))) (defmethod post-mouse-documentation (stream string) #FEATURE-CASE

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/listener.lisp
by ahefner＠common-lisp.net 11 Jan '05

11 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv24962 Modified Files: listener.lisp Log Message: Adjust default width and height of the listener to fit on most screens. Date: Tue Jan 11 06:26:37 2005 Author: ahefner Index: mcclim/Apps/Listener/listener.lisp diff -u mcclim/Apps/Listener/listener.lisp:1.20 mcclim/Apps/Listener/listener.lisp:1.21 --- mcclim/Apps/Listener/listener.lisp:1.20 Sun Jan 2 06:14:28 2005 +++ mcclim/Apps/Listener/listener.lisp Tue Jan 11 06:26:26 2005 @@ -319,8 +319,8 @@ (defun run-listener (&key (system-command-reader nil) (new-process nil) - (width 800) - (height 800) + (width 760) + (height 550) (process-name "Listener") (eval nil)) (flet ((run ()

1 0

[mcclim-cvs] CVS update: mcclim/text-selection.lisp
by ahefner＠common-lisp.net 02 Jan '05

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14779 Modified Files: text-selection.lisp Log Message: Fix bug in text selection code causing an error if the user attempts to drag a selection endpoint before any text has been selected. (Previous commit to CLX backend had nothing to do with this, sorry) Date: Sun Jan 2 06:31:32 2005 Author: ahefner Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.1 mcclim/text-selection.lisp:1.2 --- mcclim/text-selection.lisp:1.1 Tue Dec 7 05:49:51 2004 +++ mcclim/text-selection.lisp Sun Jan 2 06:31:32 2005 @@ -218,15 +218,16 @@ ;; paste (request-selection (port pane) #|:UTF8_STRING|# (sheet-direct-mirror pane) (event-timestamp event))) ((eql +pointer-right-button+ (pointer-event-button event)) - ;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around. - (when (< (+ (expt (- (pointer-event-x event) point-1-x) 2) - (expt (- (pointer-event-y event) point-1-y) 2)) - (+ (expt (- (pointer-event-x event) point-2-x) 2) - (expt (- (pointer-event-y event) point-2-y) 2))) - (rotatef point-1-x point-2-x) - (rotatef point-1-y point-2-y)) - (eos/shift-drag pane event) - (setf dragging-p t)) + (when (and point-1-x point-1-y point-2-x point-2-y) + ;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around. + (when (< (+ (expt (- (pointer-event-x event) point-1-x) 2) + (expt (- (pointer-event-y event) point-1-y) 2)) + (+ (expt (- (pointer-event-x event) point-2-x) 2) + (expt (- (pointer-event-y event) point-2-y) 2))) + (rotatef point-1-x point-2-x) + (rotatef point-1-y point-2-y)) + (eos/shift-drag pane event) + (setf dragging-p t))) (t (describe event))))) (defmethod eos/shift-release ((pane extended-output-stream) event)

1 0

[mcclim-cvs] CVS update: mcclim/Examples/gadget-test.lisp
by ahefner＠common-lisp.net 02 Jan '05

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv14647/Examples Modified Files: gadget-test.lisp Log Message: Cleanups to gadget-test. Date: Sun Jan 2 06:29:19 2005 Author: ahefner Index: mcclim/Examples/gadget-test.lisp diff -u mcclim/Examples/gadget-test.lisp:1.11 mcclim/Examples/gadget-test.lisp:1.12 --- mcclim/Examples/gadget-test.lisp:1.11 Wed Jul 7 12:08:55 2004 +++ mcclim/Examples/gadget-test.lisp Sun Jan 2 06:29:19 2005 @@ -19,40 +19,36 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Copied from colorslider +(in-package :clim-demo) -(in-package :clim-internals) +;; Gadget Test/Demo -;; example gadget definition -(defclass gadget-test-pane (standard-gadget) ()) +;; To run the gadget test: (clim-demo:gadget-test) -(in-package :clim-demo) +;; McCLIM contains an alternate look and feel entitled "pixie" which is +;; not the default. It can by used by creating your application using an +;; alternate frame manager, clim-internals::pixie/clx-look. + +;; To run the gadget test using the pixie frame manager: +;; (gadget-test 'clim-internals::pixie/clx-look) +;; This may require you to load the clim-looks system. + +(defun gadget-test (&optional frame-manager-name) + (run-frame-top-level + (if frame-manager-name + (make-application-frame 'gadget-test + :frame-manager (make-instance frame-manager-name + :port (find-port))) + (make-application-frame 'gadget-test)))) -(defun gadget-test () - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) - (setq frame (make-application-frame 'gadget-test - :frame-manager (make-instance 'clim-internals::pixie/clx-look - :port (find-port)))) -; (setq frame (make-application-frame 'gadget-test)) - (setq fm (frame-manager frame)) - (setq port (climi::frame-manager-port fm)) - (setq pane (frame-panes frame)) - (setq medium (sheet-medium pane)) - (setq graft (graft frame)) - ;(setq vbox (climi::frame-pane frame)) - (run-frame-top-level frame)) +(export 'gadget-test) (defun run-pixie-test (name) - (loop for port in climi::*all-ports* - do (destroy-port port)) - (setq climi::*all-ports* nil) (when name (run-frame-top-level - (make-application-frame name - :frame-manager (make-instance 'clim-internals:pixie/clx-look - :port (find-port)))))) + (make-application-frame name + :frame-manager (make-instance 'clim-internals::pixie/clx-look + :port (find-port)))))) (defmethod gadget-test-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) @@ -232,7 +228,10 @@ (:top-level (gadget-test-frame-top-level . nil))) (defmethod run-frame-top-level :around ((frame gadget-test) &key &allow-other-keys) - (clim-internals::schedule-timer-event (find-pane-named frame 'radar) 'radiate 0.1) + ;; FIXME: Timer events appear to have rotted. + ;; Also, the following won't work because the frame has not really been realized yet, + ;; so you can't get at its panes. Yet it has worked, and recently. Odd. + ;; (clim-internals::schedule-timer-event (find-pane-named frame 'radar) 'radiate 0.1) (call-next-method)) (defclass radar-pane (basic-gadget) (

1 0

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

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv14626/Backends/CLX Modified Files: port.lisp Log Message: Fix bug in text selection code causing an error if the user attempts to drag a selection endpoint before any text has been selected. Fix to decode-x-button-code for users with more than five mouse buttons. Date: Sun Jan 2 06:29:03 2005 Author: ahefner Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.101 mcclim/Backends/CLX/port.lisp:1.102 --- mcclim/Backends/CLX/port.lisp:1.101 Tue Dec 28 11:06:21 2004 +++ mcclim/Backends/CLX/port.lisp Sun Jan 2 06:29:03 2005 @@ -238,8 +238,9 @@ (setf (xlib:display-error-handler (clx-port-display port)) #'clx-error-handler) - #+nil + #+nil ;; Uncomment this when debugging CLX backend if asynchronous errors become troublesome.. (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-force-output)) + (setf (clx-port-screen port) (nth (getf options :screen-id 0) (xlib:display-roots (clx-port-display port)))) @@ -531,13 +532,16 @@ (progn ,@body))))))) -(defun decode-x-button-code (code) - (aref #.(vector +pointer-left-button+ - +pointer-middle-button+ - +pointer-right-button+ - +pointer-wheel-up+ - +pointer-wheel-down+) - (1- code))) +(defun decode-x-button-code (code) + (let ((button-mapping #.(vector +pointer-left-button+ + +pointer-middle-button+ + +pointer-right-button+ + +pointer-wheel-up+ + +pointer-wheel-down+))) + (if (and (> code 0) + (<= code (1+ (length button-mapping)))) + (aref button-mapping (1- code)) + nil))) ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1, ;; section 4.1.5: @@ -1063,7 +1067,8 @@ (or (gethash color table) (setf (gethash color table) (multiple-value-bind (r g b) (color-rgb color) - (xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port)) + (xlib:alloc-color (xlib:screen-default-colormap + (clx-port-screen port)) (xlib:make-color :red r :green g :blue b))))))) (defmethod port-mirror-width ((port clx-port) sheet) @@ -1352,6 +1357,8 @@ (xlib:convert-selection :primary :UTF8_STRING requestor :bounce time)) (defmethod get-selection-from-event ((event clx-selection-notify-event)) + (when (null (selection-event-property event)) + (format *trace-output* "~&;; Notify property is null! Why did this happen?~%")) (map 'string #'code-char (xlib:get-property (sheet-direct-mirror (event-sheet event)) (selection-event-property event) @@ -1364,8 +1371,10 @@ (property (selection-event-property event)) (target (selection-event-target event)) (time (event-timestamp event))) -; (describe event *trace-output*) -; (finish-output *trace-output*) + (when (null property) + (format *trace-output* "~&* Requestor property is null! *~%")) + (describe event *trace-output*) + (finish-output *trace-output*) (cond ((member target '(:UTF8_STRING :STRING :TEXT)) (xlib:change-property requestor property (utf-8-encode

1 0

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

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14599 Modified Files: presentation-defs.lisp Log Message: Fix presentation system bug which produced incorrect results for presentation-type-of. Date: Sun Jan 2 06:28:38 2005 Author: ahefner Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.37 mcclim/presentation-defs.lisp:1.38 --- mcclim/presentation-defs.lisp:1.37 Sun Dec 5 20:37:52 2004 +++ mcclim/presentation-defs.lisp Sun Jan 2 06:28:38 2005 @@ -76,19 +76,20 @@ (let* ((name (class-name (class-of object))) (ptype-entry (gethash name *presentation-type-table*))) (unless ptype-entry - (return-from get-ptype-from-class-of name)) + (return-from get-ptype-from-class-of nil)) ;; Does the type have required parameters? If so, we can't use it... (let ((parameter-ll (parameters-lambda-list ptype-entry))) (values name (if (eq (car parameter-ll) '&whole) (cddr parameter-ll) - parameter-ll))))) + parameter-ll))))) (defmethod presentation-type-of ((object standard-object)) (multiple-value-bind (name lambda-list) (get-ptype-from-class-of object) - (if (or (null lambda-list) - (member lambda-list lambda-list-keywords)) + (if (and name + (or (null lambda-list) + (member (first lambda-list) lambda-list-keywords))) name (call-next-method))))

1 0

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

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14584 Modified Files: panes.lisp Log Message: Added comment in panes.lisp noting the the :x-spacing, :y-spacing, and :spacing initargs don't appear to work for grid and table panes. Date: Sun Jan 2 06:26:44 2005 Author: ahefner Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.146 mcclim/panes.lisp:1.147 --- mcclim/panes.lisp:1.146 Tue Dec 7 05:49:51 2004 +++ mcclim/panes.lisp Sun Jan 2 06:26:44 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.146 2004/12/07 04:49:51 hefner1 Exp $ +;;; $Id: panes.lisp,v 1.147 2005/01/02 05:26:44 ahefner Exp $ (in-package :clim-internals) @@ -1343,6 +1343,9 @@ ) ;;; TABLE PANE + +;; TODO: The table and grid panes should respect the :x-spacing, +;; :y-spacing, and :spacing initargs. (defclass table-pane (composite-pane) ((array

1 0

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

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14568 Modified Files: gadgets.lisp Log Message: Fix incorrect default mode of list pane. Provide some tactile feedback by changing the pointer cursor within box-adjuster-gadget. Date: Sun Jan 2 06:25:38 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.85 mcclim/gadgets.lisp:1.86 --- mcclim/gadgets.lisp:1.85 Mon Nov 15 07:17:04 2004 +++ mcclim/gadgets.lisp Sun Jan 2 06:25:38 2005 @@ -46,9 +46,6 @@ ;; Why is there GADGET-LABEL-TEXT-STYLE? The spec says, that just the ;; pane's text-style should be borrowed. -;; Is "no label" as initarg to labelled gadget really such a good -;; idea? I would prefer "". - ;; RANGE-GADGET / RANGE-GADGET-MIXIN: same thing as with ;; ORIENTED-GADGET-MIXIN. @@ -1965,7 +1962,7 @@ (defclass meta-list-pane () ((mode :initarg :mode - :initform :some-of + :initform :exclusive :reader list-pane-mode :type (member :one-of :some-of)) (items :initarg :items @@ -2835,3 +2832,6 @@ (changing-space-requirements (:resize-frame nil) (adjust-space-requirement left-peer left-sr orientation delta) (adjust-space-requirement right-peer right-sr orientation (- delta))))))) + +(defmethod note-sheet-grafted ((sheet clim-extensions:box-adjuster-gadget)) + (setf (sheet-pointer-cursor sheet) :rotate))

1 0

[mcclim-cvs] CVS update: mcclim/bordered-output.lisp mcclim/dialog.lisp
by ahefner＠common-lisp.net 02 Jan '05

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14532 Modified Files: bordered-output.lisp dialog.lisp Log Message: Add new :inset border shape. Use this to surround text fields created by accepting-values. Reduce offset of :drop-shadow border by one pixel, to three pixels. In accepting values dialogs, reclaim the space occupied by the dialog after exiting. Date: Sun Jan 2 06:24:50 2005 Author: ahefner Index: mcclim/bordered-output.lisp diff -u mcclim/bordered-output.lisp:1.12 mcclim/bordered-output.lisp:1.13 --- mcclim/bordered-output.lisp:1.12 Wed Oct 6 14:03:56 2004 +++ mcclim/bordered-output.lisp Sun Jan 2 06:24:49 2005 @@ -90,7 +90,7 @@ (define-border-type :drop-shadow (stream left top right bottom) (let* ((gap 3) ; FIXME? - (offset 4) + (offset 3) (left-edge (- left gap)) (bottom-edge (+ bottom gap)) (top-edge (- top gap)) @@ -108,13 +108,29 @@ :filled T))) (define-border-type :underline (stream record) - (labels ((fn (record) + (labels ((fn (record) (loop for child across (output-record-children record) do (typecase child (text-displayed-output-record (with-bounding-rectangle* (left top right bottom) child (declare (ignore top)) (draw-line* stream left bottom right bottom))) - (updating-output-record nil) + (updating-output-record nil) (compound-output-record (fn child)))))) (fn record))) + +(define-border-type :inset (stream left top right bottom) + (let* ((gap 3) + (left-edge (- left gap)) + (bottom-edge (+ bottom gap)) + (top-edge (- top gap)) + (right-edge (+ right gap)) + (dark *3d-dark-color*) + (light *3d-light-color*)) + (flet ((draw (left-edge right-edge bottom-edge top-edge light dark) + (draw-line* stream left-edge bottom-edge left-edge top-edge :ink dark) + (draw-line* stream left-edge top-edge right-edge top-edge :ink dark) + (draw-line* stream right-edge bottom-edge right-edge top-edge :ink light) + (draw-line* stream left-edge bottom-edge right-edge bottom-edge :ink light))) + (draw left-edge right-edge bottom-edge top-edge light dark) + (draw (1+ left-edge) (1- right-edge) (1- bottom-edge) (1+ top-edge) light dark)))) Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.14 mcclim/dialog.lisp:1.15 --- mcclim/dialog.lisp:1.14 Sun Oct 24 17:47:02 2004 +++ mcclim/dialog.lisp Sun Jan 2 06:24:49 2005 @@ -130,50 +130,53 @@ (frame-class 'accept-values)) (declare (ignore own-window exit-boxes modify-initial-query resize-frame label scroll-bars x-position y-position - width height frame-class)) - (let* ((*accepting-values-stream* - (make-instance 'accepting-values-stream - :stream stream - :align-prompts align-prompts)) - (arecord (updating-output (stream - :record-type 'accepting-values-record) - (if align-prompts - (formatting-table (stream) - (funcall body *accepting-values-stream*)) - (funcall body *accepting-values-stream*)) - (display-exit-boxes *application-frame* - stream - (stream-default-view - *accepting-values-stream*)))) - (first-time t) - (current-command (if initially-select-p - `(com-select-query - ,initially-select-query-identifier) - *default-command*))) - (letf (((frame-command-table *application-frame*) - (find-command-table command-table))) - (unwind-protect - (handler-case - (loop - (if first-time - (setq first-time nil) - (when resynchronize-every-pass - (redisplay arecord stream))) - (with-input-context - ('(command :command-table accepting-values)) - (object) - (progn - (apply (command-name current-command) - (command-arguments current-command)) - ;; If current command returns without throwing a - ;; command, go back to the default command - (setq current-command *default-command*)) - (t (setq current-command object))) - (redisplay arecord stream)) - (av-exit () - (finalize-query-records *accepting-values-stream*) - (redisplay arecord stream))) - (erase-output-record arecord stream))))) + width height frame-class)) + (multiple-value-bind (cx cy) (stream-cursor-position stream) + (let* ((*accepting-values-stream* + (make-instance 'accepting-values-stream + :stream stream + :align-prompts align-prompts)) + (arecord (updating-output (stream + :record-type 'accepting-values-record) + (if align-prompts + (formatting-table (stream) + (funcall body *accepting-values-stream*)) + (funcall body *accepting-values-stream*)) + (display-exit-boxes *application-frame* + stream + (stream-default-view + *accepting-values-stream*)))) + (first-time t) + (current-command (if initially-select-p + `(com-select-query + ,initially-select-query-identifier) + *default-command*))) + (letf (((frame-command-table *application-frame*) + (find-command-table command-table))) + (unwind-protect + (handler-case + (loop + (if first-time + (setq first-time nil) + (when resynchronize-every-pass + (redisplay arecord stream))) + (with-input-context + ('(command :command-table accepting-values)) + (object) + (progn + (apply (command-name current-command) + (command-arguments current-command)) + ;; If current command returns without throwing a + ;; command, go back to the default command + (setq current-command *default-command*)) + (t (setq current-command object))) + (redisplay arecord stream)) + (av-exit () + (finalize-query-records *accepting-values-stream*) + (redisplay arecord stream))) + (erase-output-record arecord stream) + (setf (stream-cursor-position stream) + (values cx cy))))))) (defgeneric display-exit-boxes (frame stream view)) @@ -355,7 +358,7 @@ (with-output-as-presentation (stream query-identifier 'selectable-query) (surrounding-output-with-border - (stream :shape :drop-shadow :move-cursor t) + (stream :shape :inset :move-cursor t) (setq editing-stream (make-instance 'standard-input-editing-stream :stream stream

1 0

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

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14488 Modified Files: system.lisp Log Message: Migrate listener system definition into McCLIM/system.lisp. It should now be possible to load the listener by loading McCLIM/system.lisp then loading the clim-listener system and at least one backend system (such as clim-clx). This obsoletes clim-listener.asd. Date: Sun Jan 2 06:18:00 2005 Author: ahefner Index: mcclim/system.lisp diff -u mcclim/system.lisp:1.106 mcclim/system.lisp:1.107 --- mcclim/system.lisp:1.106 Mon Dec 20 16:49:49 2004 +++ mcclim/system.lisp Sun Jan 2 06:17:59 2005 @@ -250,3 +250,14 @@ "Apps/Scigraph/scigraph/frame" "Apps/Scigraph/scigraph/export" "Apps/Scigraph/scigraph/demo-frame") + +(clim-defsystem (:clim-listener :depends-on (:clim #+clx :clim-looks #+sbcl :sb-posix)) + "Experimental/xpm" + "Apps/Listener/package" + "Apps/Listener/hotfixes" + "Apps/Listener/util" + "Apps/Listener/icons.lisp" + "Apps/Listener/file-types" + "Apps/Listener/dev-commands" + "Apps/Listener/listener" + #+CMU "Apps/Listener/cmu-hacks")

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp mcclim/Apps/Listener/icons.lisp mcclim/Apps/Listener/listener.lisp mcclim/Apps/Listener/util.lisp
by ahefner＠common-lisp.net 02 Jan '05

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv13750 Modified Files: dev-commands.lisp icons.lisp listener.lisp util.lisp Log Message: Added additional presentation translators to the listener to make class metaobjects and class names more interchangable (thanks to someone on IRC, I've forgotten who, very sorry..). Also a bugfix where class names were potentially printed to the wrong stream. Adjust menu item names for entries in the listener show-commands table. Some cleanups to the listener wholine-pane, and addition of a spiffy 3D background. Date: Sun Jan 2 06:14:28 2005 Author: ahefner Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.27 mcclim/Apps/Listener/dev-commands.lisp:1.28 --- mcclim/Apps/Listener/dev-commands.lisp:1.27 Mon Dec 20 16:44:47 2004 +++ mcclim/Apps/Listener/dev-commands.lisp Sun Jan 2 06:14:28 2005 @@ -384,10 +384,51 @@ (room)) (define-presentation-to-command-translator mem-room-translator - (lisp-memory-usage com-room lisp-commands :gesture :select) + (lisp-memory-usage com-room lisp-commands + :gesture :select + :documentation "Room" + :pointer-documentation "Room") ()) +(define-presentation-to-command-translator com-show-class-subclasses-translator + (class-name com-show-class-subclasses lisp-commands + :menu t + :documentation "Show Class Subclasses" + :pointer-documentation "Show Class Subclasses") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-superclasses-translator + (class-name com-show-class-superclasses lisp-commands + :menu t + :tester ((presentation) + (not (eq t (presentation-object presentation)))) + :documentation "Show Class Superclasses" + :pointer-documentation "Show Class Superclasses") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-generic-functions-translator + (class-name com-show-class-generic-functions lisp-commands + :menu t + :documentation "Show Class Generic Functions" + :pointer-documentation "Show Class Generic Functions") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-slots-translator + (class-name com-show-class-slots lisp-commands + :menu t + :documentation "Show Class Slots" + :pointer-documentation "Show Class Slots") + (presentation) + (list (presentation-object presentation))) + + ;;; CLOS introspection commands (defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) @@ -407,7 +448,7 @@ ;; class object itself is rather long and freaks out the pointer doc pane. (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name) ; (surrounding-output-with-border (stream :shape :drop-shadow) - (princ (clim-mop:class-name class))))) ;) + (princ (clim-mop:class-name class) stream)))) ;) inferior-fun :stream stream :merge-duplicates T @@ -425,7 +466,7 @@ (define-command (com-show-class-superclasses :name "Show Class Superclasses" :command-table show-commands - :menu t + :menu "Class Superclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -435,7 +476,7 @@ (define-command (com-show-class-subclasses :name "Show Class Subclasses" :command-table show-commands - :menu t + :menu "Class Subclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -551,7 +592,7 @@ (defun print-slot-table-heading () (formatting-row (T) (dolist (name '("Slot name" "Initargs" "Initform" "Accessors")) - (formatting-cell (T :align-x :center) + (formatting-cell (T :align-x :center) (underlining (T) (with-text-family (T :sans-serif) (princ name))))))) @@ -586,7 +627,7 @@ (define-command (com-show-class-slots :name "Show Class Slots" :command-table show-commands - :menu t + :menu "Class Slots" :provide-output-destination-keyword t) ((class-name 'clim:symbol :prompt "class name")) (let ((class (find-class class-name nil))) @@ -652,7 +693,7 @@ (define-command (com-show-class-generic-functions :name "Show Class Generic Functions" :command-table show-commands - :menu t + :menu "Class Generic Functions" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -796,7 +837,7 @@ (define-command (com-show-generic-function :name t :command-table show-commands - :menu t + :menu "Generic Function" :provide-output-destination-keyword t) ((gf 'generic-function :prompt "a generic function") &key (classes 'boolean :default nil :mentioned-default t) @@ -936,7 +977,7 @@ (define-command (com-show-used-packages :name "Show Used Packages" :command-table show-commands - :menu t + :menu "Used Packages" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec @@ -949,7 +990,7 @@ (define-command (com-show-package-users :name "Show Package Users" :command-table show-commands - :menu t + :menu "Package Users" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec @@ -1388,7 +1429,9 @@ ;;; Some CLIM developer commands -(define-command (com-show-command-table :name t :menu t :command-table show-commands) +(define-command (com-show-command-table :name t + :menu "Command Table" + :command-table show-commands) ((table 'clim:command-table :prompt "command table") &key (locally 'boolean :default nil :mentioned-default t) @@ -1407,7 +1450,8 @@ (push (cons ct (sort commands (lambda (x y) (string-lessp (command-line-name-for-command x ct :errorp :create) - (command-line-name-for-command y ct :errorp :create))))) our-tables))) + (command-line-name-for-command y ct :errorp :create))))) + our-tables))) (setq our-tables (nreverse our-tables)) (when show-commands ;; sure, why not? Index: mcclim/Apps/Listener/icons.lisp diff -u mcclim/Apps/Listener/icons.lisp:1.2 mcclim/Apps/Listener/icons.lisp:1.3 --- mcclim/Apps/Listener/icons.lisp:1.2 Mon Sep 29 22:33:03 2003 +++ mcclim/Apps/Listener/icons.lisp Sun Jan 2 06:14:28 2005 @@ -33,7 +33,8 @@ ;(defparameter *icon-path* (merge-pathnames #P"icons/" #.*compile-file-truename*)) (defmacro deficon (var pathname) - `(defparameter ,var (climi::xpm-parse-file ,(merge-pathnames pathname *icon-path*)))) + `(eval-when (:load-toplevel :execute) + (defparameter ,var (climi::xpm-parse-file ,(merge-pathnames pathname *icon-path*))))) (defvar *icon-cache* (make-hash-table :test #'equal)) Index: mcclim/Apps/Listener/listener.lisp diff -u mcclim/Apps/Listener/listener.lisp:1.19 mcclim/Apps/Listener/listener.lisp:1.20 --- mcclim/Apps/Listener/listener.lisp:1.19 Mon Dec 20 16:45:34 2004 +++ mcclim/Apps/Listener/listener.lisp Sun Jan 2 06:14:28 2005 @@ -22,26 +22,21 @@ ;; Wholine Pane -(defclass wholine-pane (application-pane) ()) +(defclass wholine-pane (application-pane) () + (:default-initargs :background +gray90+)) (defmethod compose-space ((pane wholine-pane) &key width height) (declare (ignore width height)) - (let ((h (+ 3 (text-style-height (medium-text-style pane) pane)))) ; magic padding - (make-space-requirement :min-width 500 :width 768 ; magic space requirements - :height h - :min-height h - :max-height h))) - -(defvar *reconfiguring-wholine* nil) - -(defmethod allocate-space ((pane wholine-pane) width height) - (unless *reconfiguring-wholine* - (let ((*reconfiguring-wholine* t)) - (call-next-method) - (window-clear pane) - (redisplay-frame-pane (pane-frame pane) pane)))) - - + (let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding + (make-space-requirement :height h + :min-height h + :max-height h))) + +;; When the pane is grown, we must repaint more than just the newly exposed +;; regions, because the decoration within the previous region must move. +;; Likewise, shrinking the pane requires repainting some of the interior. +(defmethod allocate-space :after ((pane wholine-pane) width height) + (repaint-sheet pane (sheet-region pane))) (defun print-package-name (stream) (let ((foo (package-name *package*))) @@ -53,7 +48,27 @@ (defun frob-pathname (pathname) (namestring (truename pathname))) -(defun display-wholine (frame pane) +;; How to add repaint-time decoration underneath the contents of a +;; stream pane: Write your own handle-repaint that draws the +;; decoration then replays the recorded output, and define a +;; window-clear method which calls the next window-clear method, +;; then calls handle-repaint to redraw the decoration. + +(defmethod handle-repaint ((pane wholine-pane) region) + (declare (ignore region)) + (with-output-recording-options (pane :draw t :record nil) + (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) + (climi::draw-bordered-rectangle* (sheet-medium pane) + x0 y0 x1 y1 + :style :mickey-mouse-inset) + #+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+)) + (replay-output-record (stream-output-history pane) pane))) + +(defmethod window-clear ((pane wholine-pane)) + (call-next-method) + (handle-repaint pane (sheet-region pane))) + +(defun generate-wholine-contents (frame pane) (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) @@ -84,15 +99,19 @@ (format T " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters - ;; to really do so such that the memory usage appears right justified. + ;; to really do so such that the memory usage appears right justified. (cell (:center) (when (numberp memusage) (present memusage 'lisp-memory-usage))))))))) -;; This is a (very simple) command history. -;; Should we move this into CLIM-INTERNALS ? +(defun display-wholine (frame pane) + (invoke-and-center-output pane + (lambda () (generate-wholine-contents frame pane)) + :horizontally nil :hpad 5)) + +;; This is a toy command history. ;; Possibly this should become something integrated with the presentation -;; histories which I have not played with. +;; histories, which I have not played with. (defclass command-history-mixin () ((history :initform nil :accessor history) @@ -224,8 +243,6 @@ '(#$ #$ #\[ #\] #\# #\; #\: #\' #\" #\* #\, #\` #\- #\+ #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - - (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) "Specialized for the listener, read a lisp form to eval, or a command." (if (system-command-reader frame) @@ -302,11 +319,15 @@ (defun run-listener (&key (system-command-reader nil) (new-process nil) + (width 800) + (height 800) (process-name "Listener") (eval nil)) (flet ((run () (run-frame-top-level (make-application-frame 'listener + :width width + :height height :system-command-reader system-command-reader) :listener-funcall (cond ((null eval) nil) ((functionp eval) eval) Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.15 mcclim/Apps/Listener/util.lisp:1.16 --- mcclim/Apps/Listener/util.lisp:1.15 Mon Dec 20 16:46:49 2004 +++ mcclim/Apps/Listener/util.lisp Sun Jan 2 06:14:28 2005 @@ -209,6 +209,26 @@ (- x (stream-cursor-position stream))) 0)) +(defun invoke-and-center-output (stream-pane continuation + &key (horizontally t) (vertically t) (hpad 0) (vpad 0)) + (let ((record (with-output-to-output-record (stream-pane) + (funcall continuation)))) + (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region stream-pane) + (with-bounding-rectangle* (rx0 ry0 rx1 ry1) (bounding-rectangle record) + (setf (output-record-position record) + (values (if horizontally + (+ rx0 (/ (- (- sx1 sx0) + (- rx1 rx0)) + 2)) + (+ rx0 hpad)) + (if vertically + (+ ry0 (/ (- (- sy1 sy0) + (- ry1 ry0)) + 2)) + (+ ry0 vpad)))))) + (add-output-record record (stream-output-history stream-pane)) + (repaint-sheet stream-pane record))) + ;;; Pathname evil ;;; Fixme: Invent some more useful operators for manipulating pathnames, add a ;;; pinch of syntactic sugar, and cut the LOC here down to a fraction.

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/package.lisp
by ahefner＠common-lisp.net 02 Jan '05

02 Jan '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv13715 Added Files: package.lisp Log Message: Package definition for listener. Date: Sun Jan 2 06:08:47 2005 Author: ahefner

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs January 2005