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))