6-2 initial version (not working)

1 files changed, 108 insertions, 0 deletions

diff --git a/6-2.hs b/6-2.hs
new file mode 100644
index 0000000..5153fb8
--- /dev/null
+++ b/6-2.hs
@@ -0,0 +1,108 @@
+import Control.Monad.State
+import Control.Parallel
+import Control.Parallel.Strategies
+import Data.List ((\\), intersperse, nub)
+
+type Map = [[Tile]]
+data Tile = Free | Obstacle deriving (Eq, Show)
+data Coords = Coords Int Int deriving (Eq, Show)
+type Vel = Coords
+
+width, height :: [[a]] -> Int
+width = length . head
+height = length
+
+map2 :: (a -> b) -> [[a]] -> [[b]]
+map2 = map . map
+
+showMap :: Map -> String
+showMap = unlines . map2 f
+  where
+    f :: Tile -> Char
+    f Free = '.'
+    f Obstacle = '#'
+
+sub :: Map -> Coords -> Tile
+sub m c@(Coords x y)
+  | outOfBounds m c = Free
+  | otherwise = m !! y !! x
+
+parseLines :: [[Char]] -> Map
+parseLines =
+  let p c = case c of
+              '#' -> Obstacle
+              _   -> Free
+  in map2 p
+
+startingPosition :: [[Char]] -> Coords
+startingPosition = head . coords . map2 (== '^')
+  where
+    coords :: [[Bool]] -> [Coords]
+    coords xs = [ Coords x y | x <- [0 .. width xs  - 1]
+                             , y <- [0 .. height xs - 1]
+                             , xs !! y !! x
+                             ]
+
+move :: Vel -> Coords -> Coords
+move (Coords vx vy) (Coords px py) = Coords (px + vx) (py + vy)
+
+checkAhead :: Map -> Vel -> Coords -> Bool
+checkAhead m = (((== Free) . sub m) .) . move
+
+turn :: Vel -> Coords -> (Coords, Vel)
+turn v p = let rot (Coords x y) = Coords (-y) x
+               v' = rot v
+  in (move v' p, v')
+
+step :: Map -> Vel -> Coords -> (Coords, Vel)
+step m v p = if checkAhead m v p
+  then (move v p, v)
+  else turn v p
+
+outOfBounds :: Map -> Coords -> Bool
+outOfBounds m (Coords x y) = x < 0 || x >= w || y < 0 || y >= h
+  where
+    w = width m
+    h = height m
+
+-- return true if loop
+run :: Map -> Vel -> Coords -> State [(Coords,Vel)] Bool
+run m v p = do
+  if outOfBounds m p
+    then return False
+    else do
+    t <- get
+    if (p,v) `elem` t
+      then return True
+      else do
+      modify ((p,v):)
+      let (p', v') = step m v p
+        in run m v' p'
+
+block :: Map -> (Int, Int) -> Map
+block m (x,y) =
+  [
+    [ if (x',y') == (x,y)
+      then Obstacle
+      else sub m (Coords x' y')
+    | x' <- [0 .. width m - 1] ]
+  | y' <- [0 .. height m - 1]
+  ]
+
+possibilities :: Map -> [Coords]-> [Map]
+possibilities m cs =
+  let coords = map (\ (Coords x y) -> (x,y)) cs
+  in coords `pseq` (map (block m) coords `using` parList rseq)
+
+main :: IO ()
+main = do
+  ls <- lines <$> getContents
+  let m = parseLines ls
+  let p = startingPosition ls
+  let v = Coords 0 (-1)
+  let path = map fst $ execState (run m v p) []
+  let ms = possibilities m $ nub path
+  let res = ms `pseq` (map (\ n -> evalState (run n v p) []) ms `using` parList rdeepseq)
+--  putStr . unlines . intersperse "--" . map (showMap . fst) . filter snd . zip ms $ res
+  print . length . filter id $ res
+--  print . length $ ms