-
Notifications
You must be signed in to change notification settings - Fork 49
/
online-navigation.scm
208 lines (196 loc) · 8.32 KB
/
online-navigation.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
;; [[file:~/prg/scm/aima/aima.org::*Simulation][Simulation:1]]
(use aima-tessellation
animation
define-record-and-printer
debug
files
format
miscmacros
random-bsd
shell
srfi-95
stack)
(define-record-and-printer agent
point
score
program)
(define zero-motion (make-point 0 0))
(define (zero-motion? move) (equal? move zero-motion))
(define origin (make-point 0 0))
(define (origin? move) (equal? move zero-motion))
(define-record-and-printer stop)
(define stop (make-stop))
(define (write-dot-preamble width height title score)
(display "digraph G {")
(display "node [shape=point];")
(let ((width-in-inches (/ width 96))
(height-in-inches (/ height 96)))
(format #t "graph [fontsize=48, label=\"~a (Score: ~,2f)\", ratio=fill, viewport=\"~a,~a\", size=\"~a,~a!\", labelloc=t];"
title
score
(* width-in-inches 72)
(* height-in-inches 72)
width-in-inches
height-in-inches)))
;;; Oh, shit; we're going to have to assign absolute points here
;;; starting arbitrarily with the first node.
;;;
;;; Unless we have some kind of path, this is problematic; should we
;;; assign absolute coördinates as we discover them?
;;;
;;; Christ, maybe we should label these things as we find them, too.
;;;
;;; No, in order to coordinates rigorously; we're going to have to
;;; backtrack. Can we update as we go along? The map may change,
;;; depending on what root we find.
;;;
;;; No; let's wipe the absolute coordinates clean every time we
;;; teleport, but keep the relative ones.
(define (write-agent-as-dot points
coordinates
labels
result
untried
unbacktracked
previous-state
previous-action
start
goal
score)
(write-dot-preamble 1600 900 "Online DFS" score)
(let ((displayed (make-hash-table))
(linear-scale (* 5 72)))
(define (node-maybe-display state label)
(hash-table-update!
displayed
state
identity
(lambda ()
(let ((coordinate
(coordinate-point
(hash-table-ref coordinates state))))
(format #t "~a [pos=\"~a,~a\"~a];"
label
(* (point-x coordinate) linear-scale)
(* (point-y coordinate) linear-scale)
(cond ((equal? state start)
", shape=circle, label=S")
((equal? state goal)
", shape=circle, label=G")
(else ""))))
#t)))
(hash-table-walk result
(lambda (whence whither->action)
(hash-table-walk whither->action
(lambda (whither action)
(let ((whence-label
(hash-table-ref labels whence))
(whither-label
(hash-table-ref labels whither)))
(node-maybe-display whence whence-label)
(node-maybe-display whither whither-label)
(format #t "~a -> ~a [color=~a, penwidth=~a];"
whence-label
whither-label
(if (equal? whence previous-state)
"orange"
"blue")
(if (equal? whence previous-state)
2
1))))))))
(display "}"))
(define (write-agent-as-png png
points
coordinates
labels
result
untried
unbacktracked
previous-state
previous-action
start
goal
score)
(let ((dot (create-temporary-file ".dot")))
(with-output-to-file dot
(lambda () (write-agent-as-dot points
coordinates
labels
result
untried
unbacktracked
previous-state
previous-action
start
goal
score)))
(run (neato -n1 -Tpng -o ,png < ,dot))))
(define-record-and-printer coordinate
point
time)
(define (simulate-navigation make-agent
#!key
(n-points 50)
(n-steps 1000)
(p-slippage 0)
(animation-file #f))
(let ((world (tessellate n-points)))
(let ((points (tessellation-points world))
(neighbors (tessellation-neighbors world))
(goal (tessellation-end world)))
;; (debug (length points))
(receive (next-frame finalize!)
(make-animator)
(let* ((start (list-ref points (random (length points))))
(agent (make-agent start next-frame)))
(dotimes (step n-steps agent)
(let* ((agent-point (agent-point agent))
(visible-points (hash-table-ref neighbors agent-point))
(relative-points
(map (lambda (point)
(make-point (- (point-x point) (point-x agent-point))
(- (point-y point) (point-y agent-point))))
visible-points)))
(let* ((goal? (equal? agent-point goal))
;; Initial hypothesis: agent dictates a move.
(move ((agent-program agent) relative-points goal? (agent-score agent)))
;; We may revise this to wind up somewhere else
;; (ends up being less than p-slippage, because
;; it may randomly select the point it meant to
;; move to).
(move (if (< (random-real) p-slippage)
;; Add the zero-motion case.
(list-ref (cons zero-motion relative-points)
(random (add1 (length relative-points))))
move)))
(debug move)
(let* ((relative->visible-points
(alist->hash-table (zip relative-points visible-points)))
(new-point
(if (and (zero-motion? move) goal?)
(begin
(agent-score-set! agent (+ (agent-score agent) 1000))
(list-ref points (random (length points))))
(if (stop? move)
(error "Stop!")
(if (zero-motion? move)
agent-point
(begin
(agent-score-set! agent
(- (agent-score agent)
(point-distance zero-motion move)))
(make-point (+ (point-x move) (point-x agent-point))
(+ (point-y move) (point-y agent-point)))
(car (hash-table-ref relative->visible-points move))))))))
(if goal? (debug (agent-score agent)))
(agent-point-set! agent new-point)))))
(debug (agent-score agent))
(when animation-file
(finalize! animation-file)
;; (run (sudo -E vt mplayer -really-quiet -vo fbdev2 -loop 0 ,animation-file))
;; sudo mplayer -really-quiet -vo fbdev2 -vf scale=1440:900 online-dfs-random-statistics.avi
;; (run (sudo mplayer -vo fbdev2 -loop 0 ,animation-file))
;; (run (vt mplayer -really-quiet -vo fbdev2 -loop 0 ,animation-file))
(run (mplayer -really-quiet -loop 0 ,animation-file)))
(agent-score agent))))))
;; Simulation:1 ends here