;;; 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))])))