~ chicken-core (chicken-5) /tests/loopy-loop.scm

  1
  2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3;; Adapted from http://okmij.org/ftp/Scheme/keyword-arg-macro.txt
  4;; Currently fails in Gauche.
  5;; A more commented version is available at
  6;; http://mumble.net/~campbell/scheme/syn-param.scm
  7
  8(define-syntax let-keyword-form
  9  (syntax-rules ()
 10    ((let-keyword-form
 11      ((labeled-arg-macro-name
 12        (positional-form-name (arg-name . arg-default) ...)))
 13      . body)
 14     (letrec-syntax
 15         ((labeled-arg-macro-name
 16           (syntax-rules ()
 17             ((labeled-arg-macro-name . keyword-val-pairs)
 18              (letrec-syntax
 19                  ((find
 20                    (syntax-rules (<- arg-name ...)
 21                      ((find kvp k-args (arg-name . default) arg-name <- val
 22                             . others) ; found arg-name among keyword-val-pairs
 23                       (next kvp val . k-args)) ...
 24                      ((find kvp k-args key arg-no-match-name <- val . others)
 25                       (find kvp k-args key . others))
 26                      ((find kvp k-args (arg-name default)) ; default must be here
 27                       (next kvp default . k-args)) ...
 28                      ))
 29                   (next               ; pack the continuation to find
 30                    (syntax-rules ()
 31                      ((next kvp val vals key . keys)
 32                       (find kvp ((val . vals) . keys) key . kvp))
 33                      ((next kvp val vals) ; processed all arg-descriptors
 34                       (rev-apply (val) vals))))
 35                   (match-positionals
 36                    (syntax-rules (<-)
 37                      ((match-positionals () res . rest)
 38                       (rev-apply () res))
 39                      ((match-positionals args (val . vals) name <- value . rest)
 40                       (next (name <- value . rest) val vals . args))
 41                      ((match-positionals args (val . vals))
 42                       (next () val vals . args))
 43                      ((match-positionals (arg1 . args) res pos-arg . rest)
 44                       (match-positionals args (pos-arg . res) . rest))))
 45                   (rev-apply
 46                    (syntax-rules ()
 47                      ((rev-apply form (x . xs))
 48                       (rev-apply (x . form) xs))
 49                      ((rev-apply form ()) form))))
 50                (match-positionals ((arg-name . arg-default) ...)
 51                                   (positional-form-name)
 52                                   . keyword-val-pairs)
 53                )))))
 54       . body))))
 55
 56;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 57
 58(define-syntax loop
 59  (syntax-rules ()
 60    ;; unnamed, implicit recursion
 61    ((loop (vars ...) body ...)
 62     (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
 63    ;; named, explicit recursion
 64    ((loop name (vars ...) body ...)
 65     (%loop name () () () () () (vars ...) body ...))))
 66
 67;; Main LOOP macro. Separate the variables from the iterator and
 68;; parameters, then walk through each parameter expanding the
 69;; bindings, and build the final form.
 70
 71(define-syntax %loop
 72  (syntax-rules (=> <-)
 73    ;; automatic iteration
 74    ((_ name l v c r f ((var1 <- iterator source ...) rest ...) . body)
 75     (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
 76    ((_ name l v c r f ((var1 var2 <- iterator source ...) rest ...) . body)
 77     (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
 78    ((_ name l v c r f ((var1 var2 var3 <- iterator source ...) rest ...) . body)
 79     (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
 80    ((_ name l v c r f ((var1 var2 var3 var4 <- iterator source ...) rest ...) . body)
 81     (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
 82    ;; do equivalents, with optional guards
 83    ((_ name l (vars ...) (checks ...) r f ((var init step guard) rest ...) . body)
 84     (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
 85    ((_ name l (vars ...) c r f ((var init step) rest ...) . body)
 86     (%loop name l (vars ... (var init step)) c r f (rest ...) . body))
 87    ((_ name l (vars ...) c r f ((var init) rest ...) . body)
 88     (%loop name l (vars ... (var init var)) c r f (rest ...) . body))
 89    ;; specify a default done?
 90    ((_ name l v c r f ())
 91     (%loop name l v c r f () (#f #f)))
 92    ((_ name l v c r f () () . body)
 93     (%loop name l v c r f () (#f #f) . body))
 94    ;; final expansion
 95    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
 96        => result
 97        . body)
 98     (let* (lets ...)
 99       (letrec ((tmp (lambda (var ...)
100                       (if (or checks ...)
101                         (let-keyword-form ((name (tmp (var step) ...)))
102                            (match-let (finals ...)
103                              result))
104                         (match-let (refs ...)
105                           (let-keyword-form ((name (tmp (var step) ...)))
106                             (if #f #f)
107                             . body))))))
108         (tmp init ...))))
109    ;; unspecified return value case
110    ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
111        . body)
112     (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
113            => (if #f #f) . body))
114    ))
115
116(define-syntax %loop-next
117  (syntax-rules ()
118    ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
119        name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
120        . rest)
121     (%loop name (lets ... new-lets ...) (vars ... new-vars ...)
122                 (checks ... new-checks ...) (refs ... new-refs ...)
123                 (finals ... new-finals ...)
124        . rest))))
125
126;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127;; Iterators
128
129;; Each gets passed two lists, those items left of the <- and those to
130;; the right, followed by a NEXT and REST continuation.
131
132;; Should finish with
133;;
134;;  (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
135;;        (loop-vars ...) (final-vars ...) . rest)
136;;
137;;  OUTER-VARS: bound once outside the loop in a LET*
138;;  CURSOR-VARS: DO-style bindings of the form (name init update)
139;;  DONE?-TESTS: possibly empty list of forms that terminate the loop on #t
140;;  LOOP-VARS: inner variables, updated in parallel after the cursors
141;;  FINAL-VARS: final variables, bound only in the => result
142
143(define-syntax in-list                  ; called just "IN" in ITER
144  (syntax-rules ()
145    ((in-list ((var) source) next . rest)
146     (in-list ((var cursor) source) next . rest))
147    ((in-list ((var cursor) source) next . rest)
148     (in-list ((var cursor succ) source) next . rest))
149    ((in-list ((var cursor succ) (source)) next . rest)
150     (in-list ((var cursor succ) (source cdr)) next . rest))
151    ((in-list ((var cursor succ) (source step)) next . rest)
152     (in-list ((var cursor succ) (source step null?)) next . rest))
153    ((in-list ((var cursor succ) (source step done?)) next . rest)
154     (next ()                              ; outer let bindings
155           ((cursor source succ))          ; iterator, init, step
156           ((done? cursor))                ; finish tests for iterator vars
157           ((var (car cursor))             ; step variables and values
158            (succ (step cursor)))
159           ()                              ; final result bindings
160           . rest))))
161
162;; Iterator from Taylor R. Campbell.  If you know the number of lists
163;; ahead of time it's much more efficient to iterate over each one
164;; separately.
165(define-syntax in-lists
166  (syntax-rules ()
167    ((in-lists ((elts) lol) next . rest)
168     (in-lists ((elts pairs) lol) next . rest))
169    ((in-lists ((elts pairs) lol) next . rest)
170     (in-lists ((elts pairs succ) lol) next . rest))
171    ((in-lists ((elts pairs succ) (lol)) next . rest)
172     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
173    ((in-lists ((elts pairs succ) (lol)) next . rest)
174     (in-lists ((elts pairs succ) (lol cdr)) next . rest))
175    ((in-lists ((elts pairs succ) (lol step)) next . rest)
176     (in-lists ((elts pairs succ) (lol step null?)) next . rest))
177    ((in-lists ((elts pairs succ) (lol step done?)) next . rest)
178     (next ()
179           ((pairs lol succ))
180           ((let lp ((ls pairs)) ; yes, an in-lined ANY
181              (and (pair? ls) (or (done? (car ls)) (lp (cdr ls))))))
182           ((elts (map car pairs))
183            (succ (map step pairs)))
184           ()
185           . rest))
186    ))
187
188(define-syntax define-in-indexed
189  (syntax-rules ()
190    ((define-in-indexed in-type in-type-reverse length ref)
191     (begin
192       (define-syntax in-type
193         (syntax-rules ()
194           ((in-type ls next . rest)
195            (%in-indexed >= + 0 (length tmp) ref tmp ls next . rest))))
196       (define-syntax in-type-reverse
197         (syntax-rules ()
198           ((in-type-reverse ls next . rest)
199            (%in-indexed < - (- (length tmp) 1) 0 ref tmp ls next . rest))))
200       ))))
201
202(define-in-indexed in-string in-string-reverse string-length string-ref)
203(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
204(define-in-indexed in-u8vector in-u8vector-reverse u8vector-length u8vector-ref)
205(define-in-indexed in-s8vector in-s8vector-reverse s8vector-length s8vector-ref)
206(define-in-indexed in-u16vector in-u16vector-reverse u16vector-length u16vector-ref)
207(define-in-indexed in-s16vector in-s16vector-reverse s16vector-length s16vector-ref)
208(define-in-indexed in-u32vector in-u32vector-reverse u32vector-length u32vector-ref)
209(define-in-indexed in-s32vector in-s32vector-reverse s32vector-length s32vector-ref)
210(define-in-indexed in-u64vector in-u64vector-reverse u64vector-length u64vector-ref)
211(define-in-indexed in-s64vector in-s64vector-reverse s64vector-length s64vector-ref)
212(define-in-indexed in-f32vector in-f32vector-reverse f32vector-length f32vector-ref)
213(define-in-indexed in-f64vector in-f64vector-reverse f64vector-length f64vector-ref)
214
215;; helper for the above string and vector iterators
216(define-syntax %in-indexed
217  (syntax-rules ()
218    ;;   cmp inc start end ref
219    ((%in-indexed ge + s e r tmp-vec ((var) (vec ...)) next . rest)
220     (%in-indexed ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest))
221    ((%in-indexed ge + s e r tmp-vec ((var index) (vec)) next . rest)
222     (%in-indexed ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest))
223    ((%in-indexed ge + s e r tmp-vec ((var index) (vec from)) next . rest)
224     (%in-indexed ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest))
225    ((%in-indexed ge + s e r tmp-vec ((var index) (vec from to)) next . rest)
226     (%in-indexed ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest))
227    ((%in-indexed ge + s e r tmp-vec ((var index) (vec from to step)) next . rest)
228     (next ((tmp-vec vec) (end to))
229           ((index from (+ index step)))
230           ((ge index end))
231           ((var (r tmp-vec index)))
232           ()
233       . rest))
234    ))
235
236(define-syntax in-port
237  (syntax-rules ()
238    ((in-port ((var) source) next . rest)
239     (in-port ((var p) source) next . rest))
240    ((in-port ((var p) ()) next . rest)
241     (in-port ((var p) ((current-input-port))) next . rest))
242    ((in-port ((var p) (port)) next . rest)
243     (in-port ((var p) (port read-char)) next . rest))
244    ((in-port ((var p) (port read-char)) next . rest)
245     (in-port ((var p) (port read-char eof-object?)) next . rest))
246    ((in-port ((var p) (port reader eof?)) next . rest)
247     (next ((p port) (r reader) (e? eof?))
248           ((var (r p) (r p)))
249           ((e? var))
250           ()
251           ()
252       . rest))))
253
254(define-syntax in-file
255  (syntax-rules ()
256    ((in-file ((var) source) next . rest)
257     (in-file ((var p) source) next . rest))
258    ((in-file ((var p) (file)) next . rest)
259     (in-file ((var p) (file read-char)) next . rest))
260    ((in-file ((var p) (file reader)) next . rest)
261     (in-file ((var p) (file reader eof-object?)) next . rest))
262    ((in-file ((var p) (file reader eof?)) next . rest)
263     (next ((p (open-input-file file)) (r reader) (e? eof?))
264           ((var (r p) (r p)))
265           ((e? var))
266           ()
267           ((dummy (close-input-port p)))
268       . rest))))
269
270;; XXXX Consider a keyword approach such as Taylor uses.
271
272(define-syntax in-range
273  (syntax-rules ()
274    ((in-range ((var) ()) next . rest)
275     (next () ((var 0 (+ var 1))) () () . rest))
276    ((in-range ((var) (to)) next . rest)
277     (next () ((var 0 to)) () () . rest))
278    ((in-range ((var) (from to)) next . rest)
279     (in-range ((var) (from to 1)) next . rest))
280    ((in-range ((var) (from to step)) next . rest)
281     (next ((tmp-to to))
282           ((var from (+ var step)))
283           ((>= var tmp-to))
284           ()
285           ()
286       . rest))))
287
288(define-syntax in-range-reverse
289  (syntax-rules ()
290    ((in-range ((var) ()) next . rest)
291     (next () ((var 0 (- var 1))) () () . rest))
292    ((in-range ((var) (to)) next . rest)
293     (next () ((var 0 to)) () () . rest))
294    ((in-range ((var) (from to)) next . rest)
295     (in-range ((var) (from to 1)) next . rest))
296    ((in-range ((var) (from to step)) next . rest)
297     (next ((tmp-to to))
298           ((var from (- var step)))
299           ((<= var tmp-to))
300           ()
301           ()
302       . rest))))
303
304;; XXXX A generalized accumulator, possibly not worth the effort.
305
306(define-syntax collecting
307  (syntax-rules ()
308    ((collecting ((var) source) next . rest)
309     (collecting ((var cursor) source) next . rest))
310    ((collecting ((var cursor) (source)) next . rest)
311     (collecting ((var cursor) (source cons)) next . rest))
312    ((collecting ((var cursor) (source kons)) next . rest)
313     (collecting ((var cursor) (source kons reverse)) next . rest))
314    ((collecting ((var cursor) (source kons final)) next . rest)
315     (next ((tmp-kons kons))
316           ((cursor '() (tmp-kons source cursor)))
317           ()
318           ()
319           ((var (final cursor)))
320       . rest))))
321
322;; XXXX should these be loop variables or body variables?
323
324(define-syntax in-random
325  (syntax-rules ()
326    ((in-random ((var) ()) next . rest) ; XXXX consider in-random-real
327     (next ((MAX_RAND (+ (expt 2 29) (- (expt 2 29) 1))))
328           ((var (/ (pseudo-random-integer MAX_RAND) MAX_RAND)
329                 (/ (pseudo-random-integer MAX_RAND) MAX_RAND)))
330           ()
331           ()
332           . rest))
333    ((in-random ((var) (n)) next . rest)
334     (next ((tmp-n n))
335           ((var (pseudo-random-integer tmp-n)
336                 (pseudo-random-integer tmp-n)))
337           ()
338           ()
339           ()
340        . rest))
341    ((in-random ((var) (n lo)) next . rest)
342     (next ((tmp-n n) (tmp-lo lo))
343           ((var (+ tmp-lo (pseudo-random-integer tmp-n))
344                 (+ tmp-lo (pseudo-random-integer tmp-n))))
345           ()
346           ()
347           ()
348       . rest))
349    ))
350
351;; takes either a list or vector
352
353(define-syntax in-random-element
354  (syntax-rules ()
355    ((in-random-element ((var) (source)) next . rest)
356     (next ((tmp-source source)
357            (tmp-vec (if (pair? tmp-source)
358                       (list->vector tmp-source)
359                       tmp-source))
360            (tmp-len (vector-length tmp-vec)))
361           ((var (vector-ref tmp-vec (pseudo-random-integer tmp-len))
362                 (vector-ref tmp-vec (pseudo-random-integer tmp-len))))
363           ()
364           ()
365           ()
366           . rest))))
367
368;; XXXX document this and explain what the hell it's doing :)
369(define-syntax in-permutations
370  (syntax-rules ()
371    ((in-permutations ((var) source) next . rest)
372     (in-permutations ((var p) source) next . rest))
373    ((in-permutations ((var p) (set)) next . rest)
374     (in-permutations ((var p) (set #f)) next . rest))
375    ((in-permutations ((var p) (set len)) next . rest)
376     (next
377      ((tmp-set set))
378      ((p
379        (let ((tmp-len (or len (length tmp-set))))
380          (let lp ((i 0) (ls tmp-set) (res '()))
381            (if (= i tmp-len)
382              res
383              (lp (+ i 1) (cdr ls) (cons (cons ls '()) res)))))
384        (and (pair? p)
385             (let lp ((ls p) (count 0))
386               (if (pair? (cdaar ls))
387                 (let lp2 ((i count)
388                           (ls2 (append (reverse (cdar ls))
389                                        (cons (caaar ls) (cddaar ls))))
390                           (res (cons (cons (cdaar ls)
391                                            (cons (caaar ls) (cdar ls)))
392                                      (cdr ls))))
393                   (if (zero? i)
394                     res
395                     (lp2 (- i 1) (cdr ls2) (cons (cons ls2 '()) res))))
396                 (and (pair? (cdr ls)) (lp (cdr ls) (+ count 1))))))))
397      ((not p))
398      ((var
399        (let lp ((ls p) (res '()))
400          (if (null? ls) res (lp (cdr ls) (cons (caaar ls) res))))))
401      ()
402      . rest))
403    ))
404
405(define-syntax in-combinations
406  (syntax-rules ()
407    ((in-combinations ((var) x) next . rest)
408     (in-combinations ((var p) x) next . rest))
409    ;; all 2^len combinations
410    ((in-combinations ((var p) (set)) next . rest)
411     (next
412      ((tmp-vec (list->vector set))
413       (tmp-len (vector-length tmp-vec))
414       (tmp-limit (expt 2 tmp-len)))
415      ((p 0 (+ p 1)))
416      ((>= p tmp-limit))
417      ((var
418        (let lp ((p p) (i 0) (res '()))
419          (cond
420            ((zero? p) (reverse res))
421            ((odd? p)
422             (lp (arithmetic-shift p -1)
423                 (+ i 1)
424                 (cons (vector-ref tmp-vec i) res)))
425            (else (lp (arithmetic-shift p -1) (+ i 1) res))))))
426      ()
427      . rest))
428    ;; all C(n,k) combinations of length k
429    ((in-combinations ((var p) (set len)) next . rest)
430     (next
431      ((tmp-len len))
432      ((p
433        (let lp ((i 0) (ls set) (res '()))
434          (if (= i tmp-len)
435            res
436            (lp (+ i 1) (cdr ls) (cons ls res))))
437        (and (pair? p)
438             (if (and (pair? (car p)) (pair? (cdar p)))
439               (cons (cdar p) (cdr p))
440               (let lp ((ls (cdr p)) (count 1))
441                 (and (pair? ls)
442                      (if (> (length (cdar ls)) count)
443                        (let lp2 ((i count)
444                                  (ls2 (cddar ls))
445                                  (res (cons (cdar ls) (cdr ls))))
446                          (if (zero? i)
447                            res
448                            (lp2 (- i 1) (cdr ls2) (cons ls2 res))))
449                        (lp (cdr ls) (+ count 1)))))))))
450      ((not p))
451      ((var
452        (let lp ((ls p) (res '()))
453          (if (null? ls) res (lp (cdr ls) (cons (caar ls) res))))))
454      ()
455      . rest))
456    ))
457
458(define-syntax in-cartesian-product
459  (syntax-rules ()
460    ((in-cartesian-product ((var) (lol-src)) next . rest)
461     (in-cartesian-product ((var p) (lol-src)) next . rest))
462    ;; all NxMx... joins
463    ((in-cartesian-product ((var x) (lol-src)) next . rest)
464     (next
465      ((lol lol-src))
466      ((x (and (pair? lol)
467               (cons (reverse lol) (reverse (cdr lol))))
468          (let lp ((p (car x)) (ls (cdr x)) (rev '()))
469            (cond
470              ((pair? (cdar p))
471               (cons (append (reverse rev)
472                             (cons (cdar p) (cdr p)))
473                     (cdr x)))
474              ((pair? (cdr p))
475               (lp (cdr p) (cdr ls) (cons (car ls) rev)))
476              (else
477               #f)))))
478      ((not x))
479      ((var (let lp ((ls (car x)) (res '()))
480              (if (null? ls) res (lp (cdr ls) (cons (caar ls) res))))))
481      ()
482      . rest))
483    ))
484
485;; CHICKEN-specific implementation using internal knowledge of the
486;; vector+alist representation.  The ##sys#slot form will cause most
487;; other implementations to choke, so comment this out if needed.
488
489(define-syntax in-hash-table
490  (syntax-rules ()
491    ((in-hash-table ((key val) (table)) next . rest)
492     (next ((tmp-vec (##sys#slot table 1))
493            (end (vector-length tmp-vec))
494            (next-pair-bucket
495             (lambda (start)
496               (let lp ((i start))
497                 (and (< i end)
498                      (let ((x (vector-ref tmp-vec i)))
499                        (if (pair? x)
500                          i
501                          (lp (+ i 1))))))))
502            (first-bucket (next-pair-bucket 0)))
503           ((bucket first-bucket
504                    (if (and (pair? cell) (pair? (cdr cell)))
505                      bucket
506                      (next-pair-bucket (+ bucket 1))))
507            (cell (and first-bucket (vector-ref tmp-vec first-bucket))
508                  (if (and (pair? cell) (pair? (cdr cell)))
509                    (cdr cell)
510                    (let ((i (next-pair-bucket (+ bucket 1))))
511                      (and i (vector-ref tmp-vec i))))))
512           ((not bucket))
513           ((key (caar cell))
514            (val (cdar cell)))
515           ()
516       . rest))
517    ))
518
519;; Portable R5RS + SRFI-69 version.
520
521;; (define-syntax in-hash-table
522;;   (syntax-rules ()
523;;     ((in-hash-table ((key val) (table)) next . rest)
524;;      (next ((tmp-table table)
525;;             (start-cursor
526;;              (call-with-current-continuation
527;;                (lambda (return)
528;;                  (hash-table-walk
529;;                   table
530;;                   (lambda (k v)
531;;                     (call-with-current-continuation
532;;                       (lambda (inside)
533;;                         (return
534;;                          (lambda (sym)
535;;                            (cond
536;;                              ((eq? sym 'key) k)
537;;                              ((eq? sym 'value) v)
538;;                              ((eq? sym 'next) (inside #t))
539;;                              ((eq? sym 'end?) #f))))))))
540;;                  (lambda (sym)
541;;                    (if (eq? sym 'end?)
542;;                      #t
543;;                      (error "past end of hash table")))))))
544;;            ((tmp-cursor start-cursor (tmp-cursor 'next)))
545;;            ((tmp-cursor 'end?))
546;;            ((key (tmp-cursor 'key))
547;;             (val (tmp-cursor 'value)))
548;;            ()
549;;            . rest))
550;;     ))
551