Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

alpha-renaming oc procs

  • Loading branch information...
commit 47783626072a93c58e50f34fb0f4b18a21d644be 1 parent 31a9156
@calvis authored
View
14 ak.rkt
@@ -11,17 +11,17 @@
(fresh-aux nom (n ...) g g* ...))
(define (sus-constrained? x oc)
- (and (eq? (oc->rator oc) 'sus-c)
+ (and (eq? (oc-rator oc) 'sus-c)
(eq? (sus-constraint-v oc) x)))
-(define (sus-constraint-v oc) (car (oc->rands oc)))
+(define (sus-constraint-v oc) (car (oc-rands oc)))
(define (sus? x)
(and (pair? x) (eq? (car x) 'sus)))
(define (get-sus x c)
(let ((oc (findf (lambda (oc) (sus-constrained? x oc)) c)))
- (and oc (cons 'sus (oc->rands oc)))))
+ (and oc (cons 'sus (oc-rands oc)))))
(define (sus-v s) (cadr s))
(define (sus-pi s) (caddr s))
@@ -269,7 +269,7 @@
(else t))))
(define (alpha-constraint? oc)
- (memq (oc->rator oc) '(sus-c hash-c)))
+ (memq (oc-rator oc) '(sus-c hash-c)))
(define (reify-alpha-constraints v r c)
(let ((c (filter alpha-constraint? c)))
@@ -286,10 +286,10 @@
(else c^))))
(define (reify-oc oc r)
- (case (oc->rator oc)
+ (case (oc-rator oc)
((hash-c)
- (let ((lhs (car (oc->rands oc)))
- (rhs (cadr (oc->rands oc))))
+ (let ((lhs (car (oc-rands oc)))
+ (rhs (cadr (oc-rands oc))))
(let ((rhs (if (sus? rhs) (cadr rhs) rhs)))
(let ((lhs (reify-cvar lhs r))
(rhs (reify-cvar rhs r)))
View
16 ck.rkt
@@ -6,7 +6,7 @@
;; framework for defining constraints
update-s update-c make-a any/var? prefix-s prtm
lambdam@ identitym composem goal-construct ext-c
- build-oc oc->proc oc->rands oc->rator run run* prt
+ build-oc oc-proc oc-rands oc-rator run run* prt
extend-enforce-fns extend-reify-fns goal? a?
walk walk* var? lambdag@ mzerog unitg onceo fresh-aux
conde conda condu ifa ifu project fresh succeed fail
@@ -373,7 +373,7 @@
(lambda (oc)
(lambdam@ (a : s c)
(cond
- ((any/var? (oc->rands oc))
+ ((any/var? (oc-rands oc))
(make-a s (ext-c oc c)))
(else a)))))
@@ -428,11 +428,10 @@
;; contains a closure waiting to be evaluated with a new package,
;; a symbolic representation of the constrant's name and it's args
(struct oc (proc rator rands)
+ #:extra-constructor-name make-oc
#:methods gen:custom-write
[(define (write-proc . args) (apply write-oc args))])
-(define make-oc oc)
-
(define (write-oc oc port mode)
(define fn (lambda (str) ((parse-mode mode) str port)))
(fn (format "(~a" (oc-rator oc)))
@@ -440,11 +439,6 @@
(fn (format " ~a" arg)))
(fn (format ")")))
-;; accessors
-(define oc->proc oc-proc)
-(define oc->rator oc-rator)
-(define oc->rands oc-rands)
-
;; creates an oc given the constraint operation and it's args
(define-syntax (build-oc x)
(syntax-case x ()
@@ -461,7 +455,7 @@
(define (run-constraints x* c)
(for/fold ([rest identitym])
([oc c]
- #:when (any-relevant/var? (oc->rands oc) x*))
+ #:when (any-relevant/var? (oc-rands oc) x*))
(composem rest (rem/run oc))))
;; removes a constraint from the constraint store and then
@@ -471,7 +465,7 @@
(lambdam@ (a : s c)
(cond
((memq oc c)
- ((oc->proc oc)
+ ((oc-proc oc)
(make-a s (remq oc c))))
(else a))))
View
14 fd.rkt
@@ -58,7 +58,7 @@
(lambda (x c)
(cond
((findf (existing-domain x) c)
- => (lambda (oc) (cadr (oc->rands oc))))
+ => (lambda (oc) (cadr (oc-rands oc))))
(else #f))))
(define process-dom
@@ -255,8 +255,8 @@
(process-dom v new-v-dom))))))))
(define (enforce-constraintsfd x)
- (define (domfd-c? oc) (eq? (oc->rator oc) 'domfd-c))
- (define (domfd-c->var domfd-c) (car (oc->rands domfd-c)))
+ (define (domfd-c? oc) (eq? (oc-rator oc) 'domfd-c))
+ (define (domfd-c->var domfd-c) (car (oc-rands domfd-c)))
(fresh ()
(force-ans x)
(lambdag@ (a : s c)
@@ -266,12 +266,12 @@
(define fd-cs '(=/=fd-c distinctfd-c distinct/fd-c
<=fd-c =fd-c plusfd-c timesfd-c))
-(define (fd-c? oc) (memq (oc->rator oc) fd-cs))
+(define (fd-c? oc) (memq (oc-rator oc) fd-cs))
(define (verify-all-bound s c bound-x*)
(define (bound? x) (memq x bound-x*))
(for ([oc c] #:when (fd-c? oc))
- (define oc-vars (filter var? (oc->rands oc)))
+ (define oc-vars (filter var? (oc-rands oc)))
(cond
((findf (compose not bound?) oc-vars)
=> (lambda (x)
@@ -295,8 +295,8 @@
(else (cons (car ls) (list-insert pred x (cdr ls))))))
(define ((existing-domain x) oc)
- (and (eq? (oc->rator oc) 'domfd-c)
- (eq? (car (oc->rands oc)) x)))
+ (and (eq? (oc-rator oc) 'domfd-c)
+ (eq? (car (oc-rands oc)) x)))
;;;
View
12 neq.rkt
@@ -25,16 +25,16 @@
;;; serious functions
-(define oc->prefix
+(define oc-prefix
(lambda (oc)
- (car (oc->rands oc))))
+ (car (oc-rands oc))))
(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 ((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*) '())
@@ -74,9 +74,9 @@
((null? c)
(let ((c^ (ext-c (build-oc =/=neq-c p) c^)))
(make-a s c^)))
- ((eq? (oc->rator (car c)) '=/=neq-c)
+ ((eq? (oc-rator (car c)) '=/=neq-c)
(let* ((oc (car c))
- (p^ (oc->prefix oc)))
+ (p^ (oc-prefix oc)))
(cond
((subsumes? p^ p) a)
((subsumes? p p^) (loop (cdr c) c^))
View
6 never-true.rkt
@@ -35,7 +35,7 @@
(lambda (x)
(goal-construct
(lambdam@ (a : s c)
- (and (not (findf (lambda (oc) (eq? 'required-c (oc->rator oc))) c))
+ (and (not (findf (lambda (oc) (eq? 'required-c (oc-rator oc))) c))
a)))))
(define allowedo
@@ -52,8 +52,8 @@
(define reified-allowed
(lambda (v r c)
- (let ((c (filter (lambda (oc) (eq? (oc->rator oc) 'allowed-c)) c)))
- (let ((c (walk* (map oc->rands c) r)))
+ (let ((c (filter (lambda (oc) (eq? (oc-rator oc) 'allowed-c)) c)))
+ (let ((c (walk* (map oc-rands c) r)))
(if (null? c) `() `((allowed . ,c)))))))
(extend-enforce-fns 'required required-enforceo)
View
4 pref.rkt
@@ -50,10 +50,10 @@
(loop
(map
(lambda (oc)
- (let ((p (oc->rands oc)))
+ (let ((p (oc-rands oc)))
(cons (car p) (cadr p))))
(filter
- (lambda (oc) (eq? (oc->rator oc) 'prefo-c))
+ (lambda (oc) (eq? (oc-rator oc) 'prefo-c))
c))))
a))))
Please sign in to comment.
Something went wrong with that request. Please try again.