Constraint Programming Languages: Bertrand, etc. 
Author Message
 Constraint Programming Languages: Bertrand, etc.

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

{decwrl,hplabs,ucbvax}!sun!Eng!vladimir         Mountain View, CA 94043-1100
                         Disclaimer: I speak for myself.



Sun, 12 Feb 1995 06:23:04 GMT  
 Constraint Programming Languages: Bertrand, etc.
Apparently Wm (pronounced "Whim") Leler is now working at Ithaca Software

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:




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
...

read more »



Wed, 15 Feb 1995 03:50:12 GMT  
 
 [ 3 post ] 

 Relevant Pages 

1. For the use of programming language Bertrand

2. CFP: DIPLCL99 - International Workshop on Distributed and Internet Programming with Logic and Constraint Languages

3. CFP: Workshop on Parallelism and Implementation Technology for (Constraint) Logic Programming Languages

4. New Release of Constraint Logic Programming language, CLP(R)

5. State of the art in constraint programming languages

6. New Release of Constraint Logic Programming language, CLP(R)

7. CFP: MultiCPL'03 - WS on Multiparadigm Constraint Programming Languages

8. CFP: DIPLCL99 - International Workshop on Distributed and Internet Programming with Logic and Constraint Languages -

9. CFP: Workshop on Parallelism and Implementation Technology for (Constraint) Logic Programming Languages

10. New Release of Constraint Logic Programming language, CLP(R)

11. Seeking a constraint logic programming language for Apollo, Mac II or Sun

12. FS: "Eiffel, The Language", book by Bertrand Meyer on eBay

 

 
Powered by phpBB® Forum Software