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

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Thu May 1 08:29:33 2003 UTC (10 years, 11 months ago) by hefner1
Branch: MAIN
Changes since 1.5: +27 -1 lines
Implemented :drop-shadow and :underline
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 ;;; TODO:
21 ;;; - Use DRAWING-OPTIONS, MOVE-CURSOR in I-S-O-W-B
22 ;;; - Gap computation
23
24 (in-package :clim-internals)
25
26 (defvar *border-types* (make-hash-table))
27
28 (defmacro surrounding-output-with-border ((&optional stream
29 &rest drawing-options
30 &key (shape :rectangle) (move-cursor t))
31 &body body)
32 (declare (ignore shape move-cursor))
33 (orf stream '*standard-output*)
34 (check-type stream symbol)
35 (let ((continuation-name (gensym)))
36 `(flet ((,continuation-name (,stream) ,@body))
37 (invoke-surrounding-output-with-border ,stream
38 #',continuation-name
39 ,@drawing-options))))
40
41 (defun invoke-surrounding-output-with-border (stream cont
42 &rest drawing-options
43 &key (shape :rectangle) (move-cursor t))
44 (with-sheet-medium (medium stream)
45 (let ((record (with-new-output-record (stream)
46 (funcall cont stream))))
47 (with-bounding-rectangle* (left top right bottom) record
48 (letf (((medium-transformation medium) +identity-transformation+))
49 (funcall (gethash shape *border-types*)
50 :stream stream
51 :record record
52 :left left :top top
53 :right right :bottom bottom
54 :allow-other-keys t))))))
55
56 (defmacro define-border-type (shape arglist &body body)
57 (check-type arglist list)
58 (loop for arg in arglist
59 do (check-type arg symbol)
60 (assert (member arg '(&key stream record left top right bottom)
61 :test #'string-equal)))
62 `(setf (gethash ,shape *border-types*)
63 (lambda ,arglist ,@body)))
64
65
66 ;;;; Standard border types
67
68 (define-border-type :rectangle (&key stream left top right bottom)
69 (let ((gap 3)) ; FIXME
70 (draw-rectangle* stream
71 (- left gap) (- top gap)
72 (+ right gap) (+ bottom gap)
73 :filled nil)))
74
75 (define-border-type :oval (&key stream left top right bottom)
76 (let ((gap 3)) ; FIXME
77 (draw-oval* stream
78 (/ (+ left right) 2) (/ (+ top bottom) 2)
79 (+ (/ (- right left) 2) gap) (+ (/ (- bottom top) 2) gap)
80 :filled nil)))
81
82 (define-border-type :drop-shadow (&key stream left top right bottom)
83 (let* ((gap 3) ; FIXME?
84 (offset 4)
85 (left-edge (- left gap))
86 (bottom-edge (+ bottom gap))
87 (top-edge (- top gap))
88 (right-edge (+ right gap)))
89 (draw-rectangle* stream
90 left-edge top-edge
91 right-edge bottom-edge
92 :filled nil)
93 (draw-rectangle* stream
94 right-edge (+ top-edge offset)
95 (+ right-edge offset) bottom-edge :filled T)
96 (draw-rectangle* stream
97 (+ left-edge offset) bottom-edge
98 (+ right-edge offset) (+ bottom-edge offset)
99 :filled T)))
100
101 (define-border-type :underline (&key stream record)
102 (let ((children (output-record-children record)))
103 (loop for child across children do
104 (when (text-displayed-output-record-p child)
105 (with-bounding-rectangle* (left top right bottom) child
106 (declare (ignore top))
107 (draw-line* stream left bottom right bottom))))))

  ViewVC Help
Powered by ViewVC 1.1.5