forked from sekia/Piet
-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
evaluator.ml
461 lines (405 loc) · 14.1 KB
/
evaluator.ml
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
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
type codel_chooser = Left | Right
type direction = North | East | South | West
type point = int * int
type edges =
{ north: point * point;
east: point * point;
south: point * point;
west: point * point }
type block =
{ color: Picture.color;
edges: edges;
size: int }
module ColorBlocks =
struct
module Codels =
Set.Make (
struct
type t = point
let compare (a : t) b = compare a b
end)
module Map =
Map.Make (
struct
type t = point
let compare (a : t) b = compare a b
end)
type t = block Map.t
let find = Map.find
let edges codels =
assert (codels <> Codels.empty);
let edge_coordinates fixed_coord variable_coord =
let variable_coords fixed_value =
Codels.fold
(fun codel (curr_min, curr_max) ->
let c = variable_coord codel in (min curr_min c, max curr_max c))
(Codels.filter
(fun codel -> (fixed_coord codel) = fixed_value)
codels)
(max_int, 0) in
let fixed1, fixed2 =
Codels.fold
(fun codel (curr_min, curr_max) ->
let c = fixed_coord codel in (min curr_min c, max curr_max c))
codels
(max_int, 0) in
let variable11, variable12 = variable_coords fixed1 in
let variable21, variable22 = variable_coords fixed2 in
(fixed1, variable11, variable12), (fixed2, variable21, variable22) in
let (west_x, west_y_right, west_y_left),
(east_x, east_y_left, east_y_right) = edge_coordinates fst snd in
let (north_y, north_x_left, north_x_right),
(south_y, south_x_right, south_x_left) = edge_coordinates snd fst in
{ north = ((north_x_left, north_y), (north_x_right, north_y));
east = ((east_x, east_y_left), (east_x, east_y_right));
south = ((south_x_left, south_y), (south_x_right, south_y));
west = ((west_x, west_y_left), (west_x, west_y_right)) }
let of_picture picture =
assert (Array.fold_left
(fun acc color -> acc && color = Picture.Black)
true
picture.(0));
let height, width =
(Array.length picture), (Array.length picture.(0)) in
let color_block ((x, y) as codel) =
let color = picture.(y).(x) in
let queue = Queue.create () in
let rec color_block acc =
if Queue.is_empty queue then (color, acc)
else
begin
let x, y = Queue.pop queue in
let adjoining_codels =
List.filter
(fun ((x, y) as codel) ->
0 <= x && x < width && 0 <= y && y < height
&& picture.(y).(x) = color && not @@ Codels.mem codel acc)
[ (x - 1, y); (x + 1, y); (x, y - 1); (x, y + 1) ] in
List.iter
(fun codel -> Queue.push codel queue)
adjoining_codels;
color_block
@@ Codels.union acc @@ Codels.of_list adjoining_codels
end in
Queue.push codel queue;
color_block @@ Codels.add codel Codels.empty in
let blocks = ref Map.empty in
for i = 0 to height - 1 do
for j = 0 to width - 1 do
let codel = (j, i) in
if not @@ Map.mem codel !blocks then
let (color, codels) = color_block codel in
let block = { color;
edges = edges codels;
size = Codels.cardinal codels } in
Codels.iter
(fun codel -> blocks := Map.add codel block !blocks)
codels
done
done;
!blocks
end
module Stack =
struct
type t = int list
let empty = []
let dump = function
| [] -> "[]"
| stack ->
"[ " ^ (String.concat ", " @@ List.map string_of_int stack) ^ " ]"
let push stack x = x :: stack
let pop = function
| [] -> ([], None)
| x :: stack -> (stack, Some x)
let pop2 = function
| x :: y :: stack -> (stack, Some (x, y))
| stack -> (stack, None)
let roll stack depth n =
if depth <= 0 then stack
else
let rec take rest depth acc =
if depth = 0 then Some (List.rev acc, rest)
else
match rest with
| [] -> None
| x :: rest -> take rest (depth - 1) (x :: acc) in
match take stack depth [] with
| None -> stack
| Some (taken, rest) ->
let n = n mod depth in
let n = if n < 0 then n + depth else n in
match take taken n [] with
| None -> assert (false)
| Some (latter, former) -> former @ latter @ rest
end
module Trace =
Set.Make (
struct
type t = direction * point
let compare (a : t) b = compare a b
end)
type t =
{ blocks: ColorBlocks.t;
codel_chooser: codel_chooser;
debug: bool;
direction: direction;
point: point;
stack: Stack.t }
let create ?(debug=false) picture =
{ blocks = ColorBlocks.of_picture picture;
codel_chooser = Left;
debug;
direction = East;
point = (1, 1);
stack = Stack.empty }
let block_at evaluator point = ColorBlocks.find point evaluator.blocks
let codel_chooser_name = function
| Left -> "Left"
| Right -> "Right"
let direction_name = function
| North -> "North"
| East -> "East"
| South -> "South"
| West -> "West"
let point_description point blocks =
let block = ColorBlocks.find point blocks in
let x, y = point in
Printf.sprintf "(%d, %d) = %s" x y (Picture.color_name block.color)
let evaluator_description evaluator =
let color =
let block = block_at evaluator evaluator.point in
Picture.color_name block.color in
let codel_chooser = codel_chooser_name evaluator.codel_chooser in
let direction = direction_name evaluator.direction in
let x, y = evaluator.point in
Printf.sprintf
"Point: (%d, %d) = %s, Codel Chooser: %s, Direction: %s, Stack: %s"
x y color codel_chooser direction (Stack.dump evaluator.stack)
let forward evaluator (x, y) =
match evaluator.direction with
| North -> (x, y - 1)
| East -> (x + 1, y)
| South -> (x, y + 1)
| West -> (x - 1, y)
let rotate_direction evaluator =
let direction = match evaluator.direction with
| North -> East
| East -> South
| South -> West
| West -> North in
if evaluator.debug then
prerr_endline
@@ "DP rotated: "
^ (direction_name evaluator.direction)
^ " -> "
^ (direction_name direction);
{ evaluator with direction }
let toggle_codel_chooser evaluator =
let codel_chooser = match evaluator.codel_chooser with
| Left -> Right
| Right -> Left in
if evaluator.debug then
prerr_endline
@@ "CC toggled: "
^ (codel_chooser_name evaluator.codel_chooser)
^ " -> "
^ (codel_chooser_name codel_chooser);
{ evaluator with codel_chooser }
module Command =
struct
let darkness =
let open Picture in
function
| Black | White -> invalid_arg "darkness"
| Color (Light, _) -> 0
| Color (Normal, _) -> 1
| Color (Dark, _) -> 2
let hue =
let open Picture in
function
| Black | White -> invalid_arg "hue"
| Color (_, Red) -> 0
| Color (_, Yellow) -> 1
| Color (_, Green) -> 2
| Color (_, Cyan) -> 3
| Color (_, Blue) -> 4
| Color (_, Magenta) -> 5
let darkness_change prev_color color =
let prev_darkness, darkness = darkness prev_color, darkness color in
(darkness - prev_darkness + 3) mod 3
let hue_change prev_color color =
let prev_hue, hue = hue prev_color, hue color in
(hue - prev_hue + 6) mod 6
let nop _ evaluator = evaluator
let push prev_evaluator evaluator =
let prev_block = block_at prev_evaluator prev_evaluator.point in
{ evaluator with stack = Stack.push evaluator.stack prev_block.size }
let pop _ evaluator =
let stack, _ = Stack.pop evaluator.stack in
{ evaluator with stack }
let unary_command command =
fun _ evaluator ->
let stack, popped = Stack.pop evaluator.stack in
match popped with
| None -> evaluator
| Some x -> command { evaluator with stack } x
let binary_command command =
fun _ evaluator ->
let stack, popped = Stack.pop2 evaluator.stack in
match popped with
| None -> evaluator
| Some (x, y) -> command { evaluator with stack } x y
let binary_arithmetic op =
binary_command
(fun evaluator x y ->
{ evaluator with stack = Stack.push evaluator.stack (op y x) })
let add = binary_arithmetic ( + )
let subtract = binary_arithmetic ( - )
let multiply = binary_arithmetic ( * )
let divide prev_evaluator evaluator =
try binary_arithmetic ( / ) prev_evaluator evaluator
with Division_by_zero -> evaluator
let mod_ prev_evaluator evaluator =
let mod_ x y =
let mod_ = x mod y in
if mod_ * y >= 0 then mod_ else mod_ + y in
try binary_arithmetic mod_ prev_evaluator evaluator
with Division_by_zero -> evaluator
let not =
unary_command
(fun evaluator x ->
let not = if x = 0 then 1 else 0 in
{ evaluator with stack = Stack.push evaluator.stack not })
let greater =
let greater x y = if x > y then 1 else 0 in
binary_arithmetic greater
let pointer =
unary_command
(fun evaluator x ->
let x = x mod 4 in
let x = if x < 0 then x + 4 else x in
let evaluator = ref evaluator in
for i = 1 to x do
evaluator := rotate_direction !evaluator
done;
!evaluator)
let switch =
unary_command
(fun evaluator x ->
if x mod 2 = 0 then evaluator
else toggle_codel_chooser evaluator)
let duplicate =
unary_command
(fun evaluator x ->
let stack = Stack.push evaluator.stack x in
let stack = Stack.push stack x in
{ evaluator with stack })
let roll =
binary_command
(fun evaluator x y ->
{ evaluator with stack = Stack.roll evaluator.stack y x })
let in_char _ evaluator =
let char = input_char stdin in
{ evaluator with stack = Stack.push evaluator.stack @@ Char.code char }
let in_number _ evaluator =
{ evaluator with stack = Stack.push evaluator.stack @@ read_int () }
let out_char =
unary_command
(fun evaluator x ->
print_string @@ Text.char x;
evaluator)
let out_number =
unary_command
(fun evaluator x ->
print_int x;
evaluator)
let process prev_evaluator evaluator =
let block_color evaluator =
let block = block_at evaluator evaluator.point in
block.color in
let prev_color, color =
block_color prev_evaluator, block_color evaluator in
let dispatched, op_name =
if prev_color = Picture.White || color = Picture.White then nop, "nop"
else
match hue_change prev_color color, darkness_change prev_color color
with
| 0, 0 -> nop, "nop"
| 0, 1 -> push, "push"
| 0, 2 -> pop, "pop"
| 1, 0 -> add, "add"
| 1, 1 -> subtract, "substract"
| 1, 2 -> multiply, "multiply"
| 2, 0 -> divide, "divide"
| 2, 1 -> mod_, "mod"
| 2, 2 -> not, "not"
| 3, 0 -> greater, "greater"
| 3, 1 -> pointer, "pointer"
| 3, 2 -> switch, "switch"
| 4, 0 -> duplicate, "duplicate"
| 4, 1 -> roll, "roll"
| 4, 2 -> in_number, "in_number"
| 5, 0 -> in_char, "in_char"
| 5, 1 -> out_number, "out_number"
| 5, 2 -> out_char, "out_char"
| _ -> assert (false) in
if evaluator.debug then prerr_endline @@ "OP dispatched: " ^ op_name;
dispatched prev_evaluator evaluator
end
let step evaluator =
if evaluator.debug then prerr_endline @@ evaluator_description evaluator;
let rec slide evaluator trace =
let forward = forward evaluator evaluator.point in
let forward_block = block_at evaluator forward in
match forward_block.color with
| Picture.White -> slide { evaluator with point = forward } trace
| Picture.Black ->
if Trace.mem (evaluator.direction, evaluator.point) trace then None
else
let trace = Trace.add (evaluator.direction, evaluator.point) trace in
let evaluator = rotate_direction @@ toggle_codel_chooser evaluator in
slide evaluator trace
| _ -> Some { evaluator with point = forward } in
let rec move evaluator retry =
if retry = 0 then None
else
let block = block_at evaluator evaluator.point in
let edge_codel =
let edge = match evaluator.direction with
| North -> block.edges.north
| East -> block.edges.east
| South -> block.edges.south
| West -> block.edges.west in
match evaluator.codel_chooser with
| Left -> fst edge
| Right -> snd edge in
let forward = forward evaluator edge_codel in
let forward_block = block_at evaluator forward in
match forward_block.color with
| Picture.Black ->
let change_route =
if retry mod 2 = 0 then toggle_codel_chooser
else rotate_direction in
move (change_route evaluator) (retry - 1)
| _ -> Some { evaluator with point = forward } in
let block = block_at evaluator evaluator.point in
let next_evaluator =
if block.color = Picture.White then slide evaluator Trace.empty
else move evaluator 8 in
match next_evaluator with
| None -> None
| Some next_evaluator ->
if evaluator.debug then
begin
prerr_endline
@@ "Moved to: "
^ (point_description next_evaluator.point next_evaluator.blocks);
flush stderr
end;
Some (Command.process evaluator next_evaluator)
let run ?(debug=false) picture =
let evaluator = create ~debug picture in
let rec loop = function
| None -> ()
| Some evaluator -> loop @@ step evaluator in
loop (Some evaluator)