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
|
import Data.Array.IArray
import Data.Tree
import Control.Arrow
import qualified Data.Set as S
import Data.Foldable (toList)
import Data.Sequence hiding (filter)
data Color
= Red
| Orange
| Yellow
| Green
| Blue
| Purple
deriving (Eq, Show)
data Shape
= Square
| Times
| Plus
| Triangle
| Arrow
| Circle
| Equals
deriving (Eq, Show)
linearGrid =
[ (Green , Times )
, (Yellow , Triangle )
, (Green , Square )
, (Yellow , Arrow )
, (Purple , Circle )
, (Purple , Equals )
, (Blue , Triangle )
, (Yellow , Arrow )
, (Orange , Triangle )
, (Green , Arrow )
, (Orange , Square )
, (Green , Square )
, (Blue , Plus )
, (Green , Arrow )
, (Blue , Triangle )
, (Green , Square )
, (Orange , Triangle )
, (Orange , Square )
, (Red , Square )
, (Blue , Times )
, (Red , Plus )
, (Orange , Times )
, (Purple , Equals )
, (Blue , Equals )
, (Green , Square )
, (Orange , Times )
, (Red , Square )
, (Orange , Triangle )
, (Blue , Equals )
, (Blue , Times )
, (Red , Plus )
, (Orange , Triangle )
, (Blue , Plus )
, (Yellow , Triangle )
, (Green , Circle )
, (Purple , Circle )
]
arrayBounds = ((0,0),(5,5))
endPos :: (Int, Int)
endPos = (5,5)
startPos :: (Int, Int)
startPos = (0, 0)
arrayGrid :: Array (Int,Int) (Color, Shape)
arrayGrid = listArray arrayBounds linearGrid
validPositions pos =
map (,snd pos) (foo $ fst pos) ++ map (fst pos,) (foo $ snd pos)
where foo x = [0 .. x 1] ++ [x + 1 .. 5]
legalPositions pos = filter g vps
where symbol = arrayGrid ! pos
vps = validPositions pos
f (a,b) (c,d) = a == c || b == d
g = (f symbol) . (arrayGrid !)
allMoveSequences = unfoldTree (id &&& legalPositions) startPos
findSolution queue (parents, (Node root children)) =
if root == endPos
then newParents
else let hd :< tl = viewl $ queue >< fromList (map (newParents,) newChildren) in
findSolution tl hd
where newParents = parents |> root
newChildren = filter (not . onQueue . rootLabel) children
onQueue x = S.member x $ S.fromList $ map (rootLabel . snd) $ toList queue
solution = findSolution empty (empty, allMoveSequences)
toNumber (x, y) = 6 * x + y + 1
main = print $ map toNumber $ toList solution |