== aima

AIMA-support for Chicken Scheme
[[toc:]]
=== AIMA
==== {{aima}}
'''[module]''' {{aima}}

AIMA contains functions common to agents and environments.
* [[#compose-environments]]
* [[#debug?]]
* [[#debug-print]]
* [[#default-steps]]
* [[#define-record-and-printer]]
* [[#make-debug-environment]]
* [[#make-step-limited-environment]]
* [[#make-performance-measuring-environment]]
* [[#random-seed]]
* [[#randomize!]]
* [[#simulate]]
==== {{define-record-and-printer}}
<syntax>(define-record-and-printer) → unspecified</syntax>
Define both a record type and a vector-form printer.

<enscript highlight="scheme">(define-syntax
  define-record-and-printer
  (lambda (expression rename compare)
    (match expression
           ((_ record . fields)
            (let ((%define-record (rename 'define-record))
                  (%define-record-printer (rename 'define-record-printer))
                  (%begin (rename 'begin))
                  (%lambda (rename 'lambda))
                  (%write (rename 'write))
                  (%record->vector (rename 'record->vector)))
              `(,%begin
                (,%define-record ,record ,@fields)
                (,%define-record-printer
                 ,record
                 (,%lambda
                  (record out)
                  (,%write (,%record->vector record) out)))))))))
</enscript>
==== {{debug?}}
<parameter>debug? → #t</parameter>
Should we print debugging information to stdout?
<enscript highlight="scheme">(define debug? (make-parameter #t))
</enscript>
==== {{debug-print}}
<procedure>(debug-print key value) → unspecified</procedure>
<procedure>(debug-print key value out) → unspecified</procedure>
Print key-value pairs if the parameter `debug?' is true.
; key : The key to print
; value : The value to print
; out : The port to print to
<enscript highlight="scheme">(define debug-print
  (case-lambda
    ((key value) (debug-print key value #t))
    ((key value out) (if (debug?) (format out "~a: ~a~%" key value)))))
</enscript>
==== {{random-seed}}
<parameter>random-seed → #f</parameter>
`random-seed' is passed to `randomize!' during `simulate'.
<enscript highlight="scheme">(define random-seed (make-parameter #f))
</enscript>
==== {{randomize!}}
<parameter>randomize! → randomize</parameter>
`randomize!' is called before simulation and is seeded with
`random-seed'.
<enscript highlight="scheme">(define randomize! (make-parameter randomize))
</enscript>
==== {{simulate}}
<procedure>(simulate environment) → #f</procedure>
<procedure>(simulate environment randomize! random-seed) → #f</procedure>
Run an environment to completion; an environment
is complete when it returns false.
; environment : The environment to simulate
; randomize! : Function to seed the random-number generator for reproducible results
; random-seed : Seed to seed the random-number generator
<enscript highlight="scheme">(define simulate
  (case-lambda
    ((environment) (simulate environment (randomize!) (random-seed)))
    ((environment randomize! random-seed)
     (if random-seed (randomize! random-seed))
     (loop ((while (environment)))))))
</enscript>
==== {{compose-environments}}
<procedure>(compose-environments . environments) → environment</procedure>
Compose environments into a single environment suitable for
`simulate'.

`compose-environments' effectively `ands' over its constituent
environments every step.
; environments : The environments to be composed
<enscript highlight="scheme">(define (compose-environments . environments)
  (lambda ()
    (every identity (map (lambda (environment) (environment)) environments))))
</enscript>
==== {{make-performance-measuring-environment}}
<procedure>(make-performance-measuring-environment measure-performance score-update!) → environment</procedure>
Make an environment that updates a score according to a
performance measure.
; measure-performance : A nullary procedure which measures performance
; score-update! : A function which receives the performance measure and updates the score accordingly
<enscript highlight="scheme">(define (make-performance-measuring-environment
         measure-performance
         score-update!)
  (lambda () (score-update! (measure-performance))))
</enscript>
==== {{default-steps}}
<parameter>default-steps → 1000</parameter>
Default number of steps for the step-limited environment
<enscript highlight="scheme">(define default-steps (make-parameter 1000))
</enscript>
==== {{make-step-limited-environment}}
<procedure>(make-step-limited-environment) → environment</procedure>
<procedure>(make-step-limited-environment steps) → environment</procedure>
Make an environment that stops simulation after a certain number
of steps.
; steps : The number of steps after which to stop simulating
<enscript highlight="scheme">(define make-step-limited-environment
  (case-lambda
    (() (make-step-limited-environment (default-steps)))
    ((steps)
     (let ((current-step 0))
       (lambda ()
         (set! current-step (+ current-step 1))
         (< current-step steps))))))
</enscript>
==== {{make-debug-environment}}
<syntax>(make-debug-environment object make-printable-object) → environment</syntax>
Make an environment that prints debugging information (according
to `debug?').
; object : The object to debug
; make-printable-object : A function which optionally transforms the object before printing
<enscript highlight="scheme">(define-syntax
  make-debug-environment
  (er-macro-transformer
    (lambda (expression rename compare)
      (let ((%print (rename 'debug-print)))
        (match expression
               ((_ object) `(lambda () (,%print ',object ,object)))
               ((_ object make-printable-object)
                `(lambda ()
                   (,%print ',object (,make-printable-object ,object)))))))))
</enscript>
=== AIMA-CSP
==== {{aima-csp}}
'''[module]''' {{aima-csp}}

Solver for constraint-satisfaction-problems
* [[#ac-3]]
* [[#backtracking-search]]
* [[#backtracking-enumeration]]
* [[#consistent?]]
* [[#csp-constraints]]
* [[#csp-copy]]
* [[#csp-domains]]
* [[#csp-neighbors]]
* [[#display-map-as-png]]
* [[#failure]]
* [[#failure?]]
* [[#inference]]
* [[#make-csp]]
* [[#neq?]]
* [[#random-map]]
* [[#set-alldiff-constraints!]]
* [[#set-bidirectional-constraint!]]
* [[#set-pairwise-bidirectional-constraints!]]
* [[#set-pairwise-constraints!]]
* [[#set-domains!]]
* [[#shuffle]]
* [[#success?]]
* [[#write-map-as-dot]]
* [[#write-map-as-png]]
* [[#xor]]
==== {{failure}}
<constant>failure → (make-failure)</constant>
The failure object: to distinguish ''bona-fide'' solutions to a
CSP that are {{#f}}.
<enscript highlight="scheme">(define failure (make-failure))
</enscript>
==== {{success?}}
<procedure>(success? result) → boolean</procedure>
Success is defined negatively as the absence of failure.
; result : The result to test
<enscript highlight="scheme">(define success? (complement failure?))
</enscript>
==== {{csp}}
<record>csp</record>
A constraint-satisfaction-problem
; domains : A hash-table mapping variables to possible values
; constraints : A hash-table mapping pairs of variables to a dyadic lambda which returns {{#f}} if the values don't satisfy the constraint
; neighbors : A hash-table adjacency-list of constraints
<enscript highlight="scheme">(define-record-and-printer csp domains constraints neighbors)
</enscript>
===== Examples
A trivial (but inconsistent) CSP
 (define arc-inconsistent-coloring
   (make-csp (alist->hash-table '((a white) (b white)))
             (alist->hash-table
              `(((a . b) unquote neq?) ((b . a) unquote neq?)))
             (alist->hash-table '((a b) (b a)))))
==== {{backtracking-search}}
<procedure>(backtracking-search csp) → object or {{failure}}</procedure>
Find a solution to the CSP or return {{failure}}.
; csp : The CSP to solve
<enscript highlight="scheme">(define (backtracking-search csp)
  (let ((enumeration (backtracking-enumeration 1 csp)))
    (if (null? enumeration) failure (car enumeration))))
</enscript>
===== Examples
A trivial 2-coloring problem
 (define arc-consistent-coloring
   (make-csp (alist->hash-table '((a white black) (b white black)))
             (alist->hash-table
              `(((a . b) unquote neq?) ((b . a) unquote neq?)))
             (alist->hash-table '((a b) (b a)))))
 (test "Arc-consistent coloring"
   '((b . white) (a . black))
   (hash-table->alist (backtracking-search arc-consistent-coloring)))
==== {{backtracking-enumeration}}
<procedure>(backtracking-enumeration csp) → list</procedure>
<procedure>(backtracking-enumeration n csp) → list</procedure>
<procedure>(backtracking-enumeration csp cons nil stop?) → list</procedure>
Enumerate up to {{n}} solutions of the {{csp}}; enumerate all if {{n}}
is {{#f}} or unspecified.
; n : Enumerate up to {{n}} solutions
; csp : The CSP to solve
; cons : How to construct enumerations ({{cons}} by default)
; nil : Base enumeration ({{()}} by default)
; stop? : Unary function taking the current enumeration: {{#t}} stops, {{#f}} continues; by default, compares {{n}} to the length of the current enumeration.
<enscript highlight="scheme">(define backtracking-enumeration
  (case-lambda
    ((csp) (backtracking-enumeration #f csp))
    ((n csp)
     (backtracking-enumeration
       csp
       cons
       '()
       (lambda (enumeration) (and n (= (length enumeration) n)))))
    ((csp cons nil stop?)
     (let ((enumeration (make-parameter nil)))
       (backtrack-enumerate enumeration (make-assignment csp) csp cons stop?)
       (enumeration)))))
</enscript>
==== {{ac-3}}
<procedure>(ac-3 csp) → boolean</procedure>
Check arc-consistency of a csp; returns {{#t}} if the object is
arc-consistent.
; csp : A constraint-satisfaction object
<enscript highlight="scheme">(define (ac-3 csp)
  (let ((queue (list->queue (hash-table-keys (csp-constraints csp)))))
    (let iter ()
      (if (queue-empty? queue)
        #t
        (match (queue-remove! queue)
               ((x . y)
                (if (revise csp x y)
                  (if (zero? (length (hash-table-ref (csp-domains csp) x)))
                    #f
                    (begin
                      (for-each
                        (lambda (neighbor)
                          (queue-add! queue (cons neighbor x)))
                        (delete y (hash-table-ref (csp-neighbors csp) x)))
                      (iter)))
                  (iter))))))))
</enscript>
==== {{xor}}
<syntax>(xor x y) → boolean</syntax>
Logical xor: whether one or the other proposition is true (but
not both)
; x : A proposition
; y : Another proposition
<enscript highlight="scheme">(define-syntax
  xor
  (lambda (expression rename compare)
    (match expression
           ((_ x y)
            (let ((%or (rename 'or)) (%and (rename 'and)) (%not (rename 'not)))
              `(,%and (,%or ,x ,y) (,%not (,%and ,x ,y))))))))
</enscript>
==== {{neq?}}
<procedure>(neq? x y) → boolean</procedure>
The complement to {{eq?}}
; x : Comparandum
; y : Comparator
<enscript highlight="scheme">(define neq? (complement eq?))
</enscript>
==== {{random-map}}
<procedure>(random-map n) → hash-table</procedure>
Create a random k-coloring problem; returns an adjacency-list of
nodes as a hash-table.
; n : The number of nodes in the problem
<enscript highlight="scheme">(define (random-map n)
  (let ((random-points (random-points n)) (connections (make-hash-table)))
    (let iter-point ((points random-points) (modified? #f))
      (if (null? points)
        (if modified? (iter-point (shuffle random-points) #f) connections)
        (let ((point (car points)))
          (let iter-counter-point ((counter-points
                                     (sort-by-proximity
                                       point
                                       (delete point random-points))))
            (if (null? counter-points)
              (iter-point (cdr points) modified?)
              (let ((counter-point (car counter-points)))
                (if (member
                      point
                      (hash-table-ref/default connections counter-point '()))
                  (iter-counter-point (cdr counter-points))
                  (if (intersects-other? connections point counter-point)
                    (iter-counter-point (cdr counter-points))
                    (begin
                      (hash-table-update!/default
                        connections
                        point
                        (lambda (counter-points)
                          (lset-adjoin eq? counter-points counter-point))
                        '())
                      (hash-table-update!/default
                        connections
                        counter-point
                        (lambda (points) (lset-adjoin eq? points point))
                        '())
                      (iter-point (cdr points) #t))))))))))))
</enscript>
==== {{shuffle}}
<procedure>(shuffle list) → unspecified</procedure>
Shuffle a list.
; list : The list to 
<enscript highlight="scheme">(define (shuffle list)
  (let ((vector (list->vector list))) (shuffle! vector) (vector->list vector)))
</enscript>
=== AIMA-Tessellation
==== {{aima-tessellation}}
'''[module]''' {{aima-tessellation}}

aima-tessellation has procedures for tessellating a plane into
disjoint, convex polygons suitable for exercise 3.7; and then plotting
that tessellation with a path.
* [[#join-animations]]
* [[#make-point]]
* [[#make-node]]
* [[#n-vertices]]
* [[#node-state]]
* [[#node-state-set!]]
* [[#node-parent]]
* [[#node-parent-set!]]
* [[#node-action]]
* [[#node-action-set!]]
* [[#node-path-cost]]
* [[#node-path-cost-set!]]
* [[#point-distance]]
* [[#plot-tessellation]]
* [[#plot-tessellation/animation]]
* [[#point-x]]
* [[#point-y]]
* [[#predecessor-path]]
* [[#tessellate]]
* [[#tessellation-points]]
* [[#tessellation-neighbors]]
* [[#tessellation-start]]
* [[#tessellation-end]]
==== {{node}}
<record>node</record>
Data structure for graphs
; state : An indexable point
; parent : The node-predecessor
; action : Not used
; path-cost : Cost of the path up to this point
<enscript highlight="scheme">(define-record node state parent action path-cost)
</enscript>
==== {{tessellation}}
<record>tessellation</record>
tessellation contains point and adjacency information for a
tessellated-plane; as well as start and end nodes.
; points : The points in the tessellation
; neighbors : The adjacency information for points
; start : The start node for the problem
; end : The end node for the problem
<enscript highlight="scheme">(define-record-and-printer tessellation R-object points neighbors start end)
</enscript>
==== {{tessellate}}
<procedure>(tessellate) → tessellation</procedure>
<procedure>(tessellate n-vertices) → tessellation</procedure>
Tessellate the plane into disjoint, convex polygons.
; n-vertices : The numbers of vertices in the tessellation
<enscript highlight="scheme">(define tessellate
  (case-lambda
    (() (tessellate (n-vertices)))
    ((n-vertices)
     (let* ((R-voronoi (R-voronoi n-vertices)) (voronoi (voronoi R-voronoi)))
       (let* ((neighbors (neighbors voronoi)) (points (points neighbors)))
         (let ((start (start points)) (end (end points)))
           (make-tessellation R-voronoi points neighbors start end)))))))
</enscript>
==== {{point-distance}}
<procedure>(point-distance p1 p2) → distance</procedure>
Calculate the distance between two points.
; p1 : The first point
; p2 : The second point
<enscript highlight="scheme">(define (point-distance p1 p2)
  (sqrt (+ (expt (- (point-x p1) (point-x p2)) 2)
           (expt (- (point-y p1) (point-y p2)) 2))))
</enscript>
==== {{predecessor-path}}
<procedure>(predecessor-path node) → list</procedure>
List the predecessors of this node.
; node : The node to predecess
<enscript highlight="scheme">(define (predecessor-path node)
  (let iter ((path (list node)))
    (let ((parent (node-parent (car path))))
      (if parent (iter (cons parent path)) path))))
</enscript>
==== {{plot-tessellation}}
<procedure>(plot-tessellation tessellation path title filename) → unspecified</procedure>
Plot the tessellation with its start and end nodes, as well as
the path taken from start to end.
; tessellation : The tessellation to plot
; path : A list of nodes
; title : Title for the graph
; filename : The PNG to which to write
<enscript highlight="scheme">(define (plot-tessellation tessellation path title filename)
  (let ((title (make-title title (length path) (node-path-cost (car path)))))
    (let ((start (tessellation-start tessellation))
          (end (tessellation-end tessellation)))
      (R (plot.voronoi
           ,(tessellation-R-object tessellation)
           ,(list->vector (path-x path))
           ,(list->vector (path-y path))
           ,(point-x start)
           ,(point-y start)
           ,(point-x end)
           ,(point-y end)
           ,filename
           ,title)))))
</enscript>
==== {{plot-tessellation/animation}}
<procedure>(plot-tessellation/animation tessellation path title filename) → unspecified</procedure>
Plot the tessellation as an animation fit for YouTube.
; tessellation : The tessellation to plot
; path : A list of nodes
; title : Title for the animation
; filename : A filename for the movie (ending in e.g. `.avi')
<enscript highlight="scheme">(define (plot-tessellation/animation tessellation path title filename)
  (let ((directory (create-temporary-directory)))
    (let iter ((path path) (i (- (length path) 1)))
      (if (null? path)
        (let* ((frames
                 (cdr (sort (glob (make-pathname directory "*")) string<?)))
               (final-frame (last frames))
               (epilogue (make-list 10 final-frame)))
          (let ((frame-list (create-temporary-file)))
            (with-output-to-file
              frame-list
              (lambda () (for-each write-line (append frames epilogue))))
            (run (mencoder
                   ,(format "mf://@~a" frame-list)
                   -mf
                   fps=4
                   -o
                   ,filename
                   -ovc
                   lavc))))
        (let ((filename (animation-filename directory i)))
          (format #t "~a~%" filename)
          (plot-tessellation tessellation path title filename)
          (iter (cdr path) (- i 1)))))))
</enscript>
==== {{join-animations}}
<procedure>(join-animations output . animations) → unspecified</procedure>
Join the animation files into one long file.
; output : The resultant file
; animations : The input files
<enscript highlight="scheme">(define (join-animations output . animations)
  (run (mencoder -ovc copy -idx -o ,output ,@animations)))
</enscript>
=== AIMA-Vacuum
==== {{aima-vacuum}}
'''[module]''' {{aima-vacuum}}

`aima-vacuum' has agents and environments for chapter 2:
Intelligent Agents.
* [[#agent-score]]
* [[#agent-score-set!]]
* [[#agent-location]]
* [[#agent-location-set!]]
* [[#agent-program]]
* [[#agent-program-set!]]
* [[#clean]]
* [[#clean?]]
* [[#compare-graphs]]
* [[#copy-world]]
* [[#cycle]]
* [[#cycle?]]
* [[#connect!]]
* [[#default-n-nodes]]
* [[#direction->move]]
* [[#dirty]]
* [[#dirty?]]
* [[#display-world]]
* [[#display-pdf]]
* [[#down]]
* [[#down?]]
* [[#left]]
* [[#left?]]
* [[#location-status]]
* [[#location-status-set!]]
* [[#location-neighbors]]
* [[#location-neighbors-set!]]
* [[#make-agent]]
* [[#make-graph]]
* [[#make-graph-world]]
* [[#make-linear-world]]
* [[#make-location]]
* [[#make-node]]
* [[#make-performance-measure]]
* [[#make-preferential-depth-first-world]]
* [[#make-randomized-graph-agent]]
* [[#make-reflex-agent]]
* [[#make-simple-reflex-agent]]
* [[#make-stateful-reflex-agent]]
* [[#make-stateful-graph-agent]]
* [[#make-score-update!]]
* [[#make-unknown-location]]
* [[#make-world]]
* [[#move->direction]]
* [[#random-start]]
* [[#reverse-move]]
* [[#right]]
* [[#right?]]
* [[#simulate-graph]]
* [[#simulate-graph/animation]]
* [[#simulate-penalizing-vacuum]]
* [[#simulate-vacuum]]
* [[#unknown]]
* [[#unknown?]]
* [[#up]]
* [[#up?]]
* [[#world-location]]
* [[#world-location-set!]]
* [[#write-world-as-pdf]]
* [[#write-world-as-dot]]
* [[#write-world-as-gif]]
==== Two-square vacuum-world
===== {{display-world}}
<procedure>(display-world world) → unspecified</procedure>
Display the two-square vacuum world as a vector.
; world : The two-square vacuum world to be displayed
<enscript highlight="scheme">(define (display-world world)
  (pp (vector-append
        '#(world)
        (vector-map
          (lambda (i location) (if (clean? location) 'clean 'dirty))
          world))))
</enscript>
===== {{clean}}
<constant>clean → (make-clean)</constant>
A clean square
<enscript highlight="scheme">(define clean (make-clean))
</enscript>
===== {{dirty}}
<constant>dirty → (make-dirty)</constant>
A dirty square
<enscript highlight="scheme">(define dirty (make-dirty))
</enscript>
===== {{unknown}}
<constant>unknown → (make-unknown)</constant>
An unknown square (either clean or dirty)
<enscript highlight="scheme">(define unknown (make-unknown))
</enscript>
===== {{left}}
<constant>left → 0</constant>
Index of the left square
<enscript highlight="scheme">(define left 0)
</enscript>
===== {{left?}}
<procedure>(left? square) → true if it is the left square</procedure>
Is this the left square?
; square : The square to be lefted
<enscript highlight="scheme">(define left? zero?)
</enscript>
===== {{right}}
<constant>right → 1</constant>
Index of the right square
<enscript highlight="scheme">(define right 1)
</enscript>
===== {{right?}}
<procedure>(right? square) → true if it is the right square</procedure>
Is this the right square?
; square : The square to be righted
<enscript highlight="scheme">(define right? (cute = <> 1))
</enscript>
===== {{make-world}}
<procedure>(make-world left right) → a two-square vacuum world</procedure>
Make a two-square vacuum-world.
; left : State of the left square (clean or dirty)
; right : State of the left square (clean or dirty)
<enscript highlight="scheme">(define make-world vector)
</enscript>
===== {{world-location}}
<procedure>(world-location square) → the square-status</procedure>
Get a square-status (dirty, clean, unknown, &c.) from the
two-square vacuum-world.
; square : The square's index (`left' or `right')
<enscript highlight="scheme">(define world-location vector-ref)
</enscript>
===== {{world-location-set!}}
<procedure>(world-location-set! square status) → unspecified</procedure>
Set the status of a square to dirty, clean, unknown, &c.
; square : The square to be set
; status : The status to set it to
<enscript highlight="scheme">(define world-location-set! vector-set!)
</enscript>
===== {{agent}}
<record>agent</record>
The fundamental agent-record
; location : Where the agent is located
; score : The agent's score at a given time
; program : The agent's program: an n-ary procedure where each argument corresponds to a sensor; what is received by the sensors depends on the environments contract with its agents.
<enscript highlight="scheme">(define-record agent location score program)
</enscript>
===== {{simple-agent-program}}
<procedure>(simple-agent-program location clean?) → one of 'left, 'right, 'suck, 'noop</procedure>
Example of a simple two-square vacuum-agent that merely responds to 
its percept.
; location : The location of the agent
; clean? : Whether or not this square is clean
<enscript highlight="scheme">(define (simple-agent-program location clean?)
  (if clean? (if (left? location) 'right 'left) 'suck))
</enscript>
===== {{make-stateful-agent-program}}
<procedure>(make-stateful-agent-program) → stateful agent program</procedure>
Make an agent program that models the two-square vacuum-world,
and stops cleaning.

<enscript highlight="scheme">(define (make-stateful-agent-program)
  (let ((world (make-world unknown unknown)))
    (lambda (location clean?)
      (if clean?
        (begin
          (vector-set! world location clean)
          (if (all-clean? world) 'noop (if (right? location) 'left 'right)))
        'suck))))
</enscript>
===== {{make-reflex-agent}}
<procedure>(make-reflex-agent location) → unspecified</procedure>
<procedure>(make-reflex-agent location program) → unspecified</procedure>
Make a stateless agent that merely responds to its current
percept.
; location : Where does the agent start? `left' or `right'
; program : The agent's program; should be a binary procedure that takes a location and whether that location is clean. See `simple-agent-program'.
<enscript highlight="scheme">(define make-reflex-agent
  (case-lambda
    ((location) (make-reflex-agent location (default-agent-program)))
    ((location program) (make-agent location 0 program))))
</enscript>
===== {{make-simple-reflex-agent}}
<procedure>(make-simple-reflex-agent location) → a simple reflex agent</procedure>
Make a simple reflex agent and place it in the given location.
; location : Where to place the agent: `left' or `right'
<enscript highlight="scheme">(define (make-simple-reflex-agent location)
  (make-reflex-agent location simple-agent-program))
</enscript>
===== {{make-stateful-reflex-agent}}
<procedure>(make-stateful-reflex-agent location) → a stateful reflex agent</procedure>
Make a stateful reflex agent and place it in the given location.
; location : Where to place the agent: `left' or `right'
<enscript highlight="scheme">(define (make-stateful-reflex-agent location)
  (make-reflex-agent location (make-stateful-agent-program)))
</enscript>
===== {{make-performance-measure}}
<procedure>(make-performance-measure world) → environment</procedure>
Make a performance measure that awards one point for every clean
square.

<enscript highlight="scheme">(define (make-performance-measure world)
  (lambda () (vector-count (lambda (i square) (clean? square)) world)))
</enscript>
===== {{make-score-update!}}
<procedure>(make-score-update! agent) → a monadic procedure that takes the score to add</procedure>
Make a score-updater that adds score to the score of an agent.
; agent : The agent whose score to add to
<enscript highlight="scheme">(define (make-score-update! agent)
  (lambda (score) (agent-score-set! agent (+ (agent-score agent) score))))
</enscript>
===== {{simulate-vacuum}}
<procedure>(simulate-vacuum world agent) → the agent-score</procedure>
<procedure>(simulate-vacuum world agent steps) → the agent-score</procedure>
<procedure>(simulate-vacuum world agent steps make-environment) → the agent-score</procedure>
Simulate the two-square vacuum-world.
; world : The two-square vacuum world (see `make-world')
; agent : The agent to inhabit the world
; steps : The number of steps to simulate (default: 1000)
; make-environment : The environment constructor (default: `make-environment')
<enscript highlight="scheme">(define simulate-vacuum
  (case-lambda
    ((world agent) (simulate-vacuum world agent (default-steps)))
    ((world agent steps) (simulate-vacuum world agent steps make-environment))
    ((world agent steps make-environment)
     (simulate
       (compose-environments
         (make-step-limited-environment steps)
         (make-performance-measuring-environment
           (make-performance-measure world)
           (make-score-update! agent))
         (make-debug-environment
           agent
           (lambda (agent)
             (vector
               (let ((location (agent-location agent)))
                 (if (left? location) 'left 'right))
               (agent-score agent))))
         (make-debug-environment world)
         (make-environment world agent)))
     (agent-score agent))))
</enscript>
===== {{simulate-penalizing-vacuum}}
<procedure>(simulate-penalizing-vacuum world agent) → the agent-score</procedure>
<procedure>(simulate-penalizing-vacuum world agent steps) → the agent-score</procedure>
Like `simulate-vacuum', but penalizes agents for every movement.
; world : The two-square vacuum world (see `make-world')
; agent : The agent to inhabit the world
; steps : The number of steps to simulate (default: 1000)
<enscript highlight="scheme">(define simulate-penalizing-vacuum
  (case-lambda
    ((world agent) (simulate-penalizing-vacuum world agent (default-steps)))
    ((world agent steps)
     (simulate-vacuum world agent steps make-penalizing-environment))))
</enscript>
==== Graph-based vacuum-world
===== {{make-graph}}
<procedure>(make-graph) → graph</procedure>
Make a hash-table-based adjacency list.

<enscript highlight="scheme">(define make-graph make-hash-table)
</enscript>
===== {{up}}
<constant>up → 2</constant>
Index of the up square
<enscript highlight="scheme">(define up 2)
</enscript>
===== {{up?}}
<procedure>(up?) → true if it is the up square</procedure>
Is this the up square?

<enscript highlight="scheme">(define up? (cute = <> 2))
</enscript>
===== {{down}}
<constant>down → 3</constant>
Index of the down square
<enscript highlight="scheme">(define down 3)
</enscript>
===== {{down?}}
<procedure>(down?) → true if this is the down square</procedure>
Is this the down square?

<enscript highlight="scheme">(define down? (cute = <> 3))
</enscript>
===== {{location}}
<record>location</record>
Location-records describing the status (e.g. clean, dirty) of the
square and its neighbors at `left', `right', `down', `up'.

`neighbors' is a ternary vector indexed by relative directions.

<enscript highlight="scheme">(define-record location status neighbors)
</enscript>
===== {{copy-world}}
<procedure>(copy-world world) → graph-world</procedure>
Make a deep copy of a graph-world.
; world : The world to copy
<enscript highlight="scheme">(define (copy-world world)
  (let ((world (hash-table-copy world)))
    (hash-table-walk
      world
      (lambda (name location) (hash-table-update! world name copy-location)))
    world))
</enscript>
===== {{make-node}}
<procedure>(make-node) → symbol</procedure>
Make a unique symbol suitable for a node-name.

<enscript highlight="scheme">(define make-node gensym)
</enscript>
===== {{connect!}}
<procedure>(connect! world connectend connector direction) → unspecified</procedure>
Bi-connect two locations over a direction and its inverse.
; world : The graph-world within which to connect
; connectend : The node to be connected
; connector : The connecting node
; direction : The relative direction to connect over
<enscript highlight="scheme">(define (connect! world connectend connector direction)
  (hash-table-update!/default
    world
    connectend
    (lambda (location)
      (vector-set! (location-neighbors location) direction connector)
      location)
    (make-dirty-location))
  (hash-table-update!/default
    world
    connector
    (lambda (location)
      (vector-set!
        (location-neighbors location)
        (reverse-direction direction)
        connectend)
      location)
    (make-dirty-location)))
</enscript>
===== {{random-start}}
<procedure>(random-start world) → symbol</procedure>
Find a random starting node in the given world.
; world : The world to search
<enscript highlight="scheme">(define (random-start world)
  (let ((nodes (hash-table-keys world)))
    (list-ref nodes (bsd-random-integer (length nodes)))))
</enscript>
===== {{make-randomized-graph-agent}}
<procedure>(make-randomized-graph-agent start) → agent</procedure>
Make a simply reflex agent that randomly searches the graph and
cleans dirty squares.
; start : Starting square (see `random-start')
<enscript highlight="scheme">(define (make-randomized-graph-agent start)
  (make-reflex-agent
    start
    (lambda (location clean?)
      (if clean? (list-ref '(left right up down) (random-direction)) 'suck))))
</enscript>
===== {{default-n-nodes}}
<parameter>default-n-nodes → 20</parameter>
Default number of nodes for a graph
<enscript highlight="scheme">(define default-n-nodes (make-parameter 20))
</enscript>
===== {{make-linear-world}}
<procedure>(make-linear-world) → graph</procedure>
<procedure>(make-linear-world n-nodes) → graph</procedure>
Make a world that consists of a line of nodes (for testing
pathological cases.
; n-nodes : Number of nodes in the graph (default: (default-n-nodes))
<enscript highlight="scheme">(define make-linear-world
  (case-lambda
    (() (make-linear-world (default-n-nodes)))
    ((n-nodes)
     (let ((world (make-graph))
           (nodes (list-tabulate n-nodes (lambda i (make-node)))))
       (for-each
         (lambda (node1 node2) (connect! world node1 node2 right))
         (drop nodes 1)
         (drop-right nodes 1))
       world))))
</enscript>
===== {{make-preferential-depth-first-world}}
<procedure>(make-preferential-depth-first-world) → graph</procedure>
<procedure>(make-preferential-depth-first-world n-nodes) → graph</procedure>
Create a random-graph using depth-first search that nevertheless
shows preference for connected nodes (á la Barabási-Albert).

The graph has no cycles.
; n-nodes : The number of nodes in the graph (default: (default-n-nodes))
<enscript highlight="scheme">(define make-preferential-depth-first-world
  (case-lambda
    (() (make-preferential-depth-first-world (default-n-nodes)))
    ((n-nodes)
     (let* ((world (make-seed-world)) (start (random-start world)))
       (let iter ((node start)
                  (n-nodes (max 0 (- n-nodes (count-nodes world))))
                  (n-degrees (count-degrees world)))
         (if (zero? n-nodes)
           world
           (let ((location
                   (hash-table-ref/default world node (make-dirty-location))))
             (let ((n-neighbors (n-neighbors location)))
               (if (and (< n-neighbors 4)
                        (< (bsd-random-real) (/ n-neighbors n-degrees)))
                 (let* ((new-directions
                          (vector-fold
                            (lambda (direction directions neighbor)
                              (if (no-passage? neighbor)
                                (cons direction directions)
                                directions))
                            '()
                            (location-neighbors location)))
                        (new-direction
                          (list-ref
                            new-directions
                            (bsd-random (length new-directions)))))
                   (let ((new-node (make-node)))
                     (connect! world node new-node new-direction)
                     (iter new-node (- n-nodes 1) (+ n-degrees 2))))
                 (let* ((neighbors
                          (vector-fold
                            (lambda (direction neighbors neighbor)
                              (if (passage? neighbor)
                                (cons neighbor neighbors)
                                neighbors))
                            '()
                            (location-neighbors location)))
                        (neighbor
                          (list-ref
                            neighbors
                            (bsd-random (length neighbors)))))
                   (iter neighbor n-nodes n-degrees)))))))))))
</enscript>
===== {{make-graph-world}}
<procedure>(make-graph-world n-nodes) → graph</procedure>
Make a random graph.
; n-nodes : The number of nodes in the graph (default: (default-n-nodes))
<enscript highlight="scheme">(define make-graph-world make-preferential-depth-first-world)
</enscript>
===== {{write-world-as-dot}}
<procedure>(write-world-as-dot world agent) → unspecified</procedure>
<procedure>(write-world-as-dot world agent step) → unspecified</procedure>
<procedure>(write-world-as-dot world agent step width height font-size title) → unspecified</procedure>
Output the graph-world as in dot-notation (i.e. Graphviz).
; world : The graph-world to output
; agent : The agent inhabiting the graph-world
; step : The current step or false
; width : Width of the output
; height : Height of the output
; font-size : Font-size of the output
; title : Title of the output
<enscript highlight="scheme">(define write-world-as-dot
  (case-lambda
    ((world agent) (write-world-as-dot world agent #f))
    ((world agent step)
     (write-world-as-dot
       world
       agent
       step
       (default-width)
       (default-height)
       (default-font-size)
       (default-title)))
    ((world agent step width height font-size title)
     (write-dot-preamble agent step width height font-size title)
     (write-dot-nodes world agent)
     (write-dot-edges world)
     (write-dot-postscript))))
</enscript>
===== {{write-world-as-pdf}}
<procedure>(write-world-as-pdf world agent pdf) → unspecified</procedure>
Output the graph-world as a pdf via graphviz.
; world : The world to output
; agent : The agent that inhabits the world
; pdf : The file to write to
<enscript highlight="scheme">(define (write-world-as-pdf world agent pdf)
  (receive
    (input output id)
    (process "neato" `("-Tpdf" "-o" ,pdf))
    (with-output-to-port
      output
      (lambda () (write-world-as-dot world agent #f #f #f #f #f)))
    (flush-output output)
    (close-output-port output)
    (close-input-port input)))
</enscript>
===== {{write-world-as-gif}}
<procedure>(write-world-as-gif world agent frame gif) → unspecified</procedure>
<procedure>(write-world-as-gif world agent frame gif width height font-size title) → unspecified</procedure>
Output the graph-world as gif via Graphviz (useful for e.g. animations).
; world : The graph-world to output
; agent : The agent inhabiting the graph-world
; frame : The frame-number
; gif : The base-name of the gif to write to
; width : Width of the output
; height : Height of the output
; font-size : Font-size of the output
; title : Title of the output
<enscript highlight="scheme">(define write-world-as-gif
  (case-lambda
    ((world agent frame gif)
     (write-world-as-gif
       world
       agent
       frame
       gif
       (default-width)
       (default-height)
       (default-font-size)
       (default-title)))
    ((world agent frame gif width height font-size title)
     (receive
       (input output id)
       (process "neato" `("-Tgif" "-o" ,gif))
       (with-output-to-port
         output
         (lambda ()
           (write-world-as-dot
             world
             agent
             frame
             width
             height
             font-size
             title)))
       (flush-output output)
       (close-output-port output)
       (close-input-port input)))))
</enscript>
===== {{make-unknown-location}}
<procedure>(make-unknown-location clean?) → location</procedure>
Make a graph-location whose neighbors are all unknown.
; clean? : Is the graph-location clean?
<enscript highlight="scheme">(define (make-unknown-location clean?)
  (make-location
    (if clean? clean dirty)
    (vector unknown unknown unknown unknown)))
</enscript>
===== {{reverse-move}}
<procedure>(reverse-move move) → direction</procedure>
Reverse the relative direction.
; move : The relative direction to reverse
<enscript highlight="scheme">(define (reverse-move move)
  (case move ((left) 'right) ((right) 'left) ((up) 'down) ((down) 'up)))
</enscript>
===== {{direction->move}}
<procedure>(direction->move direction) → relative direction</procedure>
Convert a neighbor-index into a relative direction.
; direction : The index to convert
<enscript highlight="scheme">(define (direction->move direction) (list-ref '(left right up down) direction))
</enscript>
===== {{move->direction}}
<procedure>(move->direction move) → index</procedure>
Convert a relative direction into a neighbor index.
; move : The relative direction to convert
<enscript highlight="scheme">(define (move->direction move)
  (case move ((left) left) ((right) right) ((up) up) ((down) down)))
</enscript>
===== {{make-stateful-graph-agent}}
<procedure>(make-stateful-graph-agent start) → agent</procedure>
Make a graph-traversal agent that models the graph and searches it thoroughly, stopping when the world is clean.

The agent can detect cycles.
; start : Starting position of the agent (see `random-start')
<enscript highlight="scheme">(define (make-stateful-graph-agent start)
  (make-reflex-agent
    start
    (let ((world (make-hash-table))
          (nodes (list->stack (list start)))
          (moves (make-stack)))
      (lambda (node clean?)
        (if (stack-empty? nodes)
          'noop
          (if (not clean?)
            'suck
            (let ((location
                    (hash-table-ref/default
                      world
                      node
                      (make-unknown-location clean?))))
              (if (stack-empty? moves)
                (hash-table-set! world node location)
                (let ((last-move (stack-peek moves)))
                  (if (eq? last-move 'backtrack)
                    (stack-pop! moves)
                    (if (eq? (stack-peek nodes) node)
                      (let ((last-move (stack-pop! moves)))
                        (vector-set!
                          (location-neighbors location)
                          (move->direction last-move)
                          no-passage))
                      (let* ((last-node (stack-peek nodes))
                             (last-location (hash-table-ref world last-node)))
                        (if (hash-table-exists? world node)
                          (stack-push! nodes cycle)
                          (begin
                            (hash-table-set! world node location)
                            (stack-push! nodes node)))
                        (vector-set!
                          (location-neighbors location)
                          (move->direction (reverse-move last-move))
                          last-node)
                        (vector-set!
                          (location-neighbors last-location)
                          (move->direction last-move)
                          node))))))
              (let ((new-moves
                      (map direction->move
                           (undiscovered-directions location))))
                (if (or (cycle? (stack-peek nodes)) (null? new-moves))
                  (begin
                    (stack-pop! nodes)
                    (if (stack-empty? moves)
                      'noop
                      (let ((move (stack-pop! moves)))
                        (stack-push! moves 'backtrack)
                        (reverse-move move))))
                  (let ((move (list-ref
                                new-moves
                                (bsd-random (length new-moves)))))
                    (stack-push! moves move)
                    move))))))))))
</enscript>
===== {{simulate-graph}}
<procedure>(simulate-graph world agent) → unspecified</procedure>
<procedure>(simulate-graph world agent steps) → unspecified</procedure>
Simulate the graph world.
; world : The world to simulate
; agent : The agent to inhabit the world
; steps : The steps to simulate (default: (default-steps))
<enscript highlight="scheme">(define simulate-graph
  (case-lambda
    ((world agent) (simulate-graph world agent (default-steps)))
    ((world agent steps)
     (parameterize
       ((randomize! bsd-randomize))
       (simulate
         (compose-environments
           (make-step-limited-environment steps)
           (make-debug-environment agent)
           (make-graph-environment world agent)
           (make-graph-performance-measure world agent)))))))
</enscript>
===== {{simulate-graph/animation}}
<procedure>(simulate-graph/animation world agent file) → unspecified</procedure>
<procedure>(simulate-graph/animation world agent file steps) → unspecified</procedure>
<procedure>(simulate-graph/animation world agent file steps width height font-size title) → unspecified</procedure>
Simulate the graph world, creating an animation along the way;
see, for instance, <http://youtu.be/EvZvyxAoNdo>.

Requires Graphviz.
; world : The world to simulate
; agent : The agent that inhabits the world
; file : The base-name of the animation file
; steps : The steps to simulation (default: `(default-steps)'
; width : Width of the animation in pixels
; hight : Height of the animation in pixels
; font-size : Font-size of the animation in points
; title : Title of the animation
<enscript highlight="scheme">(define simulate-graph/animation
  (case-lambda
    ((world agent file)
     (simulate-graph/animation world agent file (default-steps)))
    ((world agent file steps)
     (simulate-graph/animation
       world
       agent
       file
       steps
       (default-width)
       (default-height)
       (default-font-size)
       (default-title)))
    ((world agent file steps width height font-size title)
     (let ((directory (create-temporary-directory)))
       (parameterize
         ((randomize! bsd-randomize))
         (simulate
           (compose-environments
             (make-step-limited-environment steps)
             (make-graph-animating-environment
               world
               agent
               directory
               width
               height
               font-size
               title)
             (make-finalizing-environment
               (make-animation-finalizer directory file)
               steps)
             (make-debug-environment agent)
             (make-graph-environment world agent)
             (make-graph-performance-measure world agent))))
       directory))))
</enscript>
===== {{compare-graphs}}
<procedure>(compare-graphs world agent-one title-one agent-two title-two composite-file) → unspecified</procedure>
<procedure>(compare-graphs world agent-one title-one agent-two title-two composite-file steps width height font-size) → unspecified</procedure>
Simulate two agents in a given world and animate their progress
side-by-side; see, for instance, <http://youtu.be/B28ay_zSnoY>.

Requires Graphviz.
; world : The world to simulate
; agent-one : The first inhabiting agent
; title-one : Title of the first agent
; agent-two : The second inhabiting agent
; title-two : Title of the second agent
; composite-file : Base-name of the composite animation
<enscript highlight="scheme">(define compare-graphs
  (case-lambda
    ((world agent-one title-one agent-two title-two composite-file)
     (compare-graphs
       world
       agent-one
       title-one
       agent-two
       title-two
       composite-file
       (default-steps)
       (/ (default-width) 2)
       (default-height)
       (/ (default-font-size) 2)))
    ((world agent-one
            title-one
            agent-two
            title-two
            composite-file
            steps
            width
            height
            font-size)
     (let ((directory-one
             (simulate-comparatively
               (copy-world world)
               agent-one
               steps
               width
               height
               font-size
               title-one))
           (directory-two
             (simulate-comparatively
               world
               agent-two
               steps
               width
               height
               font-size
               title-two)))
       (let ((composite-directory (create-temporary-directory)))
         (system*
           "cd ~a && for i in *; do echo $i; convert +append $i ~a/$i ~a/$i; done"
           directory-one
           directory-two
           composite-directory)
         ((make-animation-finalizer composite-directory composite-file)))))))
</enscript>
=== About this egg

==== Author

[[/users/klutometis|Peter Danenberg]]
==== Colophon

Documented by [[/egg/cock|cock]].