;;
;; Generic interface for 2D graphics output.
;;
;; Based on Ocaml code by Matías Giovannini.
;;
;; Copyright 2011-2013 Ivan Raikov and the Okinawa Institute of
;; Science and Technology.
;;
;; 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 3 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.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;


(module groc
	
	(
	 color? make-color color-r color-g color-b 

	 <Monad>    make-<Monad>
	 <MonadOps> make-<MonadOps>
	 <GROC>     make-<GROC>

	 state? St
	 state-Monad state-MonadOps state-get state-put state-run

	 output? Output
	 output-Monad output-MonadOps
	 output-objects

	 EPS-GROC output-EPS
	 output-points-EPS output-gray-points-EPS 
	 output-boxes-EPS output-boxes-and-points-EPS
	 )


(import scheme chicken)
(require-library posix)
(import (only posix seconds->utc-time time->string)
	(only extras fprintf sprintf pp)
	(only srfi-1 filter concatenate fold-right)
	(only data-structures ->string))
(require-extension srfi-4 datatype typeclass)


(define make-point vector)
(define (coord i p) (f64vector-ref p i))


(define-record-type color
  (make-color r g b)
  color?
  (r       color-r )
  (g       color-g )
  (b       color-b )
  )

(define-class <Monad> return bind)

(define-class <MonadOps> (<Monad> m)  seq mapm_  )

(define=> (seq <Monad>) (lambda (m f) (bind m (lambda x f))))


(define=> (mapm_ <Monad>)
  (lambda (seq)
    (lambda (f l)
	(fold-right (lambda (x ax) (seq (f x) ax)) 
		    (return '()) l)
	)))


(define (Monad->MonadOps m)
  (let* ((seq* (seq m))
	 (mapm_*   ((mapm_ m) seq*))
	 (this   (make-<MonadOps> m seq* mapm_* )))
    this))


(define-datatype state state? 
  (St (f procedure?)))


(define state-Monad 
  (let ((return (lambda (a) (St (lambda (s) (cons a s)))))
	(bind   (lambda (x f)
		    (cases state x
			   (St (m) 
			       (St (lambda (s)
				     (let* ((xs1 (m s)) (x (car xs1)) 
					    (s1 (cdr xs1)) (xm1 (f x)))
				       (cases state xm1
					      (St (m1) (m1 s1)))))))
			   ))))
	
    (make-<Monad> return bind)))


(define state-MonadOps (Monad->MonadOps state-Monad))

(define state-get (St (lambda (s) (cons s s))))
(define state-put (lambda (s) (St (lambda (_) (cons '() s)))))
(define (state-run x) (cases state x (St (m) (lambda (s) (cdr (m s))))))



(define-datatype output output? (Output (f procedure?)))


(define output-Monad
  (let ((return (lambda (x) (Output (lambda (_) x))))
	(bind  (lambda  (x f) 
		   (cases output x 
			  (Output (m) 
				  (Output
				   (lambda (out)
				     (let* ((x (m out)) (xm1 (f x)))
				       (cases output xm1
					      (Output (m1) (m1 out)))))
				   ))
			  ))))

    (make-<Monad> return bind)))


(define output-MonadOps  (Monad->MonadOps output-Monad))


(define (kprintf k format arguments)
  (let ((x (cons format arguments)))
    (k x)))


(define (output-fmt fmt . arguments)
  (let ((ship (lambda (s) (Output (lambda (out) (fprintf out "~?~%" (car s) (cdr s)))))))
    (kprintf ship fmt arguments)))


(define (output-write name x)
  (cases output x
	 (Output (m) (call-with-output-file name m))
	 ))
			      

(define-class <GROC> (<MonadOps> o) weight gray color save dot line rect poly translate)


(define EPS-GROC
  (with-instance  ((<MonadOps> output-MonadOps))
    (let* ((fmt    output-fmt)
	   (weight (lambda (w) (fmt "~A setlinewidth" w)))
	   (gray   (lambda (w) (fmt "~A setgray" w)))
	   (color  (lambda (c) (fmt "~A ~A ~A setrgbcolor" (color-r c) (color-g c) (color-b c))))
	   (save   (lambda (f) (seq (seq (fmt "gsave") f) (fmt "grestore"))))
	   (moveto (lambda (p) (fmt "~A ~A moveto" (coord 0  p) (coord 1  p))))
	   (lineto (lambda (p) (fmt "~A ~A lineto" (coord 0  p) (coord 1  p))))
	   (draw   (lambda ()  (fmt "stroke")))
	   (paint  (lambda ()  (fmt "fill")))
	   (path   (lambda (f) (seq (seq (fmt "newpath") f) (fmt "closepath"))))
	   (dot    (lambda (p)  
		     (seq (path (fmt "~A ~A currentlinewidth 1.5 mul 0 360 arc" (coord 0  p) (coord 1  p)))
			  (paint))))
	   (line   (lambda (p q)
		       (seq (fmt "newpath") (seq (moveto p) (seq (lineto q) draw)))))
	   (rect   (lambda (p1 p2 #!key (fill #f))
			 (let ((w (- (coord 0  p2) (coord 0  p1))) (h (- (coord 1  p2) (coord 1  p1))))
			   (fmt "~A ~A ~A ~A rect~A" (coord 0  p1) (coord 1  p1) w h 
				(if fill "fill" "stroke")))))
	   (polyline (lambda (closing l)
			 (if (null? l) (return '())
			     (let ((p (car l)) (ps (cdr l)))
			       (seq (path (seq (moveto p) (mapm_ lineto ps))) closing)))))
	   (poly   (lambda (l #!key (fill #f))
		     (polyline (if fill (paint) (draw)) l)))
	   (translate (lambda (x y) (fmt "~A ~A translate" x y)))
	   )
      
      (make-<GROC> output-MonadOps weight gray color save dot line rect poly translate)

      ))
  )

(define (isotime) (time->string (seconds->utc-time) "%Y%m%dT%H%M%S"))

	 
(define output-EPS
  (let ((format-EPS
	 ((lambda=> (<GROC>)
	  (let ((fmt output-fmt))
	    (lambda (margin width height drawing)
	      (let ((appname "http://www.call-cc.org/egg/groc"))
		(seq
		 (fmt "%%!PS-Adobe-3.0 EPSF-3.0")
		 (seq (fmt "%%%%BoundingBox: 0 0 ~A ~A"
			   (truncate (ceiling (+ width  (* 2 margin))))
			   (truncate (ceiling (+ height (* 2 margin)))))
		      (seq (fmt "%%%%Creator: ~A" appname)
			   (seq (fmt "%%%%CreationDate: ~A" (isotime))
				(seq (fmt "%%%%DocumentData: Clean7Bit")
				     (seq (fmt "%%%%EndComments")
					  (seq drawing
					       (seq (fmt "showpage")
						    (fmt "%%%%EOF"))
					       ))
				     ))
			   ))
		 ))))) EPS-GROC )))
    (lambda (name width height f #!key (margin 0.5))
      (output-write (sprintf "~A.eps" name) (format-EPS margin width height f)))))


(define=> (output-objects <GROC>)
  (lambda (output draw)
    (lambda (name width height objects #!key (bbox #f) (w 0.9) (translation #f))
      (let ((bbox-drawing
	     (or (and bbox (let ((x1 (list-ref bbox 0))  (y1 (list-ref bbox 1)) 
				 (x2 (list-ref bbox 2))  (y2 (list-ref bbox 3)) )
			     (seq (color (make-color 0.7 0.8 0.1 ))
				  (seq (weight 3.0)
				       (poly (list (make-point x1 y1) 
						   (make-point x1 y2) 
						   (make-point x2 y2) 
						   (make-point x2 y1)))
				       ))
			     ))
		 (return '()) ))

	    (translation (or (and translation (translate
					       (car translation) 
					       (cadr translation)))
			     (return '())))
	    )
      (output (->string (gensym (string->symbol (->string name))))
	      width height (seq translation
				(seq bbox-drawing
				     (seq (weight w) (seq (gray 0) (draw objects)))
				     ))
	      )
      ))
    ))


(define=> (draw-points <GROC>)
  (lambda (l) (mapm_ dot l)))

(define draw-points-EPS (draw-points EPS-GROC))

(define output-points-EPS ((output-objects EPS-GROC) output-EPS draw-points-EPS))


(define=> (draw-gray-points <GROC>)
  (lambda (l) (mapm_ (lambda (x) (seq (gray (- 1.0 (car x))) (dot (cadr x)))) l)))

(define draw-gray-points-EPS (draw-gray-points EPS-GROC))

(define output-gray-points-EPS ((output-objects EPS-GROC) output-EPS draw-gray-points-EPS))


(define=> (draw-boxes <GROC>)
  (lambda (bl) 
    (mapm_ 
     (lambda (b) 
       (let ((x1 (list-ref b 0))  (y1 (list-ref b 1)) 
	     (x2 (list-ref b 2))  (y2 (list-ref b 3)) )
	 (seq (gray 0)
	      (poly (list (make-point x1 y1) (make-point x1 y2) (make-point x2 y2) (make-point x2 y1))))
	 ))
     bl)))

(define draw-boxes-EPS (draw-boxes EPS-GROC))

(define output-boxes-EPS ((output-objects EPS-GROC) output-EPS draw-boxes-EPS))


(define=> (draw-boxes-and-points <GROC>)
  (lambda (bl) 
    (mapm_ 
     (lambda (bpts) 
       (let ((b (car bpts)) (pts (cadr bpts))
	     (c (and (pair? (cddr bpts)) (caddr bpts))))
	 (let ((x1 (list-ref b 0))  (y1 (list-ref b 1)) 
	       (x2 (list-ref b 2))  (y2 (list-ref b 3)) )
	   (seq 
	    (seq (or (and c (case (car c)
			      ((gray)  (gray (cdr c)))
			      ((color) (color (apply make-color (cdr c))))))
		     (gray 0))
			  
		 (poly (list (make-point x1 y1) 
			     (make-point x1 y2) 
			     (make-point x2 y2) 
			     (make-point x2 y1)))
		 )
	    (mapm_ (lambda (x) (seq (weight (* 0.5 (car x))) (dot (cadr x)))) pts))
	   ))
       )
     bl)))


(define draw-boxes-and-points-EPS (draw-boxes-and-points EPS-GROC))

(define output-boxes-and-points-EPS ((output-objects EPS-GROC) output-EPS draw-boxes-and-points-EPS))






)