root/lang/zu/interpreter/scheme/trunk/lib/nt/textgraph.scm

Revision 7, 5.9 kB (checked in by naoya_t, 17 years ago)

Zu interpreter for Gauche: initial import

Line 
1;;;
2;;; TextGraph - ported from yhara's Ruby implementation, by naoya_t
3;;;
4(define-module nt.textgraph
5  (export
6;   make-cell
7;   cell=?
8;   make-charmap
9;   make-parser
10   parse-textgraph
11   ))
12
13(select-module nt.textgraph)
14
15(define undef-object (if #f #f))
16
17(use srfi-1) ; drop-right
18(use srfi-13) ; string-trim
19(use gauche.sequence) ; ref
20
21;;
22;; Cell
23;;
24(define (make-cell x y w h raw-content)
25  (cond ((or (< x 0) (< y 0)) (error "x or y value too small"))
26                ((or (< w 2) (< h 2)) (error "w or h value too small"))
27                (else (lambda (m)
28                                (case m
29                                  ((x) x)
30                                  ((y) y)
31                                  ((w) w)
32                                  ((h) h)
33                                  ((includes?) (lambda (tx ty) (and (<= x tx (+ x w -1))
34                                                                                                        (<= y ty (+ y h -1)))))
35                                  ((raw-content) raw-content)
36                                  ((content) (string-trim-both raw-content))
37                                  ((to-str) (format "[~d ~d ~d ~d \"~a\"]" x y w h (string-trim-both raw-content)))
38                                  (else undef-object) ))
39                          )))
40
41(define (cell=? c1 c2)
42  (and (= [c1'x] [c2'x])
43           (= [c1'y] [c2'y])
44           (= [c1'w] [c2'w])
45           (= [c1'h] [c2'h])
46           (string=? [c1'raw-content] [c2'raw-content])))
47
48;;
49;; CharMap
50;;
51(define (string->lines str)
52  (drop-right (string-split str #[\r\n])
53                          1))
54
55(define (make-charmap str)
56  (define (partition str)
57        (map string->list
58                 (string->lines str)))
59
60  (let* ([data (partition str)]
61                 [width (apply max (map length data))]
62                 [height (length data)]
63                 )
64
65        (define (x-in-range? x)
66          (and (<= 0 x) (< x width)))
67        (define (y-in-range? y)
68          (and (<= 0 y) (< y height)))
69
70        (define (char-at x y) ; [](x,y)
71;         (if (and (x-in-range? x) (y-in-range? y))
72;                 (ref (ref data y) x)
73;                 undef-object))
74          (if (y-in-range? y)
75                  (let1 line (ref data y)
76                        (if (and (<= 0 x) (< x (length line)))
77                                (ref line x)
78                                undef-object))
79                  undef-object))
80
81        (define (map-char proc) ; takes (lambda (x y char) ...)
82          (map-with-index (lambda (y line)
83                                                (map-with-index (lambda (x char)
84                                                                                  (apply proc (list x y char))
85                                                                                  )
86                                                                                line)
87                                                )
88                                          data))
89
90        (define (each-char proc) ; takes (lambda (x y char) ...)
91          (for-each-with-index (lambda (y line)
92                                                         (for-each-with-index (lambda (x char)
93                                                                                                        (apply proc (list x y char))
94                                                                                                        )
95                                                                                                  line)
96                                                         )
97                                                   data))
98
99        (lambda (m)
100          (case m
101                ((raw-data) data)
102                ((width) width)
103                ((height) height)
104                ((x-in-range?) x-in-range?)
105                ((y-in-range?) y-in-range?)
106                ((char-at) char-at)
107                ((map-char) map-char)
108                ((each-char) each-char)
109                (else undef-object)))
110        ))
111
112;;
113;; Graph
114;;
115(define (make-graph cells links)
116;  (format #t "(make-graph ~a ~a)\n" cells links)
117  (define (dump)
118        (for-each-with-index
119         (lambda (i cell) (format #t "~d) ~a\n" i [cell'to-str]))
120         cells)
121        (for-each
122         (lambda (link) (format #t "~d --> ~d\n" (car link) (cdr link)))
123         links))
124
125  (lambda (m)
126        (case m
127          ((cells) cells)
128          ((links) links)
129          ((dump) (dump))
130          (else undef-object))))
131
132(define (make-coord x y)
133  (lambda (m)
134        (case m
135          ((x) x)
136          ((y) y)
137          ((to-str) (format "(~d,~d)" x y))
138          (else undef-object))))
139
140(define (coord=? co1 co2)
141  (and (= [co1'x] [co2'x])
142           (= [co1'y] [co2'y])))
143
144;;
145;; Parser
146;;
147(define (make-parser str)
148  (let1 charmap (make-charmap str)
149       
150        (define (collect-chars char)
151          (remove! null?
152                           (apply append!
153                                          ([charmap'map-char] (lambda (x y c)
154                                                                                        (if (eq? c char) (make-coord x y) '())
155                                                                                        )
156                                           ))))
157
158        (define (find-horizontal-end x y dir goal-ch)
159          (let1 dx (if dir 1 -1)
160                (let loop ([tx (+ x dx)] [ty y])
161                  (cond ((not ([charmap'x-in-range?] tx)) #f)
162                                ((eq? goal-ch ([charmap'char-at] tx ty)) (make-coord tx ty))
163                                (else (loop (+ tx dx) ty))))
164                ))
165        (define (find-vertical-end x y dir goal-ch)
166          (let1 dy (if dir 1 -1)
167                (let loop ([tx x] [ty (+ y dy)])
168                  (cond ((not ([charmap'y-in-range?] ty)) #f)
169                                ((eq? goal-ch ([charmap'char-at] tx ty)) (make-coord tx ty))
170                                (else (loop tx (+ ty dy)))))
171                ))
172
173        (define (cell? x y)
174          (if (and (memq ([charmap'char-at] (+ x 1) y) '(#\- #\v #\+))
175                           (memq ([charmap'char-at] x (+ y 1)) '(#\| #\> #\+)))
176                  (let* ([rt (find-horizontal-end x y #t #\*)]
177                                 [lb (find-vertical-end x y #t #\*)]
178                                 [lb-r (find-horizontal-end x [lb'y] #t #\*)]
179                                 [rt-b (find-vertical-end [rt'x] y #t #\*)])
180                        (if (and rt lb lb-r rt-b)
181                                (if (coord=? lb-r rt-b)
182                                        (make-coord (+ (- [rt'x] x) 1) (+ (- [lb'y] y) 1))
183                                        #f)
184                                #f) )
185                  #f))
186
187        (define (get-str x y w h)
188          (string-join (map (lambda (ty)
189                                                  (list->string (map (lambda (tx)
190                                                                                           ([charmap'char-at] tx ty))
191                                                                                         (iota (- w 2) (+ x 1)) )))
192                                                (iota (- h 2) (+ y 1)) )))
193
194        (define (collect-cells)
195          (remove! null?
196                           (map (lambda (coord)
197                                          (let ([x (coord'x)]
198                                                        [y (coord'y)])
199                                                (let1 wh (cell? x y)
200                                                  (if wh
201                                                          (let ([w (wh'x)]
202                                                                        [h (wh'y)])
203                                                                (make-cell x y w h (get-str x y w h)))
204                                                          '())
205                                                  )))
206                                        (collect-chars #\*)
207                                        )))
208
209        (define (find-links cells)
210          (map (lambda (coord)
211                         (let ([x (coord'x)]
212                                   [y (coord'y)])
213                           (let1 p (or (find-horizontal-end x y #t #\>)
214                                                   (find-horizontal-end x y #f #\<)
215                                                   (find-vertical-end x y #t #\v)
216                                                   (find-vertical-end x y #f #\^))
217                                 (cons (cell-at cells x y)
218                                           (cell-at cells [p'x] [p'y]))
219                                 )))
220                   (collect-chars #\+)))
221
222        (define (cell-at cells x y)
223          (find-index
224           (lambda (cell) ([cell'includes?] x y))
225           cells))
226
227        (define (get-direction x y)
228          (cond ((memq ([charmap'char-at] (+ x 1) y) '(#\- #\>)) (list 1 0 #\>))
229                        ((memq ([charmap'char-at] x (+ y 1)) '(#\| #\v)) (list 0 1 #\v))
230                        ((memq ([charmap'char-at] (- x 1) y) '(#\- #\<)) (list -1 0 #\<))
231                        ((memq ([charmap'char-at] x (- y 1)) '(#\| #\^)) (list 0 -1 #\^))
232                        (else (error "can't decide direction"))))
233
234        (define (parse)
235          (let* ([cells (collect-cells)]
236                         [links (find-links cells)])
237                (make-graph cells links)))
238
239        (lambda (m)
240          (case m
241                ((collect-chars) collect-chars)
242                ((collect-cells) (collect-cells))
243                ((parse) (parse))
244;               ((dump) (dump))
245                (else undef-object)))
246        ))
247
248(define (parse-textgraph str)
249  [(make-parser str)'parse])
250
251(provide "nt/textgraph")
252;;EOF
Note: See TracBrowser for help on using the browser.