Import Nyacc 0.72.0.
[mes.git] / module / nyacc / util.scm
1 ;;; nyacc/util.scm
2 ;;;
3 ;;; Copyright (C) 2014-2016 Matthew R. Wette
4 ;;;
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Lesser General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 3 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;;; Lesser General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Lesser General Public
16 ;;; License along with this library; if not, write to the Free Software
17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19 (define-module (nyacc util)
20   #:export (
21             fmtstr fmtout fmterr fmt
22             wrap-action
23             obj->str
24             fixed-point prune-assoc
25             map-attr->vector
26             x-flip x-comb
27             write-vec
28             ugly-print
29             tzort
30             )
31   #:use-module ((srfi srfi-43) #:select (vector-fold))
32   )
33
34 (define (fmtstr fmt . args)
35   (apply simple-format #f fmt args))
36 (define (fmtout fmt . args)
37   (apply simple-format (current-output-port) fmt args))
38 (define (fmterr fmt . args)
39   (apply simple-format (current-error-port) fmt args))
40 (define fmt simple-format)
41
42 ;; @item make-arg-list N => '($N $Nm1 $Nm2 ... $1 . $rest)
43 ;; This is a helper for @code{mkact}.
44 (define (make-arg-list n)
45   (let ((mkarg
46          (lambda (i) (string->symbol (string-append "$" (number->string i))))))
47     (let iter ((r '(. $rest)) (i 1))
48       (if (> i n) r (iter (cons (mkarg i) r) (1+ i))))))
49
50 ;; @item wrap-action (n . guts) => `(lambda ($n ... $2 $1 . $rest) ,@guts)
51 ;; Wrap user-specified action (body, as list) of n arguments in a lambda.
52 ;; The rationale for the arglist format is that we can @code{apply} this
53 ;; lambda to the the semantic stack.
54 (define (wrap-action actn)
55   (cons* 'lambda (make-arg-list (car actn)) (cdr actn)))
56
57 ;; @deffn obj->str object => string
58 ;; Convert terminal (symbol, string, character) to string.
59 ;; This is like @code{write} but will prefix symbols with @code{'}.
60 (define (obj->str obj)
61   (cond ((string? obj) (simple-format #f "~S" obj))
62         ((symbol? obj) (string-append "'" (symbol->string obj)))
63         ((char? obj) (simple-format #f "~S" obj))))
64
65 ;; @deffn prune-assoc al
66 ;; Prune obsolete entries from an a-list.  This is order n^2.
67 (define (prune-assoc al)
68   (let iter ((al1 '()) (al0 al))
69     (if (null? al0) al1
70         (iter (if (assoc (caar al0) al1) al1 (cons (car al0) al1)) (cdr al0)))))
71
72 ;; @deffn fixed-point proc seed
73 ;; .item fixed-point-by-elt proc seed
74 ;; @example
75 ;; proc: element list -> list
76 ;; @end example
77 ;; proc will take an element and insert updates at the front of list
78 ;; and return the list
79 ;; seed is a list
80 ;; fixed-point processes a list
81 ;; The procedure @code{proc} takes as arguments an element from the list
82 ;; and the entire list.   Updates should be cons'd onto the front of the
83 ;; list.
84 ;; It works by setting prev to the empty list and next, curr and item to
85 ;; the seed.  The item reference is propagated through the current list
86 ;; until it reaches prev.  The calls to proc will update @code{next}.
87 ;; @example
88 ;; next-> +---+
89 ;;        |   |
90 ;; curr-> +---+
91 ;;        |   |
92 ;; item-> |   |
93 ;;        |   |
94 ;; prev-> +---+
95 ;;        |   |
96 ;;        +---+
97 ;; @end example
98 (define (fixed-point proc seed)
99   ;; (let ((seed (if (null? seed) (fixed-point proc (proc seed '())))))
100   (let iter ((prev '()) (item seed) (curr seed) (next seed))
101     (cond
102      ((not (eqv? item prev))
103       (iter prev (cdr item) curr (proc (car item) next)))
104      ((not (eqv? next curr))
105       (iter curr next next next))
106      (else
107       curr))))
108
109 ;; @deffn vector-fixed-point proc vec => vec
110 ;; (proc vec) => chg (boolean)
111 ;; Not used yet (in step3).
112 (define (vector-fixed-point proc vec)
113   (let iter ((chg #t))
114     (if chg (proc vec) vec)))
115
116 ;; @deffn map-attr->vector list-of-alists key => vector
117 ;; map list of attribute lists to vector of attr
118 ;; @example
119 ;; (map-attr->vector '(((a . 1) ...) ((a . 2) ...) ...) => #(1 2 ...)
120 ;; @end example
121 (define (map-attr->vector al-l key)
122   (list->vector (map (lambda (al) (assq-ref al key)) al-l)))
123
124 ;; @deffn flip al => a-list
125 ;; change (a 1 2 3) to ((1 . a) (2 . a) (3 . a))
126 (define (x-flip al)
127   (let iter ((result '()) (tail (cdr al)))
128     (if (null? tail) result
129         (iter (acons (car tail) (car al) result) (cdr tail)))))
130
131 ;; @deffn x-comb (a1 a2 a3) (b1 b2 b3) => (a1 b1) (a1 b2) ...
132 ;; The implementation needs work.
133 (define (x-comb a b)
134   (let iter ((res '()) (al a) (bl b))
135     (cond
136      ((null? al) res)
137      ((pair? bl) (iter (acons (car al) (car bl) res) al (cdr bl)))
138      ((pair? al) (iter res (cdr al) b)))))
139
140 (define (write-vec port vec)
141   (let* ((nv (vector-length vec)))
142     (fmt port "  #(")
143     (let iter ((col 4) (ix 0))
144       (if (eq? ix nv) #f
145           (let* ((item (vector-ref vec ix))
146                  (stng (fmt #f "~S " item))
147                  (leng (string-length stng)))
148             (cond
149              ((> (+ col leng) 78)
150               (fmt port "\n    ~A" stng)
151               (iter (+ 4 leng) (1+ ix)))
152              (else
153               (fmt port "~A" stng)
154               (iter (+ col leng) (1+ ix)))))))
155     (fmt port ")")))
156
157
158 ;; @deffn ugly-print sexp [#:indent 4] [#:extent 78] [#:port port]
159 ;; This will print in compact form which shows no structure.
160 (define* (ugly-print sexp #:optional port #:key (indent 4) (extent 78))
161
162   (define (obj->str obj)
163     (simple-format #f "~S" obj))
164
165   ;; @deffn make-strout indent extent port
166   ;; This will generate a procedure of signature @code{(proc col str)} which
167   ;; takes a column and string, prints the string and returns updated column.
168   (define (make-strout ind ext port)
169     (let ((leader (make-string ind #\space)))
170       (lambda (col str)
171         (let* ((len (string-length str)))
172           (cond
173            ((> (+ col len) ext)
174             (newline port)
175             (display leader port)
176             (unless (string-every #\space str) (display str port))
177             (+ ind len))
178            (else
179             (display str port)
180             (+ col len)))))))
181
182   (letrec ((out-p (or port (current-output-port)))
183            (leader (make-string 2 #\space))
184            (strout (make-strout indent extent out-p))
185
186            (iter1
187             (lambda (col sx)
188               (cond
189                ((pair? sx) (strout (iter2 (strout col "(") sx) ")"))
190                ((vector? sx)
191                 (strout
192                  (vector-fold
193                   (lambda (ix col elt)
194                     (iter1 (if (zero? ix) col (strout col " ")) elt))
195                   (strout col "#(") sx) ")"))
196                (else (strout col (obj->str sx))))))
197            
198            (iter2
199             (lambda (col sx)
200               (cond
201                ((pair? sx)
202                 (if (null? (cdr sx))
203                     (iter2 (iter1 col (car sx)) (cdr sx))
204                     (iter2 (strout (iter1 col (car sx)) " ") (cdr sx))))
205                ((null? sx) col)
206                (else (strout (strout col ". ") (obj->str sx))))))
207            )
208     ;;(simple-format out-p leader)
209     (iter1 (if (pair? sexp) (strout indent "'") indent) sexp)
210     ;;(iter1 indent sexp)
211     ;;(newline out-p)
212     ))
213
214 ;; stuff
215
216 ;; @deffn depth-first-search graph => (values ht gv tv xl)
217 ;; The argument @var{gfraph} is a list of verticies and adjacency nodes:
218 ;; @example
219 ;; graph => ((1 2 3 4) (2 6 7) ...)
220 ;; @end example
221 ;; @noindent
222 ;; @table @var
223 ;; @item ht
224 ;; hash of vertex to index
225 ;; @item gv
226 ;; vector of index to vertex
227 ;; @item tv
228 ;; vector of (d . f)
229 ;; @end table
230 ;; ref: Algorithms, p 478
231 (define (depth-first-search graph)
232   (let* ((n (length graph))
233            (ht (make-hash-table n))     ; vertex -> index
234            (gv (make-vector n))         ; index -> vertex
235            (tv (make-vector n #f))      ; index -> times
236            (pv (make-vector n #f))      ; index -> predecessor :unused
237            (xl '()))
238     (letrec
239         ((next-t (let ((t 0)) (lambda () (set! t (+ 1 t)) t)))
240          (visit (lambda (k)
241                   (vector-set! tv k (cons (next-t) #f))
242                   (let iter ((l (cdr (vector-ref gv k))))
243                     (if (not (null? l))
244                         (let ((ix (hashq-ref ht (car l))))
245                           (unless (vector-ref tv ix)
246                                   (pp 0 "set-pv! ~a ~a" ix k)
247                                   (vector-set! pv ix k)
248                                   (visit ix))
249                           (iter (cdr l)))))
250                   (set! xl (cons k xl))
251                   (set-cdr! (vector-ref tv k) (next-t))
252                   ))
253            )
254       ;; Set up hash of vertex to index.
255       (do ((i 0 (+ i 1)) (l graph (cdr l))) ((= i n))
256         (vector-set! gv i (car l)) ; (vector-ref gv i) = (list-ref graph i)
257         (hashq-set! ht (caar l) i)) ; (hash-ref ht (list-ref graph i)) = i
258       ;; Run through vertices.
259       (do ((i 0 (+ 1 i))) ((= i n))
260         (unless (vector-ref tv i) (visit i)))
261       (values ht gv tv xl))))
262
263 ;; @deffn tzort dag
264 ;; Given DAG return order of nodes.  The DAG is provided as list of:
265 ;; (<node> <priors>)
266 ;; ref: D.E.Knuth - The Art of C.P., Vol I, Sec 2.2.3
267 (define (tzort dag)
268   (let* ((n (length dag))
269          (ht (make-hash-table n))       ; node -> ix
270          (nv (make-vector n #f))        ; ix -> (node . adj-list)
271          (cv (make-vector n 0))         ; ix -> count
272          (incr (lambda (ix) (vector-set! cv ix (+ (vector-ref cv ix) 1))))
273          (decr (lambda (ix) (vector-set! cv ix (- (vector-ref cv ix) 1)))))
274     ;; Set up ht and nv.
275     (do ((i 0 (+ i 1)) (l dag (cdr l))) ((= n i))
276       (vector-set! nv i (car l))
277       (hashq-set! ht (caar l) i))
278     ;; set up cv
279     (do ((i 0 (+ i 1))) ((= n i))
280       (for-each (lambda (n) (incr (hashq-ref ht n)))
281                 (cdr (vector-ref nv i))))
282     ;; Iterate through nodes until cv all zero.
283     (let iter1 ((ol '()) (uh '())       ; ordered list, unordered head 
284                 (ut (let r ((l '()) (x 0)) ; unordered tail
285                       (if (= x n) l (r (cons x l) (+ x 1))))))
286       (cond
287        ((null? ut)
288         (if (null? uh) 
289             (reverse (map (lambda (e) (car (vector-ref nv e))) ol))
290             (iter1 ol '() uh)))
291        (else
292         (let* ((ix (car ut)))
293           (if (zero? (vector-ref cv ix))
294               (iter1
295                (let iter2 ((l (cdr (vector-ref nv ix))))
296                      (if (null? l) (cons ix ol)
297                          (begin
298                            (decr (hashq-ref ht (car l)))
299                            (iter2 (cdr l)))))
300                uh
301                (cdr ut))
302               (iter1 ol (cons ix uh) (cdr ut)))))))))
303
304 ;;; --- last line ---