suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

redex: favor recursive rules above the bound

Browse Source
This commit is contained in:
Burke Fetscher 2014-09-16 14:19:12 -05:00
parent a3412354b8
commit a3e00ac87c
1 changed files with 26 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
pkgs/redex-pkgs/redex-lib/redex/private/search.rkt
View File

@ -72,9 +72,10 @@
(fresh-pat-vars input (make-hash)) (fresh-pat-vars input (make-hash))
(set! name-nums (unique-name-nums))))) (set! name-nums (unique-name-nums)))))
(define fs (list (fail-cont empty-env (define fs (list (fail-cont empty-env
(list (make-partial-rule fresh-pat (if (shuffle-clauses?) (list (make-partial-rule fresh-pat
(shuffle clauses) (if (shuffle-clauses?)
(order-clauses clauses)) (shuffle/favor-recursive-clauses clauses)
(order-clauses clauses))
'() bound)) '() bound))
bound))) bound)))
(define v-locs (make-hash)) (define v-locs (make-hash))
@ -159,7 +160,7 @@
(make-partial-rule (prem-pat prem) (make-partial-rule (prem-pat prem)
(if (positive? bound) (if (positive? bound)
(if (shuffle-clauses?) (if (shuffle-clauses?)
(shuffle prem-cls) (shuffle/favor-recursive-clauses clauses)
(order-clauses prem-cls)) (order-clauses prem-cls))
(order-clauses prem-cls)) (order-clauses prem-cls))
(cons n tr-loc) (cons n tr-loc)
@ -170,23 +171,31 @@
new-fringe new-fringe
(cons (fail-cont env failure-fringe bound) fail))])])) (cons (fail-cont env failure-fringe bound) fail))])]))
(define (shuffle/favor-recursive-clauses cs)
(define candidates (apply append
(for/list ([c (in-list cs)])
(make-list (add1 (length (clause-prems c))) c))))
(let loop ([candidates candidates])
(cond
[(null? candidates) null]
[else
(define selected (list-ref candidates (random (length candidates))))
(cons selected (loop (remove* (list selected) candidates)))])))
(define (order-clauses cs) (define (order-clauses cs)
(define num-prems->cs (hash)) (define num-prems->cs (make-hash))
(for ([c cs]) (for ([c (in-list cs)])
(set! num-prems->cs (hash-set! num-prems->cs
(hash-set num-prems->cs (length (clause-prems c))
(length (clause-prems c)) (set-add
(set-add (hash-ref num-prems->cs
(hash-ref num-prems->cs (length (clause-prems c))
(length (clause-prems c)) (set))
(λ () (set))) c)))
c))))
(apply append (apply append
(for/list ([k (sort (hash-keys num-prems->cs) <)]) (for/list ([k (in-list (sort (hash-keys num-prems->cs) <))])
(shuffle (set->list (hash-ref num-prems->cs k)))))) (shuffle (set->list (hash-ref num-prems->cs k))))))
(define (do-unification clse input env) (define (do-unification clse input env)
(match-define (clause head-pat eq/dqs prems lang name) clse) (match-define (clause head-pat eq/dqs prems lang name) clse)
(clause head-pat eq/dqs prems lang name) (clause head-pat eq/dqs prems lang name)