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

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Wed May 28 18:46:02 2003 UTC (10 years, 10 months ago) by gilbert
Branch: MAIN
Changes since 1.6: +3 -2 lines
INVOKE-SURROUNDING-OUTPUT-WITH-BORDER
    . uses WITH-IDENTITY-TRANSFORMATION now
    . more graceful behavior in case the border style is not defined.
1 adejneka 1.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 adejneka 1.3 ;;; - Gap computation
23 adejneka 1.1
24 mikemac 1.5 (in-package :clim-internals)
25 adejneka 1.1
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 adejneka 1.4 (orf stream '*standard-output*)
34 adejneka 1.1 (check-type stream symbol)
35     (let ((continuation-name (gensym)))
36 adejneka 1.2 `(flet ((,continuation-name (,stream) ,@body))
37 adejneka 1.1 (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 adejneka 1.2 (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 gilbert 1.7 (with-identity-transformation (medium)
49     (funcall (or (gethash shape *border-types*)
50     (error "Border shape ~S not defined." shape))
51 adejneka 1.2 :stream stream
52     :record record
53     :left left :top top
54     :right right :bottom bottom
55     :allow-other-keys t))))))
56 adejneka 1.1
57     (defmacro define-border-type (shape arglist &body body)
58     (check-type arglist list)
59     (loop for arg in arglist
60     do (check-type arg symbol)
61     (assert (member arg '(&key stream record left top right bottom)
62     :test #'string-equal)))
63     `(setf (gethash ,shape *border-types*)
64     (lambda ,arglist ,@body)))
65    
66    
67     ;;;; Standard border types
68    
69     (define-border-type :rectangle (&key stream left top right bottom)
70     (let ((gap 3)) ; FIXME
71     (draw-rectangle* stream
72     (- left gap) (- top gap)
73     (+ right gap) (+ bottom gap)
74 adejneka 1.3 :filled nil)))
75    
76     (define-border-type :oval (&key stream left top right bottom)
77     (let ((gap 3)) ; FIXME
78     (draw-oval* stream
79     (/ (+ left right) 2) (/ (+ top bottom) 2)
80     (+ (/ (- right left) 2) gap) (+ (/ (- bottom top) 2) gap)
81     :filled nil)))
82 hefner1 1.6
83     (define-border-type :drop-shadow (&key stream left top right bottom)
84     (let* ((gap 3) ; FIXME?
85     (offset 4)
86     (left-edge (- left gap))
87     (bottom-edge (+ bottom gap))
88     (top-edge (- top gap))
89     (right-edge (+ right gap)))
90     (draw-rectangle* stream
91     left-edge top-edge
92     right-edge bottom-edge
93     :filled nil)
94     (draw-rectangle* stream
95     right-edge (+ top-edge offset)
96     (+ right-edge offset) bottom-edge :filled T)
97     (draw-rectangle* stream
98     (+ left-edge offset) bottom-edge
99     (+ right-edge offset) (+ bottom-edge offset)
100     :filled T)))
101    
102     (define-border-type :underline (&key stream record)
103     (let ((children (output-record-children record)))
104     (loop for child across children do
105     (when (text-displayed-output-record-p child)
106     (with-bounding-rectangle* (left top right bottom) child
107     (declare (ignore top))
108     (draw-line* stream left bottom right bottom))))))

  ViewVC Help
Powered by ViewVC 1.1.5