Outdated egg!

This is an egg for CHICKEN 4, the unsupported old release. You're almost certainly looking for the CHICKEN 5 version of this egg, if it exists.

If it does not exist, there may be equivalent functionality provided by another egg; have a look at the egg index. Otherwise, please consider porting this egg to the current version of CHICKEN.

aima

Support for Russell-Norvig's AIMA

Outdated egg!
aima

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

Define both a record type and a vector-form printer.

(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)))))))))

`debug?`

[parameter] debug? → #t

Should we print debugging information to stdout?

(define debug? (make-parameter #t))

`debug-print`

[procedure] (debug-print key value) → unspecified
[procedure] (debug-print key value out) → unspecified

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

(define debug-print
  (case-lambda
    ((key value) (debug-print key value #t))
    ((key value out) (if (debug?) (format out "~a: ~a~%" key value)))))

`random-seed`

[parameter] random-seed → #f

`random-seed' is passed to `randomize!' during `simulate'.

(define random-seed (make-parameter #f))

`randomize!`

[parameter] randomize! → randomize

`randomize!' is called before simulation and is seeded with `random-seed'.

(define randomize! (make-parameter randomize))

`simulate`

[procedure] (simulate environment) → #f
[procedure] (simulate environment randomize! random-seed) → #f

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

(define simulate
  (case-lambda
    ((environment) (simulate environment (randomize!) (random-seed)))
    ((environment randomize! random-seed)
     (if random-seed (randomize! random-seed))
     (loop ((while (environment)))))))

`compose-environments`

[procedure] (compose-environments . environments) → environment

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

(define (compose-environments . environments)
  (lambda ()
    (every identity (map (lambda (environment) (environment)) environments))))

`make-performance-measuring-environment`

[procedure] (make-performance-measuring-environment measure-performance score-update!) → environment

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

(define (make-performance-measuring-environment
         measure-performance
         score-update!)
  (lambda () (score-update! (measure-performance))))

`default-steps`

[parameter] default-steps → 1000

Default number of steps for the step-limited environment

(define default-steps (make-parameter 1000))

`make-step-limited-environment`

[procedure] (make-step-limited-environment) → environment
[procedure] (make-step-limited-environment steps) → environment

Make an environment that stops simulation after a certain number of steps.

steps: The number of steps after which to stop simulating

(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))))))

`make-debug-environment`

[syntax] (make-debug-environment object make-printable-object) → environment

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

(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)))))))))

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)

The failure object: to distinguish bona-fide solutions to a CSP that are #f.

(define failure (make-failure))

`success?`

[procedure] (success? result) → boolean

Success is defined negatively as the absence of failure.

result: The result to test

(define success? (complement failure?))

`csp`

[record] csp

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

(define-record-and-printer csp domains constraints neighbors)

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)))))
 => #<unspecified>

`backtracking-search`

[procedure] (backtracking-search csp) → object or {{failure}}

Find a solution to the CSP or return failure.

csp: The CSP to solve

(define (backtracking-search csp)
  (let ((enumeration (backtracking-enumeration 1 csp)))
    (if (null? enumeration) failure (car enumeration))))

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)))))
 => #<unspecified>

(hash-table->alist (backtracking-search arc-consistent-coloring))
 => ((a . white) (b . black))

`backtracking-enumeration`

[procedure] (backtracking-enumeration csp) → list
[procedure] (backtracking-enumeration n csp) → list
[procedure] (backtracking-enumeration csp cons nil stop?) → list

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.

(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)))))

`ac-3`

[procedure] (ac-3 csp) → boolean

Check arc-consistency of a csp; returns #t if the object is arc-consistent.

csp: A constraint-satisfaction object

(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))))))))

`xor`

[syntax] (xor x y) → boolean

Logical xor: whether one or the other proposition is true (but not both)

x: A proposition
y: Another proposition

(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))))))))

`neq?`

[procedure] (neq? x y) → boolean

The complement to eq?

x: Comparandum
y: Comparator

(define neq? (complement eq?))

`random-map`

[procedure] (random-map n) → hash-table

Create a random k-coloring problem; returns an adjacency-list of nodes as a hash-table.

n: The number of nodes in the problem

(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))))))))))))

`shuffle`

[procedure] (shuffle list) → list

Shuffle a list.

list: The list to shuffle

(define (shuffle list)
  (let ((vector (list->vector list))) (shuffle! vector) (vector->list vector)))

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

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

(define-record node state parent action path-cost)

`tessellation`

[record] tessellation

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

(define-record-and-printer tessellation R-object points neighbors start end)

`tessellate`

[procedure] (tessellate) → tessellation
[procedure] (tessellate n-vertices) → tessellation

Tessellate the plane into disjoint, convex polygons.

n-vertices: The numbers of vertices in the tessellation

(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)))))))

`point-distance`

[procedure] (point-distance p1 p2) → distance

Calculate the distance between two points.

p1: The first point
p2: The second point

(define (point-distance p1 p2)
  (sqrt (+ (expt (- (point-x p1) (point-x p2)) 2)
           (expt (- (point-y p1) (point-y p2)) 2))))

`predecessor-path`

[procedure] (predecessor-path node) → list

List the predecessors of this node.

node: The node to predecess

(define (predecessor-path node)
  (let iter ((path (list node)))
    (let ((parent (node-parent (car path))))
      (if parent (iter (cons parent path)) path))))

`plot-tessellation`

[procedure] (plot-tessellation tessellation path title filename) → unspecified

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

(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)))))

`plot-tessellation/animation`

[procedure] (plot-tessellation/animation tessellation path title filename) → unspecified

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')

(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)))))))

`join-animations`

[procedure] (join-animations output . animations) → unspecified

Join the animation files into one long file.

output: The resultant file
animations: The input files

(define (join-animations output . animations)
  (run (mencoder -ovc copy -idx -o ,output ,@animations)))

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

Display the two-square vacuum world as a vector.

world: The two-square vacuum world to be displayed

(define (display-world world)
  (pp (vector-append
        '#(world)
        (vector-map
          (lambda (i location) (if (clean? location) 'clean 'dirty))
          world))))

`clean`

[constant] clean → (make-clean)

A clean square

(define clean (make-clean))

`dirty`

[constant] dirty → (make-dirty)

A dirty square

(define dirty (make-dirty))

`unknown`

[constant] unknown → (make-unknown)

An unknown square (either clean or dirty)

(define unknown (make-unknown))

`left`

[constant] left → 0

Index of the left square

(define left 0)

`left?`

[procedure] (left? square) → true if it is the left square

Is this the left square?

square: The square to be lefted

(define left? zero?)

`right`

[constant] right → 1

Index of the right square

(define right 1)

`right?`

[procedure] (right? square) → true if it is the right square

Is this the right square?

square: The square to be righted

(define right? (cute = <> 1))

`make-world`

[procedure] (make-world left right) → a two-square vacuum world

Make a two-square vacuum-world.

left: State of the left square (clean or dirty)
right: State of the left square (clean or dirty)

(define make-world vector)

`world-location`

[procedure] (world-location square) → the square-status

Get a square-status (dirty, clean, unknown, &c.) from the two-square vacuum-world.

square: The square's index (`left' or `right')

(define world-location vector-ref)

`world-location-set!`

[procedure] (world-location-set! square status) → unspecified

Set the status of a square to dirty, clean, unknown, &c.

square: The square to be set
status: The status to set it to

(define world-location-set! vector-set!)

`agent`

[record] agent

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.

(define-record agent location score program)

`simple-agent-program`

[procedure] (simple-agent-program location clean?) → one of 'left, 'right, 'suck, 'noop

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

(define (simple-agent-program location clean?)
  (if clean? (if (left? location) 'right 'left) 'suck))

`make-stateful-agent-program`

[procedure] (make-stateful-agent-program) → stateful agent program

Make an agent program that models the two-square vacuum-world, and stops cleaning.

(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))))

`make-reflex-agent`

[procedure] (make-reflex-agent location) → unspecified
[procedure] (make-reflex-agent location program) → unspecified

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'.

(define make-reflex-agent
  (case-lambda
    ((location) (make-reflex-agent location (default-agent-program)))
    ((location program) (make-agent location 0 program))))

`make-simple-reflex-agent`

[procedure] (make-simple-reflex-agent location) → a simple reflex agent

Make a simple reflex agent and place it in the given location.

location: Where to place the agent: `left' or `right'

(define (make-simple-reflex-agent location)
  (make-reflex-agent location simple-agent-program))

`make-stateful-reflex-agent`

[procedure] (make-stateful-reflex-agent location) → a stateful reflex agent

Make a stateful reflex agent and place it in the given location.

location: Where to place the agent: `left' or `right'

(define (make-stateful-reflex-agent location)
  (make-reflex-agent location (make-stateful-agent-program)))

`make-performance-measure`

[procedure] (make-performance-measure world) → environment

Make a performance measure that awards one point for every clean square.

(define (make-performance-measure world)
  (lambda () (vector-count (lambda (i square) (clean? square)) world)))

`make-score-update!`

[procedure] (make-score-update! agent) → a monadic procedure that takes the score to add

Make a score-updater that adds score to the score of an agent.

agent: The agent whose score to add to

(define (make-score-update! agent)
  (lambda (score) (agent-score-set! agent (+ (agent-score agent) score))))

[procedure] (simulate-vacuum world agent) → the agent-score
[procedure] (simulate-vacuum world agent steps) → the agent-score
[procedure] (simulate-vacuum world agent steps make-environment) → the agent-score

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')

(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))))

`simulate-penalizing-vacuum`

[procedure] (simulate-penalizing-vacuum world agent) → the agent-score
[procedure] (simulate-penalizing-vacuum world agent steps) → the agent-score

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)

(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))))

Graph-based vacuum-world

`make-graph`

[procedure] (make-graph) → graph

Make a hash-table-based adjacency list.

(define make-graph make-hash-table)

`up`

[constant] up → 2

Index of the up square

(define up 2)

`up?`

[procedure] (up?) → true if it is the up square

Is this the up square?

(define up? (cute = <> 2))

`down`

[constant] down → 3

Index of the down square

(define down 3)

`down?`

[procedure] (down?) → true if this is the down square

Is this the down square?

(define down? (cute = <> 3))

`location`

[record] location

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.

(define-record location status neighbors)

`copy-world`

[procedure] (copy-world world) → graph-world

Make a deep copy of a graph-world.

world: The world to copy

(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))

`make-node`

[procedure] (make-node) → symbol

Make a unique symbol suitable for a node-name.

(define make-node gensym)

`connect!`

[procedure] (connect! world connectend connector direction) → unspecified

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

(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)))

`random-start`

[procedure] (random-start world) → symbol

Find a random starting node in the given world.

world: The world to search

(define (random-start world)
  (let ((nodes (hash-table-keys world)))
    (list-ref nodes (bsd-random-integer (length nodes)))))

`make-randomized-graph-agent`

[procedure] (make-randomized-graph-agent start) → agent

Make a simply reflex agent that randomly searches the graph and cleans dirty squares.

start: Starting square (see `random-start')

(define (make-randomized-graph-agent start)
  (make-reflex-agent
    start
    (lambda (location clean?)
      (if clean? (list-ref '(left right up down) (random-direction)) 'suck))))

`default-n-nodes`

[parameter] default-n-nodes → 20

Default number of nodes for a graph

(define default-n-nodes (make-parameter 20))

`make-linear-world`

[procedure] (make-linear-world) → graph
[procedure] (make-linear-world n-nodes) → graph

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

(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))))

`make-preferential-depth-first-world`

[procedure] (make-preferential-depth-first-world) → graph
[procedure] (make-preferential-depth-first-world n-nodes) → graph

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

(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)))))))))))

`make-graph-world`

[procedure] (make-graph-world n-nodes) → graph

Make a random graph.

n-nodes: The number of nodes in the graph (default: (default-n-nodes))

(define make-graph-world make-preferential-depth-first-world)

`write-world-as-dot`

[procedure] (write-world-as-dot world agent) → unspecified
[procedure] (write-world-as-dot world agent step) → unspecified
[procedure] (write-world-as-dot world agent step width height font-size title) → unspecified

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

(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))))

`write-world-as-pdf`

[procedure] (write-world-as-pdf world agent pdf) → unspecified

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

(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)))

`write-world-as-gif`

[procedure] (write-world-as-gif world agent frame gif) → unspecified
[procedure] (write-world-as-gif world agent frame gif width height font-size title) → unspecified

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

(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)))))

`make-unknown-location`

[procedure] (make-unknown-location clean?) → location

Make a graph-location whose neighbors are all unknown.

clean?: Is the graph-location clean?

(define (make-unknown-location clean?)
  (make-location
    (if clean? clean dirty)
    (vector unknown unknown unknown unknown)))

`reverse-move`

[procedure] (reverse-move move) → direction

Reverse the relative direction.

move: The relative direction to reverse

(define (reverse-move move)
  (case move ((left) 'right) ((right) 'left) ((up) 'down) ((down) 'up)))

`direction->move`

[procedure] (direction->move direction) → relative direction

Convert a neighbor-index into a relative direction.

direction: The index to convert

(define (direction->move direction) (list-ref '(left right up down) direction))

`move->direction`

[procedure] (move->direction move) → index

Convert a relative direction into a neighbor index.

move: The relative direction to convert

(define (move->direction move)
  (case move ((left) left) ((right) right) ((up) up) ((down) down)))

`make-stateful-graph-agent`

[procedure] (make-stateful-graph-agent start) → agent

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')

(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))))))))))

`simulate-graph`

[procedure] (simulate-graph world agent) → unspecified
[procedure] (simulate-graph world agent steps) → unspecified

Simulate the graph world.

world: The world to simulate
agent: The agent to inhabit the world
steps: The steps to simulate (default: (default-steps))

(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)))))))

`simulate-graph/animation`

[procedure] (simulate-graph/animation world agent file) → unspecified
[procedure] (simulate-graph/animation world agent file steps) → unspecified
[procedure] (simulate-graph/animation world agent file steps width height font-size title) → unspecified

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

(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))))

`compare-graphs`

[procedure] (compare-graphs world agent-one title-one agent-two title-two composite-file) → unspecified
[procedure] (compare-graphs world agent-one title-one agent-two title-two composite-file steps width height font-size) → unspecified

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

(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)))))))

0.1: Version 0.1
0.2: 0.2
0.3: Version 0.3
0.4: Version 0.4
0.5: Version 0.5
0.5.1: Add some docs.
0.5.2: Add cock to depends.
0.5.3: Generate docs at setup-time.
0.6: Version 0.6
0.7: Tessellation!
0.7.1: Animated plots of tessellations
0.7.2: Fix dependency in R.
0.7.3: Add lolevel.
0.7.4: Use lavc.
0.7.5: With a note about cock-utils
0.7.6: Use numbers.
0.7.7: Add test-exit.
0.8: Search
0.8.1: Fix +inf; `goal?' is node, not state.
0.8.2: make-random-points
0.8.3: Add random-bsd.
0.8.4: Tessellation has its own point?
0.9: Add CSPs.
0.9.1: Add some csp-functions.
0.9.2: CSP: Use null-neighbors as default.
0.9.3: Debug
0.9.4: Fix some tests; export a few functions; &c.
0.9.5: Fix test.
0.9.6: Random-map
0.9.7: Graph visualization functions
0.9.8: Cons in enumeration
0.9.9: Export shuffle.
0.9.10: Use the new graphviz.
0.9.11: Remove the dependency on setup-helper-cock.
0.9.12: Remove the dependency on debug.
0.9.13: Evaluate examples.
0.9.14: Use hahn.

Colophon

Documented by hahn.