summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorWei Tang <i@null.tl>2015-09-09 16:53:13 +0800
committerWei Tang <i@null.tl>2015-09-09 16:53:13 +0800
commit693dc0f3cac9f82e1d637187166e42adce00d696 (patch)
treebea3de31486425abd3155c40872e0c505b5869a8
parent970d4647959f98c418491d228b601e9476ae0d9e (diff)
downloadmm-693dc0f3cac9f82e1d637187166e42adce00d696.tar.gz
mm-693dc0f3cac9f82e1d637187166e42adce00d696.tar.bz2
optimize mm speed
-rw-r--r--mm.rkt70
1 files changed, 47 insertions, 23 deletions
diff --git a/mm.rkt b/mm.rkt
index f93cd93..7bd8350 100644
--- a/mm.rkt
+++ b/mm.rkt
@@ -5,6 +5,21 @@
(provide (all-defined-out))
(require test-engine/racket-tests)
+(define listo
+ (lambda (l)
+ (conde
+ ((== l '()))
+ ((fresh (f r)
+ (== `(,f . ,r) l))))))
+
+(check-expect
+ (run* (q) (listo '()))
+ '(_.0))
+
+(check-expect
+ (run* (q) (listo '(a b c)))
+ '(_.0))
+
(define varo*
(lambda (x out)
(== `(variable ,x) out)))
@@ -230,23 +245,31 @@
(run* (q) (patterno '((param x)) '(== (param x) 1) q))
'((pattern ((param x)) (== (param x) 1))))
+(define apply-listo
+ (lambda (value params out)
+ (conde
+ ((== '() value) (== '() out))
+ ((fresh (f r outf outr)
+ (== `(,f . ,r) value)
+ (apply-atomo f params outf)
+ (apply-listo r params outr)
+ (== `(,outf . ,outr) out))))))
+
+(define apply-atomo
+ (lambda (value params out)
+ (conde
+ ((not-paramo value)
+ (== value out))
+ ((paramo value)
+ (lookup-failbacko value params out)))))
+
(define apply-valueo
(lambda (value params out)
(conde
- ((paramo value)
- (lookup-failbacko value params out))
- ((not-paramo value)
- (conde
- ((== '() value))
- ((symbolo value))
- ((numbero value)))
- (== value out))
- ((not-paramo value)
- (fresh (f r outf outr)
- (== `(,f . ,r) value)
- (apply-valueo f params outf)
- (apply-valueo r params outr)
- (== `(,outf . ,outr) out))))))
+ ((paramo value) (apply-atomo value params out))
+ ((not-paramo value) (symbolo value) (apply-atomo value params out))
+ ((not-paramo value) (numbero value) (apply-atomo value params out))
+ ((not-paramo value) (listo value) (apply-listo value params out)))))
(check-expect
(run* (q) (apply-valueo '(param x) '(((param x) (variable x))) q))
@@ -260,15 +283,15 @@
(lambda (predicate pattern-assoc params fresh-next fresh-next-out out)
(conde
((fresh (builtin s1 s2 o1 o2)
+ (conde
+ ((== 'disj builtin))
+ ((== 'conj builtin))
+ ((== '== builtin)))
(== `(,builtin ,s1 ,s2) predicate)
(== `(,builtin ,o1 ,o2) out)
(apply-valueo s1 params o1)
(apply-valueo s2 params o2)
- (== fresh-next fresh-next-out)
- (conde
- ((== '== builtin))
- ((== 'conj builtin))
- ((== 'disj builtin)))))
+ (== fresh-next fresh-next-out)))
((fresh (fvar fparam fpredicate new-params new-fresh-next)
(== `(fresh ,fparam ,fpredicate) predicate)
(varo* fresh-next fvar)
@@ -320,13 +343,14 @@
((predicateo s2 pattern-assoc)))))
((fresh (selbri args pattern pv pp a-params)
(== `(,selbri . ,args) p)
+ (=/= selbri '==)
+ (=/= selbri 'conj)
+ (=/= selbri 'disj)
+ (=/= selbri 'fresh)
(lookupo selbri pattern-assoc pattern)
(patterno pv pp pattern)
(predicateo pp pattern-assoc)
- (zipo pv args a-params)
- (=/= selbri '==)
- (=/= selbri 'conj)
- (=/= selbri 'disj))))))
+ (zipo pv args a-params))))))
(check-expect
(run* (q) (predicateo '(== 1 1) '()))