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