/src/quilt.sc
Scala | 551 lines | 515 code | 36 blank | 0 comment | 3 complexity | 17fd8766f50e8895bc2e03ccd632fd6d MD5 | raw file
- ;;; ezd - easy drawing for X11 displays.
- ;;;
- ;;; The procedures in this module generate the GRAPHIC objects representing
- ;;; rectangles and polygons.
- ;* Copyright 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 quilt)
- (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 quilt is generated by the following procedure.
-
- (define (MAKE-QUILT x y width height columns rows color-names color-name-counts
- squares)
-
- (define NUMBER-OF-COLORS (vector-length color-names))
-
- (define NUMBER-OF-SQUARES (vector-length squares))
-
- (define CURRENT-TRANSFORM #f)
-
- (define SHAPES (make-vector (vector-length color-names) '()))
-
- (define DRAWING-RECTANGLES #f)
-
- (define (TRANSFORM-SQUARES)
- (let ((transform (list user->x user->y)))
- (if (not (equal? current-transform transform))
- (let* ((ux1 (user->x x))
- (ux2 (user->x (+ x width)))
- (uy1 (user->y y))
- (uy2 (user->y (+ y height)))
- (xinc (* (/ (user->width width) columns)
- (if (<= ux1 ux2) 1 -1)))
- (yinc (* (/ (user->height height) rows)
- (if (<= uy1 uy2) 1 -1)))
- (basex (if (>= xinc 0)
- ux1
- (+ ux1 xinc)))
- (basey (if (>= yinc 0)
- uy1
- (+ uy1 yinc)))
- (square-width (inexact->exact
- (ceiling (abs xinc))))
- (square-height (inexact->exact
- (ceiling (abs yinc)))))
- (set! current-transform transform)
- (set! drawing-rectangles
- (not (= square-width square-height 1)))
- (if drawing-rectangles
- (compute-rectangles basex basey xinc yinc
- square-width square-height)
- (compute-points basex basey xinc yinc))))))
-
- (define (COMPUTE-POINTS basex basey xinc yinc)
- (do ((i 0 (+ i 1)))
- ((= i number-of-colors))
- (vector-set! shapes i
- (make-string (* (* 2 c-sizeof-short)
- (vector-ref color-name-counts i)))))
- (do ((y 0 (+ y 1))
- (cx (make-vector number-of-colors 0)))
- ((= y rows))
- (do ((x 0 (+ x 1)))
- ((= x columns))
- (let ((color (vector-ref squares (+ (* y columns) x))))
- (if color
- (let ((points (vector-ref shapes color))
- (ptx (vector-ref cx color)))
- (c-shortint-set! points ptx
- (+ basex (* x xinc)))
- (c-shortint-set! points
- (+ ptx c-sizeof-short)
- (+ basey (* y yinc)))
- (vector-set! cx color
- (+ ptx (* 2 c-sizeof-short)))))))))
-
- (define (COMPUTE-RECTANGLES basex basey xinc yinc
- square-width square-height)
- (do ((i 0 (+ i 1)))
- ((= i number-of-colors))
- (vector-set! shapes i
- (make-string (* (* 4 c-sizeof-short)
- (vector-ref color-name-counts i)))))
- (do ((y 0 (+ y 1))
- (cx (make-vector number-of-colors 0)))
- ((= y rows))
- (do ((x 0 (+ x 1)))
- ((= x columns))
- (let ((color (vector-ref squares (+ (* y columns) x))))
- (if color
- (let ((points (vector-ref shapes color))
- (ptx (vector-ref cx color)))
- (c-shortint-set! points ptx
- (+ basex (* x xinc)))
- (c-shortint-set! points
- (+ ptx c-sizeof-short)
- (+ basey (* y yinc)))
- (c-shortint-set! points
- (+ ptx (* 2 c-sizeof-short))
- square-width)
- (c-shortint-set! points
- (+ ptx (* 3 c-sizeof-short))
- square-height)
- (vector-set! cx color
- (+ ptx (* 4 c-sizeof-short)))))))))
-
- (define (DRAW-COLOR color-x)
- (let ((basex x)
- (basey y)
- (xinc (/ width columns))
- (yinc (/ height rows)))
- (pscolor (vector-ref color-names color-x))
- (do ((y 0 (+ y 1)))
- ((= y rows))
- (do ((x 0 (+ x 1)))
- ((= x columns))
- (if (eq? color-x (vector-ref squares
- (+ (* y columns) x)))
- (pscommand (+ basex (* x xinc))
- (+ basey (* y yinc)) "Q"))))))
-
- (define (INSIDE? mouse-x mouse-y)
- (let ((col (inexact->exact (/ (- mouse-x x) (/ width columns))))
- (row (inexact->exact (/ (- mouse-y y) (/ height rows)))))
- (and (< -1 row rows) (< -1 col columns)
- (vector-ref squares (+ (* row columns) col)))))
-
- (do ((i 0 (+ i 1)))
- ((= i number-of-colors))
- (if (eq? (vector-ref color-names i) 'clear)
- (vector-set! color-name-counts i 0)))
- (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))))
- (lambda ()
- (transform-squares)
- (if drawing-rectangles
- (do ((i 0 (+ i 1)))
- ((= i number-of-colors))
- (if (not (zero? (vector-ref color-name-counts i)))
- (xfillrectangles *dpy* *xwindow*
- (cv-gc #f (vector-ref color-names i)
- #f #f #f #f)
- (type/value->pointer 'xrectangleap
- (vector-ref shapes i))
- (vector-ref color-name-counts i))))
- (do ((i 0 (+ i 1)))
- ((= i number-of-colors))
- (if (not (zero? (vector-ref color-name-counts i)))
- (xdrawpoints *dpy* *xwindow*
- (cv-gc #f (vector-ref color-names i)
- #f #f #f #f)
- (type/value->pointer 'xpointap
- (vector-ref shapes i))
- (vector-ref color-name-counts i)
- CoordModeOrigin)))))
- (lambda ()
- (transform-squares)
- (pscommand 1 "dict" "begin")
- (let ((xinc (/ width columns))
- (yinc (/ height rows)))
- (pscommand "/Q" "{newpath" "moveto" xinc 0 "rlineto"
- 0 yinc "rlineto" (- xinc) 0 "rlineto" "closepath"
- "fill}" "def"))
- (do ((i 0 (+ i 1)))
- ((= i number-of-colors))
- (if (not (zero? (vector-ref color-name-counts i)))
- (draw-color i)))
- (pscommand "end"))
- (lambda (minx miny maxx maxy)
- (or (inside? minx miny)
- (inside? minx maxy)
- (inside? maxx miny)
- (inside? maxx maxy)
- (inside? (+ minx (/ (- maxx minx) 2))
- (+ miny (/ (- maxy miny) 2)))))))
- ;;; The QUILT command is used to make a "quilt" from a list colors and
- ;;; squares.
-
- (define (QUILT x y width height columns rows color-name-list square-colors)
- (let* ((color-names (list->vector color-name-list))
- (number-of-colors (length color-name-list))
- (color-name-counts (make-vector number-of-colors 0))
- (upper-case-a (char->integer #\A))
- (lower-case-a (char->integer #\a))
- (squares (if (vector? square-colors)
- square-colors
- (make-vector (* columns rows) #f)))
- (number-of-squares (if (vector? square-colors)
- (vector-length square-colors)
- (string-length square-colors))))
-
- (if (not (equal? number-of-squares (* columns rows)))
- (ezd-error 'quilt "Columns*Rows (~s) != # of Square Colors (~s)"
- (* columns rows) number-of-squares))
- (if (vector? square-colors)
- (do ((i 0 (+ i 1)))
- ((= i number-of-squares))
- (let ((x (vector-ref square-colors i)))
- (unless (eq? x #f)
- (if (not (and (fixed? x)
- (< -1 x number-of-colors)))
- (ezd-error 'quilt
- "Illegal square-color index: ~a" x))
- (vector-set! color-name-counts x
- (+ (vector-ref color-name-counts x) 1)))))
- (do ((i 0 (+ i 1)))
- ((= i number-of-squares))
- (let* ((c (string-ref square-colors i))
- (x (if (char>=? c #\a)
- (- (char->integer c) lower-case-a)
- (- (char->integer c) upper-case-a))))
- (unless (char=? c #\space)
- (if (not (< -1 x number-of-colors))
- (ezd-error 'quilt
- "Illegal square-color character: ~a"
- c))
- (vector-set! squares i x)
- (vector-set! color-name-counts x
- (+ (vector-ref color-name-counts x) 1))))))
- (make-quilt x y width height columns rows color-names
- color-name-counts squares)))
- (define (POSITIVE-INTEGER? x) (and (integer? x) (positive? x)))
- (define (SQUARE-COLORS? x) (or (vector? x) (string? x)))
- (define-ezd-command
- `(quilt ,number? ,number? ,non-negative? ,non-negative?
- ,positive-integer? ,positive-integer? (repeat ,color?)
- ,square-colors?)
- "(quilt x y width height columns rows color... \"square-colors\")"
- quilt)
- ;;; The BITMAP command is used to make a "quilt" from an X11 bitmap, a PBM
- ;;; bitmap (monochrome), a PGM bitmap (grayscale), or a PPM bit map.
- (define (BITMAP x y width-height file colors)
- (let* ((port (let ((x (catch-error (lambda () (open-input-file file)))))
- (if (not (pair? x))
- (ezd-error 'x11bitmap
- "Unable to open bit map file: ~s" file))
- (car x)))
- (pbitmap (char=? (peek-char port) #\P))
- (pbitmaptype (and pbitmap (read-char port) (read-char port))))
-
- (define (READ-NEXT-CHAR)
- (let ((c (read-char port)))
- (if (and pbitmap (char=? c #\#))
- (let loop ((c (read-char port)))
- (unless (or (eof-object? c)
- (char=? c #\newline))
- (loop (read-char port)))))
- (if (eof-object? port)
- (ezd-error 'x11bitmap "Unexpected end-of-file!")
- c)))
-
- (define (GET-NUMBER)
- (if (char-numeric? (peek-char port))
- (let ((base (if (and (eq? (peek-char port) #\0)
- (read-next-char)
- (memq (peek-char port) '(#\x #\X)))
- (begin (read-next-char)
- 16)
- 10)))
- (let loop ((c (peek-char port)) (value 0))
- (let ((c (assq c '((#\0 0) (#\1 1) (#\2 2)
- (#\3 3) (#\4 4) (#\5 5)
- (#\6 6) (#\7 7) (#\8 8)
- (#\9 9) (#\a 10) (#\b 11)
- (#\c 12) (#\d 13) (#\e 14)
- (#\f 15) (#\A 10) (#\B 11)
- (#\C 12) (#\D 13) (#\E 14)
- (#\F 15)))))
- (if c
- (loop (begin (read-next-char)
- (peek-char port))
- (+ (* base value) (cadr c)))
- value))))
- (begin (read-next-char)
- (get-number))))
-
- (define (PICK-CHAR char)
- (if (char=? (read-next-char) char)
- #t
- (pick-char char)))
-
- (define (PBM)
- (if (and (pair? colors) (> (length colors) 2))
- (ezd-error 'bitmap
- "Only two colors allowed for PBM bitmaps"))
- (let* ((bitmap-width (get-number))
- (bitmap-height (get-number))
- (count 0)
- (foreground-color (if (pair? colors)
- (car colors)
- 'black))
- (background-color (if (> (length colors) 1)
- (cadr colors)
- #f))
- (squares (make-vector (* bitmap-width bitmap-height)
- (if background-color 1 #f))))
- (do ((i 0 (+ i 1))
- (end (* bitmap-width bitmap-height)))
- ((= i end))
- (let ((bit (get-number)))
- (when (= bit 1)
- (vector-set! squares i 0)
- (set! count (+ count 1)))))
- (make-quilt x y
- (if (pair? width-height)
- (car width-height)
- bitmap-width)
- (if (pair? width-height)
- (cadr width-height)
- bitmap-height)
- bitmap-width bitmap-height
- (if (and foreground-color background-color)
- (vector foreground-color background-color)
- (vector foreground-color))
- (if background-color
- (vector count
- (- (vector-length squares) count))
- (vector count))
- squares)))
-
- (define (PGM)
- (let* ((bitmap-width (get-number))
- (bitmap-height (get-number))
- (grays (+ 1 (get-number)))
- (counts (make-vector grays 0))
- (squares (make-vector (* bitmap-width bitmap-height)
- #f))
- (color-map (if colors colors (gray-color-map grays)))
- (scale (/ (length color-map) grays)))
- (do ((i 0 (+ i 1))
- (end (* bitmap-width bitmap-height)))
- ((= i end))
- (let ((pixel (inexact->exact
- (* scale (get-number)))))
- (vector-set! squares i pixel)
- (vector-set! counts pixel
- (+ 1 (vector-ref counts pixel)))))
- (make-quilt x y
- (if (pair? width-height)
- (car width-height)
- bitmap-width)
- (if (pair? width-height)
- (cadr width-height)
- bitmap-height)
- bitmap-width bitmap-height
- (list->vector color-map)
- counts
- squares)))
-
- (define (GRAY-COLOR-MAP grays)
- (let ((inc (/ 100 (- (min grays 101) 1))))
- (let loop ((count (- (min grays 101) 1))
- (color 100) (cl '()))
- (if (zero? count)
- (let ((cl (cons 'black cl)))
- (for-each color? cl)
- cl)
- (loop (- count 1) (- color inc)
- (cons (string->symbol
- (format "GRAY~S"
- (inexact->exact
- color)))
- cl))))))
-
- (define (PPM)
- (if colors
- (format stderr-port
- "BITMAP - PPM bitmaps ignore command colors~%"))
- (let* ((bitmap-width (get-number))
- (bitmap-height (get-number))
- (colorvalues (+ 1 (get-number)))
- (scale (/ 256 colorvalues))
- (counts (make-vector colorvalues 0))
- (color-names '())
- (cvalue-color-x '())
- (color-x 0)
- (squares (make-vector (* bitmap-width bitmap-height)
- #f)))
-
- (define (ALLOCATE-COLOR cvalue)
- (let ((cname (string->symbol
- (format "PPM-COLOR-~s"
- cvalue))))
- (display-define-color *display* cname
- cvalue)
- (set! color-names
- (cons cname color-names))
- (set! cvalue-color-x
- (cons (cons cvalue color-x)
- cvalue-color-x))
- (set! color-x (+ color-x 1))
- (- color-x 1)))
-
- (do ((i 0 (+ i 1))
- (end (* bitmap-width bitmap-height)))
- ((= i end))
- (let* ((r (inexact->exact (* scale (get-number))))
- (g (inexact->exact (* scale (get-number))))
- (b (inexact->exact (* scale (get-number))))
- (cvalue (+ (* (+ (* r 256) g) 256) b))
- (ca (assq cvalue cvalue-color-x))
- (pixel (or (and ca (cdr ca))
- (allocate-color cvalue))))
- (vector-set! squares i pixel)
- (vector-set! counts pixel
- (+ 1 (vector-ref counts pixel)))))
- (make-quilt x y
- (if (pair? width-height)
- (car width-height)
- bitmap-width)
- (if (pair? width-height)
- (cadr width-height)
- bitmap-height)
- bitmap-width bitmap-height
- (list->vector (reverse color-names))
- counts
- squares)))
-
- (define (X11BITMAP)
- (if (and (pair? colors) (> (length colors) 2))
- (ezd-error 'bitmap
- "Only two colors allowed for X11 bitmaps"))
- (let* ((bitmap-width (begin (pick-char #\space)
- (pick-char #\_)
- (pick-char #\space)
- (get-number)))
- (bitmap-height (begin (pick-char #\space)
- (pick-char #\_)
- (pick-char #\space)
- (get-number)))
- (count 0)
- (foreground-color (if (pair? colors)
- (car colors)
- 'black))
- (background-color (if (> (length colors) 1)
- (cadr colors)
- #f))
- (squares (make-vector (* bitmap-width bitmap-height)
- (if background-color 1 #f))))
- (pick-char #\{)
- (let loop ((bits (get-number))
- (bits-left 8)
- (rows-left bitmap-height)
- (columns-left bitmap-width)
- (x 0))
- (cond ((zero? columns-left)
- (unless (= rows-left 1)
- (loop (get-number) 8
- (- rows-left 1)
- bitmap-width x)))
- ((zero? bits-left)
- (loop (get-number) 8 rows-left
- columns-left x))
- (else (when (odd? bits)
- (set! count (+ count 1))
- (vector-set! squares x 0))
- (loop (quotient bits 2)
- (- bits-left 1)
- rows-left (- columns-left 1)
- (+ x 1)))))
- (make-quilt x y
- (if (pair? width-height)
- (car width-height)
- bitmap-width)
- (if (pair? width-height)
- (cadr width-height)
- bitmap-height)
- bitmap-width bitmap-height
- (if (and foreground-color background-color)
- (vector foreground-color background-color)
- (vector foreground-color))
- (if background-color
- (vector count
- (- (vector-length squares) count))
- (vector count))
- squares)))
-
- (let ((result (case (and pbitmap pbitmaptype)
- ((#\1) (pbm))
- ((#\2) (pgm))
- ((#\3) (ppm))
- (else (x11bitmap)))))
- (close-input-port port)
- result)))
- (define-ezd-command
- `(bitmap ,number? ,number? (optional ,non-negative? ,non-negative?)
- ,string? (repeat ,color?))
- "(bitmap x y [width height] \"file name\" [<color>...])"
- bitmap)