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

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Wed Oct 6 12:03:56 2004 UTC (9 years, 6 months ago) by moore
Branch: MAIN
Changes since 1.11: +1 -1 lines
Changed STREAM-DESIGNATOR-SYMBOL to take a default value
argument. The value corresponding to T isn't always *STANDARD-OUTPUT*.

Fixed a problem in the incremental redisplay code checked in
recently: the output record that holds an updating output record's
children wasn't always created.

Some tweaks (in progress) to ACCEPTING-VALUES.
1 adejneka 1.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 adejneka 1.3 ;;; - Gap computation
22 adejneka 1.1
23 mikemac 1.5 (in-package :clim-internals)
24 adejneka 1.1
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 moore 1.12 (setf stream (stream-designator-symbol stream '*standard-output*))
33 gilbert 1.8 (gen-invoke-trampoline 'invoke-surrounding-output-with-border
34     (list stream)
35     drawing-options
36     body))
37 adejneka 1.1
38     (defun invoke-surrounding-output-with-border (stream cont
39     &rest drawing-options
40 moore 1.11 &key (shape :rectangle)
41     (move-cursor t))
42 adejneka 1.2 (with-sheet-medium (medium stream)
43 moore 1.11 (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 adejneka 1.1
65     (defmacro define-border-type (shape arglist &body body)
66     (check-type arglist list)
67     (loop for arg in arglist
68 moore 1.10 do (check-type arg symbol))
69     ;; The Franz User guide implies that &key isn't needed.
70     (pushnew '&key arglist)
71 adejneka 1.1 `(setf (gethash ,shape *border-types*)
72     (lambda ,arglist ,@body)))
73    
74    
75     ;;;; Standard border types
76    
77 moore 1.10 (define-border-type :rectangle (stream left top right bottom)
78 adejneka 1.1 (let ((gap 3)) ; FIXME
79     (draw-rectangle* stream
80     (- left gap) (- top gap)
81     (+ right gap) (+ bottom gap)
82 adejneka 1.3 :filled nil)))
83    
84 moore 1.10 (define-border-type :oval (stream left top right bottom)
85 adejneka 1.3 (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 hefner1 1.6
91 moore 1.10 (define-border-type :drop-shadow (stream left top right bottom)
92 hefner1 1.6 (let* ((gap 3) ; FIXME?
93     (offset 4)
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 moore 1.10 (define-border-type :underline (stream record)
111 hefner1 1.9 (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)))

  ViewVC Help
Powered by ViewVC 1.1.5