-------------
Problem 5.1:
Pick a classic puzzle, such as the "Missionaries and Cannibals Puzzle"
(see http://www.jimloy.com/puzz/cannibal.htm), or any other one that
you find fun. Represent it as a (perhaps implicit) graph to be
searched, and express it in our description system. How many steps
does it take to solve your problem with each kind of search? Can you
use the priorities in the best-first-search to help get better
performance on your problem?
-------------
(load "~/classes/symbolic/src/some-functions.scm")
(load "~/classes/symbolic/psets/05/patdb.scm")
(load "~/classes/symbolic/psets/05/new-search.scm")
(define (cannibals-do-not-outnumber-missionaries? state)
(let ((banks ((component '(0 3)) state)))
(for-all? banks
(lambda (bank)
(or (apply <= bank)
(zero? ((component 1) bank)))))))
(define (calculate-right-bank partial-state)
(list
((component 0) partial-state)g
((component 1) partial-state)
((component 2) partial-state)
(list
(- 3 (apply + ((component * 0)
(remove partial-state null?))))
(- 3 (apply + ((component * 1)
(remove partial-state null?)))))))
(define (no-more-than-3-of-each? partial-state)
(and (<= (apply + ((component * 0)
(remove partial-state null?)))
3)
(<= (apply + ((component * 1)
(remove partial-state null?)))
3)))
(define (cons-c lis)
(cons (car lis)
(cadr lis)))
(define boat-states
' ((() (0 0))
((0 0) ())
(() (0 1))
((0 1) ())
(() (1 0))
((1 0) ())
(() (1 1))
((1 1) ())))
(define all-cannibal-states
(filter
(map
calculate-right-bank
(filter
(functional-cartesian-product cons-c
(cartesian-product (iota 4) (iota 4))
boat-states)
no-more-than-3-of-each?))
cannibals-do-not-outnumber-missionaries?))
#|
(pp all-cannibal-states)
(((0 0) () (0 0) (3 3)) ((0 0) (0 0) () (3 3))
((0 0) () (1 0) (2 3))
((0 0) (1 0) () (2 3))
((0 0) () (1 1) (2 2))
((0 0) (1 1) () (2 2))
((0 1) () (1 0) (2 2))
((0 1) (1 0) () (2 2))
((0 2) () (0 1) (3 0))
((0 2) (0 1) () (3 0))
((0 2) () (1 1) (2 0))
((0 2) (1 1) () (2 0))
((0 3) () (0 0) (3 0))
((0 3) (0 0) () (3 0))
((0 3) () (1 0) (2 0))
((0 3) (1 0) () (2 0))
((1 0) () (0 0) (2 3))
((1 0) (0 0) () (2 3))
((1 0) () (0 1) (2 2))
((1 0) (0 1) () (2 2))
((1 0) () (1 0) (1 3))
((1 0) (1 0) () (1 3))
((1 0) () (1 1) (1 2))
((1 0) (1 1) () (1 2))
((1 1) () (0 0) (2 2))
((1 1) (0 0) () (2 2))
((1 1) () (1 0) (1 2))
((1 1) (1 0) () (1 2))
((1 1) () (1 1) (1 1))
((1 1) (1 1) () (1 1))
((1 2) () (0 1) (2 0))
((1 2) (0 1) () (2 0))
((1 2) () (1 0) (1 1))
((1 2) (1 0) () (1 1))
((1 2) () (1 1) (1 0))
((1 2) (1 1) () (1 0))
((1 3) () (0 0) (2 0))
((1 3) (0 0) () (2 0))
((1 3) () (1 0) (1 0))
((1 3) (1 0) () (1 0))
((2 0) () (0 0) (1 3))
((2 0) (0 0) () (1 3))
((2 0) () (0 1) (1 2))
((2 0) (0 1) () (1 2))
((2 0) () (1 0) (0 3))
((2 0) (1 0) () (0 3))
((2 0) () (1 1) (0 2))
((2 0) (1 1) () (0 2))
((2 2) () (0 0) (1 1))
((2 2) (0 0) () (1 1))
((2 2) () (0 1) (1 0))
((2 2) (0 1) () (1 0))
((2 2) () (1 0) (0 1))
((2 2) (1 0) () (0 1))
((2 2) () (1 1) (0 0))
((2 2) (1 1) () (0 0))
((2 3) () (0 0) (1 0))
((2 3) (0 0) () (1 0))
((2 3) () (1 0) (0 0))
((2 3) (1 0) () (0 0))
((3 0) () (0 0) (0 3))
((3 0) (0 0) () (0 3))
((3 0) () (0 1) (0 2))
((3 0) (0 1) () (0 2))
((3 3) () (0 0) (0 0))
((3 3) (0 0) () (0 0)))
|#
(define left-bank (component 0))
(define right-bank (component 3))
(define boat (component '(1 2)))
(define (boat-on-left? state)
(null? ((component 2)
state)))
(define (boat-on-right? state)
(null? ((component 1)
state)))
(define (boat-empty? state)
(zero?
(apply +
(flatten (boat state)))))
(define (adjacent-cannibal-states? state-1 state-2)
(and
(not (equal? state-1 state-2))
(let ((state-1-left-bank (left-bank state-1))
(state-1-right-bank (right-bank state-1))
(state-1-boat (boat state-1))
(state-1-boat-on-left? (boat-on-left? state-1))
(state-1-boat-on-right? (boat-on-right? state-1))
(state-1-boat-empty? (boat-empty? state-1))
(state-2-left-bank (left-bank state-2))
(state-2-right-bank (right-bank state-2))
(state-2-boat (boat state-2))
(state-2-boat-on-left? (boat-on-left? state-2))
(state-2-boat-on-right? (boat-on-right? state-2)))
(or (and (equal? state-1-left-bank
state-2-left-bank)
state-1-boat-on-right?
state-2-boat-on-right?)
(and (equal? state-1-right-bank
state-2-right-bank)
state-1-boat-on-left?
state-2-boat-on-left?)
(and (equal? state-1-left-bank
state-2-left-bank)
(equal? state-1-right-bank
state-2-right-bank)
(not state-1-boat-empty?)
(equal? state-1-boat
(reverse state-2-boat)))))))
(define (adjacent-states cannibal-state)
(filter all-cannibal-states
(lambda (state)
(adjacent-cannibal-states? state
cannibal-state))))
#|
(pp
(adjacent-states '((1 0) () (0 0) (2 3))))
(((1 0) () (0 1) (2 2))
((1 0) () (1 0) (1 3))
((1 0) () (1 1) (1 2)))
(pp
(adjacent-states '((1 0) () (1 0) (1 3))))
(((1 0) () (0 0) (2 3))
((1 0) () (0 1) (2 2))
((1 0) (1 0) () (1 3))
((1 0) () (1 1) (1 2)))
|#
(define (name-state state)
(string->symbol
(apply string-append
(cons (if (boat-on-right? state)
"right-"
"left--")
(map
number->string
(flatten state))))))
#|
(name-state '((2 2) (0 1) () (1 0)))
|#
(define (state->link-structure state)
(map name-state
(cons state
(adjacent-states state))))
#|
(state->link-structure '((2 2) (0 1) () (1 0)))
|#
(define cannibal-link-structure
(map state->link-structure
all-cannibal-states))
#|
(pp
((component (iota 4))
cannibal-link-structure))
((right-000033 right-001023 right-001122)
(left-000033)
(right-001023 right-000033 left-001023 right-001122)
(left-001023 right-001023 left-100023))
|#
(define (goal-test state)
(eqv? state
'right-000033))
(define (link-structure-to-node-define input)
(let ((name (car input))
(links (cdr input)))
`(define ,name
,(cons* `make-node `(quote ,name)
`(goal-test (quote ,name))
(map (lambda (link)
`(make-link (lambda () ,link)))
links)))))
#|
(pp (link-structure-to-node-define
'(right-001023 (right-000033 6) (left--001023 5) (right-001122 4))))
(define right-001023
(make-node (quote right-001023)
(goal-test (quote right-001023))
(make-link (lambda () (right-000033 6)))
(make-link (lambda () (left--001023 5)))
(make-link (lambda () (right-001122 4)))))
|#
(define (link-structure-to-graph-define input graph-name start)
`(define
(,graph-name)
,@(map link-structure-to-node-define
input)
,start))
(eval
(link-structure-to-graph-define cannibal-link-structure
'cannibal-graph
'left--330000)
(the-environment))
(pp
(link-structure-to-graph-define cannibal-link-structure
'cannibal-graph
'left--330000))
#|
(pp (search-values->list
(depth-first-search (cannibal-graph))))
((left--330000
left--221100
right-221100
right-220011
right-220110
left--220110
left--121110
right-121110
right-120120
right-121011
left--121011
left--111111
right-111111
right-110022
right-111012
left--111012
left--101112
right-101112
right-100023
right-100122
left--100122
left--001122
right-001122
right-000033))
(length (car (depth-first-search (cannibal-graph))))
(pp (search-values->list
(breadth-first-search (cannibal-graph))))
((left--330000
left--221100
right-221100
right-220110
left--220110
left--121110
right-121110
right-121011
left--121011
left--111111
right-111111
right-111012
left--111012
left--101112
right-101112
right-100122
left--100122
left--001122
right-001122
right-000033))
(length (car (breadth-first-search (cannibal-graph))))
(define (priority state)
(- ((component 3 0) state)
((component 0 0) state))
)
#|
(priority '((2 0) (1 1) () (0 2)))
|#
(define (named-priority-labeled-state state)
(list (name-state state)
(priority state)))
#|
(named-priority-labeled-state '((2 0) (1 1) () (0 2)))
|#
(define (state->new-link-structure state)
(cons (name-state state)
(map named-priority-labeled-state
(adjacent-states state))))
#|
(pp
(state->new-link-structure '((2 0) (1 1) () (0 2))))
(left--201102 (right-201102 2) (left--300102 2))
|#
(define cannibal-new-link-structure
(map state->new-link-structure
all-cannibal-states))
#|
(pp
((component (iota 4))
cannibal-new-link-structure))
((right-000033 (right-001023 5) (right-001122 4))
(left--000033)
(right-001023 (right-000033 6) (left--001023 5) (right-001122 4))
(left--001023 (right-001023 5) (left--100023 5)))
|#
(define (new-link-structure-to-node-define input)
(let ((name (car input))
(links (cdr input)))
`(define ,name
,(cons* `make-node `(quote ,name)
`(goal-test (quote ,name))
(map (lambda (link)
`(make-link (lambda () ,(car link)) ,(cadr link)))
links)))))
#|
(pp (new-link-structure-to-node-define
'(right-001023 (right-000033 6) (left--001023 5) (right-001122 4))))
(define right-001023
(make-node (quote right-001023)
(goal-test (quote right-001023))
(make-link (lambda () right-000033) 6)
(make-link (lambda () left--001023) 5)
(make-link (lambda () right-001122) 4)))
|#
(define (new-link-structure-to-graph-define input graph-name start)
`(define
(,graph-name)
,@(map new-link-structure-to-node-define
input)
,start))
(eval
(new-link-structure-to-graph-define cannibal-new-link-structure
'new-cannibal-graph
'left--330000)
(the-environment))
#|
(pp (search-values->list
(best-first-search (new-cannibal-graph))))
((left--330000
left--221100
right-221100
right-220110
left--220110
left--121110
right-121110
right-121011
left--121011
left--111111
right-111111
right-111012
left--111012
left--101112
right-101112
right-100122
left--100122
left--001122
right-001122
right-000033))
(length (car (best-first-search (cannibal-graph))))
|#
(define (maybe-accumulate-names history get-next)
(let ((node (car history)))
(if *debug-trace?*
(begin
(fresh-line)
(write-string ";accum-names trace: ")
(write (node-name node))
(newline)))
(if (node-value node)
(cons (reverse (map node-name history)) get-next)
(get-next))))
(define (depth-first-walk node link-filter)
(let per-node ((history (list node))
(k (lambda () #f)))
(maybe-accumulate-names
history
(lambda ()
(let ((node (car history)))
(let per-link ((links (node-links node)))
(if (pair? links)
(let ((node
(dereference-link (car links)
link-filter)))
(if node
(per-node (cons node history)
(lambda ()
(per-link (cdr links))))
(per-link (cdr links))))
(k))))))))
(define (breadth-first-walk node link-filter)
(define (per-node history pending k)
(maybe-accumulate-names
history
(lambda ()
(let ((node (car history)))
(let per-link ((links (node-links node))
(pending pending))
(if (pair? links)
(per-link (cdr links)
(let ((node
(dereference-link (car links)
link-filter)))
(if node
(begin
(if *debug-trace-bfw?*
(begin
(fresh-line)
(write-string ";breadth-walk trace: ")
(write (map node-name history))
(newline)))
(cons (cons node history) pending))
pending)))
(k pending)))))))
(define (step pending)
(if (pair? pending)
(let loop ((histories pending) (pending '()))
(if (pair? histories)
(per-node (car histories)
pending
(lambda (pending)
(loop (cdr histories) pending)))
(step pending)))
#f))
(per-node (list node) '() step))
(define (best-first-walk node link-filter)
(let ((pq (make-priority-queue)))
(define (per-node history)
(let ((node (car history)))
(for-each (lambda (link)
(add-to-queue (cons link history)
(link-priority link)
pq))
(node-links node)))
(maybe-accumulate-names history next-node))
(define (next-node)
(let ((possible-path (remove-from-queue pq)))
(if possible-path
(let ((node
(dereference-link (car possible-path)
link-filter))
(history (cdr possible-path)))
(if node
(per-node (cons node history))
(next-node)))
#f)))
(per-node (list node))))
-------------
Problem 5.2:
Reconstruct the rule interpreter of Problem Set 4 to use Chris's
matcher/discrimination-net database. You will discard the matcher,
rewrite rule-simplifier.scm, and make some changes to
rule-compiler.scm.
-------------
(load "~/classes/symbolic/psets/05/patdb.scm")
(define-syntax rule
(syntax-rules ()
((rule2 pattern restriction template)
`(patdb-rule ,@(let* ((names (pattern-names `pattern))
(replacement-alist (names->replacement-alist names))
(new-pattern (rewrite-pattern `pattern
replacement-alist))
(new-template (rewrite-pattern `template
replacement-alist)))
(list new-pattern
new-template))
,(eval-restriction `restriction
(the-environment)
(pattern-names `pattern))
restriction))))
(define (eval-restriction restriction env names)
(eval (close-syntax
`(lambda ,names ,(filter-restriction restriction))
env)
env))
(define (filter-restriction restriction?)
(or (eqv? restriction?
'none)
(not restriction?)
restriction?))
(define (rule-maker? form)
(and (list form)
(eqv? (car form)
'patdb-rule)))
(define (make-rule-node pattern
restriction?
bindings
template
uncompiled-restriction)
(list 'rule-node
pattern
restriction?
bindings
template
uncompiled-restriction))
(define (rule-node? node)
(eqv? (car node)
'rule-node))
(define rule-node:pattern cadr)
(define rule-node:restriction? caddr)
(define rule-node:bindings cadddr)
(define (rule-node:template rule-node)
(list-ref rule-node 4))
(define (rule-node:uncompiled-restriction rule-node)
(list-ref rule-node 5))
(define (pattern-variable? seg-var)
(and (pair? seg-var)
(let ((type (car seg-var)))
(or (eqv? '? type)
(eqv? '?? type)))))
(define (element-variable? seg-var)
(and (pair? seg-var)
(let ((type (car seg-var)))
(eqv? '? type))))
(define (segment-variable? seg-var)
(and (pair? seg-var)
(let ((type (car seg-var)))
(eqv? '?? type))))
(define (pattern-variable-equal? name seg-var)
(and (pattern-variable? seg-var)
(eqv? name (cadr seg-var))))
(define (atom? x)
(and (not (null? x))
(not (list? x))))
;;; structure-manipulation
(define (pattern-names pattern)
(let loop ((pattern pattern) (names '()))
(cond ((pattern-variable? pattern)
(let ((name (cadr pattern)))
(if (memq name names)
names
(cons name names))))
((list? pattern)
(let elt-loop ((elts pattern) (names names))
(if (pair? elts)
(elt-loop (cdr elts) (loop (car elts) names))
names)))
(else names))))
(define (replace-pattern-variable-from-replacement-alist expr pair)
(let ((to-replace (car pair))
(replace-by (cdr pair)))
(let loop ((expr expr))
(cond ((null? expr)
'())
((atom? expr)
expr)
(else
(let ((current (car expr)))
(cond ((atom? current)
(cons current (loop (cdr expr))))
((pattern-variable? current)
(if (pattern-variable-equal? to-replace
current)
(cons (list (car current) replace-by)
(loop (cdr expr)))
(cons current (loop (cdr expr)))))
(else
(cons (loop current)
(loop (cdr expr)))))))))))
(define (rewrite-pattern expr replacement-alist)
(fold-left replace-pattern-variable-from-replacement-alist
expr
replacement-alist))
(define (names->replacement-alist names)
(map (lambda (name)
(cons name (generate-uninterned-symbol)))
names))
(define (replace-from-binding expr binding)
(let ((to-replace (car binding))
(replace-by (cdr binding)))
(let loop ((expr expr))
(cond ((null? expr)
'())
((atom? expr)
expr)
(else
(let ((current (car expr)))
(cond ((atom? current)
(cons current (loop (cdr expr))))
((element-variable? current)
(if (pattern-variable-equal? to-replace
current)
(cons replace-by (loop (cdr expr)))
(cons current (loop (cdr expr)))))
((segment-variable? current)
(if (pattern-variable-equal? to-replace
current)
(append replace-by (loop (cdr expr)))
(cons current (loop (cdr expr)))))
(else
(cons (loop current)
(loop (cdr expr)))))))))))
(define (rewrite-expr-from-bindings expr bindings)
(fold-left replace-from-binding
expr
bindings))
;;; patdb stuff
(define (loop-avoidance-node-filter)
(let ((table (make-equal-hash-table)))
(lambda (node)
(let ((value (node-value node)))
(if value
(if (rule-node? value)
(let ((bindings (rule-node:bindings value)))
(if (hash-table/get table bindings #f)
(begin
(pp "loop-avoidance: repeat")
(pp bindings)
#f)
(begin
(hash-table/put! table bindings #t)
(pp "loop-avoidance: new")
(pp bindings)
node))))
node)))))
(define (patdb:make-rule-db rules)
(let ((db (patdb:make)))
(for-each
(lambda (rule)
(if (not (rule-maker? rule))
(begin (pp rule)
(pp "patdb:make-rule-db: not a rule!"))
(let ((pattern (cadr rule))
(template (caddr rule))
(restriction? (cadddr rule))
(uncompiled-restriction (list-ref rule 4)))
(patdb:store pattern
(lambda (bindings)
(make-rule-node pattern
restriction?
bindings
template
uncompiled-restriction))
db))))
rules)
db))
(define (patdb:rule-applier search db filter)
(lambda (expr)
(or
(let loop ()
(let ((search-result (search (patdb:make-root-node expr db)
filter)))
(and
(pair? search-result)
(let ((current-match (node-value (car search-result))))
(let ((pattern (rule-node:pattern current-match))
(restriction? (rule-node:restriction? current-match))
(bindings (rule-node:bindings current-match))
(template (rule-node:template current-match)))
(if (apply restriction? (map cdr bindings))
(rewrite-expr-from-bindings template bindings)
(loop)))))))
expr)))
(define (equal?-fixed-point fn start)
(let ((history (make-equal-hash-table)))
(let loop ((value start))
(if (hash-table/get history value #f)
value
(begin
(pp "fixed-point value:")
(pp value)
(hash-table/put! history value #t)
(loop (fn value)))))))
(define (ruleset rule-list)
(lambda (expr)
(equal?-fixed-point
(let ((filter (loop-avoidance-node-filter)))
(patdb:rule-applier depth-first-walk
(patdb:make-rule-db rule-list)
filter))
expr)))
#|
(define test-ruleset
(ruleset
(list
(rule (+ (?? w) (? x) (? y) (?? z))
(> x y)
(+ (?? w) (? y) (? x) (?? z)))
(rule (* 1 (?? x))
none
(* (?? x))))))
(test-ruleset '(+ 3 1))
"fixed-point value:"
(+ 3 1)
"loop-avoidance: new"
((G70) (G71 . 1) (G72 . 3) (G73))
"fixed-point value:"
(+ 1 3)
"loop-avoidance: new"
((G70) (G71 . 3) (G72 . 1) (G73))
#f
"loop-avoidance: repeat"
((G70) (G71 . 3) (G72 . 1) (G73))
;Value: (+ 1 3)
(test-ruleset '(+ 3 2 1))
"fixed-point value:"
(+ 3 2 1)
"loop-avoidance: new"
((G70 1) (G71 . 2) (G72 . 3) (G73))
"fixed-point value:"
(+ 2 3 1)
"loop-avoidance: new"
((G70 1) (G71 . 3) (G72 . 2) (G73))
#f
"loop-avoidance: repeat"
((G70 1) (G71 . 3) (G72 . 2) (G73))
;Value: (+ 2 3 1)
(test-ruleset '(* 1 1 1 5 4))
"fixed-point value:"
(* 1 1 1 4 5)
"loop-avoidance: new"
((G69 1 1 4 5))
"fixed-point value:"
(* 1 1 4 5)
"loop-avoidance: new"
((G69 1 4 5))
"fixed-point value:"
(* 1 4 5)
"loop-avoidance: new"
((G69 4 5))
"fixed-point value:"
(* 4 5)
;Value: (* 4 5)
|#
-------------
Problem 5.3:
Often in a game like chess we want a "plausible-move generator" that
sorts the legal moves so as to arrange that locally better moves are
considered first. We also want a "static evaluator" that evaluates
positions for their value. Can the searching paradigm provided here
be used or extended to incorporate such ideas? Explain your opinions
on this matter in a coherent paragraph or two. You may illustrate
your explanation with code, if that is useful.
-------------
The method that I used in the cannibal example clearly isn't suitable, since it
involves enumerating all the states, which is quantitatively impossible in
meaningful games. The search method in its present form isn't really optimal
for use as a game engine, because in its current form it doesn't store the
dependencies between the states explicitly. This is important if you want to
use a minimax-driven branch-and-bound style search (like alpha-beta pruning),
since finding a small spanning set of replies to a move with poor evaluations
can render an entire branch of the tree irrelevant. This makes it important to
explicitly store the dependencies between states, so that it can be
straightforwardly calculated which branches should be pruned.
Some aspects of the search are useful. For instance, the memoization will
prevent the same board state from being analyzed twice, and keeping a priority
queue of states to analyze further should be useful in addition to the explicit
tree structure. But trying to jam the tree code into the existing search
mechanism seems like a bad idea -- it should be its own entity.