NetNews Usenet Archive 1992 #19/NN_1992_19.iso/spool/comp/lang/misc/2800

Internet Message Format | 1992-08-29 | 22.0 KB

Path: sparky!uunet!usc!elroy.jpl.nasa.gov!ames!sun-barr!news2me.ebay.sun.com!exodus.Eng.Sun.COM!exodus!vladimir
From: [e-mail] (Vladimir Ivanovic)
Newsgroups: comp.lang.misc
Subject: Summary: Constraint Programming Languages: Bertrand, etc.
Date: 28 Aug 92 19:50:12
Organization: Sun Microsystems, Inc.
Lines: 640
Message-ID: <[e-mail]>
References: <[e-mail]>
NNTP-Posting-Host: cocteau
In-reply-to: [e-mail]'s message of 25 Aug 92 22:23:04

Apparently Wm (pronounced "Whim") Leler is now working at Ithaca Software
in Oakland, CA.  Mail to [e-mail] 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:

    [e-mail] (Bernhard Damberger)
    [e-mail] (Bob Weems)
    [e-mail] (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
[e-mail]

--
Vladimir G. Ivanovic                            Sun Microsystems, Inc
[phone]                                  MTV12-33
[e-mail]                            2550 Garcia Ave.
{decwrl,hplabs,ucbvax}!sun!Eng!vladimir         Mountain View, CA 94043-1100
                         Disclaimer: I speak for myself.