-
Notifications
You must be signed in to change notification settings - Fork 0
/
15_puzzle_solver.fs
executable file
·66 lines (53 loc) · 2.52 KB
/
15_puzzle_solver.fs
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
#! /usr/bin/gforth
cell 8 <> [if] s" 64-bit system required" exception throw [then]
\ In the stack comments below,
\ "h" stands for the hole position (0..15),
\ "s" for a 64-bit integer representing a board state,
\ "t" a tile value (0..15, 0 is the hole),
\ "b" for a bit offset of a position within a state,
\ "m" for a masked value (4 bits selected out of a 64-bit state),
\ "w" for a weight of a current path,
\ "d" for a direction constant (0..3)
\ Utility
: 3dup 2 pick 2 pick 2 pick ;
: 4dup 2over 2over ;
: shift dup 0 > if lshift else negate rshift then ;
hex 123456789abcdef0 decimal constant solution
: row 2 rshift ; : col 3 and ;
: up-valid? ( h -- f ) row 0 > ;
: down-valid? ( h -- f ) row 3 < ;
: left-valid? ( h -- f ) col 0 > ;
: right-valid? ( h -- f ) col 3 < ;
: up-cost ( h t -- 0|1 ) 1 - row swap row < 1 and ;
: down-cost ( h t -- 0|1 ) 1 - row swap row > 1 and ;
: left-cost ( h t -- 0|1 ) 1 - col swap col < 1 and ;
: right-cost ( h t -- 0|1 ) 1 - col swap col > 1 and ;
\ To iterate over all possible directions, put direction-related functions into arrays:
: ith ( u addr -- w ) swap cells + @ ;
create valid? ' up-valid? , ' left-valid? , ' right-valid? , ' down-valid? , does> ith execute ;
create cost ' up-cost , ' left-cost , ' right-cost , ' down-cost , does> ith execute ;
create step -4 , -1 , 1 , 4 , does> ith ;
\ Advance from a single state to another:
: bits ( h -- b ) 15 swap - 4 * ;
: tile ( s b -- t ) rshift 15 and ;
: new-state ( s h d -- s' ) step dup >r + bits 2dup tile ( s b t ) swap lshift tuck - swap r> 4 * shift + ;
: new-weight ( w s h d -- w' ) >r tuck r@ step + bits tile r> cost + ;
: advance ( w s h d -- w s h w' s' h' ) 4dup new-weight >r 3dup new-state >r step over + 2r> rot ;
\ Print a solution:
: rollback 2drop drop ;
: .dir ( u -- ) s" d..r.l..u" drop 4 + swap + c@ emit ;
: .dirs ( .. -- ) 0 begin >r 3 pick -1 <> while 3 pick over - .dir rollback r> 1+ repeat r> ;
: win cr ." solved (read right-to-left!): " .dirs ." - " . ." moves" bye ;
\ The main recursive function for depth-first search:
create limit 1 , : deeper 1 limit +! ;
: u-turn ( .. h2 w1 s1 h1 ) 4 pick 2 pick - ;
: search ( .. h2 w1 s1 h1 )
over solution = if win then
2 pick limit @ > if exit then
4 0 do dup i valid? if i step u-turn <> if i advance recurse rollback then then loop ;
\ Iterative-deepning search:
: solve 1 limit ! begin search deeper again ;
\ -1 0 hex 0c9dfbae37254861 decimal 0 solve
-1 0 hex fe169b4c0a73d852 decimal 8 solve
\ -1 0 hex 123456789afbde0c decimal 14 solve
bye