source: project/release/4/groc/tags/1.3/groc.scm @ 28138

Last change on this file since 28138 was 28138, checked in by Ivan Raikov, 8 years ago

groc release 1.3

File size: 8.6 KB
Line 
1;;
2;; Generic interface for 2D graphics output.
3;;
4;; Based on Ocaml code by Matías Giovannini.
5;;
6;; Copyright 2011-2013 Ivan Raikov and the Okinawa Institute of
7;; Science and Technology.
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22
23
24(module groc
25       
26        (
27         color? make-color color-r color-g color-b 
28
29         <Monad>    make-<Monad>
30         <MonadOps> make-<MonadOps>
31         <GROC>     make-<GROC>
32
33         state? St
34         state-Monad state-MonadOps state-get state-put state-run
35
36         output? Output
37         output-Monad output-MonadOps
38         output-objects
39
40         EPS-GROC output-EPS
41         output-points-EPS output-gray-points-EPS 
42         output-boxes-EPS output-boxes-and-points-EPS
43         )
44
45
46(import scheme chicken)
47(require-library posix)
48(import (only posix seconds->utc-time time->string)
49        (only extras fprintf sprintf pp)
50        (only srfi-1 filter concatenate fold-right)
51        (only data-structures ->string))
52(require-extension srfi-4 datatype typeclass)
53
54
55(define make-point f64vector)
56(define (coord i p) (f64vector-ref p i))
57
58
59(define-record-type color
60  (make-color r g b)
61  color?
62  (r       color-r )
63  (g       color-g )
64  (b       color-b )
65  )
66
67(define-class <Monad> return bind)
68
69(define-class <MonadOps> (<Monad> m)  seq mapm_  )
70
71(define=> (seq <Monad>) (lambda (m f) (bind m (lambda x f))))
72
73
74(define=> (mapm_ <Monad>)
75  (lambda (seq)
76    (lambda (f l)
77        (fold-right (lambda (x ax) (seq (f x) ax)) 
78                    (return '()) l)
79        )))
80
81
82(define (Monad->MonadOps m)
83  (let* ((seq* (seq m))
84         (mapm_*   ((mapm_ m) seq*))
85         (this   (make-<MonadOps> m seq* mapm_* )))
86    this))
87
88
89(define-datatype state state? 
90  (St (f procedure?)))
91
92
93(define state-Monad 
94  (let ((return (lambda (a) (St (lambda (s) (cons a s)))))
95        (bind   (lambda (x f)
96                    (cases state x
97                           (St (m) 
98                               (St (lambda (s)
99                                     (let* ((xs1 (m s)) (x (car xs1)) 
100                                            (s1 (cdr xs1)) (xm1 (f x)))
101                                       (cases state xm1
102                                              (St (m1) (m1 s1)))))))
103                           ))))
104       
105    (make-<Monad> return bind)))
106
107
108(define state-MonadOps (Monad->MonadOps state-Monad))
109
110(define state-get (St (lambda (s) (cons s s))))
111(define state-put (lambda (s) (St (lambda (_) (cons '() s)))))
112(define (state-run x) (cases state x (St (m) (lambda (s) (cdr (m s))))))
113
114
115
116(define-datatype output output? (Output (f procedure?)))
117
118
119(define output-Monad
120  (let ((return (lambda (x) (Output (lambda (_) x))))
121        (bind  (lambda  (x f) 
122                   (cases output x 
123                          (Output (m) 
124                                  (Output
125                                   (lambda (out)
126                                     (let* ((x (m out)) (xm1 (f x)))
127                                       (cases output xm1
128                                              (Output (m1) (m1 out)))))
129                                   ))
130                          ))))
131
132    (make-<Monad> return bind)))
133
134
135(define output-MonadOps  (Monad->MonadOps output-Monad))
136
137
138(define (kprintf k format arguments)
139  (let ((x (cons format arguments)))
140    (k x)))
141
142
143(define (output-fmt fmt . arguments)
144  (let ((ship (lambda (s) (Output (lambda (out) (fprintf out "~?~%" (car s) (cdr s)))))))
145    (kprintf ship fmt arguments)))
146
147
148(define (output-write name x)
149  (cases output x
150         (Output (m) (call-with-output-file name m))
151         ))
152                             
153
154(define-class <GROC> (<MonadOps> o) weight gray color save dot line rect poly translate)
155
156
157(define EPS-GROC
158  (with-instance  ((<MonadOps> output-MonadOps))
159    (let* ((fmt    output-fmt)
160           (weight (lambda (w) (fmt "~A setlinewidth" w)))
161           (gray   (lambda (w) (fmt "~A setgray" w)))
162           (color  (lambda (c) (fmt "~A ~A ~A setrgbcolor" (color-r c) (color-g c) (color-b c))))
163           (save   (lambda (f) (seq (seq (fmt "gsave") f) (fmt "grestore"))))
164           (moveto (lambda (p) (fmt "~A ~A moveto" (coord 0  p) (coord 1  p))))
165           (lineto (lambda (p) (fmt "~A ~A lineto" (coord 0  p) (coord 1  p))))
166           (draw   (lambda ()  (fmt "stroke")))
167           (paint  (lambda ()  (fmt "fill")))
168           (path   (lambda (f) (seq (seq (fmt "newpath") f) (fmt "closepath"))))
169           (dot    (lambda (p) 
170                     (seq (path (fmt "~A ~A currentlinewidth 1.5 mul 0 360 arc" (coord 0  p) (coord 1  p)))
171                          (paint))))
172           (line   (lambda (p q)
173                       (seq (fmt "newpath") (seq (moveto p) (seq (lineto q) draw)))))
174           (rect   (lambda (p1 p2 #!key (fill #f))
175                         (let ((w (- (coord 0  p2) (coord 0  p1))) (h (- (coord 1  p2) (coord 1  p1))))
176                           (fmt "~A ~A ~A ~A rect~A" (coord 0  p1) (coord 1  p1) w h 
177                                (if fill "fill" "stroke")))))
178           (polyline (lambda (closing l)
179                         (if (null? l) (return '())
180                             (let ((p (car l)) (ps (cdr l)))
181                               (seq (path (seq (moveto p) (mapm_ lineto ps))) closing)))))
182           (poly   (lambda (l #!key (fill #f))
183                     (polyline (if fill (paint) (draw)) l)))
184           (translate (lambda (x y) (fmt "~A ~A translate" x y)))
185           )
186     
187      (make-<GROC> output-MonadOps weight gray color save dot line rect poly translate)
188
189      ))
190  )
191
192(define (isotime) (time->string (seconds->utc-time) "%Y%m%dT%H%M%S"))
193
194         
195(define output-EPS
196  (let ((format-EPS
197         ((lambda=> (<GROC>)
198          (let ((fmt output-fmt))
199            (lambda (margin width height drawing)
200              (let ((appname "http://www.call-cc.org/egg/groc"))
201                (seq
202                 (fmt "%%!PS-Adobe-3.0 EPSF-3.0")
203                 (seq (fmt "%%%%BoundingBox: 0 0 ~A ~A"
204                           (truncate (ceiling (+ width  (* 2 margin))))
205                           (truncate (ceiling (+ height (* 2 margin)))))
206                      (seq (fmt "%%%%Creator: ~A" appname)
207                           (seq (fmt "%%%%CreationDate: ~A" (isotime))
208                                (seq (fmt "%%%%DocumentData: Clean7Bit")
209                                     (seq (fmt "%%%%EndComments")
210                                          (seq drawing
211                                               (seq (fmt "showpage")
212                                                    (fmt "%%%%EOF"))
213                                               ))
214                                     ))
215                           ))
216                 ))))) EPS-GROC )))
217    (lambda (name width height f #!key (margin 0.5))
218      (output-write (sprintf "~A.eps" name) (format-EPS margin width height f)))))
219
220
221(define=> (output-objects <GROC>)
222  (lambda (output draw)
223    (lambda (name width height objects #!key (bbox #f) (w 0.9) (translation #f))
224      (let ((bbox-drawing
225             (or (and bbox (let ((x1 (list-ref bbox 0))  (y1 (list-ref bbox 1)) 
226                                 (x2 (list-ref bbox 2))  (y2 (list-ref bbox 3)) )
227                             (seq (color (make-color 0.7 0.8 0.1 ))
228                                  (seq (weight 3.0)
229                                       (poly (list (make-point x1 y1) 
230                                                   (make-point x1 y2) 
231                                                   (make-point x2 y2) 
232                                                   (make-point x2 y1)))
233                                       ))
234                             ))
235                 (return '()) ))
236
237            (translation (or (and translation (translate
238                                               (car translation) 
239                                               (cadr translation)))
240                             (return '())))
241            )
242      (output (->string (gensym (string->symbol (->string name))))
243              width height (seq translation
244                                (seq bbox-drawing
245                                     (seq (weight w) (seq (gray 0) (draw objects)))
246                                     ))
247              )
248      ))
249    ))
250
251
252(define=> (draw-points <GROC>)
253  (lambda (l) (mapm_ dot l)))
254
255(define draw-points-EPS (draw-points EPS-GROC))
256
257(define output-points-EPS ((output-objects EPS-GROC) output-EPS draw-points-EPS))
258
259
260(define=> (draw-gray-points <GROC>)
261  (lambda (l) (mapm_ (lambda (x) (seq (gray (- 1.0 (car x))) (dot (cadr x)))) l)))
262
263(define draw-gray-points-EPS (draw-gray-points EPS-GROC))
264
265(define output-gray-points-EPS ((output-objects EPS-GROC) output-EPS draw-gray-points-EPS))
266
267
268(define=> (draw-boxes <GROC>)
269  (lambda (bl) 
270    (mapm_ 
271     (lambda (b) 
272       (let ((x1 (list-ref b 0))  (y1 (list-ref b 1)) 
273             (x2 (list-ref b 2))  (y2 (list-ref b 3)) )
274         (seq (gray 0)
275              (poly (list (make-point x1 y1) (make-point x1 y2) (make-point x2 y2) (make-point x2 y1))))
276         ))
277     bl)))
278
279(define draw-boxes-EPS (draw-boxes EPS-GROC))
280
281(define output-boxes-EPS ((output-objects EPS-GROC) output-EPS draw-boxes-EPS))
282
283
284(define=> (draw-boxes-and-points <GROC>)
285  (lambda (bl) 
286    (mapm_ 
287     (lambda (bpts) 
288       (let ((b (car bpts)) (pts (cadr bpts))
289             (c (and (pair? (cddr bpts)) (caddr bpts))))
290         (let ((x1 (list-ref b 0))  (y1 (list-ref b 1)) 
291               (x2 (list-ref b 2))  (y2 (list-ref b 3)) )
292           (seq 
293            (seq (or (and c (case (car c)
294                              ((gray)  (gray (cdr c)))
295                              ((color) (color (apply make-color (cdr c))))))
296                     (gray 0))
297                         
298                 (poly (list (make-point x1 y1) 
299                             (make-point x1 y2) 
300                             (make-point x2 y2) 
301                             (make-point x2 y1)))
302                 )
303            (mapm_ (lambda (x) (seq (weight (* 0.5 (car x))) (dot (cadr x)))) pts))
304           ))
305       )
306     bl)))
307
308
309(define draw-boxes-and-points-EPS (draw-boxes-and-points EPS-GROC))
310
311(define output-boxes-and-points-EPS ((output-objects EPS-GROC) output-EPS draw-boxes-and-points-EPS))
312
313
314
315
316
317
318)
Note: See TracBrowser for help on using the repository browser.