/[mcclim]/mcclim/bordered-output.lisp
ViewVC logotype

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Sun Jan 2 05:24:49 2005 UTC (9 years, 3 months ago) by ahefner
Branch: MAIN
CVS Tags: McCLIM-0-9-1, McCLIM-0-9-2
Changes since 1.12: +19 -3 lines
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.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4 ;;; This library is free software; you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Library General Public
6 ;;; License as published by the Free Software Foundation; either
7 ;;; version 2 of the License, or (at your option) any later version.
8 ;;;
9 ;;; This library is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Library General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Library General Public
15 ;;; License along with this library; if not, write to the
16 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17 ;;; Boston, MA 02111-1307 USA.
18
19 ;;; TODO:
20 ;;; - Use DRAWING-OPTIONS, MOVE-CURSOR in I-S-O-W-B
21 ;;; - Gap computation
22
23 (in-package :clim-internals)
24
25 (defvar *border-types* (make-hash-table))
26
27 (defmacro surrounding-output-with-border ((&optional stream
28 &rest drawing-options
29 &key (shape :rectangle) (move-cursor t))
30 &body body)
31 (declare (ignore shape move-cursor))
32 (setf stream (stream-designator-symbol stream '*standard-output*))
33 (gen-invoke-trampoline 'invoke-surrounding-output-with-border
34 (list stream)
35 drawing-options
36 body))
37
38 (defun invoke-surrounding-output-with-border (stream cont
39 &rest drawing-options
40 &key (shape :rectangle)
41 (move-cursor t))
42 (with-sheet-medium (medium stream)
43 (let ((bbox-record
44 (with-new-output-record (stream)
45 (let ((record (with-new-output-record (stream)
46 (funcall cont stream))))
47 (with-bounding-rectangle* (left top right bottom) record
48 (with-identity-transformation (medium)
49 (with-keywords-removed
50 (drawing-options (:shape :move-cursor))
51 (apply (or (gethash shape *border-types*)
52 (error "Border shape ~S not defined." shape))
53 :stream stream
54 :record record
55 :left left :top top
56 :right right :bottom bottom
57 :allow-other-keys t
58 drawing-options))))))))
59 (when move-cursor
60 (with-bounding-rectangle* (left top right bottom) bbox-record
61 (declare (ignore left top))
62 (setf (stream-cursor-position stream) (values right bottom))))
63 bbox-record)))
64
65 (defmacro define-border-type (shape arglist &body body)
66 (check-type arglist list)
67 (loop for arg in arglist
68 do (check-type arg symbol))
69 ;; The Franz User guide implies that &key isn't needed.
70 (pushnew '&key arglist)
71 `(setf (gethash ,shape *border-types*)
72 (lambda ,arglist ,@body)))
73
74
75 ;;;; Standard border types
76
77 (define-border-type :rectangle (stream left top right bottom)
78 (let ((gap 3)) ; FIXME
79 (draw-rectangle* stream
80 (- left gap) (- top gap)
81 (+ right gap) (+ bottom gap)
82 :filled nil)))
83
84 (define-border-type :oval (stream left top right bottom)
85 (let ((gap 3)) ; FIXME
86 (draw-oval* stream
87 (/ (+ left right) 2) (/ (+ top bottom) 2)
88 (+ (/ (- right left) 2) gap) (+ (/ (- bottom top) 2) gap)
89 :filled nil)))
90
91 (define-border-type :drop-shadow (stream left top right bottom)
92 (let* ((gap 3) ; FIXME?
93 (offset 3)
94 (left-edge (- left gap))
95 (bottom-edge (+ bottom gap))
96 (top-edge (- top gap))
97 (right-edge (+ right gap)))
98 (draw-rectangle* stream
99 left-edge top-edge
100 right-edge bottom-edge
101 :filled nil)
102 (draw-rectangle* stream
103 right-edge (+ top-edge offset)
104 (+ right-edge offset) bottom-edge :filled T)
105 (draw-rectangle* stream
106 (+ left-edge offset) bottom-edge
107 (+ right-edge offset) (+ bottom-edge offset)
108 :filled T)))
109
110 (define-border-type :underline (stream record)
111 (labels ((fn (record)
112 (loop for child across (output-record-children record) do
113 (typecase child
114 (text-displayed-output-record
115 (with-bounding-rectangle* (left top right bottom) child
116 (declare (ignore top))
117 (draw-line* stream left bottom right bottom)))
118 (updating-output-record nil)
119 (compound-output-record (fn child))))))
120 (fn record)))
121
122 (define-border-type :inset (stream left top right bottom)
123 (let* ((gap 3)
124 (left-edge (- left gap))
125 (bottom-edge (+ bottom gap))
126 (top-edge (- top gap))
127 (right-edge (+ right gap))
128 (dark *3d-dark-color*)
129 (light *3d-light-color*))
130 (flet ((draw (left-edge right-edge bottom-edge top-edge light dark)
131 (draw-line* stream left-edge bottom-edge left-edge top-edge :ink dark)
132 (draw-line* stream left-edge top-edge right-edge top-edge :ink dark)
133 (draw-line* stream right-edge bottom-edge right-edge top-edge :ink light)
134 (draw-line* stream left-edge bottom-edge right-edge bottom-edge :ink light)))
135 (draw left-edge right-edge bottom-edge top-edge light dark)
136 (draw (1+ left-edge) (1- right-edge) (1- bottom-edge) (1+ top-edge) light dark))))

  ViewVC Help
Powered by ViewVC 1.1.5