[mcclim-cvs] CVS update: mcclim/bordered-output.lisp mcclim/dialog.lisp
Andy Hefner
ahefner at common-lisp.net
Sun Jan 2 05:24:52 UTC 2005
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
More information about the Mcclim-cvs
mailing list