/src/rectangle.sc
Scala | 216 lines | 202 code | 14 blank | 0 comment | 3 complexity | 8f5ec82cdbf36e176de4bbc28f84c4ca MD5 | raw file
- ;;; ezd - easy drawing for X11 displays.
- ;;;
- ;;; The procedures in this module generate the GRAPHIC objects representing
- ;;; rectangles and polygons.
- ;* Copyright 1990-1993 Digital Equipment Corporation
- ;* All Rights Reserved
- ;*
- ;* Permission to use, copy, and modify this software and its documentation is
- ;* hereby granted only under the following terms and conditions. Both the
- ;* above copyright notice and this permission notice must appear in all copies
- ;* of the software, derivative works or modified versions, and any portions
- ;* thereof, and both notices must appear in supporting documentation.
- ;*
- ;* Users of this software agree to the terms and conditions set forth herein,
- ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
- ;* right and license under any changes, enhancements or extensions made to the
- ;* core functions of the software, including but not limited to those affording
- ;* compatibility with other hardware or software environments, but excluding
- ;* applications which incorporate this software. Users further agree to use
- ;* their best efforts to return to Digital any such changes, enhancements or
- ;* extensions that they make and inform Digital of noteworthy uses of this
- ;* software. Correspondence should be provided to Digital at:
- ;*
- ;* Director of Licensing
- ;* Western Research Laboratory
- ;* Digital Equipment Corporation
- ;* 250 University Avenue
- ;* Palo Alto, California 94301
- ;*
- ;* This software may be distributed (but not offered for sale or transferred
- ;* for compensation) to third parties, provided such third parties agree to
- ;* abide by the terms and conditions of this notice.
- ;*
- ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
- ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
- ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
- ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
- ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
- ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
- ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
- ;* SOFTWARE.
- (module rectangle)
- (include "struct.sch")
- (include "commands.sch")
- (include "ginfo.sch")
- (include "display.sch")
- (include "view.sch")
- (include "psdraw.sch")
- (include "drawing.sch")
- (include "graphic.sch")
- (include "xternal.sch")
- ;;; A rectangle is generated by the following procedure.
- (define (RECTANGLE x y width height line-width color dash)
- (make-graphic
- #f
- (lambda ()
- (let ((ux1 (user->x x))
- (ux2 (user->x (+ x width)))
- (uy1 (user->y y))
- (uy2 (user->y (+ y height)))
- (lwdiv2 (quotient (user->lw line-width) 2)))
- (list (- (min ux1 ux2) lwdiv2)
- (- (min uy1 uy2) lwdiv2)
- (+ (max ux1 ux2) lwdiv2 1)
- (+ (max uy1 uy2) lwdiv2 1))))
- (if (eq? color 'clear)
- draw-clear
- (lambda ()
- (xdrawrectangle *dpy* *xwindow*
- (cv-gc (user->lw line-width) color #f dash #f #f)
- (min (user->x x) (user->x (+ x width)))
- (min (user->y y) (user->y (+ y height)))
- (user->width width) (user->height height))))
- (if (eq? color 'clear)
- draw-clear
- (lambda ()
- (pscolor color)
- (pscommand "newpath" x y "moveto" width 0 "rlineto"
- 0 height "rlineto" (- width) 0 "rlineto"
- "closepath")
- (psstroke (user->lw line-width) dash)))
- (lambda (minx miny maxx maxy)
- (let* ((lwdiv2 (quotient (user->lw line-width) 2))
- (in-minx (+ x (width->user lwdiv2)))
- (in-miny (+ y (height->user lwdiv2)))
- (in-maxx (+ x width (- (width->user lwdiv2))))
- (in-maxy (+ y height (- (height->user lwdiv2)))))
- (not (and (<= in-minx minx maxx in-maxx)
- (<= in-miny miny maxy in-maxy)))))))
- (define-ezd-command
- `(rectangle ,number? ,number? ,non-negative? ,non-negative?
- (optional ,non-negative?) (optional ,color?) (optional ,dash?))
- "(rectangle x y width height [<line-width>] [<color>] [dash])"
- rectangle)
- ;;; A filled rectangle is generated by the following procedure.
- (define (FILL-RECTANGLE x y width height color stipple)
- (make-graphic
- #f
- (lambda ()
- (let ((ux1 (user->x x))
- (ux2 (user->x (+ x width)))
- (uy1 (user->y y))
- (uy2 (user->y (+ y height))))
- (list (min ux1 ux2)
- (min uy1 uy2)
- (+ (max ux1 ux2) 1)
- (+ (max uy1 uy2) 1))))
- (if (eq? color 'clear)
- draw-clear
- (lambda ()
- (xfillrectangle *dpy* *xwindow*
- (cv-gc #f color stipple #f #f #f)
- (min (user->x x) (user->x (+ x width)))
- (min (user->y y) (user->y (+ y height)))
- (user->width width) (user->height height))))
- (if (eq? color 'clear)
- draw-clear
- (lambda ()
- (pscolor color)
- (pscommand "newpath" x y "moveto" width 0 "rlineto"
- 0 height "rlineto" (- width) 0 "rlineto" "closepath"
- "fill")))
- (lambda (minx miny max maxy) #t)))
- (define-ezd-command
- `(fill-rectangle ,number? ,number? ,non-negative? ,non-negative?
- (optional ,color?) (optional ,stipple?))
- "(fill-rectangle x y width height [<color>] [<stipple>])"
- fill-rectangle)
- ;;; A filled polygon is generated by the following procedure.
- (define (FILL-POLYGON points color stipple)
- (let ((buffer (make-string (* 4 (length points))))
- (point-count (length points)))
-
- (define (LOAD-BUFFER)
- (let loop ((i 0) (points points))
- (if points
- (let ((x (caar points))
- (y (cadar points)))
- (c-shortint-set! buffer i (user->x x))
- (c-shortint-set! buffer (+ i 2) (user->y y))
- (loop (+ i 4) (cdr points))))))
-
- (let loop ((pl points) (minx #f) (miny #f) (maxx #f) (maxy #f))
- (if pl
- (let ((x (caar pl))
- (y (cadar pl)))
- (loop (cdr pl) (bbmin x minx) (bbmin y miny)
- (bbmax x maxx) (bbmax y maxy)))
- (make-graphic
- #f
- (lambda ()
- (let ((ux1 (user->x minx))
- (ux2 (user->x maxx))
- (uy1 (user->y miny))
- (uy2 (user->y maxy)))
- (list (min ux1 ux2)
- (min uy1 uy2)
- (+ (max ux1 ux2) 1)
- (+ (max uy1 uy2) 1))))
- (if (eq? color 'clear)
- draw-clear
- (lambda ()
- (load-buffer)
- (xfillpolygon *dpy* *xwindow*
- (cv-gc #f color stipple #f #f #f)
- (cons 'xpointap buffer) point-count
- complex coordmodeorigin)))
- (if (eq? color 'clear)
- draw-clear
- (lambda ()
- (pscolor color)
- (pscommand "newpath")
- (let loop ((pl points) (cmd "moveto"))
- (when pl
- (pscommand (caar pl)
- (cadar pl) cmd)
- (loop (cdr pl) "lineto")))
- (pscommand "closepath" "fill")))
- (lambda (minx miny maxx maxy)
- (let ((region (begin (load-buffer)
- (xpolygonregion
- (cons 'xpointap buffer)
- point-count
- evenoddrule))))
- (define (IN? x y)
- (not (zero? (xpointinregion
- region (user->x x)
- (user->y y)))))
- (let ((in (or (in? minx miny)
- (in? minx maxy)
- (in? maxx miny)
- (in? maxx maxy)
- (in? (+ minx
- (/ (- maxx minx) 2))
- (+ miny
- (/ (- maxy miny)
- 2))))))
- (xdestroyregion region)
- in))))))))
- (define-ezd-command
- `(fill-polygon (repeat ,number? ,number?) (optional ,color?)
- (optional ,stipple?))
- "(fill-polygon x1 y1 ... xn yn [<color>] [<stipple>])"
- fill-polygon)