Mercurial > repos > other > SevenLanguagesInSevenWeeks

annotate 7-Haskell/day3-maze.hs @ 102:d3e35dfc6f84

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Do some "have we been here via another route" filtering This (combined with simplified maze) means we solve the maze in under 10s!
author IBBoard <dev@ibboard.co.uk>
date Sun, 14 Jul 2019 13:43:22 +0100
parents 830140560f70
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
100
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
1 module Day3Maze where
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
2 import System.IO
102
d3e35dfc6f84 Do some "have we been here via another route" filtering
IBBoard <dev@ibboard.co.uk>
parents: 100
diff changeset
3 import Data.Set (empty, fromList, union, notMember)
100
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
4
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
5 -- This is a "type" alias, because they're just naming pre-existing types with specific patterns
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
6 -- Note: Nested lists with indexes will be inefficient compared to Vectors, but I'm working with what I know!
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
7 type Maze = [[Node]]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
8 type Coords = (Int, Int)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
9 type Node = (Coords, [Direction])
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
10 data Direction = North | South | East | West deriving (Show, Eq)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
11
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
12 -- Input map based on https://github.com/icefox/asciimaze/blob/master/sample-mazes/input1.txt
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
13
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
14 -- Usage:
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
15 --
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
16 -- my_maze <- parseMap "day3-simple.maze"
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
17 -- let exits = findExits my_maze
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
18 -- solveMaze my_maze exits
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
19
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
20 -- Currently takes too long on bay3.maze because a) the paths are double-width and b) we don't discard routes that get to the same position by a different route
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
21
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
22 parseMap :: String -> IO Maze
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
23 parseMap map_path = do
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
24 file_contents <- (readFile map_path)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
25 let file_lines = lines file_contents
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
26 return (parseMap' file_lines)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
27
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
28 findExits :: Maze -> Maybe (Node, Node)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
29 findExits maze = let exits = findExits' maze
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
30 in if (length exits) == 2 then Just (exits !! 0, exits !! 1) else Nothing
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
31
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
32 solveMaze :: Maze -> Maybe (Node, Node) -> [Coords]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
33 solveMaze maze (Just (start, end)) = findRoute maze (fst end) [[fst start]]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
34 solveMaze maze _ = []
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
35
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
36 findRoute :: Maze -> Coords -> [[Coords]] -> [Coords]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
37 findRoute maze exit routes
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
38 | routes == [] = [] -- No solution
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
39 | successful_routes /= [] = head successful_routes
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
40 | otherwise = findRoute maze exit (step maze routes)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
41 where successful_routes = filter ((exit ==) . head) routes
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
42
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
43 getNode' :: [[a]] -> Int -> Int -> a
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
44 getNode' two_d_array x y = (two_d_array !! y) !! x
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
45
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
46 getNode :: [[a]] -> Coords -> a
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
47 getNode two_d_array (x, y) = getNode' two_d_array x y
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
48
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
49 getRelativeNode :: Maze -> Coords -> Direction -> Node
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
50 getRelativeNode maze (x, y) direction =
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
51 case direction of
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
52 North -> getNode' maze x (y - 1)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
53 South -> getNode' maze x (y + 1)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
54 East -> getNode' maze (x + 1) y
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
55 West -> getNode' maze (x - 1) y
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
56
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
57 parseMap' :: [String] -> Maze
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
58 parseMap' map_string = zipWith (makeRow map_string) [0..] map_string
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
59
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
60 makeRow :: [String] -> Int -> String -> [Node]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
61 makeRow map_string row_num cols = zipWith (makeNode map_string row_num) [0..] cols
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
62
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
63 makeNode :: [String] -> Int -> Int -> Char -> Node
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
64 makeNode map_string row_num col_num node = if node /= ' ' then ((col_num, row_num), [])
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
65 else ((col_num, row_num), makeExitsList map_string row_num col_num)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
66
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
67 makeExitsList :: [String] -> Int -> Int -> [Direction]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
68 -- FIXME: This can probably be done with a "map (isExit…) directions", with a modified isExit
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
69 makeExitsList map_string row_num col_num = map fst (filter snd (zip directions isExitDirections))
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
70 where {
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
71 directions = [North, South, East, West] ;
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
72 isExitDirections = [isExit map_string col_num (row_num - 1), isExit map_string col_num (row_num + 1), isExit map_string (col_num + 1) row_num, isExit map_string (col_num - 1) row_num]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
73 }
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
74
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
75 isExit :: [String] -> Int -> Int -> Bool
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
76 isExit map_string x y
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
77 | y < 0 || x < 0 = False
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
78 | y >= length map_string || x >= length (map_string !! y) = False
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
79 | otherwise = (getNode' map_string x y) == ' '
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
80
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
81 findExits' :: Maze -> [Node]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
82 -- Examine the outside by taking the first and last item from each row, and the first and last row)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
83 -- This doubles up the corners, but we'll make an assumption that the corner is always filled in!
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
84 findExits' maze = let candidates = (map last maze) ++ (map head maze) ++ (head maze) ++ (last maze)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
85 in filter (\node -> (snd node) /= []) candidates
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
86
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
87 step :: Maze -> [[Coords]] -> [[Coords]]
102
d3e35dfc6f84 Do some "have we been here via another route" filtering
IBBoard <dev@ibboard.co.uk>
parents: 100
diff changeset
88 -- Map out all of the next steps, but remove ones that go back on themselves (head is in its own tail) or that we've been to before
d3e35dfc6f84 Do some "have we been here via another route" filtering
IBBoard <dev@ibboard.co.uk>
parents: 100
diff changeset
89 -- (head is in previous points, meaning we've found a shorter route)
d3e35dfc6f84 Do some "have we been here via another route" filtering
IBBoard <dev@ibboard.co.uk>
parents: 100
diff changeset
90 step maze routes = filter (\(hd:lst) -> (hd `notElem` lst) && (hd `notMember` all_previous_points)) (concatMap (\route -> map (: route) (nextSteps maze route)) routes)
d3e35dfc6f84 Do some "have we been here via another route" filtering
IBBoard <dev@ibboard.co.uk>
parents: 100
diff changeset
91 where all_previous_points = foldl union empty (map fromList routes)
100
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
92
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
93 nextSteps :: Maze -> [Coords] -> [Coords]
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
94 nextSteps maze route = map (fst . getRelativeNode maze pos) exits
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
95 where {
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
96 pos:prior_steps = route ;
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
97 exits = snd (getNode maze pos)
830140560f70 First successful attempt at maze parsing and solving
IBBoard <dev@ibboard.co.uk>
parents:
diff changeset
98 }