247 lines
9.3 KiB
Racket
247 lines
9.3 KiB
Racket
#lang racket
|
|
|
|
(provide for-trie/list
|
|
for-trie/set
|
|
for-trie/patch
|
|
for-trie/fold
|
|
for-trie)
|
|
|
|
(require "core.rkt"
|
|
(only-in "actor.rkt" analyze-pattern)
|
|
(for-syntax racket/syntax)
|
|
(for-syntax syntax/strip-context)
|
|
(for-syntax racket/match))
|
|
|
|
(begin-for-syntax
|
|
; Pattern-Syntax Syntax ->
|
|
; (SyntaxOf TempVar TempVar Projection-Pattern Match-Pattern)
|
|
(define (helper pat-stx outer-stx)
|
|
(match-define (list temp1 temp2) (generate-temporaries #'(tmp1 tmp2)))
|
|
(define-values (proj-stx pat match-pat bindings _instantiated)
|
|
(analyze-pattern outer-stx pat-stx))
|
|
(list temp1 temp2 proj-stx bindings)))
|
|
|
|
;; trie projection symbol -> (U set exn:fail?)
|
|
;; tries to project the trie. If the resulting trie would be infinite, raise an
|
|
;; error, using the third argument to describe the pattern being projected.
|
|
;; If the resulting trie is finite, return it as a set.
|
|
(define (project-finite t proj pat)
|
|
(define s? (trie-project/set #:take (projection-arity proj) t proj))
|
|
(unless s?
|
|
(error "pattern projection created infinite trie:" pat))
|
|
s?)
|
|
|
|
(begin-for-syntax
|
|
(define (build-fold stx ctx)
|
|
(syntax-case stx ()
|
|
[(_ ([acc-id acc-init] ...)
|
|
()
|
|
body ...)
|
|
#'(let () body ...)]
|
|
[(_ ([acc-id acc-init] ...)
|
|
((pat_0 trie_0)
|
|
clauses ...)
|
|
body ...)
|
|
(begin
|
|
(match-define (list set-tmp loop-tmp proj-stx match-pat)
|
|
(helper #'pat_0 ctx))
|
|
(with-syntax ([new-acc (generate-temporary 'acc)])
|
|
#`(let ([#,set-tmp (project-finite trie_0 #,proj-stx 'pat_0)])
|
|
(for/fold/derived #,ctx ([acc-id acc-init]
|
|
...)
|
|
([loop-tmp (in-set #,set-tmp)])
|
|
(match loop-tmp
|
|
[(list #,@match-pat)
|
|
#,(build-fold
|
|
#`(_ ([acc-id acc-id]
|
|
...)
|
|
(clauses ...)
|
|
body ...)
|
|
ctx)]
|
|
[_ (values acc-id ...)])))))]
|
|
[(_ ([acc-id acc-init] ...)
|
|
(#:where pred clauses ...)
|
|
body ...)
|
|
#`(if pred
|
|
#,(build-fold #'(_ ([acc-id acc-init] ...) (clauses ...) body ...)
|
|
ctx)
|
|
(values acc-id ...))])))
|
|
|
|
(define-syntax (for-trie/fold stx)
|
|
(build-fold stx stx))
|
|
|
|
(define-syntax (make-fold stx)
|
|
(syntax-case stx ()
|
|
[(_ name folder initial)
|
|
#'(define-syntax (name stx)
|
|
(syntax-case stx ()
|
|
[(_ (clauses (... ...)) body (... ...))
|
|
(with-syntax ([loop #'(for-trie/fold ([acc initial])
|
|
(clauses (... ...))
|
|
(folder (let () body (... ...)) acc))])
|
|
(build-fold #'loop stx))]))]))
|
|
|
|
(make-fold for-trie/list cons empty)
|
|
|
|
(define (set-folder x acc)
|
|
(set-add acc x))
|
|
|
|
(make-fold for-trie/set set-folder (set))
|
|
|
|
(make-fold for-trie/patch patch-seq patch-empty)
|
|
|
|
(define (ret-second a b) b)
|
|
|
|
(make-fold for-trie-inner ret-second #f)
|
|
|
|
(define-syntax (for-trie stx)
|
|
(syntax-case stx ()
|
|
[(_ (clauses ...) body ...)
|
|
(with-syntax ([loop #'(for-trie/fold ([acc (void)])
|
|
(clauses ...)
|
|
(begin (let () body ...) acc))])
|
|
(build-fold #'loop stx))]))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(require "trie.rkt")
|
|
|
|
(define (make-trie . vs)
|
|
(for/fold ([acc trie-empty])
|
|
([v (in-list vs)])
|
|
(trie-union acc (pattern->trie 'a v))))
|
|
|
|
(struct foo (bar zot) #:prefab)
|
|
(struct quasi-cons (car cdr) #:transparent)
|
|
|
|
;; This test should pass OK, since we're ignoring all the infinite
|
|
;; dimensions, and just projecting out a finite one.
|
|
(check-equal? (for-trie/set ([(observe (foo $bar _))
|
|
(make-trie (observe (foo 1 'a))
|
|
(observe (foo 2 'b))
|
|
(observe (foo 3 ?)))])
|
|
bar)
|
|
(set 1 2 3))
|
|
|
|
;; We should support internal definitions.
|
|
(check-equal? (for-trie/set ([(foo $bar $zot) (make-trie (foo 1 2)
|
|
(foo 3 4)
|
|
(foo 5 6))])
|
|
(define sum (+ bar zot))
|
|
sum)
|
|
(set 3 7 11))
|
|
|
|
(check-equal? (sort (for-trie/list ([$x (make-trie 1 2 3 4)]
|
|
#:where (even? x))
|
|
(+ x 1))
|
|
<)
|
|
'(3 5))
|
|
|
|
(check-equal? (for-trie/set ([$x (make-trie 1 2 3 4)]
|
|
#:where (even? x))
|
|
(+ x 1))
|
|
(set 3 5))
|
|
(check-equal? (for-trie/set ([(quasi-cons $x _)
|
|
(make-trie 1 2 (list 0)
|
|
(list 1 2 3)
|
|
(quasi-cons 'x 'y)
|
|
(quasi-cons 3 4)
|
|
(quasi-cons 'a 'b)
|
|
"x" 'foo)])
|
|
x)
|
|
(set 'x 3 'a))
|
|
(check-equal? (for-trie/fold ([acc 0])
|
|
([$x (make-trie 1 2 3 4)]
|
|
#:where (even? x))
|
|
(+ acc x))
|
|
6)
|
|
(check-equal? (for-trie/fold ([acc 0])
|
|
([$x (make-trie 1 2 3 4)]
|
|
[x (make-trie 0 1 2 4)]
|
|
#:where (even? x))
|
|
(+ acc x))
|
|
6)
|
|
(let-values ([(acc1 acc2)
|
|
(for-trie/fold ([acc1 0]
|
|
[acc2 0])
|
|
([(quasi-cons $x $y)
|
|
(make-trie (quasi-cons 1 2)
|
|
(quasi-cons 3 8)
|
|
(quasi-cons 9 7))])
|
|
(values (+ acc1 x)
|
|
(+ acc2 y)))])
|
|
(check-equal? acc1 13)
|
|
(check-equal? acc2 17))
|
|
(check-equal? (for-trie/set ([$x (make-trie 1 2 3)]
|
|
[$y (make-trie 4 5 6)])
|
|
(cons x y))
|
|
(set (cons 1 4) (cons 1 5) (cons 1 6)
|
|
(cons 2 4) (cons 2 5) (cons 2 6)
|
|
(cons 3 4) (cons 3 5) (cons 3 6)))
|
|
(let ([p (for-trie/patch ([$x (make-trie 1 2 3 4)])
|
|
(retract x))])
|
|
(check-equal? (trie-project/set #:take 1 (patch-removed p) (?!))
|
|
(set '(1) '(2) '(3) '(4))))
|
|
(check-equal? (for-trie/set ([$x (make-trie 1 2 3)]
|
|
[(quasi-cons x 3)
|
|
(make-trie (quasi-cons 'x 'y)
|
|
(quasi-cons 5 5)
|
|
(quasi-cons 2 4)
|
|
(quasi-cons 3 3)
|
|
(quasi-cons 4 3))])
|
|
(cons x 4))
|
|
(set (cons 3 4)))
|
|
(check-equal? (for-trie/set ([(quasi-cons $x $x)
|
|
(make-trie 'a 'b
|
|
(quasi-cons 'x 'y)
|
|
(quasi-cons 2 3)
|
|
3 4
|
|
'x
|
|
(quasi-cons 1 1)
|
|
"abc"
|
|
(quasi-cons 'x 'x))])
|
|
x)
|
|
(set 1 'x))
|
|
(check-equal? (for-trie/set ([$x (make-trie 1 2 3)])
|
|
(void)
|
|
x)
|
|
(set 1 2 3))
|
|
(check-equal? (for-trie/fold ([acc 0])
|
|
([$x (make-trie 1 2 3)])
|
|
(void)
|
|
(+ acc x))
|
|
6)
|
|
;; projecting an infinite set out of an infinite trie raisies an error
|
|
(check-exn (lambda (e) (and (exn:fail? e) (not (exn:fail:contract? e))))
|
|
(lambda ()
|
|
(for-trie/list ([$x (pattern->trie 'x (projection->pattern ?))])
|
|
x)))
|
|
;; projecting something finite out is ok
|
|
(check-equal? (for-trie/list ([1 (pattern->trie 'x (projection->pattern ?))])
|
|
1)
|
|
(list 1))
|
|
(let ([a-set (mutable-set)])
|
|
;; for-trie results in (void)
|
|
(check-equal? (for-trie ([$x (make-trie 1 2 3 4)])
|
|
(set-add! a-set x))
|
|
(void))
|
|
;; for-trie runs body for effects
|
|
(check-equal? a-set (mutable-set 1 2 3 4)))
|
|
;; allow any number of #:where clauses
|
|
(check-equal? (for-trie/set ([$x (make-trie 1 2 3 4)]
|
|
#:where (even? x)
|
|
#:where #t
|
|
[$y (make-trie 3 4 5 6)]
|
|
#:where (< x y))
|
|
x)
|
|
(set 2 4))
|
|
#;(check-equal? (for-trie/set (#:where #t
|
|
[$x (make-trie 1 2 3 4)]
|
|
#:where (even? x)
|
|
#:where #t
|
|
[$y (make-trie 3 4 5 6)]
|
|
#:where (< x y))
|
|
x)
|
|
(set 2)))
|