Permalink
Browse files

added a 'default-reify' function that works for neq, symbolo, numbero…

…, and absento. also cleanup
  • Loading branch information...
calvis committed Apr 3, 2013
1 parent f6b3efe commit b44af8317e7815b6c3e3f87e2d1d52c1c0049de7
Showing with 44 additions and 55 deletions.
  1. +15 −28 absento.rkt
  2. +12 −6 ck.rkt
  3. +17 −21 neq.rkt
View
@@ -31,13 +31,9 @@
(findf (lambda (oc) (and (eq? (oc-rator oc) 'symbol-c)
(eq? (car (oc-rands oc)) v))) c)))
-(define (reify-symbol-cs v r c)
- (let ([c (filter (lambda (oc) (eq? (oc-rator oc) 'symbol-c)) c)])
- (let ([ocs (map (lambda (oc) (walk (car (oc-rands oc)) r)) c)])
- (let ([ocs (filter-not any/var? ocs)])
- (cond
- [(null? ocs) '()]
- [else `((sym . ,(sort (remove-duplicates ocs) lex<=)))])))))
+(define reify-symbol-cs
+ (default-reify 'sym '(symbol-c)
+ (lambda (rands) (remove-duplicates (map car rands)))))
;; numbero
@@ -65,13 +61,15 @@
(findf (lambda (oc) (and (eq? (oc-rator oc) 'number-c)
(eq? (car (oc-rands oc)) v))) c)))
-(define (reify-number-cs v r c)
- (let ([c (filter (lambda (oc) (eq? (oc-rator oc) 'number-c)) c)])
- (let ([ocs (map (lambda (oc) (walk (car (oc-rands oc)) r)) c)])
- (let ([ocs (filter-not any/var? ocs)])
- (cond
- [(null? ocs) '()]
- [else `((num . ,(sort (remove-duplicates ocs) lex<=)))])))))
+(define remove-duplicates
+ (lambda (l)
+ (for/fold ([s '()])
+ ([x l])
+ (if (member x s) s (cons x s)))))
+
+(define reify-number-cs
+ (default-reify 'num '(number-c)
+ (lambda (rands) (remove-duplicates (map car rands)))))
;; absento
@@ -127,16 +125,11 @@
(lambda (u t s c)
(cond
((unify `((,u . ,t)) s c) =>
- (lambda (s0) (eq? s0 s)))
+ (lambda (s^) (eq? s ^s)))
(else #f))))
-(define (reify-absent-cs v r c)
- (let ([c (filter (lambda (oc) (eq? (oc-rator oc) 'absent-c)) c)])
- (let ([ocs (map (lambda (oc) (walk* (oc-rands oc) r)) c)])
- (let ([ocs (filter-not any/var? ocs)])
- (cond
- [(null? ocs) '()]
- [else `((absento . ,(sort (remove-duplicates ocs) lex<=)))])))))
+(define reify-absent-cs
+ (default-reify 'absento '(absent-c) remove-duplicates))
(define (absento-split u v)
(lambdam@ (a : s c)
@@ -189,12 +182,6 @@
((== #f x) succeed)
((== #t x) succeed))))
-(define remove-duplicates
- (lambda (l)
- (for/fold ([s '()])
- ([x l])
- (if (member x s) s (cons x s)))))
-
;; ckanren stuffs
(extend-enforce-fns 'absento rerun-type-cs)
View
18 ck.rkt
@@ -15,7 +15,7 @@
gen:mk-struct recur constructor mk-struct? unifiable?
lex<= sort-by-lex<= reify-with-colon occurs-check
run-constraints build-attr-oc attr-oc? attr-oc-uw?
- get-attributes filter/rator filter-not/rator
+ get-attributes filter/rator filter-not/rator default-reify
(for-syntax build-srcloc))
;; == VARIABLES =================================================================
@@ -570,11 +570,17 @@
[else `(,v . ,(sort-store c^))])))))
;; runs all the reification functions
-(define run-reify-fns
- (lambda (v r c)
- (for/fold ([c^ `()])
- ([fn (map cdr (reify-fns))])
- (append (fn v r c) c^))))
+(define (run-reify-fns v r c)
+ (for/fold ([c^ `()])
+ ([fn (map cdr (reify-fns))])
+ (append (fn v r c) c^)))
+
+(define ((default-reify sym cs fn) v r c)
+ (let ((c (filter (lambda (oc) (memq (oc-rator oc) cs)) c)))
+ (let ((rands (filter-not any/var? (walk* (map oc-rands c) r))))
+ (cond
+ ((null? rands) `())
+ (else `((,sym . ,(sort (fn rands) lex<=))))))))
(define (sort-store c) (sort c lex<= #:key car))
View
38 neq.rkt
@@ -31,28 +31,16 @@
(define reify-prefix-dot (make-parameter #t))
-(define reify-constraintsneq
- (lambda (v r c)
- (let ((c (filter (lambda (oc) (eq? (oc-rator oc) '=/=neq-c)) c)))
- (let ((p* (walk* (map oc-prefix c) r)))
- (let ((p* (sort-p* (filter-not any/var? p*))))
- (cond
- ((null? p*) '())
- ((reify-prefix-dot) `((=/= . ,p*)))
- (else `((=/= . ,(map remove-dots p*))))))))))
-
(define (remove-dots p*)
- (map (lambda (p) (list (car p) (cdr p))) p*))
-
-(define (sort-p* p*)
- (sort-by-lex<=
- (map (lambda (p)
- (sort-by-lex<=
- (map (lambda (a)
- (let ([u (car a)] [v (cdr a)])
- (sort-diseq u v)))
- p)))
- p*)))
+ (cond
+ [(reify-prefix-dot) p*]
+ [else (map (lambda (p) (list (car p) (cdr p))) p*)]))
+
+(define (sort-ps p*)
+ (map (lambda (p)
+ (sort-by-lex<=
+ (map (lambda (a) (sort-diseq (car a) (cdr a))) p)))
+ p*))
(define (sort-diseq u v)
(cond
@@ -63,6 +51,14 @@
((lex<= u v) (cons u v))
(else (cons v u))))
+(define reify-constraintsneq
+ (default-reify
+ '=/=
+ '(=/=neq-c)
+ (lambda (rands)
+ (let ([p* (map car rands)])
+ (map remove-dots (sort-ps p*))))))
+
(define =/=neq-c
(lambda (p)
(lambdam@ (a : s c)

0 comments on commit b44af83

Please sign in to comment.