quilt.scm

;;; 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.

;;; 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-s16vector (* 2 (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)))
				  (s16vector-set! points ptx
				      (+ basex (* x xinc)))
				  (s16vector-set! points
				      (+ ptx 1)
				      (+ basey (* y yinc)))
				  (vector-set! cx color
				      (+ ptx 4))))))))
    
    (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-s16vector (* 4 (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)))
				  (s16vector-set! points ptx
				      (+ basex (* x xinc)))
				  (s16vector-set! points
				      (+ ptx 1)
				      (+ basey (* y yinc)))
				  (s16vector-set! points
				      (+ ptx 2)
				      square-width)
				  (s16vector-set! points
				      (+ ptx 3)
				      square-height)
				  (vector-set! cx color
				      (+ ptx 4))))))))
    
    (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)
				(make-locative
				    (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)
				(make-locative
				    (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 (fixnum? 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 (handle-exceptions exn #f (list (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 (current-error-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)