trying out a bidirectional nondeterministic substitution evaluator

sub-eval.scm

;; todo: variable constrainns throughout whole sub-eval
;;       avoid infinite wildcard vars!!
;;       figure out the perfect eval order...
;;       how to handle infinite recursive rules?
;;       inductive programming ? ?

;; return possible evaluations by substitution of expression according to rules
(define (sub-eval expression rules direction)
  (let ((subs (sub expression rules direction)))
    (if (not (null? subs))
      (apply append (map (lambda (sub) (sub-eval sub rules direction)) subs))
      (list expression))))

;; return the list of possible single substitutions for expression against list of rules
(define (sub expression rules direction)
  (let ((matches (match expression rules direction)))
    (if (null? matches)
      (if (or (list? expression) (pair? expression))
        (sub-parts expression rules direction)
	'())
      matches)))

;; return the possible substitutions by checking the first item in expression that matches
(define (sub-parts expression rules direction)
  (if (or (list? expression) (pair? expression))
    (if (null? expression)
      '()
      (let ((matches (sub (car expression) rules direction)))
        (if (not (null? matches))
          (map (lambda (match) (cons match (cdr expression))) matches)
          (let ((rest-matches (sub-parts (cdr expression) rules direction)))
            (if (not (null? rest-matches))
	      (map (lambda (match) (cons (car expression) match)) rest-matches)
              '())))))
    (sub expression rules direction)))

;; return matches of expression against list of rules
(define (match expression rules direction)
  (let ((selectors (cond ((eq? direction 'left->right) (cons car cadr))
                         ((eq? direction 'right->left) (cons cadr car)))))
    (map (lambda (match)
	   ((cdr selectors) (sub-vars (car match) (cdr match))))
	 (filter (lambda (match)
		   (cdr match))
		 (map (lambda (rule)
			(cons rule (var-match expression ((car selectors) rule))))
		      rules)))))

;; replace var symbolse in expression according to alist of vars
(define (sub-vars expression vars)
  (if (list-or-pair? expression)
    ;; match lists that aren't empty
    (cons (sub-vars (car expression) vars) (sub-vars (cdr expression) vars))
    ;; match primitive
    (let ((v (assoc expression vars)))
      (if v (cdr v) expression))))

;; does a symbol represent a variable? (starts with ?)
(define (var? s)
  (and (symbol? s) (char=? (car (string->list (symbol->string s))) #\?)))

;; is it either a list or a pair?
;; and if its a list, it cant be empty
(define (list-or-pair? a)
  (or (and (list? a) (not (null? a))) (pair? a)))

;; list all pairs of items in a and b
(define (combinations a b)
  (apply append (map (lambda (a)
		       (map (lambda (b) 
			      (cons a b)) b)) a)))

;; do two sets of var bindings contradict?
(define (contradict? a b)
  (fold (lambda (a b) (or a b)) #f
	(map (lambda (pair)
	       (and (eq? (caar pair) (cadr pair))
		    (not (eq? (car pair) (cdr pair)))))
	     (combinations a b))))

;; same as below but returns alist of bindings if does match, else false
;; this could probably be written better
;; vars is a list of vars that cant be contradicted
(define (var-match a b)
  (if (and (or (var? a) (var? b)) (not (eq? a b)))
    (append (if (var? a) (list (cons a b)) '())
	    (if (var? b) (list (cons b a)) '()))
    (if (and (list-or-pair? a) (list-or-pair? b))
      ;; match lists that aren't empty
      (let ((head (var-match (car a) (car b)))
            (tail (var-match (cdr a) (cdr b))))
        (if (and head tail (not (contradict? head tail))) (append head tail) #f))
      ;; match primitive
      (if (eq? a b) '() #f))))

;; check if expression a matches expression b with ?vars okay
(define (var-match? a b)
  (if (and (list-or-pair? a) (list-or-pair? b)
	   (not (null? a)) (not (null? b)))
    ;; match lists that aren't empty
    (and (var-match? (car a) (car b))
	 (var-match? (cdr a) (cdr b)))
    ;; match primitive
    (or (var? a) (var? b) (eq? a b))))

;; check if expression a literally matches expression b
(define (match? a b)
  (if (and (list-or-pair? a) (list-or-pair? b)
	   (not (null? a)) (not (null? b)))
    ;; match lists that aren't empty
    (and (match? (car a) (car b))
	 (match? (cdr a) (cdr b)))
    ;; match primitive
    (eq? a b)))

(define rules '(((sentence (noun-phrase . ?np) (predicate . ?pr))
		 (++ (noun-phrase . ?np) (predicate . ?pr)))
		((noun-phrase (modifier . ?m) (noun . ?n))
		 (++ (modifier . ?m) (noun . ?n)))
		((predicate (verb . ?v) (noun-phrase . ?o))
		 (++ (verb . ?v) (noun-phrase . ?o)))
		((modifier "the") (string "the"))
		((modifier "a") (string "a"))
		((noun "cat") (string "cat"))
		((noun "dog") (string "dog"))
		((verb "pats") (string "pats"))
		((verb "eats") (string "eats"))))

(display (sub-eval
	   '(sentence ? (predicate (verb "pats") ?))
	   rules 'left->right))
;(newline)
;(display (sub-eval
;	   '(++ (++ (modifier "a") (noun "dog")) (++ (string "pats") (++ (string "a") (string "dog"))))
;	   rules 'right->left))
;(display (sub-eval '(++ (string "the") ?o) rules 'right->left))
; infinite matching is an issue.........

;(display (sub '(noun . ?) rules 'left->right))
;(display (var-match? '(a ?b) '(a 2)))
;(display (var-match '(?b . 8) '?a))
;(display (sub-vars '(a . ?u) '((?u . 4))))
;(display (var-match '(a b a) '(a ?a ?a)))
;(display (combinations '(1 2 3) '(4 5 6)))
;(display (contradict? '((a . 4) (c . 1)) '((a . 4))))
;(display (sub-vars '(a b ?u) '((?u . (3 ?u)))))