Thread View: comp.lang.misc
2 messages
2 total messages
Started by Vladimir Ivanovic
Tue, 25 Aug 1992 22:23
Constraint Programming Languages: Bertrand, etc.
Author: Vladimir Ivanovic
Date: Tue, 25 Aug 1992 22:23
Date: Tue, 25 Aug 1992 22:23
19 lines
1231 bytes
1231 bytes
In Wm Leler's book, "Constraint Programming Languages", the appendix gives
an interpreter written in Scheme for an augmented term rewriting system.
Can someone save me the typing (and the inevitable typos) and point me to a
copy?
In the Preface, Wm Leler give as his address P.O. Box 69044, Portland OR
97201 for inquiries on Bertrand, his general-purpose specification
language. Does anyone have experience with Bertrand and is the address
still good?
Many thanks for any information.
-- Vladimir
--
Vladimir G. Ivanovic Sun Microsystems, Inc
(415) 336-2315 MTV12-33
vladimir@Eng.Sun.COM 2550 Garcia Ave.
{decwrl,hplabs,ucbvax}!sun!Eng!vladimir Mountain View, CA 94043-1100
Disclaimer: I speak for myself.
Summary: Constraint Programming Languages: Bertrand, etc.
Author: Vladimir Ivanovic
Date: Fri, 28 Aug 1992 19:50
Date: Fri, 28 Aug 1992 19:50
640 lines
23149 bytes
23149 bytes
Apparently Wm (pronounced "Whim") Leler is now working at Ithaca Software
in Oakland, CA. Mail to wm@cse.ogi.edu bounced.
A copy of the augmented term rewriting system in the appendix of Leler's
book, "Constraint Programming Languages", Addison-Wesley, 1988, ISBN
0-201-06243-7 can be found in nexus.yorku.ca:/pub/scheme/scm/bevan.sha (a
shar file) in atr.scm. Also, below, I include the copies from weems and
then bernied.
Thanks to:
bernied@ncsa.uiuc.edu (Bernhard Damberger)
weems@cse.uta.edu (Bob Weems)
bevan@computer-science.manchester.ac.uk (Stephen J Bevan)
for doing the typing.
Enjoy!
-- Vladimir
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define constant? (lambda (x) (and (pair? x)
(eq? (car x) 'constant))))
(define parameter? (lambda (x) (and (pair? x)
(eq? (car x) 'parameter))))
(define typed? (lambda (x) (and (pair? x) (eq? (car x) 'typed))))
(define var? (lambda (x) (and (pair? x) (eq? (car x) 'var))))
(define term? (lambda (x) (and (pair? x) (eq? (car x) 'term))))
(define isis? (lambda (x) (and (pair? x) (eq? (car x) 'is))))
(define head (lambda (x) (vector-ref x 0))) ; head of rule
(define body (lambda (x) (vector-ref x 1))) ; body of rule
(define tag ; tag of rule
(lambda (x)
(if (=? (vector-length x) 3)
(vector-ref x 2)
#f))) ; return false if no tag
(define make-state (lambda (s g t n) (vector s g t n)))
(define subject (lambda (x) (vector-ref x 0)))
(define globals (lambda (x) (vector-ref x 1)))
(define typesp (lambda (x) (vector-ref x 2)))
(define newname (lambda (x) (vector-ref x 3)))
(define replace-s ; replace subject expression in state
(lambda (state new-subject)
(vector new-subject
(globals state)
(typesp state)
(newname state))))
(define replace-g ; replace globals in state
(lambda (state new-globals)
(vector (subject state)
new-globals
(typesp state)
(newname state))))
(define replace-t ; replace type space in state
(lambda (state new-typesp)
(vector (subject state)
(globals state)
new-typesp
(newname state))))
(define incr-n ; increment label generator in state
(lambda (state)
(vector (subject state)
(globals state)
(typesp state)
(+ 1 (newname state)))))
(define augmented-term-rewriter
(lambda (subject-exp rules)
(rewrite
(make-state ; state
subject-exp ; subject expression
init-phi ; initial global name space
init-phi ; initial type space
0) ; initial generated label name
rules))) ; rules
(define init-phi '((*reserved* . *reserved*)))
(define rewrite
(lambda (state rules)
(let ((no-bv-state (rewrite-globals state)))
(if no-bv-state ; bound var was found
(rewrite no-bv-state rules)
(let ((new-state (rewrite-exp state rules rules)))
(if new-state ; match (or "is") found
(rewrite new-state rules)
state))))))
(define rewrite-exp
(lambda (state rules-left-to-try rules)
(if (null? rules-left-to-try)
(rewrite-subexpressions state rules)
(let ((new-state (try-rule
state
(car rules-left-to-try))))
(if new-state
new-state
(rewrite-exp state
(cdr rules-left-to-try)
rules))))))
(define rewrite-subexpressions
(lambda (state rules)
(let ((expr (subject state)))
(cond ((constant? expr) #f)
((var? expr) #f)
((term? expr)
(rewrite-args (first3 expr)
(cdddr expr)
state
rules))
((isis? expr) (rewrite-is state))
(else (error "Invalid subject expression:"
expr))))))
(define rewrite-args
(lambda (previous-terms terms-to-try state rules)
(if (null? terms-to-try)
#f
(let ((new-state (rewrite-exp
(replace-s state (car terms-to-try))
rules rules)))
(if new-state
(replace-s
new-state
(append previous-terms
(cons (subject new-state)
(cdr terms-to-try))))
(rewrite-args
(append previous-terms
(list (car terms-to-try)))
(cdr terms-to-try) state rules))))))
(define first3 ; return the first 3 elements of a list
(lambda (alist)
(list (car alist) (cadr alist) (caddr alist))))
(define rewrite-is
(lambda (state)
(let ((expr) (subject state))
(space (globals state)))
(if (and (pair? (cdr expr)) ; two args?
(var? (cadr expr)) ; first is var?
(pair? (cddr expr)) ; second is expr?
(not (lookup (cdadr expr)
space)) ; var not bound?
(not (rewrite-globals ; var not in expr?
(make-state (caddr expr)
(bind (cdadr expr)
'()
init-phi 0))))
(replace-g (replace-s state true-expr)
(bind (cdadr expr) (caddr expr) space))
(error "invalid "is" expression:" expr)))))
(define true-expr '(expr (:) true))
(define try-rule
(lambda (state rule)
(let ((phi (match state (head rule) init-phi)))
(if phi
(let ((label (get-label (subject state)
(newname state))))
(replace-s
(bind-type
(if (eq? (last label) (newname state))
(incr-n state)
state)
rule label)
(transform (body rule) phi label)))
#f))))
(define match
(lambda (state pattern phi)
(let ((expr (subject state)))
(cond
((parameter? pattern) (bind (cadr pattern) expr phi))
((and (typed? pattern) (var? expr))
(let ((var-type (lookup (cdr expr) (typesp state))))
(if (and var-type
(memq var-type (cddr pattern)))
(bind (cadr pattern) expr phi)
#f)))
((and (typed? pattern) (constant? expr)
(eq? (caddr pattern) 'constant))
(bind (cadr pattern) expr phi))
((and (constant? pattern) (constant? expr)
(=? (cdr pattern) (cdr expr))) phi)
((and (term? pattern) (term? expr)
(eq? (caddr pattern) (caddr expr)))
(match-args (replace-s state (cdddr expr))
(cdddr pattern) phi))
((var? pattern)
(error "Local variable in head of rule"))
(else #f)))))
(define match-args
(lambda (state patterns phi)
(let ((args (subject state)))
(cond
((and (null? args) (null? patterns)) phi)
((null? args) #f)
((null? patterns) #f)
(else
(let ((new-phi (match (replace-s state (car args))
(car patterns) phi)))
(if new-phi
(match-args (replace-s state (cdr args))
(cdr patterns) new-phi)
#f)))))))
(define get-label
(lambda (expr lgen)
(if (eq? (last (cadr expr)) ':)
(replace-last (cadr expr) lgen)
(cadr expr))))
(define last ; return the last element of a proper list
(lambda (lst)
(if (pair? lst)
(if (null? (cdr lst))
(car lst)
(last (cdr lst)))
(error "Cannot return last element of atom:" lst))))
(define replace-last ; replace the last element of a list
(lambda (lst val)
(if (and (pair? lst) (null? (cdr lst)))
(list val)
(cons (car lst) (replace-last (cdr lst) val)))))
(define bind-type
(lambda (state rule label)
(let ((rule-tag (tag rule)))
(if rule-tag
(replace-t state
(bind label rule-tag (typesp state)))
state))))
(define transform
(lambda (rule-body phi label)
(cond
((parameter? rule-body)
(let ((param-val (lookup (cadr rule-body) phi)))
(if param-val
(if (=? (length (cdr rule-body)) 1)
param-val ; not qualified parameter
(if (var? param-val)
(cons (car param-val)
(append (cdr param-val)
(cddr rule-body)))
(error
"A qualified parameter matched a "
"non-variable:"
param-val)))
(error "Parameter in body that is not in head:"
rule-body))))
((var? rule-body)
(cons (car rule-body) (append label (cdr rule-body))))
((constant? rule-body) rule-body)
((term? rule-body)
(append (list
(car rule-body) ; 'term
(append label (cadr rule-body))
(caddr rule-body))
(transform-args (cdddr rule-body) phi label)))
((isis? rule-body)
(cons (car rule-body)
(transform-args (cdr rule-body) phi label)))
(else (error "Invalid body of rule:" rule-body)))))
(define transform-args
(lambda (args phi label)
(if (null? args)
'()
(cons (transform (car args) phi label)
(transform-args (cdr args) phi label)))))
(define bind
(lambda (var val name-space)
(cons (cons var val) name-space)))
(define lookup
(lambda (var name-space)
(let ((entry (assoc var name-space)))
(if entry
(cdr entry)
#f))))
(define rewrite-globals
(lambda (state)
(let ((expr (subject state))
(space (globals state)))
(cond
((var? expr)
(let ((val (lookup (cdr expr) (globals state))))
(if val ; variable is bound
(replace-s state val) ; replace by value
#f)))
((constant? expr) #f)
((term? expr)
(rewrite-g-args (first3 expr) (cdddr expr) state))
((isis? expr)
(rewrite-g-args (list (car expr)) (cdr expr) state))
(else (error "invalid subject expression:" expr))))))
(define rewrite-g-args
(lambda (previous-terms terms state)
(if (null? terms)
#f
(let ((new-state (rewrite-globals
(replace-s state (car terms)))))
(if new-state
(replace-s new-state
(append previous-terms
(cons (subject new-state)
(cdr terms))))
(rewrite-g-args
(append previous-terms (list (car terms)))
(cdr terms) state))))))
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;---------------------------------------------------------------------
; This is an Augmented Term Rewriter. It is taken out of appendix C
; in Wm Leler's "Constraint Programming Languages"
; This is untested. bhd: 4/23/92
;---------------------------------------------------------------------
(define constant? (lambda (x) (and (pair? x) (eq? (car x) 'constant))))
(define parameter? (lambda (x) (and (pair? x) (eq? (car x) 'parameter))))
(define typed? (lambda (x) (and (pair? x) (eq? (car x) 'typed))))
(define var? (lambda (x) (and (pair? x) (eq? (car x) 'var))))
(define term? (lambda (x) (and (pair? x) (eq? (car x) 'term))))
(define isis? (lambda (x) (and (pair? x) (eq? (car x) 'is))))
(define head (lambda (x) (vector-ref x 0))) ; head of rule
(define body (lambda (x) (vector-ref x 1))) ; body of rule
(define tag
(lambda (x)
(if (=? (vector-length x) 3)
(vector-ref x 2)
#f))) ; return false if no tag
(define make-state (lambda (s g t n) (vector s g t n)))
(define subject (lambda (x) (vector-ref x 0)))
(define globals (lambda (x) (vector-ref x 1)))
(define typesp (lambda (x) (vector-ref x 2)))
(define newname (lambda (x) (vector-ref x 3)))
(define replace-s
(lambda (state new-subject)
(vector new-subject
(globals state)
(typesp state)
(newname state))))
(define replace-g
(lambda (state new-globals)
(vector (subject state)
new-globals
(typesp state)
(newname state))))
(define replace-t
(lambda (state new-typesp)
(vector (subject state)
(globals state)
new-typesp
(newname state))))
(define incr-n
(lambda (state)
(vector (subject state)
(globals state)
(typesp state)
(+ 1 (newname state)))))
(define augmented-term-rewriter
(lambda (subject-exp rules)
(rewrite
(make-state
subject-exp
init-phi
init-phi
0)
rules)))
(define init-phi '((*reserved* . *reserved*)))
(define rewrite
(lambda (state rules)
(let ((no-bv-state (rewrite-globals state)))
(if no-bv-state
(rewrite no-bv-state rules)
(let ((new-state (rewrite-exp state rules rules)))
(if new-state
(rewrite new-state rules)
state))))))
(define rewrite-exp
(lambda (state rules-left-to-try rules)
(if (null? rules-left-to-try)
(rewrite-subexpressions state rules)
(let ((new-state (try-rule
state
(car rules-left-to-try))))
(if new-state
new-state
(rewrite-exp state
(cdr rules-left-to-try)
rules))))))
(define rewrite-subexpressions
(lambda (state rules)
(let ((expr (subject state)))
(cond ((constant? expr) #f)
((var? expr) #f)
((term? expr)
(rewrite-args (first3 expr)
(cdddr expr)
state
rules))
((isis? expr) (rewrite-is state))
(else (error "Invalid subject expression:"
expr))))))
(define rewrite-args
(lambda (previous-terms terms-to-try state rules)
(if (null? terms-to-try)
#f
(let ((new-state (rewrite-exp
(replace-s state (car terms-to-try))
rules rules)))
(if new-state
(replace-s
new-state
(append previous-terms
(cons (subject new-state)
(cdr terms-to-try))))
(rewrite-args
(append previous-terms
(list (car terms-to-try)))
(cdr terms-to-try) state rules))))))
(define first3
(lambda (alist)
(list (car alist) (cadr alist) (caddr alist))))
(define rewrite-is
(lambda (state)
(let ((expr (subject state))
(space (globals state)))
(if (and (pair? (cdr expr))
(var? (cadr expr))
(pair? (cddr expr))
(not (lookup (cdadr expr)
space))
(not (rewrite-globals
(make-state (caddr expr)
(bind (cdadr expr)
'()
init-phi)
init-phi 0))))
(replace-g (replace-s state true-expr)
(bind (cdadr expr) (caddr expr) space))
(error "invalid "is" expression:" expr)))))
(define true-expr '(expr (:) true))
(define try-rule
(lambda (state rule)
(let ((phi (match state (head rule) init-phi)))
(if phi
(let ((label (get-label (subject state)
(newname state))))
(replace-s
(bind-type
(if (eq? (last label) (newname state))
(incr-n state)
state)
rule label)
(transform (body rule) phi label)))
#f))))
(define match
(lambda (state pattern phi)
(let ((expr (subject state)))
(cond
((parameter? pattern) (bind (cadr pattern) expr phi))
((and (typed? pattern) (var? expr))
(let ((var-type (lookup (cdr expr) (typesp state))))
(if (and var-type
(memq var-type (cddr pattern)))
(bind (cadr pattern) expr phi)
#f)))
((and (typed? pattern) (constant? expr)
(eq? (caddr pattern) 'constant))
(bind (cadr pattern) expr phi))
((and (constant? pattern) (constant? expr)
(=? (cdr pattern) (cdr expr))) phi)
((and (term? pattern) (term? expr)
(eq? (caddr pattern) (caddr expr)))
(match-args (replace-s state (cdddr expr))
(cdddr pattern) phi))
((var? pattern)
(error "Local variable in head of rule"))
(else #f)))))
(define get-label
(lambda (expr lgen)
(if (eq? (last (cadr expr)) ':)
(replace-last (cadr expr) lgen)
(cadr expr))))
(define last
(lambda (lst)
(if (pair? lst)
(if (null? (cdr lst))
(car lst)
(last (cdr lst)))
(error "Cannot return last element of atom:" lst))))
(define replace-last
(lambda (lst val)
(if (and (pair? lst) (null? (cdr lst)))
(list val)
(cons (car lst) (replace-last (cdr lst) val)))))
(define bind-type
(lambda (state rule label)
(let ((rule-tag (tag rule)))
(if rule-tag
(replace-t state
(bind label rule-tag (typesp state)))
state))))
(define transform
(lambda (rule-body phi label)
(cond
((parameter? rule-body)
(let ((param-val (lookup (cadr rule-body) phi)))
(if param-val
(if (=? (length (cdr rule-body)) 1)
param-val
(if (var? param-val)
(cons (car param-val)
(append (cdr param-val)
(cddr rule-body)))
(error
"A qualified parameter "
"matched a non-variable:"
param-val)))
(error "Parameter in body that is not in head:"
rule-body))))
((var? rule-body)
(cons (car rule-body) (append label (cdr rule-body))))
((constant? rule-body) rule-body)
((term? rule-body)
(append (list
(car rule-body)
(append label (cadr rule-body))
(caddr rule-body))
(transform-args (cdddr rule-body) phi label)))
((isis? rule-body)
(cons (car rule-body)
(transform-args (cdr rule-body) phi label)))
(else (error "Invalid body of rule:" rule-body)))))
(define transform-args
(lambda (args phi label)
(if (null? args)
'()
(cons (transform (car args) phi label)
(transform-args (cdr args) phi label)))))
(define bind
(lambda (var val name-space)
(cons (cons var val) name-space)))
(define lookup
(lambda (var name-space)
(let ((entry (assoc var name-space)))
(if entry
(cdr entry)
#f))))
(define rewrite-globals
(lambda (state)
(let ((expr (subject state))
(space (globals state)))
(cond
((var? expr)
(let ((val (lookup (cdr expr) (globals state))))
(if val
(replace-s state val)
#f)))
((constant? expr) #f)
((term? expr)
(rewrite-g-args (first3 expr) (cdddr expr) state))
((isis? expr)
(rewrite-g-args (list (car expr)) (cdr expr) state))
(else (error "invalid subject expression:" expr))))))
(define rewrite-g-args
(lambda (previous-terms terms state)
(if (null? terms)
#f
(let ((new-state (rewrite-globals
(replace-s state (car terms)))))
(if new-state
(replace-s new-state
(append previous-terms
(cons (subject new-state)
(cdr terms))))
(rewrite-g-args
(append previous-terms (list (car terms)))
(cdr terms) state))))))
-----
Have a bajillion brilliant Jobsian lithium licks.
Bernhard Damberger
bernied@ncsa.uiuc.edu
--
Vladimir G. Ivanovic Sun Microsystems, Inc
(415) 336-2315 MTV12-33
vladimir@Eng.Sun.COM 2550 Garcia Ave.
{decwrl,hplabs,ucbvax}!sun!Eng!vladimir Mountain View, CA 94043-1100
Disclaimer: I speak for myself.
Thread Navigation
This is a paginated view of messages in the thread with full content displayed inline.
Messages are displayed in chronological order, with the original post highlighted in green.
Use pagination controls to navigate through all messages in large threads.
Back to All Threads