;;; Answers to Problem Set #3: Pattern Matching, Unification, and Logic Programming
;;; ===============================================================================

;;;   Original versions by Mike Dixon
;;;   Last edited by Brian Smith:  Sunday June 3, 1984  
;;;   

;;; Match-0: Simple recursive structure matching:
;;; =============================================

(define MATCH-0
   (lambda [pattern structure]
      (cond [(atom pattern) (= pattern structure)]
            [(rail pattern)
             (and (rail structure)
                  (match-rail-0 pattern structure))]
            [$T $F])))

(define MATCH-RAIL-0
   (lambda [pattern structure]
      (cond [(null pattern) (null structure)]
            [(null structure) $F]
            [(match-0 (first pattern) (first structure))
             (match-rail-1 (rest pattern) (rest structure))]
            [$T $F])))

;;; Match-1: With Single element "wild-card" matches:
;;; =================================================

(define MATCH-1
   (lambda [pattern structure]
      (cond [(atom pattern) (= pattern structure)]
            [(rail pattern)
             (and (rail structure)
                  (match-rail-1 pattern structure))]
            [(unnamed-wild pattern) $T])))

(define UNNAMED-WILD
   (lambda [pattern]
      (and (pair pattern)
           (= (pproc pattern) '?)
           (rail (pargs pattern))
           (null (pargs pattern)))))

(define MATCH-RAIL-1
   (lambda [pattern structure]
      (cond [(null pattern) (null structure)]
            [(null structure) $F]
            [(match-1 (first pattern) (first structure))
             (match-rail-1 (rest pattern) (rest structure))]
            [$T $F])))

;;; Match-2: With multi-element "wild-card" matches:
;;; ================================================

(define MATCH-2
   (lambda [pattern structure]
      (cond [(atom pattern) (= pattern structure)]
            [(rail pattern)
             (and (rail structure)
                  (match-rail-2 pattern structure))]
            [(unnamed-wild pattern) $T])))

(define MATCH-RAIL-2
   (lambda [pattern structure]
      (cond [(null pattern) (null structure)]
            [(unnamed-segment (first pattern))
             (or (match-rail-2 (rest pattern) structure)
                 (and (not (null structure))
                      (match-rail-2 pattern (rest structure))))]
            [(null structure) $F]
            [(match-2 (first pattern) (first structure))
             (match-rail-2 (rest pattern) (rest structure))]
            [$T $F])))

(define UNNAMED-SEGMENT
   (lambda [pattern]
      (and (pair pattern)
           (= (pproc pattern) '*)
           (rail (pargs pattern))
           (null (pargs pattern)))))

;;; Match-3: As above, but with pattern variables:
;;; ==============================================

(define MATCH-3
   (lambda [pattern structure bindings]
      (cond [(atom pattern) (= pattern structure)]
            [(rail pattern)
             (and (rail structure)
                  (match-rail-3 pattern structure bindings))]
            [(unnamed-wild pattern) $T]
            [(and (named-wild pattern) (bound pattern bindings))
             (= (the-binding pattern bindings) structure)])))

(define MATCH-RAIL-3
   (lambda [pattern structure bindings]
      (cond [(null pattern) (null structure)]
            [(unnamed-segment (first pattern))
             (or (match-rail-3 (rest pattern) structure bindings)
                 (and (not (null structure))
                      (match-rail-3 pattern (rest structure) bindings)))]
            [(named-segment (first pattern))
             (and (bound (first pattern) bindings)
                  (rail (the-binding (first pattern) bindings))
                  (match-rail-3 (append (the-binding (first pattern) bindings)
                                        (rest pattern))
                                structure
                                bindings))]
            [(null structure) $F]
            [(match-3 (first pattern) (first structure) bindings)
             (match-rail-3 (rest pattern) (rest structure) bindings)]
            [$T $F])))

(define NAMED-WILD
   (lambda [pattern]
      (and (pair pattern)
           (= (pproc pattern) '?)
           (rail (pargs pattern))
           (= (length (pargs pattern)) 1)
           (atom (first (pargs pattern))))))

(define NAMED-SEGMENT
   (lambda [pattern]
      (and (pair pattern)
           (= (pproc pattern) '*)
           (rail (pargs pattern))
           (= (length (pargs pattern)) 1)
           (atom (first (pargs pattern))))))

(define PATTERN-NAME
   (lambda [pattern]
      (arg 1 pattern)))

(define FIND-BINDING
   (lambda [name bindings]
      (cond [(null bindings) $F]
            [(= name (first (first bindings)))
             (rest (first bindings))]
            [$T (find-binding name (rest bindings))])))

(define BOUND
   (lambda [pattern bindings]
      (sequence (find-binding (pattern-name pattern) bindings))))

(define THE-BINDING
   (lambda [pattern bindings]
      (first (find-binding (pattern-name pattern) bindings))))


;;; Match-4: As above, but generates the bindings:
;;; ==============================================

(define MATCH-4
   (lambda [pattern structure]
      (match-iv pattern structure [])))

(define MATCH-iv
   (lambda [pattern structure bindings-to-date]
      (cond [(atom pattern)
             (if (= pattern structure) bindings-to-date $F)]
            [(rail pattern)
             (if (rail structure)
                 (match-rail-4 pattern structure bindings-to-date)
                 $F)]
            [(unnamed-wild pattern) bindings-to-date]
            [(and (named-wild pattern) (bound pattern bindings-to-date))
             (if (= (the-binding pattern bindings-to-date) structure)
                 bindings-to-date
                 $F)]
            [(named-wild pattern)
             (append bindings-to-date [[(pattern-name pattern) structure]])])))

(define MATCH-RAIL-4
   (lambda [pattern structure bindings-to-date]
      (cond [(null pattern)
             (if (null structure) bindings-to-date $F)]
            [(unnamed-segment (first pattern))
             (let [[r (match-rail-4 (rest pattern) structure bindings-to-date)]]
                (cond [(sequence r) r]
                      [(null structure) $F]
                      [$T (match-rail-4 pattern (rest structure) bindings-to-date)]))]
            [(and (named-segment (first pattern))
                  (bound (first pattern) bindings-to-date))
             (if (sequence (the-binding (first pattern) bindings-to-date))
                 (match-rail-4 (append (the-binding (first pattern) bindings-to-date)
                                       (rest pattern))
                               structure
                               bindings-to-date)
                 $F)]
            [(named-segment (first pattern))
             (match-named-segment (pattern-name (first pattern))
                                  (rest pattern)
                                  structure
                                  bindings-to-date
                                  [])]
            [(null structure) $F]
            [$T
             (let [[r (match-iv (first pattern) (first structure) bindings-to-date)]]
                (if (= r $F)
                    $F
                    (match-rail-4 (rest pattern) (rest structure) r)))])))

(define MATCH-NAMED-SEGMENT
   (lambda [name pattern structure bindings-to-date so-far]
      (let [[r (match-rail-4 pattern
                             structure
                             (append bindings-to-date [[name so-far]]))]]
         (cond [(sequence r) r]
               [(null structure) $F]
               [$T (match-named-segment name
                                        pattern
                                        (rest structure)
                                        bindings-to-date
                                        (append so-far [(first structure)]))]))))

;;; Match-5: First step towards a unifier:
;;; ======================================

(define MATCH-5
   (lambda [a b bindings]
      (cond [(unnamed-wild a) $T]
            [(unnamed-wild b) $T]
            [(and (named-wild a)
                  (named-wild b)
                  (= (pattern-name a) (pattern-name b)))
             $T]
            [(named-wild a) (check-against-binding a b bindings)]
            [(named-wild b) (check-against-binding b a bindings)]
            [(and (rail a) (rail b)) (match-rail-5 a b bindings)]
            [$T (= a b)])))

(define CHECK-AGAINST-BINDING
   (lambda [wild form bindings]
      (and (bound wild bindings)
           (match-5 (the-binding wild bindings) form bindings))))

(define MATCH-RAIL-5
   (lambda [a b bindings]
      (cond [(null a) (null b)]
            [(null b) $F]
            [$T (and (match-5 (first a) (first b) bindings)
                     (match-rail-5 (rest a) (rest b) bindings))])))

;;; Match-6: A full Unifier:
;;; ========================

(define MATCH-6
   (lambda [a b]
      (unify a b [])))

(define UNIFY
   (lambda [a b bindings-to-date]
      (cond [(unnamed-wild a) bindings-to-date]
            [(unnamed-wild b) bindings-to-date]
            [(and (named-wild a)
                  (named-wild b)
                  (= (pattern-name a) (pattern-name b)))
             bindings-to-date]
            [(and (named-wild a) (bound a bindings-to-date))
             (unify (the-binding a bindings-to-date) b bindings-to-date)]
            [(and (named-wild b) (bound b bindings-to-date))
             (unify a (the-binding b bindings-to-date) bindings-to-date)]
            [(named-wild a)
             (if (occurs (pattern-name a) b bindings-to-date)
                 $F
                 (cons [(pattern-name a) b] bindings-to-date))]
            [(named-wild b)
             (if (occurs (pattern-name b) a bindings-to-date)
                 $F
                 (cons [(pattern-name b) a] bindings-to-date))]
            [(and (rail a) (rail b))
             (unify-rails a b bindings-to-date)]
            [(= a b) bindings-to-date]
            [$T $F])))

(define UNIFY-RAILS
   (lambda [a b bindings-to-date]
      (cond [(and (null a) (null b)) bindings-to-date]
            [(or (null a) (null b)) $F]
            [$T (let [[r (unify (first a) (first b) bindings-to-date)]]
                   (if (= r $F)
                       $F
                       (unify-rails (rest a) (rest b) r)))])))

(define OCCURS
   (lambda [name form bindings]
      (if (named-wild form)
          (if (bound form bindings)
              (occurs name (the-binding form bindings) bindings)
              (= (pattern-name form) name))
          (and (rail form)
               (not (null form))
               (or (occurs name (first form) bindings)
                   (occurs name (rest form) bindings))))))


;;;  NANO-PROLOG:
;;;  ============

(define NANO-PROLOG
   (lambda [goal defns]
      (solve [goal] [] defns [] goal)))

(define SOLVE
   (lambda [goals bindings defns stack original-goal]
      (if (null goals)
          (begin (print primary-stream "  --: ")
                 (print primary-stream (update original-goal bindings))
                 (print primary-stream cr)
                 (backtrack stack defns original-goal))
          (let [[goal (first goals)]]
             (solve-goal (pargs goal)
                         (lookup (pproc goal) defns)
                         (rest goals)
                         bindings stack defns original-goal)))))

(define BACKTRACK
   (lambda [stack defns original-goal]
      (if (null stack)
          'done
          (solve-goal . (append stack [defns original-goal])))))

(define SOLVE-GOAL
   (lambda [args clauses goals bindings stack defns original-goal]
      (if (null clauses)
          (backtrack stack defns original-goal)
          (letseq [[clause (clone (first clauses))]
                   [r (unify (first clause) args bindings)]]
             (if (sequence r)
                 (solve (append (rest clause) goals)
                        r
                        defns
                        [args (rest clauses) goals bindings stack]
                        original-goal)
                 (solve-goal args (rest clauses) goals bindings
                             stack defns original-goal))))))

(define UPDATE
   (lambda [goal bindings]
      (cond [(atom goal) goal]
            [(rail goal)
             (if (null goal)
                 goal
                 (cons (update (first goal) bindings)
                       (update (rest goal) bindings)))]
            [(unnamed-wild goal) goal]
            [(named-wild goal)
             (if (bound goal bindings)
                 (update (the-binding goal bindings) bindings)
                 goal)]
            [(pair goal) (pcons (pproc goal) (update (pargs goal) bindings))])))

(define CLONE
   (lambda [clause]
      (first (cloner clause []))))

(define CLONER
   (lambda [s b]
      (cond [(atom s) [s b]]
            [(rail s)
             (if (null s)
                 [s b]
                 (letseq [[r (cloner (first s) b)]
                          [r2 (cloner (rest s) (second r))]]
                    [(cons (first r) (first r2)) (second r2)]))]
            [(unnamed-wild s) [s b]]
            [(named-wild s)
             (if (bound s b)
                 [(the-binding s b) b]
                 (let [[new '(? ,(acons))]]
                    [new (cons [(pattern-name s) new] b)]))]
            [(pair s)
             (let [[r (cloner (pargs s) b)]]
                [(pcons (pproc s) (first r)) (second r)])])))

(define LOOKUP
   (lambda [name defns]
      (cond [(null defns) '[]]
            [(= name (pproc (first (first defns))))
             (cons (cons (pargs (first (first defns)))
                         (rest (first defns)))
                   (lookup name (rest defns)))]
            [$T (lookup name (rest defns))])))