;;; PLUMBING GRAPHICS version 3.6
;;; Side effect free turtle-ish graphics for MzScheme with rendering to postscript.

;;; Copyright (c) 1998,1999,2000,2006 Luis Marcial Hernandez
;;; <luismh@cs.unm.edu>, Barak Pearlmutter <bap@cs.unm.edu>, Lance
;;; Williams <williams@cs.unm.edu> and David Ellis
;;; <dellis@cs.unm.edu>.

;;;     This program is free software; you can redistribute it and/or
;;;     modify it under the terms of the GNU General Public License
;;;     as published by the Free Software Foundation; either version 2
;;;     of the License, or (at your option) any later version.
     
;;;     This program is distributed in the hope that it will be useful,
;;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;     GNU General Public License for more details.

;;;     You should have received a copy of the GNU General Public
;;;     License along with this program; if not, write to the Free
;;;     Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
;;;     USA, or fetch http://www.fsf.org/copyleft/gpl.html.

(require (lib "process.ss"))
(require (lib "defmacro.ss"))

(define-macro name-parts-of
  (lambda (ls names . body)
    `(apply (lambda ,names ,@body) ,ls)))

;;; ghostscript-path give the path to the executable that the rendered
;;; output file is passed to.  If it is wrong, you may or may not see
;;; an error, but you'll certainly see no output.

;; for *nix with ghostview
(define ghostscript-path "/usr/bin/gv")
;; for *nix with ghostscript
;(define ghostscript-path "/usr/bin/gs")
;; for Windoze with gsview
;(define ghostscript-path "C:/Progra~1/Ghostgum/gsview/gsview32.exe")
;; for Windoze with ghostscript
;(define ghostscript-path "C:/gs/gs8.50/bin/gswin32.exe")
;; for Macintosh
;(define ghostscript-path "/usr/local/bin/gv")

;;; postscript-temp-file is the file name in the current directory that 
;;; the rendered output will be written to.  It will hang around until
;;; it is manually deleted
(define postscript-temp-file "__plumber.ps")

;;; This defines MAKE-GRAPHIC, GRAPHIC-TYPE, and GRAPHIC? automatically

(define-struct graphic (type args))

(define graphic-nil (make-graphic 'nil '()))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (straight len . args)
  (cond ((not (number? len))
	 (error "STRAIGHT: argument not a number" len))
	((null? args)
	 (make-graphic 'st (list len '(255 255 255) 1)))
	((null? (cdr args))
	 (name-parts-of args (color)
	   (if (not (list? color))
	       (error "STRAIGHT: argument not a color" color)
	       (make-graphic 'st (list len color 1)))))
        (else
	 (name-parts-of args (color width)
	   (cond ((not (list? color))
		  (error "STRAIGHT: argument not a color" color))
		 ((not (number? width))
		  (error "STRAIGHT: argument not a number" width))
		 (else
		  (make-graphic 'st (list len color width))))))))

;;; A transparent piece of pipe x pixels long
(define (transparent x)
  (cond ((not (number? x))
	 (error "TRANSPARENT: argument not a number " x))
	((zero? x) graphic-nil)
	(else
	 (make-graphic 'tr (list x)))))

;;; a pipe with zero length and a bend of x degrees
(define (bend x)
  (cond ((not (number? x))
	 (error "BEND: argument not a number " x))
	((zero? x) graphic-nil)
	(else
	 (make-graphic 'be (list x)))))

;;; Draw some horizontal text at the position of the plumber
(define (text str . args)
  (cond ((not (string? str))
	 (error "TEXT: argument not a string" str))
	((null? args)
	 (make-graphic 'txt (list str '(255 255 255) 1)))
	((null? (cdr args))
	 (name-parts-of args (color)
	   (if (not (list? color))
	       (error "TEXT: argument not a color" color)
	       (make-graphic 'txt (list str color 1)))))
        (else
	 (name-parts-of args (color size)
	   (cond ((not (list? color))
		  (error "TEXT: argument not a color" color))
		 ((not (number? size))
		  (error "TEXT: argument not a number" size))
		 (else
		  (make-graphic 'txt (list str color size))))))))

;;; Draw a spot at the position of the plumber.
(define (spot diameter . args)
  (cond ((not (number? diameter))
	 (error "SPOT: argument not a number" diameter))
	((null? args)
	 (make-graphic 'sp (list diameter '(255 255 255))))
	(else
	 (name-parts-of args (color)
	   (if (not (list? color))
	       (error "SPOT: argument not a color" color)
	       (make-graphic 'sp (list diameter color)))))))

;;; Returns the first graphic object of an adorn or adjoin structure.
(define (graphic-car g)
  (case (graphic-type g)
    ((adj ado)
     (car (graphic-args g)))
    (else
     (error "GRAPHIC-CAR: not a graphic object of type 'adorn' or 'adjoin' " g))))

;;; Returns the adjoin or adorn structure less the first object.
(define (graphic-cdr g)
  (let ((ty (graphic-type g))
	(ar (graphic-args g)))
    (case ty
      ((adj)
       (apply adjoin (cdr ar)))
      ((ado)
       (apply adorn (cdr ar)))
      (else
       (error "GRAPHIC-CDR: not a graphic object of type 'adorn' or 'adjoin' " g)))))

(define (adjoin . args)
  (for-each
   (lambda (g)
     (if (not (graphic? g))
	 (error "ADJOIN: not a graphic object" g))) args)
  (cond ((null? args) graphic-nil)
	((null? (cdr args)) (car args))
	(else
	 (make-graphic 'adj args))))

(define (adorn . args)
  (let aux ((lis args) (ok '()))
    (if (null? lis)
	(if (null? ok)
	    graphic-nil
	    (make-graphic 'ado ok))
	(let ((g (car lis)))
	  (cond ((not (graphic? g))
		 (error "ADORN: not a graphic object" g))
		((eq? g graphic-nil) (aux (cdr lis) ok))
		(else
		 (aux (cdr lis) (cons g ok))))))))

(define (old-adorn g . args)
  (adjoin g (apply adorn args)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define red '(255 0 0))
(define green '(0 255 0))
(define blue '(0 0 255))
(define black '(0 0 0))

(define (graphic-straight? g)
  (case (graphic-type g)
    ((st tr fst) #t)
    (else #f)))

(define (graphic-bend? g) (eq? (graphic-type g) 'be))
(define (graphic-spot? g) (eq? (graphic-type g) 'sp))
(define (graphic-text? g) (eq? (graphic-type g) 'txt))
(define (graphic-adjoin? g) (eq? (graphic-type g) 'adj))
(define (graphic-adorn? g) (eq? (graphic-type g) 'ado))
(define (graphic-null? g) (eq? g graphic-nil))

(define graphic-color
  (lambda (g color)
    (cond ((graphic-null? g) g)
	  ((graphic-adjoin? g)
	   (adjoin (graphic-color (gcar g) color)
		   (graphic-color (gcdr g) color)))
	  ((graphic-adorn? g)
	   (adorn (graphic-color (gcar g) color)
		  (graphic-color (gcdr g) color)))
	  ((graphic-straight? g)
	   (name-parts-of (graphic-args g) (len ignore width)
             (straight len color width)))
	  (else g))))

(define graphic-scale
  (lambda (g scale)
    (cond ((graphic-null? g) g)
	  ((graphic-adjoin? g)
	   (adjoin (graphic-scale (gcar g) scale)
		   (graphic-scale (gcdr g) scale)))
	  ((graphic-adorn? g)
	   (adorn (graphic-scale (gcar g) scale)
		  (graphic-scale (gcdr g) scale)))
	  ((graphic-straight? g)
	   (name-parts-of (graphic-args g) (len color width)
             (straight (* len scale) color width)))
	  (else g))))

(define graphic-mirror
  (lambda (g)
    (cond ((graphic-null? g) g)
	  ((graphic-adjoin? g)
	   (adjoin (graphic-mirror (gcar g)) 
		   (graphic-mirror (gcdr g))))
	  ((graphic-adorn? g)
	   (adorn (graphic-mirror (gcar g)) 
		  (graphic-mirror (gcdr g))))
	  ((graphic-bend? g)
	   (name-parts-of (graphic-args g) (angle)
	     (bend (- angle))))
	  (else g))))

(define graphic-reverse
  (lambda (g)
    (cond ((graphic-null? g) g)
	  ((graphic-adjoin? g)
	   (adjoin (graphic-reverse (gcdr g)) 
		   (graphic-reverse (gcar g))))
	  ((graphic-adorn? g)
	   (adorn (graphic-reverse (gcar g))
		  (graphic-reverse (gcdr g))))
	  (else g))))

(define draw-graphic 
  (lambda (g) (draw-graphic-ps g)))

(define (graphic-print g)
  (display "#<graphic ")
  (display (graphic-type g))
  (display " ")
  (display (graphic-args g))
  (display ">")
  (newline))

(define (modulo-f a b)
  (if (and (exact? a) (integer? a))
      (modulo a b)
      (- a (* b (floor (/ a b))))))

(define (->string x)
  (if (string? x)
      x
      (let ((o (open-output-string)))
	(write x o)
	(get-output-string o))))

;;;======================================================================;;;
;;;postscript rendering code                                             ;;;
;;;======================================================================;;;

(define draw-graphic-ps
  (let ((gs-last-env #f))
    (lambda (g)
      (when gs-last-env
        (name-parts-of gs-last-env (gs-stdin gs-stdout gs-pid gs-stderr gs-ctl)
	    (close-input-port gs-stdin)
	    (close-output-port gs-stdout)
	    (close-input-port gs-stderr)
	    (gs-ctl 'kill)
	    (set! gs-last-env #f)))
      (when (file-exists? postscript-temp-file)
        (delete-file postscript-temp-file))
      (graphic->postscript g postscript-temp-file)
      (set! gs-last-env (process* ghostscript-path postscript-temp-file))
      (name-parts-of gs-last-env (gs-stdin gs-stdout gs-pid gs-stderr gs-ctl)
        (case (gs-ctl 'status)
          ((done-error) 
           (error "draw-graphic: Ghostscript process failed to start: exit code" (gs-ctl 'exit-code)))
          (else (void)))))))

(define pi (acos -1))
(define twopi (* 2 pi))
(define halfpi (asin 1))
(define s30 0.5)
(define c30 0.86602540378)
(define C45 0.70710678118)

(define (deg->rad deg)
  (* deg (/ twopi 360)))

(define (angle-difference x y)
  (modulo-f (- x y) twopi))

(define (writeln port)
  (lambda args
    (for-each (lambda (x) (display (if (number? x) (exact->inexact x) x) port)) args)
    (newline port)))

(define (generate-postscript-header port ratio title)
  (let ((writeln (writeln port)))
    (writeln "%!PS-Adobe-2.0 EPSF-1.2")
    (writeln "%%%%Title: " title)
    (writeln "%%%%Creator: University of New Mexico Plumbing Graphics 2.0")
    (if (< ratio 1.0)
	(writeln "%%%%BoundingBox: 0 " (* 432 (- 1 ratio)) " " 432 " " 432)
	(writeln "%%%%BoundingBox: 0 0 " (/ 432 ratio) " " 432))
    (writeln "%%%%Pages: 1")
    (writeln "%%%%EndComments")
    (writeln "save")
    (writeln "/inch {72 mul} def")
    (writeln "/displine { /y2 exch def /x2 exch def /y1 exch def /x1 exch def")
    (writeln "x1 y1 moveto x2 y2 lineto stroke } def")
    (writeln "%%%%EndProlog")
    (writeln "%%%%%%Page: 1 1")
    (writeln "72 180 translate")
    (writeln "432 432 scale")
    (writeln "0.00115741 setlinewidth")
    (writeln "0.5 dup translate -90 rotate -0.5 dup translate");
    (if (< ratio 1)
	(writeln "0 0 moveto 0 1 lineto " ratio " 1 lineto " ratio " 0 lineto closepath")
	(writeln "0 0 moveto 0 1 lineto " (/ ratio) " 1 lineto " (/ ratio) " 0 lineto closepath"))
    (writeln "stroke")))

(define (graphic->postscript g fname)
  (let ((port (open-output-file fname)))
    (generate-postscript-header port 1.0 "Plumbing Graphics Object")
    (let ((p (make-plumber 1 -0.66667 halfpi)))
      (draw-plumber-postscript p '(255 0 0) port)
      (draw-graphic-postscript! p g port)
      (draw-plumber-postscript p '(0 0 255) port)
      ((writeln port) "showpage")
      (close-output-port port))))

(define (make-plumber x0 y0 heading0)
  (let ((x x0) (y y0) (heading heading0))
    (lambda (msg . args)
      (case msg
	((type) 'plumber)
	((x) x)
	((y) y)
	((heading) heading)
	((state) (list x y heading))
	((update!)
	 (name-parts-of args (x1 y1 heading1)
	   (set! x x1)
	   (set! y y1)
	   (set! heading heading1)))))))

(define (draw-graphic-postscript! p g port)
  (if (graphic-null? g)
      p
      (case (graphic-type g)
	((straight st) (draw-straight-postscript! p g port))
	((transparent tr) (draw-transparent-postscript! p g))
	((spot sp) (draw-spot-postscript p g port))
	((adjoin adj) (draw-adjoin-postscript! p g port))
	((adorn ado) (draw-adorn-postscript! p g port) p)
	((bend be) (draw-bend-postscript! p g))
	((text txt) (draw-text-postscript p g port))
	(else
	 (error 'draw-graphic-postscript! "Unrecognized graphic type: " (graphic-type g))))))

(define (draw-plumber-postscript p color port)
  (let ((heading (p 'heading))
	(writeln (writeln port)))
    (let ((c (/ (cos (- heading halfpi)) 60))
	  (s (/ (sin (- heading halfpi)) 60))
	  (x (p 'x))
	  (y (p 'y)))
      (let ((x0 (+ x (- (* c c30)) (* s30 s)))
	    (y0 (+ (- 1 y) (* c30 s) (* s30 c)))
	    (x1 (- x s))
	    (y1 (- 1 y c))
	    (x2 (+ x (* c30 c) (* s30 s)))
	    (y2 (- 1 y (* c30 s) (- (* c s30)))))
	(writeln (/ 864) " setlinewidth")
	(name-parts-of color (r g b)
	  (if (> (+ r g b) 764)
	      (writeln "0 0 0 setrgbcolor")
	      (writeln (/ r 128) " " (/ g 128) " " (/ b 128) " setrgbcolor")))
	(writeln (/ y0 2) " " (/ x0 2) " moveto")
	(writeln (/ y1 2) " " (/ x1 2) " lineto")
	(writeln (/ y2 2) " " (/ x2 2) " lineto")
	(writeln (/ y0 2) " " (/ x0 2) " lineto")
	(writeln "stroke")))))

(define (draw-straight-postscript! p g port)
  (let ((x (p 'x))
	(y (p 'y))
	(heading (p 'heading))
	(writeln (writeln port)))
    (name-parts-of (graphic-args g) (len color width)
	(writeln (/ width 864) " setlinewidth")
	(name-parts-of color (r g b)
	  (if (> (+ r g b) 764)
	      (writeln "0 0 0 setrgbcolor")
	      (writeln (/ r 128) " " (/ g 128) " " (/ b 128) " setrgbcolor")))
	(let ((u (+ x (* (/ len 300) (cos heading))))
	      (v (+ y (* (/ len 300) (sin heading)))))
	  (writeln (/ (- 1 y) 2) " " (/ x 2) " " (/ (- 1 v) 2) " " (/ u 2) " displine")
	  (p 'update! u v heading))))
  p)

(define (draw-transparent-postscript! p g)
  (let ((x (p 'x))
	(y (p 'y))
	(heading (p 'heading)))
    (name-parts-of (graphic-args g) (len)
      (let ((u (+ x (* (/ len 300) (cos heading))))
	    (v (+ y (* (/ len 300) (sin heading)))))
	(p 'update! u v heading))))
  p)

(define (draw-adjoin-postscript! p g port)
  (if (graphic-null? g)
      p
      (draw-graphic-postscript!
       (draw-graphic-postscript! p (gcar g) port)
       (gcdr g)
       port))
  p)

(define (draw-adorn-postscript! p g port)
  (if (null? g)
      p
      (let ((state (p 'state)))
	(draw-graphic-postscript! p (gcar g) port)
	(apply p 'update! state)
	(draw-graphic-postscript! p (gcdr g) port)
	(apply p 'update! state)))
  p)

(define (draw-bend-postscript! p g)  
  (name-parts-of (graphic-args g) (angle)
    (p 'update! (p 'x) (p 'y) (angle-difference (p 'heading) (deg->rad angle))))
  p)

(define (draw-text-postscript p g port)
  (let ((writeln (writeln port)))
    (name-parts-of (graphic-args g) (text color size)
      (writeln (/ (- 1 (p 'y)) 2) " " (/ (p 'x) 2) " moveto")
      (writeln "90 rotate")
      (writeln "/Helvetica findfont")
      (writeln (* size 0.02) " scalefont")
      (writeln "setfont")
      (name-parts-of color (r g b)
        (if (> (+ r g b) 764)
	    (writeln "0 0 0 setrgbcolor")
	    (writeln (/ r 128) " " (/ g 128) " " (/ b 128) " setrgbcolor")))
      (writeln "(" text ") show")
      (writeln "-90 rotate")))
  p)

(define (draw-spot-postscript p g port)
  (let ((writeln (writeln port)))
    (name-parts-of (graphic-args g) (width color)
      (writeln "newpath")
      (name-parts-of color (r g b)
        (if (> (+ r g b) 764)
	    (writeln "0 0 0 setrgbcolor")
	    (writeln (/ r 128) " " (/ g 128) " " (/ b 128) " setrgbcolor")))
      (writeln (/ (- 1 (p 'y)) 2) " " (/ (p 'x) 2) " " (/ width 432) " 0 360 arc")
      (writeln "fill")))
  p)

(define plumber-top-level
  (lambda ()
    (let ((orig-print (current-print)))
      (parameterize
       ((current-print
	 (lambda (obj)
	   (orig-print obj)
	   (if (graphic? obj) (draw-graphic obj))))
	(read-case-sensitive #f))
       (read-eval-print-loop)))
    (newline)))

;;; Abbreviations
(define st straight)
(define be bend)
(define adj adjoin)
(define ado adorn)
(define tr transparent)
(define sp spot)
(define txt text)
(define gcar graphic-car)
(define gcdr graphic-cdr)
(define gscale graphic-scale)
(define gcolor graphic-color)
(define greverse graphic-reverse)
(define gmirror graphic-mirror)
(define gargs graphic-args)
(define gnull? graphic-null?)

(display "PLUMBING GRAPHICS version 3.6 (postscript) loaded")
(newline)
(plumber-top-level)

;;; TO DO:
;;;
;;; - make text rotate properly, at least a little
;;; - something to compute bounding boxes
;;; - center object before displaying it
;;; - documentation, improve web tutorial, examples file
;;; - animated graphic objects

;;; - special unique empty graphic object
;;; - optimizations to simplify returned object
;;; - Galois representation (overcomplete) to eliminate rounding
;;;   errors in common cases.
;;; - switch to turn on/off arrows
;;; - break top-level code into separate file
;;; - refresh on re-exposure
;;; - proper fancy .ss files with import/export