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

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Tue May 28 08:00:33 2002 UTC (11 years, 10 months ago) by adejneka
Branch: MAIN
Changes since 1.2: +10 -3 lines
* Implemented oval border
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     ;;; - Implement :DROP-SHADOW, :UNDERLINE
24 adejneka 1.1
25     (in-package :CLIM-INTERNALS)
26    
27     (defvar *border-types* (make-hash-table))
28    
29     (defmacro surrounding-output-with-border ((&optional stream
30     &rest drawing-options
31     &key (shape :rectangle) (move-cursor t))
32     &body body)
33     (declare (ignore shape move-cursor))
34     (check-type stream symbol)
35     (unless stream
36     (setq stream *standard-output*))
37     (let ((continuation-name (gensym)))
38 adejneka 1.2 `(flet ((,continuation-name (,stream) ,@body))
39 adejneka 1.1 (invoke-surrounding-output-with-border ,stream
40     #',continuation-name
41     ,@drawing-options))))
42    
43     (defun invoke-surrounding-output-with-border (stream cont
44     &rest drawing-options
45     &key (shape :rectangle) (move-cursor t))
46 adejneka 1.2 (with-sheet-medium (medium stream)
47     (let ((record (with-new-output-record (stream)
48     (funcall cont stream))))
49     (with-bounding-rectangle* (left top right bottom) record
50     (letf (((medium-transformation medium) +identity-transformation+))
51     (funcall (gethash shape *border-types*)
52     :stream stream
53     :record record
54     :left left :top top
55     :right right :bottom bottom
56     :allow-other-keys t))))))
57 adejneka 1.1
58     (defmacro define-border-type (shape arglist &body body)
59     (check-type arglist list)
60     (loop for arg in arglist
61     do (check-type arg symbol)
62     (assert (member arg '(&key stream record left top right bottom)
63     :test #'string-equal)))
64     `(setf (gethash ,shape *border-types*)
65     (lambda ,arglist ,@body)))
66    
67    
68     ;;;; Standard border types
69    
70     (define-border-type :rectangle (&key stream left top right bottom)
71     (let ((gap 3)) ; FIXME
72     (draw-rectangle* stream
73     (- left gap) (- top gap)
74     (+ right gap) (+ bottom gap)
75 adejneka 1.3 :filled nil)))
76    
77     (define-border-type :oval (&key stream left top right bottom)
78     (let ((gap 3)) ; FIXME
79     (draw-oval* stream
80     (/ (+ left right) 2) (/ (+ top bottom) 2)
81     (+ (/ (- right left) 2) gap) (+ (/ (- bottom top) 2) gap)
82     :filled nil)))

  ViewVC Help
Powered by ViewVC 1.1.5