initial commit

.gitignore

@@ -0,0 +1,172 @@
+# ---> Haskell
+dist
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+.stack-work/
+
+# ---> C Sharp
+# Build Folders (you can keep bin if you'd like, to store dlls and pdbs)
+[Bb]in/
+[Oo]bj/
+
+# mstest test results
+TestResults
+
+## Ignore Visual Studio temporary files, build results, and
+## files generated by popular Visual Studio add-ons.
+
+# User-specific files
+*.suo
+*.user
+*.sln.docstates
+
+# Build results
+[Dd]ebug/
+[Rr]elease/
+x64/
+*_i.c
+*_p.c
+*.ilk
+*.meta
+*.obj
+*.pch
+*.pdb
+*.pgc
+*.pgd
+*.rsp
+*.sbr
+*.tlb
+*.tli
+*.tlh
+*.tmp
+*.log
+*.vspscc
+*.vssscc
+.builds
+
+# Visual C++ cache files
+ipch/
+*.aps
+*.ncb
+*.opensdf
+*.sdf
+
+# Visual Studio profiler
+*.psess
+*.vsp
+*.vspx
+
+# Guidance Automation Toolkit
+*.gpState
+
+# ReSharper is a .NET coding add-in
+_ReSharper*
+
+# NCrunch
+*.ncrunch*
+.*crunch*.local.xml
+
+# Installshield output folder
+[Ee]xpress
+
+# DocProject is a documentation generator add-in
+DocProject/buildhelp/
+DocProject/Help/*.HxT
+DocProject/Help/*.HxC
+DocProject/Help/*.hhc
+DocProject/Help/*.hhk
+DocProject/Help/*.hhp
+DocProject/Help/Html2
+DocProject/Help/html
+
+# Click-Once directory
+publish
+
+# Publish Web Output
+*.Publish.xml
+
+# NuGet Packages Directory
+packages
+
+# Windows Azure Build Output
+csx
+*.build.csdef
+
+# Windows Store app package directory
+AppPackages/
+
+# Others
+[Bb]in
+[Oo]bj
+sql
+TestResults
+[Tt]est[Rr]esult*
+*.Cache
+ClientBin
+[Ss]tyle[Cc]op.*
+~$*
+*.dbmdl
+Generated_Code #added for RIA/Silverlight projects
+
+# Backup & report files from converting an old project file to a newer
+# Visual Studio version. Backup files are not needed, because we have git ;-)
+_UpgradeReport_Files/
+Backup*/
+UpgradeLog*.XML
+
+# ---> C++
+# Compiled Object files
+*.slo
+*.lo
+*.o
+*.obj
+
+# Precompiled Headers
+*.gch
+*.pch
+
+# Compiled Dynamic libraries
+*.so
+*.dylib
+*.dll
+
+# Fortran module files
+*.mod
+
+# Compiled Static libraries
+*.lai
+*.la
+*.a
+*.lib
+
+# Executables
+*.exe
+*.out
+*.app
+
+# ---> Java
+*.class
+
+# Mobile Tools for Java (J2ME)
+.mtj.tmp/
+
+# Package Files #
+*.jar
+*.war
+*.ear
+
+# virtual machine crash logs, see http://www.java.com/en/download/help/error_hotspot.xml
+hs_err_pid*
+

APU/APU2-1.txt

@@ -0,0 +1,7 @@
+7
+5
+2..2.1.
+.3..5.3
+.2.1...
+2...2..
+.1....2

APU/APU2.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE MultiParamTypeClasses, RankNTypes, FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns, FunctionalDependencies, TupleSections  #-}
+
+module Main (main) where
+
+import System.IO
+import Control.Applicative
+import Control.Monad
+import Data.Array
+import Data.Function
+import Data.Functor
+import Data.Functor.Identity
+import Data.List
+import Data.Monoid
+import Debug.Trace
+
+import qualified Data.Foldable as F
+import qualified Data.Set      as S
+
+type Node      = (Int, Int)
+type NodeArray = Array Node (Int, [Node], [Node])
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    
+    (width, height) <- (,) <$> readLn <*> readLn
+
+    let readCell d = (case d of { '.' -> (-1); _ -> read [d] }, [], [])
+    gridLines <- replicateM height getLine
+    let nodes' = listArray ((0,0),(width-1,height-1)) . concatMap (map readCell) $
+                 transpose gridLines
+    
+    -- traceM $ unlines $ [show width, show height] ++ gridLines
+    
+    let firstCell f is = take 1 [ i | i <- map f is, (nodes'!i)^._1 >= 0 ]
+    let nodes = nodes' //
+            [ ((x1,y1),(x,ns++ns,[]))
+            | ((x1,y1),(x,_,_)) <- zip (indices nodes') (elems nodes')
+            , x >= 0
+            , let ns = firstCell (,y1) [x1+1..width-1] ++ firstCell (x1,) [y1+1..height-1]
+            ]
+
+    forM_ (head $ loop nodes (indices nodes) []) $ \((x1,y1),(x2,y2)) ->
+        putStrLn . unwords $ map show [x1,y1,x2,y2,1]
+
+loop :: NodeArray -> [Node] -> [(Node,Node)] -> [[(Node, Node)]]
+loop nodes []      links = [] <$ guard (connected nodes)
+loop nodes (n1:ns) links = if (nodes!n1)^._1 < 1 then loop nodes ns links else do
+    n2 <- nub $ (nodes!n1)^._2
+    guard $ (nodes!n2)^._1 >= 1
+    guard . not $ any (crosses (n1,n2)) links
+    let nodes' = accum (\(x,ns,ls) n -> (x-1,delete n ns,n:ls)) nodes [(n1,n2), (n2,n1)]
+    ls <- loop nodes' (n1:ns) ((n1,n2):links)
+    return $ (n1,n2):ls
+
+crosses :: (Node,Node) -> (Node,Node) -> Bool
+crosses ((ax1,ay1),(bx1,by1)) ((ax2,ay2),(bx2,by2)) =
+    (ax1 == bx1 && ay2 == by2 && (ax1 > ax2 && ax1 < bx2) && (ay2 > ay1 && ay2 < by1)) ||
+    (ax2 == bx2 && ay1 == by1 && (ax2 > ax1 && ax2 < bx1) && (ay1 > ay2 && ay1 < by2))
+
+connected :: NodeArray -> Bool
+connected nodes = go (S.singleton (head allNodes)) S.empty
+    where
+        allNodes = filter (\i -> (nodes!i)^._1 >= 0) $ indices nodes
+        go ns vs = case S.minView ns of
+            Nothing     -> S.size vs == length allNodes
+            Just (n, _) -> let ns' = ns `S.union` S.fromList ((nodes!n)^._3)
+                               vs'  = S.insert n vs
+                           in go (S.difference ns' vs') vs'
+
+--
+-- Primitive lenses for easy access to the parts of a tuple
+--
+
+type Lens s t a b    = Functor f => (a -> f b) -> s -> f t
+type Getting r s a   = (a -> Const r a) -> s -> Const r s
+type Setting s t a b = (a -> Identity b) -> s -> Identity t
+
+class Field1 s t a b | s -> a, t -> b, s b -> t, t a -> s where _1 :: Lens s t a b
+class Field2 s t a b | s -> a, t -> b, s b -> t, t a -> s where _2 :: Lens s t a b
+class Field3 s t a b | s -> a, t -> b, s b -> t, t a -> s where _3 :: Lens s t a b
+class Field4 s t a b | s -> a, t -> b, s b -> t, t a -> s where _4 :: Lens s t a b
+
+instance Field1 (a,b)     (a',b)     a a' where _1 f (a,b)     = (,b)     <$> f a
+instance Field2 (a,b)     (a,b')     b b' where _2 f (a,b)     = (a,)     <$> f b
+instance Field1 (a,b,c)   (a',b,c)   a a' where _1 f (a,b,c)   = (,b,c)   <$> f a
+instance Field2 (a,b,c)   (a,b',c)   b b' where _2 f (a,b,c)   = (a,,c)   <$> f b
+instance Field3 (a,b,c)   (a,b,c')   c c' where _3 f (a,b,c)   = (a,b,)   <$> f c
+instance Field1 (a,b,c,d) (a',b,c,d) a a' where _1 f (a,b,c,d) = (,b,c,d) <$> f a
+instance Field2 (a,b,c,d) (a,b',c,d) b b' where _2 f (a,b,c,d) = (a,,c,d) <$> f b
+instance Field3 (a,b,c,d) (a,b,c',d) c c' where _3 f (a,b,c,d) = (a,b,,d) <$> f c
+instance Field4 (a,b,c,d) (a,b,c,d') d d' where _4 f (a,b,c,d) = (a,b,c,) <$> f d
+
+view :: Getting a s a -> s -> a
+view l = getConst . l Const
+
+(^.) :: s -> Getting a s a -> a
+(^.) = flip view
+infixl 8 ^.
+
+over :: Setting s t a b -> (a -> b) -> s -> t
+over l f = runIdentity . l (Identity . f)
+
+set :: Setting s t a b -> b -> s -> t
+set l = over l . const

APU/APU2.txt

@@ -0,0 +1,6 @@
+4
+4
+25.1
+47.4
+..1.
+3344

Contests/BackToTheCode/BackToTheCode01.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+
+import System.IO
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+import qualified Data.Set         as S
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    
+    trailRef <- newIORef []
+
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+    
+        modifyIORef trailRef (((myX, myY):) . take 2)
+        trail <- readIORef trailRef
+        
+        -- treat recent "collisions" as occupied spaces
+        let grid' = accum (\c _ -> if c == '.' then 'X' else c) grid $ map (,()) trail
+    
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case findTarget (myX, myY) trail grid' opponents myBackInTimeLeft of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+
+findTarget :: (Int, Int)
+           -> [(Int, Int)]
+           -> Array (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> Either Int (Int, Int)
+findTarget myPt@(myX,myY) trail grid opponents myBackInTimeLeft =
+        Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts
+    where
+        scoredPts = map (\pt -> (pt, score pt)) . take 50
+                  . map fst . sortBy (compare `on` snd)
+                  . map (\(x,y) -> ((x,y), dist myPt (x,y) + fromIntegral (abs (myX-x) + abs (myY-y))))
+                  . filter (\p -> inRange (bounds grid) p && grid!p == '.')
+                  $ indices grid
+        baseScore = scoreGrid' myPt grid
+        score pt = (scoreGrid' pt (updateGrid grid myPt pt) - baseScore) / (dist myPt pt ** 2)
+        scoreGrid' pt grid = scoreGrid grid
+            + 3 * sum (map (sqrt . dist pt . fst) opponents)
+        dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
+
+diagonals (x0,y0) i =
+    [ (x0+i, y0  )
+    , (x0+i, y0-i)
+    , (x0,   y0-i)
+    , (x0-i, y0-i)
+    , (x0-i, y0  )
+    , (x0-i, y0+i)
+    , (x0,   y0+i)
+    , (x0+i, y0+i)
+    ]
+
+scoreCells :: Array (Int, Int) Char -> Array (Int, Int) Int
+scoreCells grid = STA.runSTArray $ do
+    scores  <- STA.newArray (bounds grid) 100
+    doWhileM_ $ fmap getAny $ liftM F.fold $ T.forM (assocs grid) $ \(p,g) -> do
+        v  <- STA.readArray scores p
+        nv <- mapM (STA.readArray scores) (neighbours p)
+        let v' | g == '0'   = 400
+               | g /= '.'   = 0
+               | isBorder p = 5
+               | otherwise  = min v $ 5 + minimum nv
+        when (v' /= v) $ STA.writeArray scores p v'
+        return $ Any (v' /= v)
+    return scores    
+    where
+        isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
+            where ((xMin,yMin),(xMax,yMax)) = bounds grid
+        neighbours (x,y) = filter (inRange $ bounds grid) (diagonals (x,y) 1)
+
+scoreGrid grid = sum $ map (sqrt . fromIntegral) $ elems $ scoreCells grid
+
+findPath from@(fromX, fromY) to@(toX, toY)
+    | from  == to  = [to]
+    | fromX == toX = from : findPath (fromX, if fromY < toY then fromY+1 else fromY-1) to
+    | otherwise    = from : findPath (if fromX < toX then fromX+1 else fromX-1, fromY) to
+
+updateGrid :: Array (Int,Int) Char -> (Int, Int) -> (Int, Int) -> Array (Int,Int) Char
+updateGrid grid from to = accum update grid $ map (,()) $ findPath from to
+    where update c _ = if c == '.' then '0' else c
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)

Contests/BackToTheCode/BackToTheCode02.hs

@@ -0,0 +1,169 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+import qualified Data.Set         as S
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    
+    trailRef   <- newIORef []
+    nPointsRef <- newIORef 10
+
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+    
+        modifyIORef trailRef (((myX, myY):) . take 2)
+        trail <- readIORef trailRef
+        
+        -- treat recent "collisions" as occupied spaces
+        let grid' = accum (\c _ -> if c == '.' then 'X' else c) grid $ map (,()) trail
+
+        startTime <- getCPUTime
+        
+        let (action, nPts) = findTarget (myX, myY) trail grid' opponents myBackInTimeLeft
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case action of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+        
+        stopTime <- getCPUTime
+        let diff = stopTime - startTime
+        
+        hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
+
+findTarget :: (Int, Int)
+           -> [(Int, Int)]
+           -> UArray (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> (Either Int (Int, Int), Int)
+findTarget myPt@(myX,myY) trail grid opponents myBackInTimeLeft =
+        (Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts, length scoredPts)
+    where
+        scoredPts = unsafeTimeoutList 90000
+                  . map (\pt -> (pt,) $! score pt)
+                  . map fst . sortBy (compare `on` snd)
+                  . map (\(x,y) -> ((x,y), dist myPt (x,y)))
+                  . filter (\p -> inRange (bounds grid) p && grid!p == '.')
+                  $ indices grid
+        baseScore = scoreGrid' myPt grid
+        score pt = (scoreGrid' pt (updateGrid grid myPt pt) - baseScore) / (dist myPt pt ** 2)
+        scoreGrid' pt grid = scoreGrid grid
+            + 3 * sum (map (sqrt . dist pt . fst) opponents)
+        dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
+
+diagonals (x0,y0) i =
+    [ (x0+i, y0  )
+    , (x0+i, y0-i)
+    , (x0,   y0-i)
+    , (x0-i, y0-i)
+    , (x0-i, y0  )
+    , (x0-i, y0+i)
+    , (x0,   y0+i)
+    , (x0+i, y0+i)
+    ]
+
+scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
+scoreCells grid = STA.runSTUArray $ do
+    scores  <- STA.newArray (bounds grid) 80
+    doWhileM_ $ do
+        fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
+            v  <- STA.readArray scores p
+            nv <- mapM (STA.readArray scores) (neighbours p)
+            let outside = 8 - length (neighbours p)
+            let free    = count ((=='.') . (grid!)) $ neighbours p
+            let mine    = count ((=='0') . (grid!)) $ neighbours p
+            let other   = 8 - (outside + mine + free)
+            let v' | g == '0'   = 100 + 10*mine + 35*(min 1 $ outside + other) + 10*free
+                   | g /= '.'   = 0
+                   | isBorder p = 0
+                   | otherwise  = min v $ minimum nv + (max 0 $ 2*mine - other) + 1
+            when (v' /= v) $ STA.writeArray scores p v'
+            return $ Any (v' /= v)
+    return scores    
+    where
+        isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
+            where ((xMin,yMin),(xMax,yMax)) = bounds grid
+        neighbours (x,y) = filter (inRange $ bounds grid) $ diagonals (x,y) 1
+
+scoreGrid grid = sum $ map (sqrt . fromIntegral) $ elems $ scoreCells grid
+
+findPath from@(fromX, fromY) to@(toX, toY)
+    | from  == to  = [to]
+    | fromX == toX = from : findPath (fromX, if fromY < toY then fromY+1 else fromY-1) to
+    | otherwise    = from : findPath (if fromX < toX then fromX+1 else fromX-1, fromY) to
+
+updateGrid :: UArray (Int,Int) Char -> (Int, Int) -> (Int, Int) -> UArray (Int,Int) Char
+updateGrid grid from to = accum update grid $ map (,()) $ findPath from to
+    where update c _ = if c == '.' then '0' else c
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: F.Foldable f => (a -> Bool) -> f a -> Int
+count f xs = getSum $ F.foldMap (\x -> if f x then Sum 1 else Sum 0) xs
+
+-- Compute elements of the list to WHNF for `t` microseconds.
+-- After `t` microseconds, abandon the calculation and terminate
+-- the list. Note that this causes the length of the result to depend
+-- on timing and system load. Marked "unsafe" for a reason!
+unsafeTimeoutList :: Integer -> [a] -> [a]
+unsafeTimeoutList t xs = unsafePerformIO $ do
+    start <- getCPUTime
+    return $ evalUntil (start + (1000000 * t)) xs
+    where
+        evalUntil end xs = unsafePerformIO $ do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ return $! case xs of
+                []     -> []
+                (a:as) -> a `seq` (a:as)
+            return $ case r of
+                Nothing     -> []
+                Just []     -> []
+                Just (a:as) -> (a : evalUntil end as)
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t

Contests/BackToTheCode/BackToTheCode03.hs

@@ -0,0 +1,171 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+import qualified Data.Set         as S
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    
+    trailRef   <- newIORef []
+    nPointsRef <- newIORef 10
+
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+    
+        modifyIORef trailRef (((myX, myY):) . take 2)
+        trail <- readIORef trailRef
+        
+        -- treat recent "collisions" as occupied spaces
+        let grid' = accum (\c _ -> if c == '.' then 'X' else c) grid $ map (,()) trail
+
+        startTime <- getCPUTime
+        
+        let (action, nPts) = findTarget (myX, myY) trail grid' opponents myBackInTimeLeft
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case action of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+        
+        stopTime <- getCPUTime
+        let diff = stopTime - startTime
+        
+        hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
+
+findTarget :: (Int, Int)
+           -> [(Int, Int)]
+           -> Array (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> (Either Int (Int, Int), Int)
+findTarget myPt@(myX,myY) trail grid opponents myBackInTimeLeft =
+        (Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts, length scoredPts)
+    where
+        scoredPts = unsafeTimeoutList 90000
+                  . (\xs -> trace (unlines $ map show $ take 6 xs) xs)
+                  . map (\rt -> (head rt,) $! score rt)
+                  . map fst . sortBy (compare `on` snd)
+                  . map (\rt -> (rt, length rt))
+                  . map (\(x,y) -> findRoute grid (myX,myY) (x,y))
+                  . filter (\p -> p /= myPt && grid!p == '.')
+                  $ indices grid
+        baseScore = scoreGrid grid
+        score rt = (scoreGrid (updateGrid grid rt) - baseScore) -- / (fromIntegral $ 1 + length rt)
+
+diagonals (x0,y0) i =
+    [ (x0+i, y0  )
+    , (x0+i, y0-i)
+    , (x0,   y0-i)
+    , (x0-i, y0-i)
+    , (x0-i, y0  )
+    , (x0-i, y0+i)
+    , (x0,   y0+i)
+    , (x0+i, y0+i)
+    ]
+
+scoreCells :: Array (Int, Int) Char -> Array (Int, Int) Int
+scoreCells grid = STA.runSTArray $ do
+    scores  <- STA.newArray (bounds grid) 100
+    doWhileM_ $ do
+        fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
+            v  <- STA.readArray scores p
+            nv <- mapM (STA.readArray scores) (neighbours p)
+            let outside = 8 - length (neighbours p)
+            let free    = count ((=='.') . (grid!)) $ neighbours p
+            let mine    = count ((=='0') . (grid!)) $ neighbours p
+            let other   = 8 - (outside + mine + free)
+            let v' | g == '0'   = 100 -- + 10*mine + 35*(min 1 $ outside + other) + 10*free
+                   | g /= '.'   = 0
+                   | isBorder p = 0
+                   | otherwise  = min v $ minimum nv -- + (max 0 $ 2*mine - other) + 1
+            when (v' /= v) $ STA.writeArray scores p v'
+            return $ Any (v' /= v)
+    return scores    
+    where
+        isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
+            where ((xMin,yMin),(xMax,yMax)) = bounds grid
+        neighbours (x,y) = filter (inRange $ bounds grid) $ diagonals (x,y) 1
+
+scoreGrid grid = sum $ map (sqrt . fromIntegral) $ elems $ scoreCells grid
+
+findRoute grid here@(x0,y0) there@(x1,y1) = filter ((=='.') . (grid!)) pts
+    where
+        pts = map (x0,) (tail (y0 `to` y1)) ++
+              map (,y1) (tail (x0 `to` x1)) ++
+              map (x1,) (tail (y1 `to` y0)) ++
+              map (,y0) (tail (x1 `to` x0))
+        x `to` y = [x,x+(if y > x then 1 else -1)..y]
+
+updateGrid :: Array (Int,Int) Char -> [(Int, Int)] -> Array (Int,Int) Char
+updateGrid grid pts = accum update grid $ map (,()) pts
+    where update c _ = if c == '.' then '0' else c
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: F.Foldable f => (a -> Bool) -> f a -> Int
+count f xs = getSum $ F.foldMap (\x -> if f x then Sum 1 else Sum 0) xs
+
+-- Compute elements of the list to WHNF for `t` microseconds.
+-- After `t` microseconds, abandon the calculation and terminate
+-- the list. Note that this causes the length of the result to depend
+-- on timing and system load. Marked "unsafe" for a reason!
+unsafeTimeoutList :: Integer -> [a] -> [a]
+unsafeTimeoutList t xs = unsafePerformIO $ do
+    start <- getCPUTime
+    return $ evalUntil (start + (1000000 * t)) xs
+    where
+        evalUntil end xs = unsafePerformIO $ do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ return $! case xs of
+                []     -> []
+                (a:as) -> a `seq` (a:as)
+            return $ case r of
+                Nothing     -> []
+                Just []     -> []
+                Just (a:as) -> (a : evalUntil end as)
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t

Contests/BackToTheCode/BackToTheCode04.hs

@@ -0,0 +1,182 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+        let claim c pt grid = if grid!pt == '.' then grid // [(pt,c)] else grid
+
+        startTime <- getCPUTime
+        
+        gen <- newStdGen
+        let (action, nPts) = findTarget (myX, myY) (claim 'X' (myX,myY) grid) opponents myBackInTimeLeft gen
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case action of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+        
+        stopTime <- getCPUTime
+        let diff = stopTime - startTime
+        
+        hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
+
+findTarget :: RandomGen g
+           => (Int, Int)
+           -> UArray (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> g
+           -> (Either Int (Int, Int), Int)
+findTarget myPt@(myX,myY) grid opponents myBackInTimeLeft gen =
+        (Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts, length scoredPts)
+    where
+        scoredPts = unsafeTimeoutList 90000
+                  . map (\pt -> let rt = bestRoute grid myPt pt in (head rt,) $! score rt)
+                  . map fst . sortBy (compare `on` snd)
+                  . map (\(r, (x,y)) -> ((x,y), r + dist myPt (x,y)))
+                  . zip (randomRs (0, 2.0::Double) gen)
+                  . filter (\p -> inRange (bounds grid) p && grid!p == '.')
+                  $ indices grid
+        baseScore = scoreGrid' myPt grid
+        score rt = (scoreGrid' (last rt) (updateGrid grid rt) - baseScore) / (fromIntegral (length rt) ** 2)
+        scoreGrid' pt grid = scoreGrid grid
+            + 3 * sum (map (sqrt . dist pt . fst) opponents)
+        dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
+
+neighbours :: (Int,Int) -> Int -> [(Int,Int)]
+neighbours (x0,y0) n =
+    [0..2*n-1] >>= \i ->
+        [ (x0-n+i,y0-n)
+        , (x0+n,y0-n+i)
+        , (x0+n-i,y0+n)
+        , (x0-n,y0+n-i)
+        ]
+
+bestRoute :: UArray (Int,Int) Char -> (Int,Int) -> (Int,Int) -> [(Int,Int)]
+bestRoute grid from@(x0,y0) to@(x1,y1) =
+        if freeCells rt1 < freeCells rt2 then rt2 else rt1
+    where
+        freeCells = count (\p -> grid!p == '.')
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
+        x `to` y | y >= x    = [x+1..y]
+                 | otherwise = [x-1,x-2..y]
+
+updateGrid :: UArray (Int,Int) Char -> [(Int, Int)] -> UArray (Int,Int) Char
+updateGrid grid route = STA.runSTUArray $ do
+    let valid = inRange (bounds grid)
+    grid' <- STA.thaw grid
+    forM_ route $ \p -> when (grid!p == '.') $ STA.writeArray grid' p '0'
+    doWhileM_ . fmap getAny . flip foldMapA (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g /= '.' then pure (Any False) else do
+            gs <- mapM (\p' -> if valid p' then STA.readArray grid' p' else pure 'X')
+                       (neighbours p 1)
+            if any (not . (`elem` ['.','0'])) gs
+                then Any True <$ STA.writeArray grid' p 'M'
+                else pure (Any False)
+    forM_ (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g == '.' then STA.writeArray grid' p '0'
+        else when (g == 'M') $ STA.writeArray grid' p '.'
+    return grid'
+        
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+-- Compute elements of the list to WHNF for `t` microseconds.
+-- After `t` microseconds, abandon the calculation and terminate
+-- the list. Note that this causes the length of the result to depend
+-- on timing and system load. Marked "unsafe" for a reason!
+unsafeTimeoutList :: Integer -> [a] -> [a]
+unsafeTimeoutList t xs = unsafePerformIO $ do
+    start <- getCPUTime
+    return $ evalUntil (start + (1000000 * t)) xs
+    where
+        evalUntil end xs = unsafePerformIO $ do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ return $! case xs of
+                []     -> []
+                (a:as) -> a `seq` (a:as)
+            return $ case r of
+                Nothing     -> []
+                Just []     -> []
+                Just (a:as) -> (a : evalUntil end as)
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+scoreGrid :: UArray (Int, Int) Char -> Double
+scoreGrid grid = sum $ map (sqrt . fromIntegral) $ elems $ scoreCells grid
+
+scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
+scoreCells grid = array (bounds grid) $
+    [ (p,v) | (p, g) <- assocs grid
+            , let valid = inRange (bounds grid)
+            , let ns = map (\p' -> if valid p' then grid!p' else 'X')
+                           (neighbours p 1 ++ neighbours p 2)
+            , let free  = count (=='.') ns
+            , let mine  = count (=='0') ns
+            , let other = count (not . (`elem` ['.','0'])) ns
+            , let v | g == '0'  = 200 + 8*mine + 12*free + 15*other
+                    | g == '.'  = max 0 $ (5 * mine - 2 * other)
+                    | otherwise = 0
+            ]

Contests/BackToTheCode/BackToTheCode05.hs

@@ -0,0 +1,191 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+        let claim c pt grid = if grid!pt == '.' then grid // [(pt,c)] else grid
+
+        startTime <- getCPUTime
+        
+        gen <- newStdGen
+        let (action, nPts) = findTarget (myX, myY) (claim 'X' (myX,myY) grid) opponents myBackInTimeLeft gen
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case action of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+        
+        stopTime <- getCPUTime
+        let diff = stopTime - startTime
+        
+        hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
+
+findTarget :: RandomGen g
+           => (Int, Int)
+           -> UArray (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> g
+           -> (Either Int (Int, Int), Int)
+findTarget myPt@(myX,myY) grid opponents myBackInTimeLeft gen =
+        (Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts, length scoredPts)
+    where
+        scoredPts = unsafeTimeoutList 90000
+                  . map (\pt -> let rt = bestRoute grid myPt pt in (head rt,) $! score rt)
+                  . map fst . sortBy (compare `on` snd)
+                  . map (\(r, (x,y)) -> ((x,y), r + dist myPt (x,y)))
+                  . zip (randomRs (0, 2.0::Double) gen)
+                  . filter (\p -> inRange (bounds grid) p && grid!p == '.')
+                  $ indices grid
+        baseScore = scoreGrid' myPt grid
+        score rt = (scoreGrid' (last rt) (updateGrid grid rt) - baseScore) / (fromIntegral (length rt) ** 2)
+        scoreGrid' pt grid = scoreGrid grid
+            + 3 * sum (map (sqrt . dist pt . fst) opponents)
+        dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
+
+neighbours :: (Int,Int) -> Int -> [(Int,Int)]
+neighbours (x0,y0) n =
+    [0..2*n-1] >>= \i ->
+        [ (x0-n+i,y0-n)
+        , (x0+n,y0-n+i)
+        , (x0+n-i,y0+n)
+        , (x0-n,y0+n-i)
+        ]
+
+bestRoute :: UArray (Int,Int) Char -> (Int,Int) -> (Int,Int) -> [(Int,Int)]
+bestRoute grid from@(x0,y0) to@(x1,y1) =
+        if freeCells rt1 < freeCells rt2 then rt2 else rt1
+    where
+        freeCells = count (\p -> grid!p == '.')
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
+        x `to` y | y >= x    = [x+1..y]
+                 | otherwise = [x-1,x-2..y]
+
+updateGrid :: UArray (Int,Int) Char -> [(Int, Int)] -> UArray (Int,Int) Char
+updateGrid grid route = STA.runSTUArray $ do
+    let valid = inRange (bounds grid)
+    grid' <- STA.thaw grid
+    forM_ route $ \p -> when (grid!p == '.') $ STA.writeArray grid' p '0'
+    doWhileM_ . fmap getAny . flip foldMapA (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g /= '.' then pure (Any False) else do
+            gs <- mapM (\p' -> if valid p' then STA.readArray grid' p' else pure 'X')
+                       (neighbours p 1)
+            if any (not . (`elem` ['.','0'])) gs
+                then Any True <$ STA.writeArray grid' p 'M'
+                else pure (Any False)
+    forM_ (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g == '.' then STA.writeArray grid' p '0'
+        else when (g == 'M') $ STA.writeArray grid' p '.'
+    return grid'
+        
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+-- Compute elements of the list to WHNF for `t` microseconds.
+-- After `t` microseconds, abandon the calculation and terminate
+-- the list. Note that this causes the length of the result to depend
+-- on timing and system load. Marked "unsafe" for a reason!
+unsafeTimeoutList :: Integer -> [a] -> [a]
+unsafeTimeoutList t xs = unsafePerformIO $ do
+    start <- getCPUTime
+    return $ evalUntil (start + (1000000 * t)) xs
+    where
+        evalUntil end xs = unsafePerformIO $ do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ return $! case xs of
+                []     -> []
+                (a:as) -> a `seq` (a:as)
+            return $ case r of
+                Nothing     -> []
+                Just []     -> []
+                Just (a:as) -> (a : evalUntil end as)
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+scoreGrid :: UArray (Int, Int) Char -> Double
+scoreGrid grid = sum $ map (sqrt . fromIntegral) $ elems $ scoreCells grid
+
+scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
+scoreCells grid = STA.runSTUArray $ do
+    scores  <- STA.newArray (bounds grid) 80
+    doWhileM_ $ do
+        fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
+            v  <- STA.readArray scores p
+            nv <- mapM (STA.readArray scores) (neighbours p)
+            let outside = 8 - length (neighbours p)
+            let free    = count ((=='.') . (grid!)) $ neighbours p
+            let mine    = count ((=='0') . (grid!)) $ neighbours p
+            let other   = 8 - (outside + mine + free)
+            let v' | g == '0'   = 100 + 10*mine + 35*(min 1 $ outside + other) + 10*free
+                   | g /= '.'   = 0
+                   | isBorder p = 0
+                   | otherwise  = min v $ minimum nv + (max 0 $ 2*mine - other) + 1
+            when (v' /= v) $ STA.writeArray scores p v'
+            return $ Any (v' /= v)
+    return scores    
+    where
+        isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
+            where ((xMin,yMin),(xMax,yMax)) = bounds grid
+        neighbours (x,y) = filter (inRange $ bounds grid) $ diagonals (x,y) 1

Contests/BackToTheCode/BackToTheCode06.hs

@@ -0,0 +1,191 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+        let claim c pt grid = if grid!pt == '.' then grid // [(pt,c)] else grid
+
+        startTime <- getCPUTime
+        
+        gen <- newStdGen
+        let (action, nPts) = findTarget (myX, myY) (claim 'X' (myX,myY) grid) opponents myBackInTimeLeft gen
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case action of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+        
+        stopTime <- getCPUTime
+        let diff = stopTime - startTime
+        
+        hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
+
+findTarget :: RandomGen g
+           => (Int, Int)
+           -> UArray (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> g
+           -> (Either Int (Int, Int), Int)
+findTarget myPt@(myX,myY) grid opponents myBackInTimeLeft gen =
+        (Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts, length scoredPts)
+    where
+        scoredPts = unsafeTimeoutList 90000
+                  . map (\pt -> let rt = bestRoute grid myPt pt in (head rt,) $! score rt)
+                  . map fst . sortBy (compare `on` snd)
+                  . map (\(r, (x,y)) -> ((x,y), r + dist myPt (x,y)))
+                  . zip (randomRs (0, 2.0::Double) gen)
+                  . filter (\p -> inRange (bounds grid) p && grid!p == '.')
+                  $ indices grid
+        baseScore = scoreGrid' myPt grid
+        score rt = (scoreGrid' (last rt) (updateGrid grid rt) - baseScore) / (fromIntegral (length rt) ** 1.5)
+        scoreGrid' pt grid = scoreGrid grid
+            + 3 * sum (map (sqrt . dist pt . fst) opponents)
+        dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
+
+neighbours :: (Int,Int) -> Int -> [(Int,Int)]
+neighbours (x0,y0) n =
+    [0..2*n-1] >>= \i ->
+        [ (x0-n+i,y0-n)
+        , (x0+n,y0-n+i)
+        , (x0+n-i,y0+n)
+        , (x0-n,y0+n-i)
+        ]
+
+bestRoute :: UArray (Int,Int) Char -> (Int,Int) -> (Int,Int) -> [(Int,Int)]
+bestRoute grid from@(x0,y0) to@(x1,y1) =
+        if freeCells rt1 < freeCells rt2 then rt2 else rt1
+    where
+        freeCells = count (\p -> grid!p == '.')
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
+        x `to` y | y >= x    = [x+1..y]
+                 | otherwise = [x-1,x-2..y]
+
+updateGrid :: UArray (Int,Int) Char -> [(Int, Int)] -> UArray (Int,Int) Char
+updateGrid grid route = STA.runSTUArray $ do
+    let valid = inRange (bounds grid)
+    grid' <- STA.thaw grid
+    forM_ route $ \p -> when (grid!p == '.') $ STA.writeArray grid' p '0'
+    doWhileM_ . fmap getAny . flip foldMapA (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g /= '.' then pure (Any False) else do
+            gs <- mapM (\p' -> if valid p' then STA.readArray grid' p' else pure 'X')
+                       (neighbours p 1)
+            if any (not . (`elem` ['.','0'])) gs
+                then Any True <$ STA.writeArray grid' p 'M'
+                else pure (Any False)
+    forM_ (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g == '.' then STA.writeArray grid' p '0'
+        else when (g == 'M') $ STA.writeArray grid' p '.'
+    return grid'
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+-- Compute elements of the list to WHNF for `t` microseconds.
+-- After `t` microseconds, abandon the calculation and terminate
+-- the list. Note that this causes the length of the result to depend
+-- on timing and system load. Marked "unsafe" for a reason!
+unsafeTimeoutList :: Integer -> [a] -> [a]
+unsafeTimeoutList t xs = unsafePerformIO $ do
+    start <- getCPUTime
+    return $ evalUntil (start + (1000000 * t)) xs
+    where
+        evalUntil end xs = unsafePerformIO $ do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ return $! case xs of
+                []     -> []
+                (a:as) -> a `seq` (a:as)
+            return $ case r of
+                Nothing     -> []
+                Just []     -> []
+                Just (a:as) -> (a : evalUntil end as)
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+scoreGrid :: UArray (Int, Int) Char -> Double
+scoreGrid grid = sum $ map ((**0.8) . fromIntegral) $ elems $ scoreCells grid
+
+scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
+scoreCells grid = STA.runSTUArray $ do
+    scores  <- STA.newArray (bounds grid) 60
+    doWhileM_ $ do
+        fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
+            let ns = filter (inRange (bounds grid)) $ neighbours p 1
+            v  <- STA.readArray scores p
+            nv <- mapM (STA.readArray scores) ns
+            let outside = 8 - length ns
+            let free    = count ((=='.') . (grid!)) ns
+            let mine    = count ((=='0') . (grid!)) ns
+            let other   = 8 - (outside + mine + free)
+            let v' | g == '0'   = 100 + 10*mine + 35*(min 1 $ outside + other) + 10*free
+                   | g /= '.'   = 0
+                   | isBorder p = 0
+                   | otherwise  = min v $ minimum nv + (max 0 $ 2*mine - other) + 1
+            when (v' /= v) $ STA.writeArray scores p v'
+            return $ Any (v' /= v)
+    return scores    
+    where
+        isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
+            where ((xMin,yMin),(xMax,yMax)) = bounds grid

Contests/BackToTheCode/BackToTheCode07.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Parallel
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    trail <- newIORef []
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+        let claim c pt grid = if grid!pt == '.' then grid // [(pt,c)] else grid
+        grid' <- foldl' (\g p -> claim 'X' p g) grid <$> readIORef trail
+        modifyIORef trail (((myX,myY):) . take 4)
+
+        startTime <- getCPUTime
+        
+        (action, nPts) <- findTarget (myX, myY) grid' opponents myBackInTimeLeft
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case action of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+        
+        stopTime <- getCPUTime
+        let diff = stopTime - startTime
+        
+        hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
+
+findTarget :: (Int, Int)
+           -> UArray (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> IO (Either Int (Int, Int), Int)
+findTarget myPt@(myX,myY) grid opponents myBackInTimeLeft = do
+    gen <- newStdGen
+    scoredPts <- evaluateListWithTimeout 90000
+               . map (\(rt,_) -> (rt,) $! score rt)
+               . sortBy (compare `on` snd)
+               . zipWith (\r pt -> (bestRoute grid myPt pt, r + score' pt))
+                         (randomRs (0, 1.0::Double) gen)
+               . filter (\p -> p /= myPt && grid!p == '.')
+               $ indices grid
+    return ( Right $ fromMaybe myPt $ fmap (head . fst) $
+                safeMaximumBy (compare `on` snd) scoredPts
+           , length scoredPts)
+    where
+        baseScore = scoreGrid' myPt grid
+        score rt = (scoreGrid' (last rt) (updateGrid grid rt) - baseScore)
+                 / (fromIntegral (length rt) ** 2)
+        score' pt = dist myPt pt + sum (map (sqrt . dist pt . fst) opponents)
+        scoreGrid' pt grid = scoreGrid grid
+            + 3 * sum (map (sqrt . dist pt . fst) opponents)
+        dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
+
+neighbours :: (Int,Int) -> Int -> [(Int,Int)]
+neighbours (x0,y0) n =
+    [0..2*n-1] >>= \i ->
+        [ (x0-n+i,y0-n)
+        , (x0+n,y0-n+i)
+        , (x0+n-i,y0+n)
+        , (x0-n,y0+n-i)
+        ]
+
+bestRoute :: UArray (Int,Int) Char -> (Int,Int) -> (Int,Int) -> [(Int,Int)]
+bestRoute grid from@(x0,y0) to@(x1,y1) =
+        if freeCells rt1 < freeCells rt2 then rt2 else rt1
+    where
+        freeCells = count (\p -> grid!p == '.')
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
+        x `to` y = if y >= x then [x+1..y] else [x-1,x-2..y]
+
+updateGrid :: UArray (Int,Int) Char -> [(Int, Int)] -> UArray (Int,Int) Char
+updateGrid grid route = STA.runSTUArray $ do
+    let valid = inRange (bounds grid)
+    grid' <- STA.thaw grid
+    forM_ route $ \p -> when (grid!p == '.') $ STA.writeArray grid' p '0'
+    doWhileM_ . fmap getAny . flip foldMapA (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g /= '.' then pure (Any False) else do
+            gs <- mapM (\p' -> if valid p' then STA.readArray grid' p' else pure 'X')
+                       (neighbours p 1)
+            if any (not . (`elem` ['.','0'])) gs
+                then Any True <$ STA.writeArray grid' p 'M'
+                else pure (Any False)
+    forM_ (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g == '.' then STA.writeArray grid' p '0'
+        else when (g == 'M') $ STA.writeArray grid' p '.'
+    return grid'
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    let evalFrom xs = do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+                case xs of
+                    []     -> return []
+                    (a:as) -> return $! a `seq` (a:as)
+            case r of
+                Nothing     -> return []
+                Just []     -> return []
+                Just (a:as) -> (a:) <$> evalFrom as
+    evalFrom xs
+
+scoreGrid :: UArray (Int, Int) Char -> Double
+scoreGrid grid = sum $ map ((**0.8) . fromIntegral) $ elems $ scoreCells grid
+
+theArray :: Array i e -> Array i e
+theArray = id
+
+scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
+scoreCells grid = STA.runSTUArray $ do
+    scores <- STA.newArray (bounds grid) 5
+    let neighbours' p = filter (inRange (bounds grid)) $ neighbours p 1
+    let nsArray = theArray $ array (bounds grid) $ flip map (indices grid) $ \p -> (p,) $
+            let ns = map (grid!) (neighbours' p) in
+            ( 8 - length ns
+            , count (=='.') ns
+            , count (=='0') ns
+            )
+    doWhileM_ $ fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
+        v  <- STA.readArray scores p
+        nv <- forM (neighbours' p) $ STA.readArray scores
+        let (outside, free, mine) = nsArray!p
+        let other = 8 - (outside + free + mine)
+        let v' | g == '0'   = 100 + 10*mine + 35*(min 1 $ outside + other) + 10*free
+               | g /= '.'   = 0
+               | isBorder p = 0
+               | otherwise  = min v $ minimum nv + (max 0 $ 2*mine - other) + 1
+        Any (v' /= v) <$ STA.writeArray scores p v'
+    pure scores
+    where
+        isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
+            where ((xMin,yMin),(xMax,yMax)) = bounds grid

Contests/BackToTheCode/BackToTheCode08.hs

@@ -0,0 +1,204 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Parallel
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Traversable as T
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    trail <- newIORef []
+    forever $ do
+        (gameRound :: Int) <- readLn
+        [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+            <- words <$> getLine
+    
+        opponents <- replicateM opponentCount $ do
+            [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                <- words <$> getLine
+            return ((x, y), backInTimeLeft)
+    
+        -- '.' for empty, '0' for me, otherwise ID of opponent
+        grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+            zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+        let claim c pt grid = if grid!pt == '.' then grid // [(pt,c)] else grid
+        grid' <- foldl' (\g p -> claim 'X' p g) grid <$> readIORef trail
+        modifyIORef trail (((myX,myY):) . take 4)
+
+        startTime <- getCPUTime
+        
+        (action, nPts) <- findTarget (myX, myY) grid' opponents myBackInTimeLeft
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        case action of
+            Left  n        -> putStrLn $ "BACK " ++ show n
+            Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
+        
+        stopTime <- getCPUTime
+        let diff = stopTime - startTime
+        
+        hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
+
+findTarget :: (Int, Int)
+           -> UArray (Int, Int) Char
+           -> [((Int, Int), Bool)]
+           -> Bool
+           -> IO (Either Int (Int, Int), Int)
+findTarget myPt@(myX,myY) grid opponents myBackInTimeLeft = do
+    gen <- newStdGen
+    scoredPts <- evaluateListWithTimeout 90000
+               . map (\(rt,_) -> (rt,) $! score rt)
+               . sortBy (compare `on` snd)
+               . zipWith (\r pt -> (bestRoute grid myPt pt, r + score' pt))
+                         (randomRs (0, 1.0::Double) gen)
+               . filter (\p -> p /= myPt && grid!p == '.')
+               $ indices grid
+    return ( Right $ fromMaybe myPt $ fmap (head . fst) $
+                safeMaximumBy (compare `on` snd) scoredPts
+           , length scoredPts)
+    where
+        baseScore = scoreGrid' myPt grid
+        score rt = (scoreGrid' (last rt) (updateGrid grid rt) - baseScore)
+                 / (fromIntegral (length rt) ** 1.5)
+                 + sum [ if grid!p == '.' then w else 0 | (p,w) <- zip rt (iterate (*0.7) 10) ]
+        score' pt = dist myPt pt + sum (map (sqrt . dist pt . fst) opponents)
+        scoreGrid' pt grid = scoreGrid grid
+            + 3 * sum (map (sqrt . dist pt . fst) opponents)
+        dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
+
+neighbours :: (Int,Int) -> Int -> [(Int,Int)]
+neighbours (x0,y0) n =
+    [0..2*n-1] >>= \i ->
+        [ (x0-n+i,y0-n)
+        , (x0+n,y0-n+i)
+        , (x0+n-i,y0+n)
+        , (x0-n,y0+n-i)
+        ]
+
+bestRoute :: UArray (Int,Int) Char -> (Int,Int) -> (Int,Int) -> [(Int,Int)]
+bestRoute grid from@(x0,y0) to@(x1,y1) = reverse $ dropWhile (\p -> grid!p /= '.') $ reverse rt
+    where
+        freeCells = count (\p -> grid!p == '.')
+        rt = if freeCells rt1 < freeCells rt2 then rt2 else rt1
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++ map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1) ++ map (x1,) (y1 `to` y0) ++ map (,y0) (x1 `to` x0)
+        x `to` y = if y >= x then [x+1..y] else [x-1,x-2..y]
+
+updateGrid :: UArray (Int,Int) Char -> [(Int, Int)] -> UArray (Int,Int) Char
+updateGrid grid route = STA.runSTUArray $ do
+    let valid = inRange (bounds grid)
+    grid' <- STA.thaw grid
+    forM_ route $ \p -> when (grid!p == '.') $ STA.writeArray grid' p '0'
+    doWhileM_ . fmap getAny . flip foldMapA (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g /= '.' then pure (Any False) else do
+            gs <- mapM (\p' -> if valid p' then STA.readArray grid' p' else pure 'X')
+                       (neighbours p 1)
+            if any (not . (`elem` ['.','0'])) gs
+                then Any True <$ STA.writeArray grid' p 'M'
+                else pure (Any False)
+    forM_ (indices grid) $ \p -> do
+        g <- STA.readArray grid' p
+        if g == '.' then STA.writeArray grid' p '0'
+        else when (g == 'M') $ STA.writeArray grid' p '.'
+    return grid'
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    let evalFrom xs = do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+                case xs of
+                    []     -> return []
+                    (a:as) -> return $! a `seq` (a:as)
+            case r of
+                Nothing     -> return []
+                Just []     -> return []
+                Just (a:as) -> (a:) <$> evalFrom as
+    evalFrom xs
+
+scoreGrid :: UArray (Int, Int) Char -> Double
+scoreGrid grid = fromIntegral $ sum $ elems $ scoreCells grid
+
+theArray :: Array i e -> Array i e
+theArray = id
+
+scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
+scoreCells grid = STA.runSTUArray $ do
+    scores <- STA.newArray (bounds grid) 60
+    let neighbours' p = filter (inRange (bounds grid)) $ neighbours p 1
+    let nsArray = theArray $ array (bounds grid) $ flip map (indices grid) $
+            \(x,y) -> ((x,y),) $ (\(Sum a,Sum b,Sum c) -> (a,b,c)) $ mconcat $
+                [ if not (inRange (bounds grid) (x',y')) then (Sum 1, Sum 0, Sum 0)
+                  else if grid!(x',y') == '.'            then (Sum 0, Sum 1, Sum 0)
+                  else if grid!(x',y') == '0'            then (Sum 0, Sum 0, Sum 1)
+                  else mempty
+                | y' <- [y-1..y+1]
+                , x' <- [x-1..x+1]
+                , (x',y') /= (x,y)
+                ]
+    doWhileM_ $ fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
+        v  <- STA.readArray scores p
+        nv <- forM (neighbours' p) $ STA.readArray scores
+        let (outside, free, mine) = nsArray!p
+        let other = 8 - (outside + free + mine)
+        let v' | g == '0'   = 50 + 10*mine + 12*(other + free) + 15*(outside + other)
+               | g /= '.'   = 0
+               | isBorder p = 10
+               | otherwise  = max 10 $ min v $ minimum nv + 1
+        Any (v' /= v) <$ STA.writeArray scores p v'
+    pure scores
+    where
+        isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
+            where ((xMin,yMin),(xMax,yMax)) = bounds grid

Contests/BackToTheCode/BackToTheCode09.hs

@@ -0,0 +1,178 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Parallel
+import Control.Monad
+import Control.Monad.Trans
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Map         as M
+import qualified Data.Traversable as T
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    forever $ do
+        gstate <- do
+            (gameRound :: Int) <- readLn
+            [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                return ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            return $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, state) <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, state)
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = traceM (show goal) *> pure (Right $ nextGoalPoint gs goal, goal)
+    where
+        goal = case snd <$> M.lookup (gsRound gs - 1) history of
+            Just g | checkGoal (gsGrid gs) g -> g
+            _ -> planNewGoal gs
+
+checkGoal :: Grid -> Goal -> Bool
+checkGoal grid goal = traceShowId $
+    not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) &&
+    any (\p -> grid!p == '.') (border goal)
+
+planNewGoal :: GameState -> Goal
+planNewGoal gs = expand (pt0,pt0) (indices grid)
+    where
+        grid = gsGrid gs
+        pt0  = fromMaybe (gsCell gs) $ nearestFree grid (gsCell gs) (indices grid)
+        expand goal@((x0,y0),(x1,y1)) pts'
+            | width + height < maxPerim, width <= 2*height, x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1)) pts'
+            | width + height < maxPerim, width <= 2*height, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1)) pts'
+            | width + height < maxPerim, height <= 2*width, y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1)) pts'
+            | width + height < maxPerim, height <= 2*width, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1)) pts'
+            | width + height < maxPerim, x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1)) pts'
+            | width + height < maxPerim, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1)) pts'
+            | width + height < maxPerim, y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1)) pts'
+            | width + height < maxPerim, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1)) pts'
+            | width * height < 16, Just pt' <- nearestFree grid (gsCell gs) pts'',
+              let goal' = expand (pt',pt') pts'', rangeSize goal' > rangeSize goal = goal'
+            | otherwise = goal
+            where
+                maxPerim = 50
+                width = x1 - x0
+                height = y1 - y0
+                check pts = not (any (\p -> grid!p /= '0' && grid!p /= '.') pts)
+                checkFree pts = any (\p -> grid!p == '.') pts
+                pts'' = pts' \\ range ((x0,y0),(x1,y1))
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) (nearestFree (gsGrid gs) (gsCell gs) (border goal))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+    where
+        dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+    where
+        n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    let evalFrom xs = do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+                case xs of
+                    []     -> return []
+                    (a:as) -> return $! a `seq` (a:as)
+            case r of
+                Nothing     -> return []
+                Just []     -> return []
+                Just (a:as) -> (a:) <$> evalFrom as
+    evalFrom xs

Contests/BackToTheCode/BackToTheCode10.hs

@@ -0,0 +1,191 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Parallel
+import Control.Monad
+import Control.Monad.Trans
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Map         as M
+import qualified Data.Traversable as T
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    forever $ do
+        gstate <- do
+            (gameRound :: Int) <- readLn
+            [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                return ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            return $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, state) <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, state)
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    goal <- case snd <$> M.lookup (gsRound gs - 1) history of
+        Just g | checkGoal (gsGrid gs) g, inRange g (gsCell gs) -> return g
+        _ -> planNewGoal gs
+    traceM (show goal)
+    pure (Right $ nextGoalPoint gs goal, goal)
+
+checkGoal :: Grid -> Goal -> Bool
+checkGoal grid goal = traceShowId $
+    not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) &&
+    any (\p -> grid!p == '.') (border goal)
+
+planNewGoal :: GameState -> IO Goal
+planNewGoal gs = do
+    let pts   = indices grid : zipWith (\\) pts (map range goals)
+        goals = map (expand . dup . fromMaybe (0,0) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+    timed <- head scored `seq` evaluateListWithTimeout 80000 scored
+    pure $ fromMaybe (gsCell gs, gsCell gs) $ fmap fst $ safeMaximumBy (compare `on` snd) timed
+    where
+        dup x = (x,x)
+        grid = gsGrid gs
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              5 * (count (\p -> grid!p == '.') $ range g)
+            - 2 * (fromMaybe 1000 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                        (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                      | ((ox,oy),_) <- gsOpponents gs
+                      ]
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= 40 = goal
+            | width <= 2*height, x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | height <= 2*width, y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | width <= 2*height, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | height <= 2*width, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width = x1 - x0
+                height = y1 - y0
+                check pts = not (any (\p -> grid!p /= '0' && grid!p /= '.') pts)
+                checkFree pts = any (\p -> grid!p == '.') pts
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+    where
+        n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    let evalFrom xs = do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+                case xs of
+                    []     -> return []
+                    (a:as) -> return $! a `seq` (a:as)
+            case r of
+                Nothing     -> return []
+                Just []     -> return []
+                Just (a:as) -> (a:) <$> evalFrom as
+    evalFrom xs

Contests/BackToTheCode/BackToTheCode11.hs

@@ -0,0 +1,192 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Parallel
+import Control.Monad
+import Control.Monad.Trans
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Map         as M
+import qualified Data.Traversable as T
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    forever $ do
+        gstate <- do
+            (gameRound :: Int) <- readLn
+            [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                return ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            return $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, state) <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, state)
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    goal <- case snd <$> M.lookup (gsRound gs - 1) history of
+        Just g | checkGoal (gsGrid gs) g, inRange g (gsCell gs) -> return g
+        _ -> planNewGoal gs
+    traceM (show goal)
+    pure (Right $ nextGoalPoint gs goal, goal)
+
+checkGoal :: Grid -> Goal -> Bool
+checkGoal grid goal = traceShowId $
+    not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) &&
+    any (\p -> grid!p == '.') (border goal)
+
+planNewGoal :: GameState -> IO Goal
+planNewGoal gs = do
+    let pts   = indices grid : zipWith (\\) pts (map range goals)
+        goals = map (expand . dup . fromMaybe (0,0) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+    timed <- head scored `seq` evaluateListWithTimeout 80000 scored
+    pure $ fromMaybe (gsCell gs, gsCell gs) $ fmap fst $ safeMaximumBy (compare `on` snd) timed
+    where
+        dup x = (x,x)
+        grid = gsGrid gs
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              5 * (count (\p -> grid!p == '.') $ range g)
+            - 5 * (count (\p -> grid!p == '.') $ border g)
+            - 2 * (fromMaybe 1000 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                        (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                      | ((ox,oy),_) <- gsOpponents gs
+                      ]
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= 24 = goal
+            | width <= 2*height, x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | height <= 2*width, y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | width <= 2*height, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | height <= 2*width, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width = x1 - x0
+                height = y1 - y0
+                check pts = not (any (\p -> grid!p /= '0' && grid!p /= '.') pts)
+                checkFree pts = any (\p -> grid!p == '.') pts
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+    where
+        n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    let evalFrom xs = do
+            now <- getCPUTime
+            r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+                case xs of
+                    []     -> return []
+                    (a:as) -> return $! a `seq` (a:as)
+            case r of
+                Nothing     -> return []
+                Just []     -> return []
+                Just (a:as) -> (a:) <$> evalFrom as
+    evalFrom xs

Contests/BackToTheCode/BackToTheCode12.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Parallel
+import Control.Monad
+import Control.Monad.Trans
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Data.STRef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.IO.Unsafe
+import System.Random
+import System.Timeout
+
+import qualified Data.Array.ST    as STA
+import qualified Data.Foldable    as F
+import qualified Data.Map         as M
+import qualified Data.Traversable as T
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    forever $ do
+        gstate <- do
+            (gameRound :: Int) <- readLn
+            [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                return ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            return $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, state) <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, state)
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    let mgoal = snd <$> M.lookup (gsRound gs - 1) history
+    goal <- case mgoal of
+        Just g | checkGoal (gsGrid gs) g, inRange g (gsCell gs) -> return g
+        _ -> planNewGoal gs history
+    if gsJumpLeft gs && isJust mgoal && Just goal /= mgoal && gsRound gs > 100
+    then pure (Left 17, goal)
+    else let gp@(gx,gy) = nextGoalPoint gs goal in
+        if gp == gsCell gs
+        then (,goal) . Right <$> (chooseIO $ filter (inRange (bounds (gsGrid gs))) [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)])
+        else pure (Right gp, goal)
+
+chooseIO :: [a] -> IO a
+chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1)
+
+checkGoal :: Grid -> Goal -> Bool
+checkGoal grid goal =
+    not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) &&
+    any (\p -> grid!p == '.') (border goal)
+
+planNewGoal :: GameState -> M.Map Int (GameState, Goal) -> IO Goal
+planNewGoal gs history = do
+    let pts   = indices grid : zipWith (\\) pts (map range goals)
+        goals = takeWhileJust $ map (fmap (expand . dup) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+    timed <- evaluateListWithTimeout 80000 scored
+    traceM . show $ length timed
+    pure $ fromMaybe (dup $ gsCell gs) $ fmap fst $ safeMaximumBy (compare `on` snd) timed
+    where
+        dup x = (x,x)
+        grid = gsGrid gs // ((gsCell gs, '0') : concat (mapMaybe (\r -> map ((,'X') . fst) . gsOpponents . fst <$> flip M.lookup history r) [gsRound gs+1..gsRound gs+10]))
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              5 * (count (\p -> grid!p == '.') $ range g)
+            - 5 * (count (\p -> grid!p == '.') $ border g)
+            - 2 * (fromMaybe 1000 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                        (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                      | ((ox,oy),_) <- gsOpponents gs
+                      ]
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= 24 = goal
+            | width <= 2*height, x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | height <= 2*width, y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | width <= 2*height, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | height <= 2*width, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width = x1 - x0
+                height = y1 - y0
+                check pts = not (any (\p -> grid!p /= '0' && grid!p /= '.') pts)
+                checkFree pts = any (\p -> grid!p == '.') pts
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+    where
+        n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+whileM_ :: Monad m => m Bool -> m a -> m ()
+whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m)
+
+doWhileM_ :: Monad m => m Bool -> m ()
+doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc)
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v
+foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t
+
+filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a]
+filterA f []     = pure []
+filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs
+
+takeWhileJust :: [Maybe a] -> [a]
+takeWhileJust []          = []
+takeWhileJust (Nothing:_) = []
+takeWhileJust (Just x:xs) = x : takeWhileJust xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    flip fix xs $ \loop xs -> do
+        now <- getCPUTime
+        r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+            case xs of
+                []     -> return []
+                (a:as) -> return $! a `seq` (a:as)
+        case r of
+            Nothing     -> return []
+            Just []     -> return []
+            Just (a:as) -> (a:) <$> loop as

Contests/BackToTheCode/BackToTheCode13.hs

@@ -0,0 +1,187 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.Random
+import System.Timeout
+
+import qualified Data.Map as M
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    forever $ do
+        gstate <- do
+            (gameRound :: Int) <- readLn
+            [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                return ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            return $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, state) <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, state)
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    let mgoal = snd <$> M.lookup (gsRound gs - 1) history
+    goal <- case mgoal of
+        Just g | checkGoal (gsGrid gs) g, inRange g (gsCell gs) -> return g
+        _ -> planNewGoal gs history
+    if gsJumpLeft gs && isJust mgoal && Just goal /= mgoal && gsRound gs > 100
+    then pure (Left 17, goal)
+    else let gp@(gx,gy) = nextGoalPoint gs goal in
+        if gp == gsCell gs
+        then (,goal) . Right <$> (chooseIO $ filter (inRange (bounds (gsGrid gs))) [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)])
+        else pure (Right gp, goal)
+
+chooseIO :: [a] -> IO a
+chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1)
+
+checkGoal :: Grid -> Goal -> Bool
+checkGoal grid goal =
+    not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) &&
+    any (\p -> grid!p == '.') (border goal)
+
+planNewGoal :: GameState -> M.Map Int (GameState, Goal) -> IO Goal
+planNewGoal gs history = do
+    let pts    = indices grid : zipWith (\\) pts (map range goals)
+        goals  = takeWhileJust $ map (fmap (expand . dup) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+    timed <- evaluateListWithTimeout 80000 scored
+    traceM . show $ length timed
+    pure $ fromMaybe (dup $ gsCell gs) $ fmap fst $ safeMaximumBy (compare `on` snd) timed
+    where
+        dup x = (x,x)
+        grid = accum claim (gsGrid gs) ((gsCell gs, '0') : concat (mapMaybe (\r -> map ((,'X') . fst) . gsOpponents . fst <$> flip M.lookup history r) [gsRound gs+1..gsRound gs+10]))
+        claim '.' c1 = c1
+        claim c0  _  = c0
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              5 * (count (\p -> grid!p == '.') $ range g)
+            - 5 * (count (\p -> grid!p == '.') $ border g)
+            - 2 * (fromMaybe 1000 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                        (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                      | ((ox,oy),_) <- gsOpponents gs
+                      ]
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= 24 = goal
+            | width <= 2*height, x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | height <= 2*width, y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | width <= 2*height, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | height <= 2*width, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | x0 >  0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1))
+            | y0 >  0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1))
+            | x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1))
+            | y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width = x1 - x0
+                height = y1 - y0
+                check pts = not (any (\p -> grid!p /= '0' && grid!p /= '.') pts)
+                checkFree pts = any (\p -> grid!p == '.') pts
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+    where
+        n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+takeWhileJust :: [Maybe a] -> [a]
+takeWhileJust []          = []
+takeWhileJust (Nothing:_) = []
+takeWhileJust (Just x:xs) = x : takeWhileJust xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    flip fix xs $ \loop xs -> do
+        now <- getCPUTime
+        r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+            case xs of
+                []     -> return []
+                (a:as) -> return $! a `seq` (a:as)
+        case r of
+            Nothing     -> return []
+            Just []     -> return []
+            Just (a:as) -> (a:) <$> loop as

Contests/BackToTheCode/BackToTheCode14.hs

@@ -0,0 +1,197 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.Random
+import System.Timeout
+
+import qualified Data.Map as M
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    forever $ do
+        gstate <- do
+            (gameRound :: Int) <- readLn
+            [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                return ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            return $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, state) <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, state)
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    let mgoal = snd <$> M.lookup (gsRound gs - 1) history
+    let grid = gsGrid gs
+    let invalid = maybe False (any (\p -> grid!p /= '0' && grid!p /= '.') . range) mgoal
+    goal <- case mgoal of
+        Just g | checkGoal (gsGrid gs) g, inRange g (gsCell gs) -> return g
+        _ -> planNewGoal gs history (evaluateListWithTimeout 80000)
+    if gsJumpLeft gs && gsRound gs > 100 && invalid
+    then pure (Left 17, goal)
+    else let gp@(gx,gy) = nextGoalPoint gs goal in
+        if gp == gsCell gs
+        then (,goal) . Right <$> (chooseIO $ filter (inRange (bounds (gsGrid gs))) [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)])
+        else pure (Right gp, goal)
+
+chooseIO :: [a] -> IO a
+chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1)
+
+checkGoal :: Grid -> Goal -> Bool
+checkGoal grid goal =
+    not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) &&
+    any (\p -> grid!p == '.') (border goal)
+
+planNewGoal :: Functor f => GameState -> M.Map Int (GameState, Goal) -> (forall a. [a] -> f [a]) -> f Goal
+planNewGoal gs history idiom =
+        fromMaybe (dup $ gsCell gs) . fmap fst . safeMaximumBy (compare `on` snd) <$> idiom scored
+    where
+        pts    = indices grid : zipWith (\\) pts (map range goals)
+        goals  = takeWhileJust $ map (fmap (expand . dup) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+        dup x  = (x,x)
+        grid   = accum claim (gsGrid gs) ((gsCell gs, '0') : projections)
+        projections = concat (mapMaybe (\r -> map ((,'X') . fst) . gsOpponents . fst <$>
+                              flip M.lookup history r) [gsRound gs+1..gsRound gs+10])
+        claim '.' c1 = c1
+        claim c0  _  = c0
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              5 * (count (\p -> grid!p == '.') $ range g)
+            - 5 * (count (\p -> grid!p == '.') $ border g)
+            - 2 * (fromMaybe 1000 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                        (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                      | ((ox,oy),_) <- gsOpponents gs
+                      ]
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= 24 = goal
+            | width <= 2*height, x0 >  0, any free left,   all (not . other) left'   = expand ((x0-1,y0),(x1,y1))
+            | height <= 2*width, y0 >  0, any free top,    all (not . other) top'    = expand ((x0,y0-1),(x1,y1))
+            | width <= 2*height, x1 < 34, any free right,  all (not . other) right'  = expand ((x0,y0),(x1+1,y1))
+            | height <= 2*width, y1 < 19, any free bottom, all (not . other) bottom' = expand ((x0,y0),(x1,y1+1))
+            |                    x0 >  0, any free left,   all (not . other) left'   = expand ((x0-1,y0),(x1,y1))
+            |                    y0 >  0, any free top,    all (not . other) top'    = expand ((x0,y0-1),(x1,y1))
+            |                    x1 < 34, any free right,  all (not . other) right'  = expand ((x0,y0),(x1+1,y1))
+            |                    y1 < 19, any free bottom, all (not . other) bottom' = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width   = x1 - x0
+                height  = y1 - y0
+                top     = map (,y0) [x0..x1]
+                bottom  = map (,y1) [x0..x1]
+                left    = map (x0,) [y0..y1]
+                right   = map (x1,) [y0..y1]
+                top'    = map (,y0-1) [x0..x1]
+                bottom' = map (,y1+1) [x0..x1]
+                left'   = map (x0-1,) [y0..y1]
+                right'  = map (x1+1,) [y0..y1]
+                free p  = grid!p == '.'
+                other p = not (free p) && grid!p /= '0'
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+    where
+        n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+takeWhileJust :: [Maybe a] -> [a]
+takeWhileJust []          = []
+takeWhileJust (Nothing:_) = []
+takeWhileJust (Just x:xs) = x : takeWhileJust xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    flip fix xs $ \loop xs -> do
+        now <- getCPUTime
+        r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+            case xs of
+                []     -> return []
+                (a:as) -> return $! a `seq` (a:as)
+        case r of
+            Nothing     -> return []
+            Just []     -> return []
+            Just (a:as) -> (a:) <$> loop as

Contests/BackToTheCode/BackToTheCode15.hs

@@ -0,0 +1,205 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.Random
+import System.Timeout
+
+import qualified Data.Map as M
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    
+    forever $ do
+        gstate <- do
+            gameRound <- readLn
+            [read -> myX, read -> myY, (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> x, read -> y, (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                pure ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            pure $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, gstate') <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, gstate')
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    let mgoal = snd <$> M.lookup (gsRound gs - 1) history
+    let free p  = (gsGrid gs)!p == '.'
+    let other p = (gsGrid gs)!p /= '0' && (gsGrid gs)!p /= '.'
+    goal <- case mgoal of
+        Just g | inRange g (gsCell gs), any free (range g), all (not.other) (range g) -> pure g
+        _ -> planNewGoal gs history (evaluateListWithTimeout 80000)
+    if gsJumpLeft gs && gsRound gs > 125 && maybe False (any other . range) mgoal
+    then pure (Left 17, goal)
+    else let gp@(gx,gy) = nextGoalPoint gs goal in
+        if gp /= gsCell gs
+        then pure (Right $ head $ bestRoute (gsGrid gs) (gsCell gs) gp, goal)
+        else (,goal) . Right <$> (chooseIO . filter (inRange (bounds (gsGrid gs))) $
+                                    [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)])
+
+chooseIO :: [a] -> IO a
+chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1)
+
+planNewGoal :: Functor f => GameState -> M.Map Int (GameState, Goal) -> (forall a. [a] -> f [a]) -> f Goal
+planNewGoal gs history idiom =
+        fromMaybe (dup $ gsCell gs) . fmap fst . safeMaximumBy (compare `on` snd) <$> idiom scored
+    where
+        dup x  = (x,x)
+        pts    = indices grid : zipWith (\\) pts (map range goals)
+        goals  = takeWhileJust $ map (fmap (expand . dup) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+        grid   = accum claim (gsGrid gs) ((gsCell gs, '0') : projections)
+        claim '.' c1 = c1
+        claim c0  _  = c0
+        projections = concat $ mapMaybe (\r -> map ((,'X') . fst) . gsOpponents . fst <$>
+                                               flip M.lookup history r)
+                                        [gsRound gs+1..gsRound gs+10]
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              5 * (count (\p -> grid!p == '.') $ range g)
+            - 6 * (count (\p -> grid!p == '.') $ border g)
+            - 2 * (fromMaybe 500 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                        (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                      | ((ox,oy),_) <- gsOpponents gs
+                      ]
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= 24 = goal
+            | width <= 2*height, x0 >  0, any free left,   all (not . other) left'   = expand ((x0-1,y0),(x1,y1))
+            | height <= 2*width, y0 >  0, any free top,    all (not . other) top'    = expand ((x0,y0-1),(x1,y1))
+            | width <= 2*height, x1 < 34, any free right,  all (not . other) right'  = expand ((x0,y0),(x1+1,y1))
+            | height <= 2*width, y1 < 19, any free bottom, all (not . other) bottom' = expand ((x0,y0),(x1,y1+1))
+            |                    x0 >  0, any free left,   all (not . other) left'   = expand ((x0-1,y0),(x1,y1))
+            |                    y0 >  0, any free top,    all (not . other) top'    = expand ((x0,y0-1),(x1,y1))
+            |                    x1 < 34, any free right,  all (not . other) right'  = expand ((x0,y0),(x1+1,y1))
+            |                    y1 < 19, any free bottom, all (not . other) bottom' = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width   = x1 - x0
+                height  = y1 - y0
+                top     = map (,y0) [x0..x1]
+                bottom  = map (,y1) [x0..x1]
+                left    = map (x0,) [y0..y1]
+                right   = map (x1,) [y0..y1]
+                top'    = map (,y0-1) [x0..x1]
+                bottom' = map (,y1+1) [x0..x1]
+                left'   = map (x0-1,) [y0..y1]
+                right'  = map (x1+1,) [y0..y1]
+                free p  = grid!p == '.'
+                other p = not (free p) && grid!p /= '0'
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+    
+bestRoute :: Grid -> Point -> Point -> [Point]
+bestRoute grid (x0,y0) (x1,y1) =
+        if count free rt1 < count free rt2 then rt2 else rt1
+    where
+        free p = grid!p == '.'
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+
+to :: Int -> Int -> [Int]
+n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+takeWhileJust :: [Maybe a] -> [a]
+takeWhileJust []          = []
+takeWhileJust (Nothing:_) = []
+takeWhileJust (Just x:xs) = x : takeWhileJust xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    flip fix xs $ \loop xs -> do
+        now <- getCPUTime
+        r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+            case xs of
+                []     -> pure []
+                (a:as) -> pure $! a `seq` (a:as)
+        case r of
+            Nothing     -> pure []
+            Just []     -> pure []
+            Just (a:as) -> (a:) <$> loop as

Contests/BackToTheCode/BackToTheCode16.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.Random
+import System.Timeout
+
+import qualified Data.Map as M
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    
+    forever $ do
+        gstate <- do
+            gameRound <- readLn
+            [read -> myX, read -> myY, (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> x, read -> y, (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                pure ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            pure $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, gstate') <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, gstate')
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    let mgoal = snd <$> M.lookup (gsRound gs - 1) history
+    let free p  = (gsGrid gs)!p == '.'
+    let other p = (gsGrid gs)!p /= '0' && (gsGrid gs)!p /= '.'
+    goal <- case mgoal of
+        Just g | inRange g (gsCell gs), any free (range g), all (not.other) (range g) -> pure g
+        _ -> planNewGoal gs history (evaluateListWithTimeout 80000)
+    traceM (show mgoal)
+    traceM $ show $ fmap (take 1 . filter other . range) mgoal
+    if gsJumpLeft gs && gsRound gs > 125 && maybe False (any other . range) mgoal
+    then pure (Left 17, goal)
+    else let gp@(gx,gy) = nextGoalPoint gs goal in
+        if gp /= gsCell gs
+        then pure (Right $ head $ bestRoute (gsGrid gs) (gsCell gs) gp, goal)
+        else (,goal) . Right <$> (chooseIO . filter (inRange (bounds (gsGrid gs))) $
+                                    [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)])
+
+chooseIO :: [a] -> IO a
+chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1)
+
+planNewGoal :: Functor f => GameState -> M.Map Int (GameState, Goal) -> (forall a. [a] -> f [a]) -> f Goal
+planNewGoal gs history idiom =
+        fromMaybe (dup $ gsCell gs) . fmap fst . safeMaximumBy (compare `on` snd) <$> idiom scored
+    where
+        dup x  = (x,x)
+        pts    = indices grid : zipWith (\\) pts (map range goals)
+        goals  = takeWhileJust $ map (fmap (expand . dup) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+        grid   = accum claim (gsGrid gs) ((gsCell gs, '0') : projections)
+        claim '.' c1 = c1
+        claim c0  _  = c0
+        projections = concat $ mapMaybe (\r -> map ((,'X') . fst) . filter (\((x,_),_) -> x >= 0) .
+                                               gsOpponents . fst <$> flip M.lookup history r)
+                                        [gsRound gs+1..gsRound gs+10]
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              25 * (count (\p -> grid!p == '.') $ range g)
+            - 20 * (count (\p -> grid!p == '.') $ border g)
+            - 15 * (fromMaybe 500 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + 10 * minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                             (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                           | ((ox,oy),_) <- gsOpponents gs
+                           ]
+        limit = case length (gsOpponents gs) of { 1 -> 30; 2 -> 24; 3 -> 18; }
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= limit = goal
+            | 2*width < 3*height, x0 >  0, check left   left'   = expand ((x0-1,y0),(x1,y1))
+            | 2*height < 3*width, y0 >  0, check top    top'    = expand ((x0,y0-1),(x1,y1))
+            | 2*width < 3*height, x1 < 34, check right  right'  = expand ((x0,y0),(x1+1,y1))
+            | 2*height < 3*width, y1 < 19, check bottom bottom' = expand ((x0,y0),(x1,y1+1))
+            |                     x0 >  0, check left   left'   = expand ((x0-1,y0),(x1,y1))
+            |                     y0 >  0, check top    top'    = expand ((x0,y0-1),(x1,y1))
+            |                     x1 < 34, check right  right'  = expand ((x0,y0),(x1+1,y1))
+            |                     y1 < 19, check bottom bottom' = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width   = x1 - x0
+                height  = y1 - y0
+                top     = map (,y0) [x0..x1]
+                bottom  = map (,y1) [x0..x1]
+                left    = map (x0,) [y0..y1]
+                right   = map (x1,) [y0..y1]
+                top'    = map (,y0-1) [x0..x1]
+                bottom' = map (,y1+1) [x0..x1]
+                left'   = map (x0-1,) [y0..y1]
+                right'  = map (x1+1,) [y0..y1]
+                free p  = grid!p == '.'
+                other p = not (free p) && grid!p /= '0'
+                check s s' = any free s && all (not . other) s'
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+    
+bestRoute :: Grid -> Point -> Point -> [Point]
+bestRoute grid (x0,y0) (x1,y1) =
+        if count free rt1 < count free rt2 then rt2 else rt1
+    where
+        free p = grid!p == '.'
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+
+to :: Int -> Int -> [Int]
+n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+takeWhileJust :: [Maybe a] -> [a]
+takeWhileJust []          = []
+takeWhileJust (Nothing:_) = []
+takeWhileJust (Just x:xs) = x : takeWhileJust xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    flip fix xs $ \loop xs -> do
+        now <- getCPUTime
+        r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+            case xs of
+                []     -> pure []
+                (a:as) -> pure $! a `seq` (a:as)
+        case r of
+            Nothing     -> pure []
+            Just []     -> pure []
+            Just (a:as) -> (a:) <$> loop as

Contests/BackToTheCode/BackToTheCode17.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes #-}
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.Array.Unboxed
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.IORef
+import Debug.Trace
+import System.CPUTime
+import System.IO
+import System.Random
+import System.Timeout
+
+import qualified Data.Map as M
+
+type Point = (Int, Int)
+type Grid  = UArray Point Char
+
+data GameState =
+    GameState
+        { gsRound     :: Int
+        , gsCell      :: Point
+        , gsJumpLeft  :: Bool
+        , gsOpponents :: [(Point, Bool)]
+        , gsGrid      :: Grid
+        }
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    
+    opponentCount <- readLn
+    history <- newIORef M.empty
+    
+    forever $ do
+        gstate <- do
+            gameRound <- readLn
+            [read -> myX, read -> myY, (/= 0) . read -> myBackInTimeLeft]
+                <- words <$> getLine
+    
+            opponents <- replicateM opponentCount $ do
+                [read -> x, read -> y, (/= 0) . read -> backInTimeLeft]
+                    <- words <$> getLine
+                pure ((x, y), backInTimeLeft)
+    
+            -- '.' for empty, '0' for me, otherwise ID of opponent
+            grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y ->
+                zipWith (\x c -> ((x,y),c)) [0..] <$> getLine
+        
+            pure $ GameState
+                { gsRound     = gameRound
+                , gsCell      = (myX, myY)
+                , gsJumpLeft  = myBackInTimeLeft
+                , gsOpponents = opponents
+                , gsGrid      = grid
+                }
+
+        (action, gstate') <- findTarget gstate =<< readIORef history
+        
+        -- action: "x y" to move or "BACK rounds" to go back in time
+        putStrLn $ case action of
+            Left  n        -> "BACK " ++ show n
+            Right (tx, ty) -> unwords $ map show [tx, ty]
+
+        modifyIORef history $ M.insert (gsRound gstate) (gstate, gstate')
+
+-- The upper-left and lower-right corners of a rectangle
+type Goal = (Point,Point)
+
+findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal)
+findTarget gs history = do
+    let mgoal = snd <$> M.lookup (gsRound gs - 1) history
+    let free p  = (gsGrid gs)!p == '.'
+    let other p = (gsGrid gs)!p /= '0' && (gsGrid gs)!p /= '.'
+    goal <- case mgoal of
+        Just g | inRange g (gsCell gs), any free (range g), all (not.other) (range g) -> pure g
+        _ -> planNewGoal gs history (evaluateListWithTimeout 80000)
+    traceM (show mgoal)
+    traceM $ show $ fmap (take 1 . filter other . range) mgoal
+    if gsJumpLeft gs && gsRound gs > 125 && maybe False (any other . range) mgoal
+    then pure (Left 17, goal)
+    else let gp@(gx,gy) = nextGoalPoint gs goal in
+        if gp /= gsCell gs
+        then pure (Right $ head $ bestRoute (gsGrid gs) (gsCell gs) gp, goal)
+        else (,goal) . Right <$> (chooseIO . filter (inRange (bounds (gsGrid gs))) $
+                                    [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)])
+
+chooseIO :: [a] -> IO a
+chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1)
+
+planNewGoal :: Functor f => GameState -> M.Map Int (GameState, Goal) -> (forall a. [a] -> f [a]) -> f Goal
+planNewGoal gs history idiom =
+        fromMaybe (dup $ gsCell gs) . fmap fst . safeMaximumBy (compare `on` snd) <$> idiom scored
+    where
+        dup x  = (x,x)
+        pts    = indices grid : zipWith (\\) pts (map range goals)
+        goals  = takeWhileJust $ map (fmap (expand . dup) . nearestFree grid (gsCell gs)) pts
+        scored = map (\g -> (g,) $! scoreGoal g) goals
+        grid   = accum claim (gsGrid gs) ((gsCell gs, '0') : projections)
+        claim '.' c1 = c1
+        claim c0  _  = c0
+        projections = concat $ mapMaybe (\r -> map ((,'X') . fst) . filter (\((x,_),_) -> x >= 0) .
+                                               gsOpponents . fst <$> flip M.lookup history r)
+                                        [gsRound gs+1..gsRound gs+10]
+        scoreGoal g@((x0,y0),(x1,y1)) =
+              25 * (count (\p -> grid!p == '.') $ range g)
+            - 26 * (count (\p -> grid!p == '.') $ border g)
+            - 15 * (fromMaybe 500 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g))
+            + 10 * minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) +
+                             (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0)
+                           | ((ox,oy),_) <- gsOpponents gs
+                           ]
+        limit = case length (gsOpponents gs) of { 1 -> 30; 2 -> 20; 3 -> 15; }
+        expand goal@((x0,y0),(x1,y1))
+            | width + height >= limit = goal
+            | 2*width < 3*height, x0 >  0, check left   left'   = expand ((x0-1,y0),(x1,y1))
+            | 2*height < 3*width, y0 >  0, check top    top'    = expand ((x0,y0-1),(x1,y1))
+            | 2*width < 3*height, x1 < 34, check right  right'  = expand ((x0,y0),(x1+1,y1))
+            | 2*height < 3*width, y1 < 19, check bottom bottom' = expand ((x0,y0),(x1,y1+1))
+            |                     x0 >  0, check left   left'   = expand ((x0-1,y0),(x1,y1))
+            |                     y0 >  0, check top    top'    = expand ((x0,y0-1),(x1,y1))
+            |                     x1 < 34, check right  right'  = expand ((x0,y0),(x1+1,y1))
+            |                     y1 < 19, check bottom bottom' = expand ((x0,y0),(x1,y1+1))
+            | otherwise = goal
+            where
+                width   = x1 - x0
+                height  = y1 - y0
+                top     = map (,y0) [x0..x1]
+                bottom  = map (,y1) [x0..x1]
+                left    = map (x0,) [y0..y1]
+                right   = map (x1,) [y0..y1]
+                top'    = map (,y0-1) [x0..x1]
+                bottom' = map (,y1+1) [x0..x1]
+                left'   = map (x0-1,) [y0..y1]
+                right'  = map (x1+1,) [y0..y1]
+                free p  = grid!p == '.'
+                other p = not (free p) && grid!p /= '0'
+                check s s' = any free s && all (not . other) s'
+
+nextGoalPoint :: GameState -> Goal -> Point
+nextGoalPoint gs goal =
+    fromMaybe (gsCell gs) $
+    nearestFree (gsGrid gs) (gsCell gs) (border goal) <|>
+    nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs))
+
+nearestFree :: Grid -> Point -> [Point] -> Maybe Point
+nearestFree grid pt0 pts =
+    fmap fst . safeMinimumBy (compare `on` snd) .
+    map (\pt -> (pt, dist pt0 pt)) $
+    filter (\pt -> grid!pt == '.') pts
+    
+bestRoute :: Grid -> Point -> Point -> [Point]
+bestRoute grid (x0,y0) (x1,y1) =
+        if count free rt1 < count free rt2 then rt2 else rt1
+    where
+        free p = grid!p == '.'
+        rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
+        rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
+
+dist :: Point -> Point -> Int
+dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0)
+
+border :: Goal -> [Point]
+border ((x0,y0),(x1,y1)) =
+        map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++
+        map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0)
+
+to :: Int -> Int -> [Int]
+n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy f xs = Just $ maximumBy f xs
+
+safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMinimumBy _ [] = Nothing
+safeMinimumBy f xs = Just $ minimumBy f xs
+
+count :: (a -> Bool) -> [a] -> Int
+count f xs = go xs 0
+    where
+        go []     !n = n
+        go (x:xs) !n = go xs $ if f x then n+1 else n
+
+takeWhileJust :: [Maybe a] -> [a]
+takeWhileJust []          = []
+takeWhileJust (Nothing:_) = []
+takeWhileJust (Just x:xs) = x : takeWhileJust xs
+
+-- Compute elements of the list to WHNF for `t` microseconds. After
+-- `t` microseconds, abandon the calculation and terminate the list.
+evaluateListWithTimeout :: Integer -> [a] -> IO [a]
+evaluateListWithTimeout t xs = do
+    end <- (+) <$> getCPUTime <*> pure (1000000 * t)
+    flip fix xs $ \loop xs -> do
+        now <- getCPUTime
+        r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $
+            case xs of
+                []     -> pure []
+                (a:as) -> pure $! a `seq` (a:as)
+        case r of
+            Nothing     -> pure []
+            Just []     -> pure []
+            Just (a:as) -> (a:) <$> loop as

Contests/CodeOfTheRings/CodeOfTheRings1.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE DataKinds, DeriveFunctor, TypeOperators, TypeFamilies, ScopedTypeVariables #-}
+
+import System.IO
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Proxy
+import Debug.Trace
+import GHC.TypeLits
+
+newtype Circular (n :: Nat) a = Cycle [a] deriving (Eq,Show,Functor)
+newtype Rune = Rune Char deriving (Eq,Show)
+type Zones = Circular 30 Rune
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    putStrLn =<< solveIt . map Rune <$> getLine
+
+solveIt :: [Rune] -> String
+solveIt phrase = loop phrase $ pure (Rune ' ')
+
+loop :: [Rune] -> Zones -> String
+loop []     _     = ""
+loop phrase zones = moves'
+    where
+        diff = if null (tail phrase) then "" else incDecMoves (phrase !! 0) (phrase !! 1)
+        seqn = head phrase : map snd (takeWhile ((== diff) . fst) (zipWith (\h t -> (incDecMoves h t, t)) phrase (tail phrase)))
+        (moves, zones') = findNearest (head seqn) zones
+        (rep, (setup, step, count)) =
+            if length seqn >= 15
+            then (3, setCounter (extractC $ rotateRight zones') $ length seqn `div` 3)
+            else (1, setCounter (extractC $ rotateRight zones') $ length seqn)
+        inner = concat $ replicate rep ('.':diff)
+        loopMoves = ">" ++ setup ++ "[<" ++ inner ++ ">" ++ step ++ "]"
+        zones'' = mapC (const $ Rune ' ') $ rotateRight $
+                  simulate (concat (replicate (count * rep) diff)) zones'
+        moves' = if length loopMoves < count * rep + (count * rep - 1) * length diff
+                 then moves ++ loopMoves ++ loop (drop (count * rep) phrase) zones''
+                 else moves ++ "." ++ loop (tail phrase) zones'
+
+simulate :: String -> Zones -> Zones
+simulate []     zs = zs
+simulate (c:cs) zs = simulate cs $ case c of
+    '.' -> zs
+    '<' -> rotateLeft zs
+    '>' -> rotateRight zs
+    '+' -> mapC succ zs
+    '-' -> mapC pred zs
+
+findNearest :: Rune -> Zones -> (String, Zones)
+findNearest r zones = first (tail . reverse) $ head $ filter ((== r) . extractC . snd) bfs
+    where
+        bfs = ("$", zones) : concatMap next bfs
+        next :: (String, Zones) -> [(String, Zones)]
+        next (ms, zs) = case head ms of
+                '$' -> [ left, right, inc, dec ]
+                '<' -> [ left, inc, dec ]
+                '>' -> [ right, inc, dec ]
+                '+' -> [ inc ]
+                '-' -> [ dec ]
+            where
+                left  = ('<':ms, rotateLeft  zs)
+                right = ('>':ms, rotateRight zs)
+                inc   = ('+':ms, mapC succ zs)
+                dec   = ('-':ms, mapC pred zs)
+
+setCounter :: Rune -> Int -> (String, String, Int)
+setCounter c n
+    | n > 26    = setCounter c 26
+    | otherwise = minimumBy (compare `on` (\(x, y, _) -> length x + length y)) $ catMaybes $
+        [ (,,) <$> (incDecMoves c <$> fromCounter    n     '+') <*> pure "+"  <*> pure n
+        , (,,) <$> (incDecMoves c <$> fromCounter    n     '-') <*> pure "-"  <*> pure n
+        , (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '+') <*> pure "++" <*> pure n2
+        , (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '-') <*> pure "--" <*> pure n2
+        ]
+    where
+        n2 = if even n then n else n - 1
+
+fromCounter :: Int -> Char -> Maybe Rune
+fromCounter 0 _ = Just $ toEnum 0
+fromCounter n _ | n < 1 || n > 26 = Nothing
+fromCounter n '+' = Just $ toEnum (27 - n)
+fromCounter n '-' = Just $ toEnum n
+
+distance :: Rune -> Rune -> (Int, Char)
+distance a b = if d1 < d2 then (d1, '-') else (d2, '+')
+    where
+        d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
+        d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
+
+incDecMoves :: Rune -> Rune -> String
+incDecMoves from to = uncurry replicate $ distance from to
+
+rotateLeft, rotateRight :: Circular n a -> Circular n a
+rotateLeft  (Cycle []) = Cycle []
+rotateLeft  (Cycle xs) = Cycle $ tail xs ++ [head xs]
+rotateRight (Cycle []) = Cycle []
+rotateRight (Cycle xs) = Cycle $ [last xs] ++ init xs
+
+extractC :: (1 <= n) => Circular n a -> a
+extractC (Cycle (x:_)) = x
+
+mapC :: (1 <= n) => (a -> a) -> Circular n a -> Circular n a
+mapC f (Cycle (x:xs)) = Cycle (f x : xs)
+
+instance Enum Rune where
+    toEnum 0 = Rune ' '
+    toEnum n | n >= 1 && n <= 26 = Rune (toEnum (fromEnum 'A' + (n - 1)))
+             | otherwise = error $ "Rune " ++ show n ++ " is out of range."
+    fromEnum (Rune ' ') = 0
+    fromEnum (Rune c) = fromEnum c - fromEnum 'A' + 1
+    succ (Rune ' ') = Rune 'A'
+    succ (Rune 'Z') = Rune ' '
+    succ (Rune  c ) = Rune (succ c)
+    pred (Rune ' ') = Rune 'Z'
+    pred (Rune 'A') = Rune ' '
+    pred (Rune  c ) = Rune (pred c)
+
+instance KnownNat n => Applicative (Circular n) where
+    pure x = Cycle $ replicate (fromInteger $ natVal (Proxy :: Proxy n)) x
+    (Cycle cf) <*> (Cycle cx) = Cycle (zipWith ($) cf cx)

Contests/CodeOfTheRings/CodeOfTheRings2.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE DataKinds, DeriveFunctor, TypeOperators, TypeFamilies, ScopedTypeVariables, ViewPatterns, ConstraintKinds, FlexibleContexts #-}
+
+import System.IO
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.Trans.State  (StateT)
+import Control.Monad.Trans.Writer (WriterT)
+import Data.Function
+import Data.List
+import Data.Maybe
+import Debug.Trace
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    putStrLn =<< execBilbo . solveIt . map Rune <$> getLine
+
+newtype Rune = Rune Char deriving (Eq,Show)
+
+solveIt :: [Rune] -> Bilbo ()
+solveIt rs = bindVar $ \dv -> clearRune dv *> solveIt' dv (Rune ' ') rs
+
+solveIt' :: Int -> Rune -> [Rune] -> Bilbo ()
+solveIt' dv dr []     = return ()
+solveIt' dv dr [r]    = atVar dv (incDecMoves dr r) *> triggerRune dv
+solveIt' dv dr rs@(a:b:_) = let (_, (m, rst, dr')) = minimumBy (compare `on` fst) candidates in m *> solveIt' dv dr' rst
+    where
+        diff   = incDecMoves a b
+        ls     = (a:) $ map snd $ takeWhile ((== diff) . fst) $ zipWith (\h t -> (incDecMoves h t, t)) rs (tail rs)
+        rst1   = drop (length ls) rs
+        moves1 = [ (bindVar $ \v -> selectRune v a *> triggerRune v *> repFn (length ls - 1) (atVar v diff *> triggerRune v), rst1, dr)
+                 | repFn <- [replicateM_, loopExpr] ]
+        moves2 = [ (atVar dv (incDecMoves dr a) *> triggerRune dv, tail rs, a) ]
+        moves3 = [ (loopExpr n $ solveIt xs, ys, dr) | (xs, n, ys) <- take 3 $ repeats rs ]
+        score (m, rst, dr) = length (execBilbo m) + (10 * length rst)
+        candidates = [ (score c, c) | c@(_, rst, _) <- moves1 ++ moves2 ++ moves3, rst /= rs ]
+
+repeats :: Eq a => [a] -> [([a], Int, [a])]
+repeats as = go (length as `div` 2)
+    where
+        go 0 = []
+        go n = let (xs, ys) = splitAt n as
+                   m = length (takeWhile id (zipWith (==) (cycle xs) as)) `div` n
+               in if m >= 2 then (xs, m, drop (m * length xs) as) : go (n - 1) else go (n - 1)
+
+type MonadBilbo m = (Applicative m, MonadWriter String m, MonadState Int m, MonadReader Int m)
+type Bilbo a = ReaderT Int (StateT Int (Writer String)) a
+
+execBilbo :: Bilbo a -> String
+execBilbo m = execWriter $ runStateT (runReaderT m 0) 0
+
+bindVar :: MonadBilbo m => (Int -> m a) -> m a
+bindVar f = ask >>= \v -> local (+1) (f v)
+
+atVar :: MonadBilbo m => Int -> String -> m ()
+atVar v cs = get >>= \n -> moveTo n *> tell cs
+    where moveTo n | v >= n    = replicateM_ (v - n) moveRight
+                   | otherwise = replicateM_ (n - v) moveLeft
+
+loopExpr :: MonadBilbo m => Int -> m () -> m ()
+loopExpr 0 m = return ()
+loopExpr 1 m = m
+loopExpr n m | n >= 27 = bindVar $ \lv -> do
+    selectRune lv $ toEnum $ n `mod` 26
+    when (n `mod` 26 == 0) $ decRune lv
+    loopExpr (1 + ((n - 1) `div` 26)) $ do
+        atVar lv "["
+        m
+        decRune lv
+        atVar lv "]"
+        decRune lv
+loopExpr n m = bindVar $ \lv -> do
+    selectRune lv $ toEnum n
+    atVar lv "["
+    m
+    decRune lv
+    atVar lv "]"
+
+moveLeft, moveRight :: MonadBilbo m => m ()
+moveLeft  = modify (\n -> (n + 26) `mod` 27) *> tell "<"
+moveRight = modify (\n -> (n + 28) `mod` 27) *> tell ">"
+
+clearRune, incRune, decRune, triggerRune :: MonadBilbo m => Int -> m ()
+clearRune   v = atVar v "[-]"
+incRune     v = atVar v "+"
+decRune     v = atVar v "-"
+triggerRune v = atVar v "."
+
+putRune :: MonadBilbo m => Rune -> m ()
+putRune r = bindVar $ \v -> selectRune v r *> triggerRune v
+ 
+selectRune :: MonadBilbo m => Int -> Rune -> m ()
+selectRune v (fromEnum -> n)
+    | n <= 14   = clearRune v *> replicateM_ n  (incRune v)
+    | otherwise = clearRune v *> replicateM_ n' (decRune v)
+    where n' = 27 - n
+
+distance :: Rune -> Rune -> (Int, Char)
+distance a b = if d1 < d2 then (d1, '-') else (d2, '+')
+    where
+        d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
+        d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
+
+incDecMoves :: Rune -> Rune -> String
+incDecMoves from to = uncurry replicate $ distance from to
+
+instance Enum Rune where
+    toEnum 0 = Rune ' '
+    toEnum n | n >= 1 && n <= 26 = Rune (toEnum (fromEnum 'A' + (n - 1)))
+             | otherwise = error $ "Rune " ++ show n ++ " is out of range."
+    fromEnum (Rune ' ') = 0
+    fromEnum (Rune c) = fromEnum c - fromEnum 'A' + 1
+    succ (Rune ' ') = Rune 'A'
+    succ (Rune 'Z') = Rune ' '
+    succ (Rune  c ) = Rune (succ c)
+    pred (Rune ' ') = Rune 'Z'
+    pred (Rune 'A') = Rune ' '
+    pred (Rune  c ) = Rune (pred c)

Contests/CodeOfTheRings/CodeOfTheRings3.hs

@@ -0,0 +1,298 @@
+{-# LANGUAGE ConstraintKinds, DataKinds, TypeFamilies, TypeOperators, DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns, ViewPatterns      #-}
+
+import System.IO
+import Control.Applicative
+import Control.Arrow (first, second, (&&&), (***))
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.Trans.State  (StateT)
+import Control.Monad.Trans.Writer (WriterT)
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Tuple
+import Debug.Trace
+
+import Data.Proxy
+import GHC.TypeLits
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    phrase <- map Rune <$> getLine
+    let sol_1 = solveIt_1 phrase
+    let sol_2 = execBilbo (solveIt_2 phrase)
+    putStrLn $ minimumBy (compare `on` length) [sol_1, sol_2]
+
+tryIt_1 :: String -> IO Bool
+tryIt_1 phrase = (result == phrase) <$ mapM_ print [program, result]
+    where
+        program = solveIt_1 $ map Rune phrase
+        result = fst $ simulate program $ pure $ Rune ' '
+
+tryIt_2 :: String -> IO Bool
+tryIt_2 phrase = (result == phrase) <$ mapM_ print [program, result]
+    where
+        program = execBilbo $ solveIt_2 $ map Rune phrase
+        result = fst $ simulate program $ pure $ Rune ' '
+
+{------ Version 2 ------}
+    
+newtype Rune = Rune Char deriving (Eq,Show)
+
+solveIt_2 :: [Rune] -> Bilbo ()
+solveIt_2 rs = bindVar $ \dv -> clearRune dv *> solveIt_2' dv (Rune ' ') rs
+
+solveIt_2' :: Int -> Rune -> [Rune] -> Bilbo ()
+solveIt_2' dv dr []     = return ()
+solveIt_2' dv dr [r]    = atVar dv (incDecMoves dr r) *> triggerRune dv
+solveIt_2' dv dr rs@(a:b:_) = let (_, (m, rst, dr')) = minimumBy (compare `on` fst) candidates in m *> solveIt_2' dv dr' rst
+    where
+        diff   = distance a b
+        ls     = (a:) $ map snd $ takeWhile ((== diff) . fst) $ zipWith (\h t -> (distance h t, t)) rs (tail rs)
+        rst1   = drop (length ls) rs
+        dr1    = last ls
+        moves1 = [ (changeRune dv dr a *> triggerRune dv *> repFn (length ls - 1) (changeRune dv a b *> triggerRune dv), rst1, dr1)
+                 | repFn <- [replicateM_, loopExpr] ]
+        moves2 = [ (bindVar $ \v -> selectRune v a *> triggerRune v *> repFn (length ls - 1) (changeRune v a b *> triggerRune v), rst1, dr)
+                 | repFn <- [replicateM_, loopExpr] ]
+        moves3 = [ (loopExpr n $ solveIt_2 xs, ys, dr) | (xs, n, ys) <- repeats rs ]
+        score (m, rst, dr) = length (execBilbo m) + (10 * length rst)
+        candidates = [ (score c, c) | c@(_, rst, _) <- moves1 ++ moves2 ++ moves3, rst /= rs ]
+
+type MonadBilbo m = (Applicative m, MonadWriter String m, MonadState Int m, MonadReader Int m)
+type Bilbo a = ReaderT Int (StateT Int (Writer String)) a
+
+execBilbo :: Bilbo a -> String
+execBilbo m = execWriter $ runStateT (runReaderT m 0) 0
+
+bindVar :: MonadBilbo m => (Int -> m a) -> m a
+bindVar f = ask >>= \v -> local (+1) (f v)
+
+atVar :: MonadBilbo m => Int -> String -> m ()
+atVar v cs = moveTo v *> tell cs
+
+loopAtVar :: MonadBilbo m => Int -> m a -> m a
+loopAtVar v m = atVar v "[" *> m <* atVar v "]"
+
+loopExpr :: MonadBilbo m => Int -> m () -> m ()
+loopExpr 0 m = return ()
+loopExpr 1 m = m
+loopExpr n m | n >= 27 = bindVar $ \lv -> do
+    selectRune lv $ toEnum $ n `mod` 26
+    when (n `mod` 26 == 0) $ decRune lv
+    loopExpr (1 + ((n - 1) `div` 26)) $ do
+        loopAtVar lv (m *> decRune lv)
+        decRune lv
+loopExpr n m | n >= 10 && n <= 13 = bindVar $ \lv -> do
+    selectRune lv $ toEnum (2 * n)
+    loopAtVar lv (m *> decRune lv *> decRune lv)
+loopExpr n m = bindVar $ \lv -> do
+    selectRune lv $ toEnum n
+    loopAtVar lv (m *> decRune lv)
+
+moveLeft, moveRight :: MonadBilbo m => m ()
+moveLeft  = modify (\n -> (n + 26) `mod` 27) *> tell "<"
+moveRight = modify (\n -> (n + 28) `mod` 27) *> tell ">"
+
+moveTo :: MonadBilbo m => Int -> m ()
+moveTo v = get >>= moveFrom
+    where moveFrom n | v >= n    = replicateM_ (v - n) moveRight
+                     | otherwise = replicateM_ (n - v) moveLeft
+
+clearRune, incRune, decRune, triggerRune :: MonadBilbo m => Int -> m ()
+clearRune   v = atVar v "[-]"
+incRune     v = atVar v "+"
+decRune     v = atVar v "-"
+triggerRune v = atVar v "."
+
+putRune :: MonadBilbo m => Rune -> m ()
+putRune r = bindVar $ \v -> selectRune v r *> triggerRune v
+ 
+selectRune :: MonadBilbo m => Int -> Rune -> m ()
+selectRune v r = clearRune v *> changeRune v (Rune ' ') r
+
+changeRune :: MonadBilbo m => Int -> Rune -> Rune -> m ()
+changeRune v a b = if d1 < d2 then replicateM_ d1 (decRune v)
+                              else replicateM_ d2 (incRune v)
+    where
+        d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
+        d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
+
+simulate :: String -> Zones -> (String, Zones)
+simulate cs zs = swap $ runWriter $ execStateT (go cs) zs
+    where
+        go []     = return ()
+        go (c:cs) = case c of
+            '.' -> do { Rune r <- extractC <$> get; tell [r]; go cs }
+            '<' -> modify rotateLeft  >> go cs
+            '>' -> modify rotateRight >> go cs
+            '+' -> modify (mapC succ) >> go cs
+            '-' -> modify (mapC pred) >> go cs
+            '[' -> let (inside, after) = splitBrackets cs in
+                fix $ \loop -> get >>= \zs' ->
+                    if extractC zs' /= Rune ' '
+                        then go inside >> loop
+                        else go after
+
+splitBrackets :: String -> (String, String)
+splitBrackets cs = go cs 0
+    where
+        go []       _ = error "splitBrackets: unmatched brackets"
+        go (']':cs) 0 = ("", cs)
+        go (c:cs)   n = first (c:) $ go cs $
+                        case c of { '[' -> n+1; ']' -> n-1; _ -> n }
+
+moveRune :: MonadBilbo m => Int -> [Int] -> m ()
+moveRune s ts = mapM_ clearRune ts *> loopAtVar s (mapM_ incRune ts *> decRune s)
+
+copyRune :: MonadBilbo m => Int -> [Int] -> m ()
+copyRune s ts = bindVar $ \v -> moveRune s (v:ts) *> moveRune v [s]
+
+switch :: MonadBilbo m => Int -> [m ()] -> m ()
+switch cv [] = clearRune cv
+switch cv ms = bindVar $ \fv -> clearRune fv *> incRune fv *> go fv ms
+    where
+        go fv [m]    = m *> decRune fv *> clearRune cv
+        go fv (m:ms) = loopAtVar cv (decRune cv *> go fv ms) 
+                    *> loopAtVar fv (m *> decRune fv)
+
+ifThenElse :: MonadBilbo m => Int -> m () -> m () -> m ()
+ifThenElse cv t f = switch cv [f, t]
+
+ifThen :: MonadBilbo m => Int -> m a -> m a
+ifThen cv t = loopAtVar cv (t <* clearRune cv)
+
+whileLoop :: MonadBilbo m => (Int -> m ()) -> m () -> m ()
+whileLoop fc m = bindVar $ \v -> selectRune v (toEnum 1) *>
+    loopAtVar v (bindVar $ \v2 -> fc v2 *> ifThenElse v2 m (decRune v))
+
+instance Enum Rune where
+    toEnum 0 = Rune ' '
+    toEnum n | n >= 1 && n <= 26 = Rune (toEnum (fromEnum 'A' + (n - 1)))
+             | otherwise = error $ "Rune.toEnum: bad argument: " ++ show n
+    fromEnum (Rune ' ') = 0
+    fromEnum (Rune c) = fromEnum c - fromEnum 'A' + 1
+    succ (Rune ' ') = Rune 'A'
+    succ (Rune 'Z') = Rune ' '
+    succ (Rune  c ) = Rune (succ c)
+    pred (Rune ' ') = Rune 'Z'
+    pred (Rune 'A') = Rune ' '
+    pred (Rune  c ) = Rune (pred c)
+
+{------ Version 1 ------} 
+
+newtype Circular (n :: Nat) a = Cycle [a] deriving (Eq,Show,Functor)
+type Zones = Circular 30 Rune
+
+solveIt_1 :: [Rune] -> String
+solveIt_1 phrase = loop phrase $ pure (Rune ' ')
+
+loop :: [Rune] -> Zones -> String
+loop []     _     = ""
+loop phrase zones = moves'
+    where
+        diff = if null (tail phrase) then "" else incDecMoves (phrase !! 0) (phrase !! 1)
+        seqn = head phrase : map snd (takeWhile ((== diff) . fst) (zipWith (\h t -> (incDecMoves h t, t)) phrase (tail phrase)))
+        (moves, zones') = findNearest (head seqn) zones
+        (rep, (setup, step, count)) =
+            if length seqn >= 15
+            then (3, setCounter (extractC $ rotateRight zones') $ length seqn `div` 3)
+            else (1, setCounter (extractC $ rotateRight zones') $ length seqn)
+        inner = concat $ replicate rep ('.':diff)
+        loopMoves = ">" ++ setup ++ "[<" ++ inner ++ ">" ++ step ++ "]"
+        zones'' = mapC (const $ Rune ' ') $ rotateRight $ snd $
+                  simulate (concat (replicate (count * rep) diff)) zones'
+        moves' = if length loopMoves < count * rep + (count * rep - 1) * length diff
+                 then moves ++ loopMoves ++ loop (drop (count * rep) phrase) zones''
+                 else moves ++ "." ++ loop (tail phrase) zones'
+
+findNearest :: Rune -> Zones -> (String, Zones)
+findNearest r zones = first (tail . reverse) $ head $ filter ((== r) . extractC . snd) bfs
+    where
+        bfs = ("$", zones) : concatMap next bfs
+        next :: (String, Zones) -> [(String, Zones)]
+        next (ms, zs) = case head ms of
+                '$' -> [ left, right, inc, dec ]
+                '<' -> [ left, inc, dec ]
+                '>' -> [ right, inc, dec ]
+                '+' -> [ inc ]
+                '-' -> [ dec ]
+            where
+                left  = ('<':ms, rotateLeft  zs)
+                right = ('>':ms, rotateRight zs)
+                inc   = ('+':ms, mapC succ zs)
+                dec   = ('-':ms, mapC pred zs)
+
+setCounter :: Rune -> Int -> (String, String, Int)
+setCounter c n
+    | n > 26    = setCounter c 26
+    | otherwise = minimumBy (compare `on` (\(x, y, _) -> length x + length y)) $ catMaybes $
+        [ (,,) <$> (incDecMoves c <$> fromCounter    n     '+') <*> pure "+"  <*> pure n
+        , (,,) <$> (incDecMoves c <$> fromCounter    n     '-') <*> pure "-"  <*> pure n
+        , (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '+') <*> pure "++" <*> pure n2
+        , (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '-') <*> pure "--" <*> pure n2
+        ]
+    where
+        n2 = if even n then n else n - 1
+
+fromCounter :: Int -> Char -> Maybe Rune
+fromCounter 0 _ = Just $ toEnum 0
+fromCounter n _ | n < 1 || n > 26 = Nothing
+fromCounter n '+' = Just $ toEnum (27 - n)
+fromCounter n '-' = Just $ toEnum n
+
+rotateLeft, rotateRight :: Circular n a -> Circular n a
+rotateLeft  (Cycle []) = Cycle []
+rotateLeft  (Cycle xs) = Cycle $ tail xs ++ [head xs]
+rotateRight (Cycle []) = Cycle []
+rotateRight (Cycle xs) = Cycle $ [last xs] ++ init xs
+
+distance :: Rune -> Rune -> (Int, Char)
+distance a b = if d1 < d2 then (d1, '-') else (d2, '+')
+    where
+        d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
+        d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
+
+incDecMoves :: Rune -> Rune -> String
+incDecMoves from to = uncurry replicate $ distance from to
+
+extractC :: (1 <= n) => Circular n a -> a
+extractC (Cycle (x:_)) = x
+
+mapC :: (1 <= n) => (a -> a) -> Circular n a -> Circular n a
+mapC f (Cycle (x:xs)) = Cycle (f x : xs)
+
+instance KnownNat n => Applicative (Circular n) where
+    pure x = Cycle $ replicate (fromInteger $ natVal (Proxy :: Proxy n)) x
+    (Cycle cf) <*> (Cycle cx) = Cycle (zipWith ($) cf cx)
+
+{--------- Utility Functions --------}
+
+repeats :: Eq a => [a] -> [([a], Int, [a])]
+repeats as = go (length as `div` 2)
+    where
+        go 0 = []
+        go n = let (xs, ys) = splitAt n as
+                   m = length (takeWhile id (zipWith (==) (cycle xs) as)) `div` n
+               in if m >= 2 then (xs, m, drop (m * length xs) as) : go (n - 1) else go (n - 1)
+
+dropLast, takeLast :: Int -> [a] -> [a]
+dropLast n xs = zipWith const xs (drop n xs)
+takeLast n xs = foldl' (\xs' ys' -> tail xs') xs (drop n xs)
+
+accum :: (a -> b -> a) -> a -> [b] -> [a]
+accum _ !a []     = [a]
+accum f !a (b:bs) = a : accum f (f a b) bs
+
+accum1 :: (a -> a -> a) -> [a] -> [a]
+accum1 f []     = error "accum1: empty list"
+accum1 f (a:as) = accum f a as
+
+cumsum, cumproduct :: Num a => [a] -> [a]
+cumsum     = accum1 (+)
+cumproduct = accum1 (*)

Contests/CodeOfTheRings/CodeOfTheRings4.hs

@@ -0,0 +1,422 @@
+{-# LANGUAGE ConstraintKinds, DataKinds, TypeFamilies, TypeOperators, DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, BangPatterns, ViewPatterns      #-}
+
+import System.IO
+import System.IO.Unsafe
+import System.Timeout
+import Control.Applicative
+import Control.Arrow (first, second, (&&&), (***))
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.Trans.State  (StateT)
+import Control.Monad.Trans.Writer (WriterT)
+import Control.Monad.Trans.List
+--import Control.Comonad
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Tuple
+import Debug.Trace
+
+import Data.Proxy
+import GHC.TypeLits
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    phrase <- toRunes <$> getLine
+    sols <- mapM (\f -> timeout 400000 $ return $!! f phrase) [solveIt_1, solveIt_2]
+    putStrLn $ minimumBy (compare `on` length) $ catMaybes sols
+
+tryIt :: ([Rune] -> String) -> String -> IO Bool
+tryIt solveIt phrase = (result == phrase) <$ mapM_ print [program, result, show steps]
+    where
+        program = solveIt $ toRunes phrase
+        (result, Sum steps) = fst $ simulate program initZones
+
+{------ Version 2 ------}
+    
+newtype Rune = Rune Char deriving (Eq,Show)
+
+solveIt_2 :: [Rune] -> String
+solveIt_2 = execBilbo . solveIt_2'
+
+solveIt_2' :: [Rune] -> Bilbo ()
+solveIt_2' []  = return ()
+solveIt_2' [r] = putRune r
+solveIt_2' rs@(a:b:_) = bestM *> solveIt_2' bestRst
+    where
+        diff   = distance a b
+        ls     = (a:) $ map snd $ takeWhile ((== diff) . fst) $ zipWith (\h t -> (distance h t, t)) rs (tail rs)
+        rst1   = drop (length ls) rs
+        moves1 = [ (bindVar $ \v -> selectRune v a *> triggerRune v *> repFn (length ls - 1) (changeRune v a b *> triggerRune v), rst1)
+                 | repFn <- [replicateM_, loopExpr] ]
+        moves2 = [ (withRunes xs (\vs -> loopExpr n $ mapM_ triggerRune vs), ys) | (xs, n, ys) <- repeats rs, n > 2 * length xs, length xs < 16 ]
+        moves3 = [ (putPattern p, ys) | (p, ys) <- unsafeTimeoutList 100000 $ patterns rs ]
+        moves4 = [ (loopExpr n (solveIt_2' xs), ys) | (xs, n, ys) <- repeats rs ]
+        score (m, rst) = length (execBilbo m) + (10 * length rst)
+        candidates = [ (score c, c) | c@(_, rst) <- moves1 ++ moves2 ++ moves3 ++ moves4, rst /= rs ]
+        (_, (bestM, bestRst)) = minimumBy (compare `on` fst) candidates
+
+-- If at any point it takes more than `t` microseconds to compute the next
+-- element of the list (to WHNF), abandon the calculation and terminate
+-- the list. Note that this causes the length of the result to depend
+-- on timing and system load. Marked "unsafe" for a reason!
+unsafeTimeoutList :: Int -> [a] -> [a]
+unsafeTimeoutList t xs = unsafePerformIO $ do
+    r <- timeout t $ return $! case xs of
+        []     -> []
+        (a:as) -> a `seq` (a:as)
+    return $ case r of
+        Nothing     -> []
+        Just []     -> []
+        Just (a:as) -> (a : unsafeTimeoutList t as)
+
+type MonadBilbo m = (Applicative m, MonadWriter String m, MonadState Int m, MonadReader Int m)
+type Bilbo a = ReaderT Int (StateT Int (Writer String)) a
+
+execBilbo :: Bilbo a -> String
+execBilbo m = execWriter $ runStateT (runReaderT m 0) 0
+
+bindVar :: MonadBilbo m => (Int -> m a) -> m a
+bindVar f = ask >>= \v -> local (+1) (f v)
+
+atVar :: MonadBilbo m => Int -> String -> m ()
+atVar v cs = moveTo v *> tell cs
+
+loopAtVar :: MonadBilbo m => Int -> m a -> m a
+loopAtVar v m = atVar v "[" *> m <* atVar v "]"
+
+loopExpr :: MonadBilbo m => Int -> m () -> m ()
+loopExpr 0 m = return ()
+loopExpr 1 m = m
+loopExpr n m | n >= 27 = bindVar $ \lv -> do
+    selectRune lv $ toEnum $ n `mod` 26
+    when (n `mod` 26 == 0) $ decRune lv
+    loopExpr (1 + ((n - 1) `div` 26)) $ do
+        loopAtVar lv (m *> decRune lv)
+        decRune lv
+loopExpr n m | n >= 10 && n <= 17 = bindVar $ \lv -> do
+    selectRune lv $ toEnum (2 * n `mod` 27)
+    loopAtVar lv (m *> decRune lv *> decRune lv)
+loopExpr n m = bindVar $ \lv -> do
+    selectRune lv $ toEnum n
+    loopAtVar lv (m *> decRune lv)
+
+moveLeft, moveRight :: MonadBilbo m => m ()
+moveLeft  = modify (\n -> (n + 26) `mod` 27) *> tell "<"
+moveRight = modify (\n -> (n + 28) `mod` 27) *> tell ">"
+
+clearAllRunes :: MonadBilbo m => m ()
+clearAllRunes = put 0 *> tell "[-]+++[>[-]>[-]<<[->>+<<]>>--]"
+
+moveTo :: MonadBilbo m => Int -> m ()
+moveTo v = get >>= moveFrom
+    where moveFrom n | v >= n    = replicateM_ (v - n) moveRight
+                     | otherwise = replicateM_ (n - v) moveLeft
+
+clearRune, incRune, decRune, triggerRune :: MonadBilbo m => Int -> m ()
+clearRune   v = atVar v "[-]"
+incRune     v = atVar v "+"
+decRune     v = atVar v "-"
+triggerRune v = atVar v "."
+
+putRune :: MonadBilbo m => Rune -> m ()
+putRune r = bindVar $ \v -> selectRune v r *> triggerRune v
+ 
+selectRune :: MonadBilbo m => Int -> Rune -> m ()
+selectRune v r = clearRune v *> changeRune v (Rune ' ') r
+
+withRunes :: MonadBilbo m => [Rune] -> ([Int] -> m a) -> m a
+withRunes []     f = f []
+withRunes (r:rs) f = bindVar $ \v -> selectRune v r *> withRunes rs (f . (v:))
+
+changeRune :: MonadBilbo m => Int -> Rune -> Rune -> m ()
+changeRune v a b = if d1 < d2 then replicateM_ d1 (decRune v)
+                              else replicateM_ d2 (incRune v)
+    where
+        d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
+        d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
+
+simulate :: String -> Zones -> ((String, Sum Int), Zones)
+simulate cs zs = swap $ runWriter $ execStateT (go cs) zs
+    where
+        go []     = return ()
+        go (c:cs) = tell ("", Sum 1) >> case c of
+            '.' -> do { Rune r <- extractC <$> get; tell ([r], Sum 0); go cs }
+            '<' -> modify rotateRight >> go cs
+            '>' -> modify rotateLeft  >> go cs
+            '+' -> modify (modifyC succ) >> go cs
+            '-' -> modify (modifyC pred) >> go cs
+            '[' -> let (inside, after) = splitBrackets cs in
+                fix $ \loop -> get >>= \zs' ->
+                    if extractC zs' /= Rune ' '
+                        then go inside >> tell ("", Sum 1) >> loop
+                        else go after
+
+splitBrackets :: String -> (String, String)
+splitBrackets cs = go cs 0
+    where
+        go []       _ = error "splitBrackets: unmatched brackets"
+        go (']':cs) 0 = ("", cs)
+        go (c:cs)   n = first (c:) $ go cs $
+                        case c of { '[' -> n+1; ']' -> n-1; _ -> n }
+
+moveRune :: MonadBilbo m => Int -> [Int] -> m ()
+moveRune s ts = mapM_ clearRune ts *> loopAtVar s (mapM_ incRune ts *> decRune s)
+
+copyRune :: MonadBilbo m => Int -> [Int] -> m ()
+copyRune s ts = bindVar $ \v -> moveRune s (v:ts) *> moveRune v [s]
+
+switch :: MonadBilbo m => Int -> [m ()] -> m ()
+switch cv [] = clearRune cv
+switch cv ms = bindVar $ \fv -> clearRune fv *> incRune fv *> go fv ms
+    where
+        go fv [m]    = m *> decRune fv *> clearRune cv
+        go fv (m:ms) = loopAtVar cv (decRune cv *> go fv ms) 
+                    *> loopAtVar fv (m *> decRune fv)
+
+ifThenElse :: MonadBilbo m => Int -> m () -> m () -> m ()
+ifThenElse cv t f = switch cv [f, t]
+
+ifThen :: MonadBilbo m => Int -> m a -> m a
+ifThen cv t = loopAtVar cv (t <* clearRune cv)
+
+whileLoop :: MonadBilbo m => (Int -> m ()) -> m () -> m ()
+whileLoop fc m = bindVar $ \v -> selectRune v (toEnum 1) *>
+    loopAtVar v (bindVar $ \v2 -> fc v2 *> ifThenElse v2 m (decRune v))
+
+instance Enum Rune where
+    toEnum 0 = Rune ' '
+    toEnum n | n >= 1 && n <= 26 = Rune (toEnum (fromEnum 'A' + (n - 1)))
+             | otherwise = error $ "Rune.toEnum: bad argument: " ++ show n
+    fromEnum (Rune ' ') = 0
+    fromEnum (Rune c) = fromEnum c - fromEnum 'A' + 1
+    succ (Rune ' ') = Rune 'A'
+    succ (Rune 'Z') = Rune ' '
+    succ (Rune  c ) = Rune (succ c)
+    pred (Rune ' ') = Rune 'Z'
+    pred (Rune 'A') = Rune ' '
+    pred (Rune  c ) = Rune (pred c)
+
+toRunes :: String -> [Rune]
+toRunes = map Rune
+
+fromRunes :: [Rune] -> String
+fromRunes = map (\(Rune c) -> c)
+
+{------ Version 1 ------} 
+
+type Zones = Circular 30 Rune
+
+initZones :: Zones
+initZones = pure $ Rune ' '
+
+solveIt_1 :: [Rune] -> String
+solveIt_1 phrase = loop phrase initZones
+
+loop :: [Rune] -> Zones -> String
+loop []     _     = ""
+loop phrase zones = moves'
+    where
+        diff = if null (tail phrase) then "" else incDecMoves (phrase !! 0) (phrase !! 1)
+        seqn = head phrase : map snd (takeWhile ((== diff) . fst) (zipWith (\h t -> (incDecMoves h t, t)) phrase (tail phrase)))
+        (moves, zones') = findNearest (head seqn) zones
+        (rep, (setup, step, count)) =
+            if length seqn >= 15
+            then (3, setCounter (extractC $ rotateRight zones') $ length seqn `div` 3)
+            else (1, setCounter (extractC $ rotateRight zones') $ length seqn)
+        inner = concat $ replicate rep ('.':diff)
+        loopMoves = ">" ++ setup ++ "[<" ++ inner ++ ">" ++ step ++ "]"
+        zones'' = modifyC (const $ Rune ' ') $ rotateRight $ snd $
+                  simulate (concat (replicate (count * rep) diff)) zones'
+        moves' = if length loopMoves < count * rep + (count * rep - 1) * length diff
+                 then moves ++ loopMoves ++ loop (drop (count * rep) phrase) zones''
+                 else moves ++ "." ++ loop (tail phrase) zones'
+
+findNearest :: Rune -> Zones -> (String, Zones)
+findNearest r zones = first (tail . reverse) $ head $ filter ((== r) . extractC . snd) bfs
+    where
+        bfs = ("$", zones) : concatMap next bfs
+        next :: (String, Zones) -> [(String, Zones)]
+        next (ms, zs) = case head ms of
+                '$' -> [ left, right, inc, dec ]
+                '<' -> [ left, inc, dec ]
+                '>' -> [ right, inc, dec ]
+                '+' -> [ inc ]
+                '-' -> [ dec ]
+            where
+                left  = ('<':ms, rotateLeft  zs)
+                right = ('>':ms, rotateRight zs)
+                inc   = ('+':ms, modifyC succ zs)
+                dec   = ('-':ms, modifyC pred zs)
+
+setCounter :: Rune -> Int -> (String, String, Int)
+setCounter c n
+    | n > 26    = setCounter c 26
+    | otherwise = minimumBy (compare `on` (\(x, y, _) -> length x + length y)) $ catMaybes $
+        [ (,,) <$> (incDecMoves c <$> fromCounter    n     '+') <*> pure "+"  <*> pure n
+        , (,,) <$> (incDecMoves c <$> fromCounter    n     '-') <*> pure "-"  <*> pure n
+        , (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '+') <*> pure "++" <*> pure n2
+        , (,,) <$> (incDecMoves c <$> fromCounter (2 * n2) '-') <*> pure "--" <*> pure n2
+        ]
+    where
+        n2 = if even n then n else n - 1
+
+fromCounter :: Int -> Char -> Maybe Rune
+fromCounter 0 _ = Just $ toEnum 0
+fromCounter n _ | n < 1 || n > 26 = Nothing
+fromCounter n '+' = Just $ toEnum (27 - n)
+fromCounter n '-' = Just $ toEnum n
+
+distance :: Rune -> Rune -> (Int, Char)
+distance a b = if d1 < d2 then (d1, '-') else (d2, '+')
+    where
+        d1 = ((fromEnum a - fromEnum b) + 27) `mod` 27
+        d2 = ((fromEnum b - fromEnum a) + 27) `mod` 27
+
+incDecMoves :: Rune -> Rune -> String
+incDecMoves from to = uncurry replicate $ distance from to
+
+{----- Fixed-size cyclic lists -----}
+
+data Circular (n :: Nat) a = Cycle [a] a [a] deriving (Eq,Show,Functor)
+
+rotateLeft, rotateRight :: (KnownNat n, 1 <= n) => Circular n a -> Circular n a
+rotateLeft  (Cycle l x []) = let (x':r') = reverse l in Cycle [x] x' r'
+rotateLeft  (Cycle l x (x':r')) = Cycle (x:l) x' r'
+rotateRight (Cycle [] x r) = let (x':l') = reverse r in Cycle l' x' [x]
+rotateRight (Cycle (x':l') x r) = Cycle l' x' (x:r)
+
+extractC :: (KnownNat n, 1 <= n) => Circular n a -> a
+extractC (Cycle _ x _) = x
+
+deleteC :: (KnownNat n, 1 <= n) => Circular (n+1) a -> (a, Circular n a)
+deleteC (Cycle (x':l') x  r) = (x, Cycle l' x' r)
+deleteC (Cycle [] x (x':r')) = (x, Cycle [] x' r')
+
+insertC :: (KnownNat n, 1 <= n) => a -> Circular n a -> Circular (n+1) a
+insertC x' (Cycle l x r) = Cycle l x' (x:r)
+
+modifyC :: (KnownNat n, 1 <= n) => (a -> a) -> Circular n a -> Circular n a
+modifyC f (Cycle l x r) = Cycle l (f x) r
+
+fillC :: (KnownNat n, 1 <= n) => [a] -> Circular n a -> Circular n a
+fillC xs (Cycle l x r) = Cycle [] x' r'
+    where (x':r') = zipWith ($) (map const xs ++ repeat id) ((x:r) ++ reverse l)
+
+instance (KnownNat n, 1 <= n) => Applicative (Circular n) where
+    pure x = Cycle [] x $ replicate (fromInteger (natVal (Proxy :: Proxy n)) - 1) x
+    (Cycle fl f fr) <*> (Cycle xl x xr) = Cycle [] (f x) (zipWith ($) fr' xr')
+        where fr' = fr ++ reverse fl
+              xr' = xr ++ reverse xl
+
+{-
+instance (KnownNat n, 1 <= n) => Comonad (Circular n) where
+    extract   c = extractC c
+    duplicate c = Cycle [] c (take (fromInteger (natVal (Proxy :: Proxy n)) - 1) cs)
+       where cs = map rotateLeft (c:cs)
+-}
+
+{--------- Utility Functions --------}
+
+repeats :: Eq a => [a] -> [([a], Int, [a])]
+repeats as = go (length as `div` 2)
+    where
+        go 0 = []
+        go n = let (xs, ys) = splitAt n as
+                   m = length (takeWhile id (zipWith (==) (cycle xs) as)) `div` n
+               in if m >= 2 then (xs, m, drop (m * length xs) as) : go (n - 1) else go (n - 1)
+
+patterns :: [Rune] -> [([[[Rune]]], [Rune])]
+patterns [] = []
+patterns xs = do
+    n <- [1 .. length xs `div` 2]
+    let (cs, xs') = chunksOf n xs
+    take 1 $ do
+        ns <- takeWhile ((<= 4) . length) $ addsUpTo n
+        let cs' = map (fst . splitAts ns) cs
+        let m = countSame $ takeWhile (all isJust) $ map (map fullSeq) cs'
+        guard $ m >= 2
+        let (cs'', ncs) = splitAt m cs'
+        let xs'' = concat (map concat ncs) ++ xs'
+        let seqHeads = transpose $ map (map head) cs''
+        let m' = let ms = m : map seqLength (zipWith take ms seqHeads) in last ms
+        guard $ m' >= 2
+        let (cs''', ncs') = splitAt m' cs''
+        let xs''' = concat (map concat ncs') ++ xs''
+        return (cs''', xs''')
+
+putPattern :: MonadBilbo m => [[[Rune]]] -> m ()
+putPattern ps = withRunes (map head $ head ps) $ \vs -> do
+    loopExpr (length ps) $ do
+        forM_ (zip vs (zip (ps!!0) (ps!!1))) $ \(v, (rs, (c:_))) -> do
+            triggerRune v
+            loopExpr (length rs - 1) $ do
+                changeRune v (rs!!0) (rs!!1)
+                triggerRune v
+            changeRune v (last rs) c
+
+chunksOf :: Int -> [a] -> ([[a]], [a])
+chunksOf n xs = if length as < n then ([], as) else first (as:) (chunksOf n bs)
+    where (as, bs) = splitAt n xs
+
+seqLength :: [Rune] -> Int
+seqLength [] = 0
+seqLength xs = (1+) $ countSame $ zipWith minusRune (tail xs) xs
+
+countSame :: Eq a => [a] -> Int
+countSame []  = 0
+countSame [x] = 1
+countSame (x:y:xs) = if x == y then 1 + countSame (y:xs) else 1
+
+fullSeq :: [Rune] -> Maybe Int
+fullSeq xs = if seqLength xs == length xs then Just (seqDiff xs) else Nothing
+
+seqDiff :: [Rune] -> Int
+seqDiff []      = 0
+seqDiff [x]     = 0
+seqDiff (x:y:_) = y `minusRune` x
+
+minusRune :: Rune -> Rune -> Int
+a `minusRune` b = (27 + fromEnum a - fromEnum b) `mod` 27
+
+-- All the list of numbers in [1..m] which add up to m, including permutations.
+-- Sorted shortest to longest, then lexographically descending.
+-- addsUpTo 3 ==> [[3],[2,1],[1,2],[1,1,1]]
+addsUpTo :: (Integral a) => a -> [[a]]
+addsUpTo m = concat [ go m n | n <- [1..m] ]
+   where go m 1 = [[m]]
+         go m n | n > 1 = concat [ map (x:) (go (m-x) (n-1)) | x <- [m-(n-1),m-n..1] ]
+
+splitAts :: [Int] -> [a] -> ([[a]], [a])
+splitAts []     xs = ([], xs)
+splitAts (a:as) xs = (bs : ds, xs')
+    where (bs,cs)  = splitAt  a  xs
+          (ds,xs') = splitAts as cs
+
+sublists :: [a] -> [[[a]]]
+sublists xs = map (fst . flip splitAts xs) $ addsUpTo (length xs)
+
+dropLast, takeLast :: Int -> [a] -> [a]
+dropLast n xs = zipWith const xs (drop n xs)
+takeLast n xs = foldl' (\xs' _ -> tail xs') xs (drop n xs)
+
+lengthGT :: Int -> [a] -> Bool
+lengthGT n xs = (n < 0) || not (null (drop n xs))
+
+accum :: (a -> b -> a) -> a -> [b] -> [a]
+accum _ _ []     = []
+accum f a (b:bs) = let a' = f a b in seq a' (a' : accum f a' bs)
+
+accum1 :: (a -> a -> a) -> [a] -> [a]
+accum1 f []     = []
+accum1 f (a:as) = a : accum f a as
+
+cumsum, cumproduct :: Num a => [a] -> [a]
+cumsum     = accum1 (+)
+cumproduct = accum1 (*)

Contests/TheGreatEscape/TheGreatEscape-2.hs

@@ -0,0 +1,223 @@
+{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
+{-# OPTIONS_GHC -O2 #-}
+
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.State
+import Data.Array.IArray ((!), (//))
+import Data.Either
+import Data.Function
+import Data.Functor.Identity
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Debug.Trace
+import System.IO
+import Text.Parsec hiding (many, (<|>))
+
+import qualified Data.Array.IArray as A
+import qualified Data.Array.MArray as MA
+import qualified Data.Array.ST     as STA
+
+type Point  = (Int, Int)
+
+data Orient = H | V deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Dir    = LEFT | RIGHT | UP | DOWN deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Player = Player { plID :: Int, plPt :: Point, plWalls :: Int } deriving (Eq, Show)
+data Wall   = Wall { wallPt :: Point, wallOrient :: Orient } deriving (Eq, Show)
+data Move   = Move Dir | Place Wall deriving (Eq)
+
+data Env = Env { boardWidth   :: Int
+               , boardHeight  :: Int
+               , playerCount  :: Int
+               , myID         :: Int
+               , players      :: [Player]
+               , walls        :: [Wall]
+               , neighborGrid :: A.Array Point [Point]
+               , grids        :: [A.Array Point (Maybe Double)]
+               } deriving (Show)
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+
+    (boardWidth, boardHeight, playerCount, myID) <-
+        parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine
+
+    forever $ do
+        players <- forM [0..playerCount-1] $ \i -> parseE (playerP i) "player" <$> getLine
+        wallCount <- parseE intP "wallCount" <$> getLine -- number of walls on the board
+        walls <- replicateM wallCount $ parseE wallP "wall" <$> getLine
+        let env = updateGrid Env { neighborGrid = undefined, grids = [], .. } walls
+
+        -- action: LEFT, RIGHT, UP, DOWN or "putX putY putOrientation" to place a wall
+        let top = take 3 $ sortBy (flip (compare `on` fst)) $
+                mapMaybe (\mv -> let e' = simulate env myID mv
+                                 in (,) <$> scoreEnv myID e' <*> pure (mv, e')) $
+                findDirMoves env myID ++ findWallMoves env myID
+        let depth = case playerCount of { 2 -> 3; 3 -> 2 }
+        let otherIDs = tail $ concat $ replicate depth $ [myID..playerCount-1] ++ [0..myID-1]
+        let doTurn i e = if escaped myID e || escaped i e then e else
+                snd $ snd $ maximumBy (compare `on` fst) $
+                mapMaybe (\mv -> let e' = simulate e i mv
+                                 in (,) <$> scoreEnv i e' <*> pure (mv, e')) $
+                findDirMoves e i ++ findWallMoves e i
+        let top' = catMaybes $
+                   [ let env'' = foldr doTurn env' otherIDs
+                     in (,) <$> (((4*sc)+) <$> scoreEnv myID env'') <*> pure (mv, env'')
+                   | (sc, (mv, env')) <- top ]
+        --traceM $ unlines $ map (show . (second fst)) top'
+        --traceM $ showGrid $ (grids $ snd $ snd $ maximumBy (compare `on` fst) top') !! myID
+
+        print $ fst $ snd $ maximumBy (compare `on` fst) top'
+
+scoreEnv :: Int -> Env -> Maybe Double
+scoreEnv pid env@Env{..} = (-) <$> myScore <*> (sum <$> sequence (map oppScore opponents))
+    where
+        (me, opponents) = removeAt pid players
+        plCost pl   = if plWalls pl < 0 then Just 0 else (grids !! plID pl) ! plPt pl
+        oppScore pl = (\cost -> 64 / (max 0.25 cost)) <$> plCost pl
+        myScore     = (\cost -> bonus - 8 * cost) <$> plCost me
+        bonus       = 56 * (max 0 (fromIntegral (plWalls me)) / maxWalls)**2
+        maxWalls    = if playerCount == 3 then 6 else 10
+
+escaped :: Int -> Env -> Bool
+escaped pid Env{..} = plWalls (players !! pid) < 0 || case pid of
+        0 -> x == boardWidth - 1
+        1 -> x == 0
+        2 -> y == boardHeight - 1
+        3 -> y == 0
+    where (x, y) = plPt (players !! pid)
+
+findDirMoves, findWallMoves :: Env -> Int -> [Move]
+findDirMoves env@Env{..} plID =
+    let myPt = plPt (players !! plID) in do
+        newPt <- neighbors env myPt
+        return $ Move $ dirFromPoints myPt newPt
+findWallMoves env@Env{..} plID =
+    if plWalls (players !! plID) == 0 then [] else do
+        wall <- if plID /= myID then adjacentWalls env (plPt $ players !! myID) else nub $ do
+            pt  <- nub $ map plPt $ filter ((>=0) . plWalls) players
+            --pt' <- pt  : (neighborGrid!pt)
+            --pt'' <- pt' : (neighborGrid!pt')
+            adjacentWalls env pt
+        guard $ not $ any (doWallsCross wall) walls
+        return $ Place wall
+
+floodFill :: Env -> Int -> A.Array Point (Maybe Double)
+floodFill env@Env{..} plID = STA.runSTArray $ do
+    grid <- STA.newArray ((0,0),(boardWidth-1,boardHeight-1)) Nothing
+    let goalEdge = case plID of
+            0 -> [ (boardWidth-1,y)  | y <- [0..boardHeight-1] ] -- right
+            1 -> [ (0,y)             | y <- [0..boardHeight-1] ] -- left
+            2 -> [ (x,boardHeight-1) | x <- [0..boardWidth-1]  ] -- bottom
+            3 -> [ (x,0)             | x <- [0..boardWidth-1]  ] -- top
+    forM_ goalEdge $ flip (MA.writeArray grid) $ Just 0
+    flip evalStateT goalEdge $ fix $ \loop -> do
+        pts <- nub . concatMap (neighborGrid!) <$> get
+        unless (null pts) $ (>> loop) $ put [] >> do
+            forM_ pts $ \pt -> do
+                old <- lift $ MA.readArray grid pt
+                new <- fmap (minimumBy cmpCost . (old:)) $ forM (neighborGrid!pt) $
+                        fmap (fmap (1+)) . lift . MA.readArray grid
+                unless (new == old) $ lift (MA.writeArray grid pt new) >> modify (pt:)
+    return grid
+
+simulate :: Env -> Int -> Move -> Env
+simulate env plID move =
+    case move of
+        Place wall -> updateGrid (modPlayer env decPlWalls) (wall : walls env)
+        Move  dir  -> checkEsc $ modPlayer env $ \p@(Player { plPt = (x,y) }) ->
+            case dir of
+                LEFT  -> p { plPt = (x-1,y) }
+                RIGHT -> p { plPt = (x+1,y) }
+                UP    -> p { plPt = (x,y-1) }
+                DOWN  -> p { plPt = (x,y+1) }
+    where modPlayer e f = e { players = modifyAt plID f (players e) }
+          decPlWalls p = p { plWalls = plWalls p - 1 }
+          checkEsc e
+            | escaped plID e = modPlayer e (\p -> p { plPt = (-1,-1), plWalls = -1 })
+            | otherwise      = e
+
+updateGrid :: Env -> [Wall] -> Env
+updateGrid env walls = env'
+    where env' = env { walls = walls, neighborGrid = neighborGrid, grids = grids }
+          neighborGrid = A.array gridIx $ map (id &&& neighbors env') $ A.range gridIx
+          grids = map (floodFill env') [0..(playerCount env)-1]
+          gridIx = ((0,0), ((boardWidth env)-1,(boardHeight env)-1))
+
+neighbors :: Env -> Point -> [Point]
+neighbors Env{..} (myX, myY) = do
+    (nx, ny) <- [ (myX-1, myY), (myX+1, myY), (myX, myY-1), (myX, myY+1) ]
+    guard $ (nx >= 0) && (ny >= 0) && (nx < boardWidth) && (ny < boardHeight)
+    let wallBetween (Wall (wx, wy) hv) =
+            (hv == H && (nx == wx || nx == wx+1) &&
+                ((ny == wy-1 && myY == wy) || (myY == wy-1 && ny == wy))) ||
+            (hv == V && (ny == wy || ny == wy+1) &&
+                ((nx == wx-1 && myX == wx) || (myX == wx-1 && nx == wx)))
+    guard $ not $ any wallBetween walls
+    return (nx, ny)
+
+adjacentWalls :: Env -> Point -> [Wall]
+adjacentWalls env@Env{..} (x, y) = do
+    (x', y') <- neighborGrid ! (x, y)
+    if y' == y then do
+        top <- [ y - 1, y ]
+        guard $ top >= 0 && top < boardHeight - 1
+        return $ Wall (max x x', top) V
+    else do
+        left <- [ x - 1, x ]
+        guard $ left >= 0 && left < boardWidth - 1
+        return $ Wall (left, max y y') H
+
+doWallsCross :: Wall -> Wall -> Bool
+doWallsCross (Wall (x1, y1) d1) (Wall (x2, y2) d2) =
+    case (d1, d2) of
+        (H, H) -> (y1 == y2) && (x1 == x2 || x1 == x2 + 1 || x2 == x1 + 1)
+        (V, V) -> (x1 == x2) && (y1 == y2 || y1 == y2 + 1 || y2 == y1 + 1)
+        (V, H) -> (x1 == x2 + 1) && (y2 == y1 + 1)
+        (H, V) -> (x2 == x1 + 1) && (y1 == y2 + 1)
+
+cmpCost :: Maybe Double -> Maybe Double -> Ordering
+Nothing `cmpCost` Nothing = EQ
+Nothing `cmpCost` _       = GT
+_       `cmpCost` Nothing = LT
+Just x  `cmpCost` Just y  = x `compare` y
+
+dirFromPoints :: Point -> Point -> Dir
+dirFromPoints from@(x0,y0) to@(x1,y1)
+    | x1 < x0 = LEFT
+    | x1 > x0 = RIGHT
+    | y1 < y0 = UP
+    | True    = DOWN
+
+intP :: Stream s m Char => ParsecT s u m Int
+intP = spaces *> (read <$> ((++) <$> (string "-" <|> pure "") <*> some digit))
+
+tok s   = spaces *> string s
+pointP  = (,) <$> intP <*> intP
+orientP = (H <$ try (tok "H")) <|> (V <$ tok "V")
+
+wallP   = Wall <$> ((,) <$> intP <*> intP) <*> orientP
+playerP = \plID -> Player plID <$> pointP <*> intP
+
+parseE :: Stream s Identity t => Parsec s () a -> SourceName -> s -> a
+parseE p src s = either (error . show) id $ parse p src s
+
+modifyAt :: Int -> (a -> a) -> [a] -> [a]
+modifyAt ix f xs = let (as, b:cs) = splitAt ix xs in as ++ [f b] ++ cs
+
+removeAt :: Int -> [a] -> (a, [a])
+removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)
+
+instance Show Move where
+    show (Move dir)              = show dir
+    show (Place (Wall (x, y) o)) = unwords [ show x, show y, show o ]
+
+showGrid :: A.Array Point (Maybe Double) -> String
+showGrid grid = unlines . map (unwords . map (maybe "X" (show . truncate))) $
+                flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
+    where ((x0,y0),(xN,yN)) = A.bounds grid

Contests/TheGreatEscape/TheGreatEscape-3.hs

@@ -0,0 +1,238 @@
+{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
+{-# OPTIONS_GHC -O2 #-}
+
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.State
+import Data.Array.IArray ((!), (//))
+import Data.Either
+import Data.Function
+import Data.Functor.Identity
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Debug.Trace
+import System.IO
+import Text.Parsec hiding (many, (<|>))
+
+import qualified Data.Array.IArray  as A
+import qualified Data.Array.Unboxed as A
+import qualified Data.Array.MArray  as MA
+import qualified Data.Array.ST      as STA
+
+type Point  = (Int, Int)
+
+data Orient = H | V deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Dir    = LEFT | RIGHT | UP | DOWN deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Player = Player { plID :: Int, plPt :: Point, plWalls :: Int } deriving (Eq, Show)
+data Wall   = Wall { wallPt :: Point, wallOrient :: Orient } deriving (Eq, Show)
+data Move   = Move Dir | Place Wall deriving (Eq)
+
+data Env = Env { width        :: Int
+               , height       :: Int
+               , playerCount  :: Int
+               , myID         :: Int
+               , players      :: [Player]
+               , walls        :: [Wall]
+               , neighborGrid :: A.Array Point [Point]
+               , grids        :: [A.UArray Point Double]
+               } deriving (Show)
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+
+    (width, height, playerCount, myID) <-
+        parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine
+
+    forever $ do
+        players <- forM [0..playerCount-1] $ \i -> parseE (playerP i) "player" <$> getLine
+        wallCount <- parseE intP "wallCount" <$> getLine -- number of walls on the board
+        walls <- replicateM wallCount $ parseE wallP "wall" <$> getLine
+        let Just env = updateGrid Env { neighborGrid = undefined, grids = [], .. } walls
+
+        -- action: LEFT, RIGHT, UP, DOWN or "putX putY putOrientation" to place a wall
+        let depth = 5 - length (filter ((>= 0) . plWalls) players)
+        print $ fst $ bestMove env myID depth
+
+bestMove :: Env -> Int -> Int -> (Move, Env)
+bestMove e i d = snd $ maximumBy (compare `on` fst) $ lookAhead <$> take (max 1 d) topMoves
+    where
+        topMoves = sortBy (flip (compare `on` fst)) $ simulateMoves $
+                   findDirMoves e i ++ findWallMoves e i
+        simulateMoves =
+            mapMaybe (\mv -> (\e' -> (scoreEnv i e', (mv, e'))) <$> simulate e i mv)
+        lookAhead (sc,(mv,e)) = (,(mv,e)) $ if d <= 1 then sc else
+            flip loopEither (i, e, d - 1, sc) $ \(i', e', d', sc') -> do
+                let active = filter ((>= 0) . plWalls) . rotateL (i' + 1) $ players e'
+                if length active < 2 then Left ((3 * sc' + scoreEnv i e') / 4)
+                else let i''  = plID $ head active
+                         e''  = snd $ bestMove e' i'' (d' - 2)
+                         sc'' = (3 * sc' + scoreEnv i e'') / 4
+                     in if i'' /= i    then Right (i'', e'', d', sc')
+                        else if d' > 1 then Right (i'', e'', d' - 1, sc'')
+                        else                Left sc''
+
+scoreEnv :: Int -> Env -> Double
+scoreEnv pid env@Env{..} = myScore - sum (map oppScore opponents)
+    where
+        (me, opponents) = removeAt pid players
+        plCost pl   = (grids !! plID pl) ! (plPt pl)
+        oppScore pl = if plWalls pl < 0 then 1500 else 64 / (plCost pl - 0.5)
+        myScore     = if plWalls me < 0 then 1000 else bonus - 20 * (plCost me)
+        bonus       = 48 * (max 0 (fromIntegral (plWalls me)) / maxWalls)**3
+        maxWalls    = if playerCount == 3 then 6 else 10
+
+findDirMoves, findWallMoves :: Env -> Int -> [Move]
+findDirMoves env@Env{..} plID = do
+    let myPt = plPt (players !! plID)
+    newPt <- neighborGrid ! myPt
+    return $ Move $ dirFromPoints myPt newPt
+findWallMoves env@Env{..} plID = do
+    guard $ plWalls (players !! plID) > 0
+    wall <- nub $ do
+        pt   <- nub $ map plPt $ filter ((>=0) . plWalls) players
+        pt'  <- pt  : (neighborGrid!pt)
+        --pt'' <- pt' : (neighborGrid!pt')
+        adjacentWalls env pt'
+    guard $ not $ any (doWallsCross wall) walls
+    return $ Place wall
+
+floodFill :: Env -> Int -> A.UArray Point Double
+floodFill env@Env{..} plID = STA.runSTUArray $ do
+    grid <- STA.newArray ((0,0),(width-1,height-1)) infinity
+    let goalEdge = case plID of
+            0 -> [ (width-1,y)  | y <- [0..height-1] ] -- right
+            1 -> [ (0,y)        | y <- [0..height-1] ] -- left
+            2 -> [ (x,height-1) | x <- [0..width-1]  ] -- bottom
+            3 -> [ (x,0)        | x <- [0..width-1]  ] -- top
+    forM_ goalEdge $ flip (MA.writeArray grid) 0
+    flip evalStateT (map (,0) goalEdge) $ untilM (null <$> get) $ do
+        pts <- get
+        put []
+        forM_ pts $ \(pt, new) -> do
+            let new' = new + 1
+            forM_ (neighborGrid!pt) $ \pt' -> do
+                old <- lift $ MA.readArray grid pt'
+                when (new' < old) $ do
+                    lift $ MA.writeArray grid pt' new'
+                    modify ((pt', new'):)
+    return grid
+
+simulate :: Env -> Int -> Move -> Maybe Env
+simulate env plID move =
+    case move of
+        Place wall -> updateGrid (modPlayer env decPlWalls) (wall : walls env)
+        Move  dir  -> Just . checkEsc . modPlayer env $ \p@(Player { plPt = (x,y) }) ->
+            case dir of
+                LEFT  -> p { plPt = (x-1,y) }
+                RIGHT -> p { plPt = (x+1,y) }
+                UP    -> p { plPt = (x,y-1) }
+                DOWN  -> p { plPt = (x,y+1) }
+    where modPlayer e f = e { players = modifyAt plID f (players e) }
+          decPlWalls p = p { plWalls = plWalls p - 1 }
+          checkEsc e
+            | escaped plID e = modPlayer e (\p -> p { plPt = (-1,-1), plWalls = -1 })
+            | otherwise      = e
+
+updateGrid :: Env -> [Wall] -> Maybe Env
+updateGrid env walls = guard (and (zipWith (\g p -> (plWalls p < 0) || not (isInfinite (g ! plPt p))) grids (players env))) *> pure env'
+    where env' = env { walls = walls, neighborGrid = neighborGrid, grids = grids }
+          neighborGrid = A.array gridIx $ map (id &&& neighbors env') $ A.range gridIx
+          grids = map (floodFill env') [0..(playerCount env)-1]
+          gridIx = ((0,0), ((width env)-1,(height env)-1))
+
+neighbors :: Env -> Point -> [Point]
+neighbors Env{..} (myX, myY) = do
+    (nx, ny) <- [ (myX-1, myY), (myX+1, myY), (myX, myY-1), (myX, myY+1) ]
+    guard $ (nx >= 0) && (ny >= 0) && (nx < width) && (ny < height)
+    let wallBetween (Wall (wx, wy) hv) =
+            (hv == H && (nx == wx || nx == wx+1) &&
+                ((ny == wy-1 && myY == wy) || (myY == wy-1 && ny == wy))) ||
+            (hv == V && (ny == wy || ny == wy+1) &&
+                ((nx == wx-1 && myX == wx) || (myX == wx-1 && nx == wx)))
+    guard $ not $ any wallBetween walls
+    return (nx, ny)
+
+adjacentWalls :: Env -> Point -> [Wall]
+adjacentWalls env@Env{..} (x, y) = do
+    (x', y') <- neighborGrid ! (x, y)
+    if y' == y then do
+        top <- [ y - 1, y ]
+        guard $ top >= 0 && top < height - 1
+        return $ Wall (max x x', top) V
+    else do
+        left <- [ x - 1, x ]
+        guard $ left >= 0 && left < width - 1
+        return $ Wall (left, max y y') H
+
+doWallsCross :: Wall -> Wall -> Bool
+doWallsCross (Wall (x1, y1) d1) (Wall (x2, y2) d2) =
+    case (d1, d2) of
+        (H, H) -> (y1 == y2) && (x1 == x2 || x1 == x2 + 1 || x2 == x1 + 1)
+        (V, V) -> (x1 == x2) && (y1 == y2 || y1 == y2 + 1 || y2 == y1 + 1)
+        (V, H) -> (x1 == x2 + 1) && (y2 == y1 + 1)
+        (H, V) -> (x2 == x1 + 1) && (y1 == y2 + 1)
+
+escaped :: Int -> Env -> Bool
+escaped pid Env{..} = plWalls (players !! pid) < 0 || case pid of
+        0 -> x == width - 1
+        1 -> x == 0
+        2 -> y == height - 1
+        3 -> y == 0
+    where (x, y) = plPt (players !! pid)
+
+dirFromPoints :: Point -> Point -> Dir
+dirFromPoints from@(x0,y0) to@(x1,y1)
+    | x1 < x0 = LEFT
+    | x1 > x0 = RIGHT
+    | y1 < y0 = UP
+    | True    = DOWN
+
+intP :: Stream s m Char => ParsecT s u m Int
+intP = spaces *> (read <$> ((++) <$> (string "-" <|> pure "") <*> some digit))
+
+tok s   = spaces *> string s
+pointP  = (,) <$> intP <*> intP
+orientP = (H <$ try (tok "H")) <|> (V <$ tok "V")
+
+wallP   = Wall <$> ((,) <$> intP <*> intP) <*> orientP
+playerP = \plID -> Player plID <$> pointP <*> intP
+
+parseE :: Stream s Identity t => Parsec s () a -> SourceName -> s -> a
+parseE p src s = either (error . show) id $ parse p src s
+
+modifyAt :: Int -> (a -> a) -> [a] -> [a]
+modifyAt ix f xs = let (as, b:cs) = splitAt ix xs in as ++ [f b] ++ cs
+
+removeAt :: Int -> [a] -> (a, [a])
+removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)
+
+rotateL :: Int -> [a] -> [a]
+rotateL _ [] = []
+rotateL n xs = let (as, bs) = splitAt (n `mod` length xs) xs in bs ++ as
+
+untilM :: Monad m => m Bool -> m a -> m ()
+untilM mc m = do { c <- mc; if c then return () else m >> untilM mc m }
+
+loopEither :: (a -> Either b a) -> a -> b
+loopEither f a = case f a of
+    Left  b  -> b
+    Right a' -> loopEither f a'
+
+infinity :: Double
+infinity = read "Infinity"
+
+instance Show Move where
+    show (Move dir)              = show dir
+    show (Place (Wall (x, y) o)) = unwords [ show x, show y, show o ]
+
+showGrid :: A.UArray Point Double -> String
+showGrid grid = unlines . map (unwords . map (\x -> if isInfinite x then "X" else show (truncate x))) $
+                flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
+    where ((x0,y0),(xN,yN)) = A.bounds grid
+
+traceShowGridId g = trace (showGrid g) g

Contests/TheGreatEscape/TheGreatEscape-WIP-2.hs

@@ -0,0 +1,235 @@
+{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
+{-# OPTIONS_GHC -O2 #-}
+
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.State
+import Data.Array.IArray ((!), (//))
+import Data.Either
+import Data.Function
+import Data.Functor.Identity
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Debug.Trace
+import System.IO
+import Text.Parsec hiding (many, (<|>))
+
+import qualified Data.Array.IArray as A
+import qualified Data.Array.MArray as MA
+import qualified Data.Array.ST     as STA
+
+type Point  = (Int, Int)
+
+data Orient = H | V deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Dir    = LEFT | RIGHT | UP | DOWN deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Player = Player { plID :: Int, plPt :: Point, plWalls :: Int } deriving (Eq, Show)
+data Wall   = Wall { wallPt :: Point, wallOrient :: Orient } deriving (Eq, Show)
+data Move   = Move Dir | Place Wall deriving (Eq)
+
+data Env = Env { boardWidth   :: Int
+               , boardHeight  :: Int
+               , playerCount  :: Int
+               , myID         :: Int
+               , players      :: [Player]
+               , walls        :: [Wall]
+               , neighborGrid :: A.Array Point [Point]
+               , grids        :: [A.Array Point Double]
+               } deriving (Show)
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+
+    (boardWidth, boardHeight, playerCount, myID) <-
+        parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine
+
+    forever $ do
+        players <- forM [0..playerCount-1] $ \i -> parseE (playerP i) "player" <$> getLine
+        wallCount <- parseE intP "wallCount" <$> getLine -- number of walls on the board
+        walls <- replicateM wallCount $ parseE wallP "wall" <$> getLine
+        let env = updateGrid Env { neighborGrid = undefined, grids = [], .. } walls
+
+        -- action: LEFT, RIGHT, UP, DOWN or "putX putY putOrientation" to place a wall
+        let depth = 5 - length (filter ((>= 0) . plWalls) players)
+        print $ fst $ bestMove env myID depth
+
+bestMove :: Env -> Int -> Int -> (Move, Env)
+bestMove e i d = snd $ maximumBy (compare `on` fst) $ do
+    (sc,(mv,e')) <- take (max 1 d) $ sortBy (flip (compare `on` fst)) $
+        mapMaybe (\mv -> let e'' = simulate e i mv in (,(mv,e'')) <$> scoreEnv i e'') $
+        findDirMoves e i ++ findWallMoves e i
+    return $ if d < 2 then (sc,(mv,e')) else flip loopEither (i, e') $ \(i', e'') -> do
+        let active = filter ((>= 0) . plWalls) . rotateL (i' + 1) $ players e''
+        if length active < 2 then
+            let Just sc' = scoreEnv i e'' in Left ((4 * sc + sc') / 5, (mv, e'))
+        else
+            let i'' = plID $ head active
+                e''' = snd $ bestMove e'' i'' (d - 1)
+            in if i'' /= i then Right (i'', e''') else
+                let Just sc' = scoreEnv i e'''
+                in Left ((4 * sc + sc') / 5, (mv, e'))
+
+scoreEnv :: Int -> Env -> Maybe Double
+scoreEnv pid env@Env{..} = (myScore -) <$> (sum <$> sequence (map oppScore opponents))
+    where
+        (me, opponents) = removeAt pid players
+        plCost pl   = if plWalls pl < 0 then 0 else (grids !! plID pl) ! (plPt pl)
+        oppScore pl = let cost = plCost pl
+                      in guard (not $ isInfinite cost) *> pure (64 / (max 0.25 cost))
+        myScore     = let cost = plCost me in if plWalls me < 0 then 1000 else bonus - 20 * cost
+        bonus       = 48 * (max 0 (fromIntegral (plWalls me)) / maxWalls)**2
+        maxWalls    = if playerCount == 3 then 6 else 10
+
+findDirMoves, findWallMoves :: Env -> Int -> [Move]
+findDirMoves env@Env{..} plID =
+    let myPt = plPt (players !! plID) in do
+        newPt <- neighbors env myPt
+        return $ Move $ dirFromPoints myPt newPt
+findWallMoves env@Env{..} plID =
+    if plWalls (players !! plID) == 0 then [] else do
+        --wall <- if plID /= myID then adjacentWalls env (plPt $ players !! myID) else nub $ do
+        wall <- nub $ do
+            pt  <- nub $ map plPt $ filter ((>=0) . plWalls) players
+            --pt' <- pt  : (neighborGrid!pt)
+            --pt'' <- pt' : (neighborGrid!pt')
+            adjacentWalls env pt
+        guard $ not $ any (doWallsCross wall) walls
+        return $ Place wall
+
+floodFill :: Env -> Int -> A.Array Point Double
+floodFill env@Env{..} plID = STA.runSTArray $ do
+    grid <- STA.newArray ((0,0),(boardWidth-1,boardHeight-1)) infinity
+    let goalEdge = case plID of
+            0 -> [ (boardWidth-1,y)  | y <- [0..boardHeight-1] ] -- right
+            1 -> [ (0,y)             | y <- [0..boardHeight-1] ] -- left
+            2 -> [ (x,boardHeight-1) | x <- [0..boardWidth-1]  ] -- bottom
+            3 -> [ (x,0)             | x <- [0..boardWidth-1]  ] -- top
+    forM_ goalEdge $ flip (MA.writeArray grid) $ 0
+    flip evalStateT (map (,0) goalEdge) $ untilM (null <$> get) $ do
+        pts <- get
+        put []
+        forM_ pts $ \(pt, new) -> do
+            let new' = new + 1
+            forM_ (neighborGrid!pt) $ \pt' -> do
+                old <- lift $ MA.readArray grid pt'
+                when (new' < old) $ do
+                    lift $ MA.writeArray grid pt' new'
+                    modify ((pt', new'):)
+    return grid
+
+simulate :: Env -> Int -> Move -> Env
+simulate env plID move =
+    case move of
+        Place wall -> updateGrid (modPlayer env decPlWalls) (wall : walls env)
+        Move  dir  -> checkEsc $ modPlayer env $ \p@(Player { plPt = (x,y) }) ->
+            case dir of
+                LEFT  -> p { plPt = (x-1,y) }
+                RIGHT -> p { plPt = (x+1,y) }
+                UP    -> p { plPt = (x,y-1) }
+                DOWN  -> p { plPt = (x,y+1) }
+    where modPlayer e f = e { players = modifyAt plID f (players e) }
+          decPlWalls p = p { plWalls = plWalls p - 1 }
+          checkEsc e
+            | escaped plID e = modPlayer e (\p -> p { plPt = (-1,-1), plWalls = -1 })
+            | otherwise      = e
+
+updateGrid :: Env -> [Wall] -> Env
+updateGrid env walls = env'
+    where env' = env { walls = walls, neighborGrid = neighborGrid, grids = grids }
+          neighborGrid = A.array gridIx $ map (id &&& neighbors env') $ A.range gridIx
+          grids = map (floodFill env') [0..(playerCount env)-1]
+          gridIx = ((0,0), ((boardWidth env)-1,(boardHeight env)-1))
+
+neighbors :: Env -> Point -> [Point]
+neighbors Env{..} (myX, myY) = do
+    (nx, ny) <- [ (myX-1, myY), (myX+1, myY), (myX, myY-1), (myX, myY+1) ]
+    guard $ (nx >= 0) && (ny >= 0) && (nx < boardWidth) && (ny < boardHeight)
+    let wallBetween (Wall (wx, wy) hv) =
+            (hv == H && (nx == wx || nx == wx+1) &&
+                ((ny == wy-1 && myY == wy) || (myY == wy-1 && ny == wy))) ||
+            (hv == V && (ny == wy || ny == wy+1) &&
+                ((nx == wx-1 && myX == wx) || (myX == wx-1 && nx == wx)))
+    guard $ not $ any wallBetween walls
+    return (nx, ny)
+
+adjacentWalls :: Env -> Point -> [Wall]
+adjacentWalls env@Env{..} (x, y) = do
+    (x', y') <- neighborGrid ! (x, y)
+    if y' == y then do
+        top <- [ y - 1, y ]
+        guard $ top >= 0 && top < boardHeight - 1
+        return $ Wall (max x x', top) V
+    else do
+        left <- [ x - 1, x ]
+        guard $ left >= 0 && left < boardWidth - 1
+        return $ Wall (left, max y y') H
+
+doWallsCross :: Wall -> Wall -> Bool
+doWallsCross (Wall (x1, y1) d1) (Wall (x2, y2) d2) =
+    case (d1, d2) of
+        (H, H) -> (y1 == y2) && (x1 == x2 || x1 == x2 + 1 || x2 == x1 + 1)
+        (V, V) -> (x1 == x2) && (y1 == y2 || y1 == y2 + 1 || y2 == y1 + 1)
+        (V, H) -> (x1 == x2 + 1) && (y2 == y1 + 1)
+        (H, V) -> (x2 == x1 + 1) && (y1 == y2 + 1)
+
+escaped :: Int -> Env -> Bool
+escaped pid Env{..} = plWalls (players !! pid) < 0 || case pid of
+        0 -> x == boardWidth - 1
+        1 -> x == 0
+        2 -> y == boardHeight - 1
+        3 -> y == 0
+    where (x, y) = plPt (players !! pid)
+
+dirFromPoints :: Point -> Point -> Dir
+dirFromPoints from@(x0,y0) to@(x1,y1)
+    | x1 < x0 = LEFT
+    | x1 > x0 = RIGHT
+    | y1 < y0 = UP
+    | True    = DOWN
+
+intP :: Stream s m Char => ParsecT s u m Int
+intP = spaces *> (read <$> ((++) <$> (string "-" <|> pure "") <*> some digit))
+
+tok s   = spaces *> string s
+pointP  = (,) <$> intP <*> intP
+orientP = (H <$ try (tok "H")) <|> (V <$ tok "V")
+
+wallP   = Wall <$> ((,) <$> intP <*> intP) <*> orientP
+playerP = \plID -> Player plID <$> pointP <*> intP
+
+parseE :: Stream s Identity t => Parsec s () a -> SourceName -> s -> a
+parseE p src s = either (error . show) id $ parse p src s
+
+modifyAt :: Int -> (a -> a) -> [a] -> [a]
+modifyAt ix f xs = let (as, b:cs) = splitAt ix xs in as ++ [f b] ++ cs
+
+removeAt :: Int -> [a] -> (a, [a])
+removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)
+
+rotateL :: Int -> [a] -> [a]
+rotateL _ [] = []
+rotateL n xs = let (as, bs) = splitAt (n `mod` length xs) xs in bs ++ as
+
+untilM :: Monad m => m Bool -> m a -> m ()
+untilM mc m = do { c <- mc; if c then return () else m >> untilM mc m }
+
+loopEither :: (a -> Either b a) -> a -> b
+loopEither f a = case f a of
+    Left  b  -> b
+    Right a' -> loopEither f a'
+
+infinity :: Double
+infinity = read "Infinity"
+
+instance Show Move where
+    show (Move dir)              = show dir
+    show (Place (Wall (x, y) o)) = unwords [ show x, show y, show o ]
+
+showGrid :: A.Array Point Double -> String
+showGrid grid = unlines . map (unwords . map (\x -> if isInfinite x then "X" else show (truncate x))) $
+                flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
+    where ((x0,y0),(xN,yN)) = A.bounds grid

Contests/TheGreatEscape/TheGreatEscape-WIP-3.hs

@@ -0,0 +1,239 @@
+{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
+{-# OPTIONS_GHC -O2 #-}
+
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.State
+import Data.Array.IArray ((!), (//))
+import Data.Either
+import Data.Function
+import Data.Functor.Identity
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Debug.Trace
+import System.IO
+import Text.Parsec hiding (many, (<|>))
+
+import qualified Data.Array.IArray  as A
+import qualified Data.Array.Unboxed as A
+import qualified Data.Array.MArray  as MA
+import qualified Data.Array.ST      as STA
+
+type Point  = (Int, Int)
+
+data Orient = H | V deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Dir    = LEFT | RIGHT | UP | DOWN deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Player = Player { plID :: Int, plPt :: Point, plWalls :: Int } deriving (Eq, Show)
+data Wall   = Wall { wallPt :: Point, wallOrient :: Orient } deriving (Eq, Show)
+data Move   = Move Dir | Place Wall deriving (Eq)
+
+data Env = Env { width   :: Int
+               , height  :: Int
+               , playerCount  :: Int
+               , myID         :: Int
+               , players      :: [Player]
+               , walls        :: [Wall]
+               , neighborGrid :: A.Array Point [Point]
+               , grids        :: [A.UArray Point Double]
+               } deriving (Show)
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+
+    (width, height, playerCount, myID) <-
+        parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine
+
+    forever $ do
+        players <- forM [0..playerCount-1] $ \i -> parseE (playerP i) "player" <$> getLine
+        wallCount <- parseE intP "wallCount" <$> getLine -- number of walls on the board
+        walls <- replicateM wallCount $ parseE wallP "wall" <$> getLine
+        let Just env = updateGrid Env { neighborGrid = undefined, grids = [], .. } walls
+
+        -- action: LEFT, RIGHT, UP, DOWN or "putX putY putOrientation" to place a wall
+        let depth = 5 - length (filter ((>= 0) . plWalls) players)
+        print $ fst $ bestMove env myID depth
+
+bestMove :: Env -> Int -> Int -> (Move, Env)
+bestMove e i d = snd $ maximumBy (compare `on` fst) $ do
+    (sc,(mv,e')) <- take (max 1 d) $ sortBy (flip (compare `on` fst)) $
+        map (\(mv, e') -> (scoreEnv i e', (mv, e'))) $
+        mapMaybe (\mv -> (mv,) <$> simulate e i mv) $
+        findDirMoves e i ++ findWallMoves e i
+    return $ if d < 1 then (sc,(mv,e')) else flip loopEither (i, e') $ \(i', e'') -> do
+        let active = filter ((>= 0) . plWalls) . rotateL (i' + 1) $ players e''
+        if length active < 2 then
+            let sc' = scoreEnv i e'' in Left ((2 * sc + sc') / 3, (mv, e'))
+        else
+            let i'' = plID $ head active
+                d' = if i'' == i then d - 1 else d - 2
+                e''' = snd $ bestMove e'' i'' d'
+            in if i'' /= i then Right (i'', e''') else
+                let sc' = scoreEnv i e'''
+                in Left ((2 * sc + sc') / 3, (mv, e'))
+
+scoreEnv :: Int -> Env -> Double
+scoreEnv pid env@Env{..} = myScore - sum (map oppScore opponents)
+    where
+        (me, opponents) = removeAt pid players
+        plCost pl   = (grids !! plID pl) ! (plPt pl)
+        oppScore pl = if plWalls pl < 0 then 1500 else 64 / (max 0.25 (plCost pl))
+        myScore     = if plWalls me < 0 then 1000 else bonus - 20 * (plCost me)
+        bonus       = 48 * (max 0 (fromIntegral (plWalls me)) / maxWalls)**2
+        maxWalls    = if playerCount == 3 then 6 else 10
+
+findDirMoves, findWallMoves :: Env -> Int -> [Move]
+findDirMoves env@Env{..} plID = do
+    let myPt = plPt (players !! plID)
+    guard $ A.inRange (A.bounds neighborGrid) myPt
+    newPt <- neighborGrid ! myPt
+    return $ Move $ dirFromPoints myPt newPt
+findWallMoves env@Env{..} plID = do
+    guard $ plWalls (players !! plID) > 0
+    wall <- nub $ do
+        pt   <- nub $ map plPt $ filter ((>=0) . plWalls) players
+        pt'  <- pt  : (neighborGrid!pt)
+        --pt'' <- pt' : (neighborGrid!pt')
+        adjacentWalls env pt'
+    guard $ not $ any (doWallsCross wall) walls
+    return $ Place wall
+
+floodFill :: Env -> Int -> A.UArray Point Double
+floodFill env@Env{..} plID = STA.runSTUArray $ do
+    grid <- STA.newArray ((0,0),(width-1,height-1)) infinity
+    let goalEdge = case plID of
+            0 -> [ (width-1,y)  | y <- [0..height-1] ] -- right
+            1 -> [ (0,y)        | y <- [0..height-1] ] -- left
+            2 -> [ (x,height-1) | x <- [0..width-1]  ] -- bottom
+            3 -> [ (x,0)        | x <- [0..width-1]  ] -- top
+    forM_ goalEdge $ flip (MA.writeArray grid) 0
+    flip evalStateT (map (,0) goalEdge) $ untilM (null <$> get) $ do
+        pts <- get
+        put []
+        forM_ pts $ \(pt, new) -> do
+            let new' = new + 1
+            forM_ (neighborGrid!pt) $ \pt' -> do
+                old <- lift $ MA.readArray grid pt'
+                when (new' < old) $ do
+                    lift $ MA.writeArray grid pt' new'
+                    modify ((pt', new'):)
+    return grid
+
+simulate :: Env -> Int -> Move -> Maybe Env
+simulate env plID move =
+    case move of
+        Place wall -> updateGrid (modPlayer env decPlWalls) (wall : walls env)
+        Move  dir  -> Just . checkEsc . modPlayer env $ \p@(Player { plPt = (x,y) }) ->
+            case dir of
+                LEFT  -> p { plPt = (x-1,y) }
+                RIGHT -> p { plPt = (x+1,y) }
+                UP    -> p { plPt = (x,y-1) }
+                DOWN  -> p { plPt = (x,y+1) }
+    where modPlayer e f = e { players = modifyAt plID f (players e) }
+          decPlWalls p = p { plWalls = plWalls p - 1 }
+          checkEsc e
+            | escaped plID e = modPlayer e (\p -> p { plPt = (-1,-1), plWalls = -1 })
+            | otherwise      = e
+
+updateGrid :: Env -> [Wall] -> Maybe Env
+updateGrid env walls = guard (and (zipWith (\g p -> (plWalls p < 0) || not (isInfinite (g ! plPt p))) grids (players env))) *> pure env'
+    where env' = env { walls = walls, neighborGrid = neighborGrid, grids = grids }
+          neighborGrid = A.array gridIx $ map (id &&& neighbors env') $ A.range gridIx
+          grids = map (floodFill env') [0..(playerCount env)-1]
+          gridIx = ((0,0), ((width env)-1,(height env)-1))
+
+neighbors :: Env -> Point -> [Point]
+neighbors Env{..} (myX, myY) = do
+    (nx, ny) <- [ (myX-1, myY), (myX+1, myY), (myX, myY-1), (myX, myY+1) ]
+    guard $ (nx >= 0) && (ny >= 0) && (nx < width) && (ny < height)
+    let wallBetween (Wall (wx, wy) hv) =
+            (hv == H && (nx == wx || nx == wx+1) &&
+                ((ny == wy-1 && myY == wy) || (myY == wy-1 && ny == wy))) ||
+            (hv == V && (ny == wy || ny == wy+1) &&
+                ((nx == wx-1 && myX == wx) || (myX == wx-1 && nx == wx)))
+    guard $ not $ any wallBetween walls
+    return (nx, ny)
+
+adjacentWalls :: Env -> Point -> [Wall]
+adjacentWalls env@Env{..} (x, y) = do
+    (x', y') <- neighborGrid ! (x, y)
+    if y' == y then do
+        top <- [ y - 1, y ]
+        guard $ top >= 0 && top < height - 1
+        return $ Wall (max x x', top) V
+    else do
+        left <- [ x - 1, x ]
+        guard $ left >= 0 && left < width - 1
+        return $ Wall (left, max y y') H
+
+doWallsCross :: Wall -> Wall -> Bool
+doWallsCross (Wall (x1, y1) d1) (Wall (x2, y2) d2) =
+    case (d1, d2) of
+        (H, H) -> (y1 == y2) && (x1 == x2 || x1 == x2 + 1 || x2 == x1 + 1)
+        (V, V) -> (x1 == x2) && (y1 == y2 || y1 == y2 + 1 || y2 == y1 + 1)
+        (V, H) -> (x1 == x2 + 1) && (y2 == y1 + 1)
+        (H, V) -> (x2 == x1 + 1) && (y1 == y2 + 1)
+
+escaped :: Int -> Env -> Bool
+escaped pid Env{..} = plWalls (players !! pid) < 0 || case pid of
+        0 -> x == width - 1
+        1 -> x == 0
+        2 -> y == height - 1
+        3 -> y == 0
+    where (x, y) = plPt (players !! pid)
+
+dirFromPoints :: Point -> Point -> Dir
+dirFromPoints from@(x0,y0) to@(x1,y1)
+    | x1 < x0 = LEFT
+    | x1 > x0 = RIGHT
+    | y1 < y0 = UP
+    | True    = DOWN
+
+intP :: Stream s m Char => ParsecT s u m Int
+intP = spaces *> (read <$> ((++) <$> (string "-" <|> pure "") <*> some digit))
+
+tok s   = spaces *> string s
+pointP  = (,) <$> intP <*> intP
+orientP = (H <$ try (tok "H")) <|> (V <$ tok "V")
+
+wallP   = Wall <$> ((,) <$> intP <*> intP) <*> orientP
+playerP = \plID -> Player plID <$> pointP <*> intP
+
+parseE :: Stream s Identity t => Parsec s () a -> SourceName -> s -> a
+parseE p src s = either (error . show) id $ parse p src s
+
+modifyAt :: Int -> (a -> a) -> [a] -> [a]
+modifyAt ix f xs = let (as, b:cs) = splitAt ix xs in as ++ [f b] ++ cs
+
+removeAt :: Int -> [a] -> (a, [a])
+removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)
+
+rotateL :: Int -> [a] -> [a]
+rotateL _ [] = []
+rotateL n xs = let (as, bs) = splitAt (n `mod` length xs) xs in bs ++ as
+
+untilM :: Monad m => m Bool -> m a -> m ()
+untilM mc m = do { c <- mc; if c then return () else m >> untilM mc m }
+
+loopEither :: (a -> Either b a) -> a -> b
+loopEither f a = case f a of
+    Left  b  -> b
+    Right a' -> loopEither f a'
+
+infinity :: Double
+infinity = read "Infinity"
+
+instance Show Move where
+    show (Move dir)              = show dir
+    show (Place (Wall (x, y) o)) = unwords [ show x, show y, show o ]
+
+showGrid :: A.UArray Point Double -> String
+showGrid grid = unlines . map (unwords . map (\x -> if isInfinite x then "X" else show (truncate x))) $
+                flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
+    where ((x0,y0),(xN,yN)) = A.bounds grid
+
+traceShowGridId g = trace (showGrid g) g

Contests/TheGreatEscape/TheGreatEscape-WIP.hs

@@ -0,0 +1,238 @@
+{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
+{-# OPTIONS_GHC -O2 #-}
+
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.State
+import Data.Array.IArray ((!), (//))
+import Data.Either
+import Data.Function
+import Data.Functor.Identity
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Debug.Trace
+import System.IO
+import Text.Parsec hiding (many, (<|>))
+
+import qualified Data.Array.IArray as A
+import qualified Data.Array.MArray as MA
+import qualified Data.Array.ST     as STA
+
+type Point  = (Int, Int)
+
+data Orient = H | V deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Dir    = LEFT | RIGHT | UP | DOWN deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Player = Player { plID :: Int, plPt :: Point, plWalls :: Int } deriving (Eq, Show)
+data Wall   = Wall { wallPt :: Point, wallOrient :: Orient } deriving (Eq, Show)
+data Move   = Move Dir | Place Wall deriving (Eq)
+
+data Env = Env { boardWidth   :: Int
+               , boardHeight  :: Int
+               , playerCount  :: Int
+               , myID         :: Int
+               , players      :: [Player]
+               , walls        :: [Wall]
+               , neighborGrid :: A.Array Point [Point]
+               , grids        :: [A.Array Point Double]
+               } deriving (Show)
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+
+    (boardWidth, boardHeight, playerCount, myID) <-
+        parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine
+
+    forever $ do
+        players <- forM [0..playerCount-1] $ \i -> parseE (playerP i) "player" <$> getLine
+        wallCount <- parseE intP "wallCount" <$> getLine -- number of walls on the board
+        walls <- replicateM wallCount $ parseE wallP "wall" <$> getLine
+        let env = updateGrid Env { neighborGrid = undefined, grids = [], .. } walls
+
+        -- action: LEFT, RIGHT, UP, DOWN or "putX putY putOrientation" to place a wall
+        let depth = 5 - length (filter ((>= 0) . plWalls) players)
+        print $ fst $ bestMove env myID depth
+
+bestMove :: Env -> Int -> Int -> (Move, Env)
+bestMove e i d = snd $ maximumBy (compare `on` fst) $ do
+    (sc,(mv,e')) <- take (max 1 d) $ sortBy (flip (compare `on` fst)) $
+        mapMaybe (\mv -> let e'' = simulate e i mv in (,(mv,e'')) <$> scoreEnv i e'') $
+        findDirMoves e i ++ findWallMoves e i
+    if d < 2
+    then return (sc,(mv,e'))
+    else flip iterateM (i, e') $ \(i', e'') -> do
+        let active = filter ((>= 0) . plWalls) . rotateL (i' + 1) $ players e''
+        if length active < 2 then do
+            let Just sc' = scoreEnv i e''
+            return $ Left ((4 * sc + sc') / 5, (mv, e'))
+        else do
+            let i'' = plID $ head active
+            let e''' = snd $ bestMove e'' i'' (d - 1)
+            if i'' /= i then return (Right (i'', e''')) else do
+                let Just sc' = scoreEnv i e'''
+                return $ Left ((4 * sc + sc') / 5, (mv, e'))
+
+scoreEnv :: Int -> Env -> Maybe Double
+scoreEnv pid env@Env{..} = (myScore -) <$> (sum <$> sequence (map oppScore opponents))
+    where
+        (me, opponents) = removeAt pid players
+        plCost pl   = if plWalls pl < 0 then 0 else (grids !! plID pl) ! (plPt pl)
+        oppScore pl = let cost = plCost pl
+                      in if isInfinite cost then Nothing else Just (64 / (max 0.25 cost))
+        myScore     = let cost = plCost me in bonus - 20 * cost
+        bonus       = 48 * (max 0 (fromIntegral (plWalls me)) / maxWalls)**2
+        maxWalls    = if playerCount == 3 then 6 else 10
+
+findDirMoves, findWallMoves :: Env -> Int -> [Move]
+findDirMoves env@Env{..} plID =
+    let myPt = plPt (players !! plID) in do
+        newPt <- neighbors env myPt
+        return $ Move $ dirFromPoints myPt newPt
+findWallMoves env@Env{..} plID =
+    if plWalls (players !! plID) == 0 then [] else do
+        --wall <- if plID /= myID then adjacentWalls env (plPt $ players !! myID) else nub $ do
+        wall <- nub $ do
+            pt  <- nub $ map plPt $ filter ((>=0) . plWalls) players
+            --pt' <- pt  : (neighborGrid!pt)
+            --pt'' <- pt' : (neighborGrid!pt')
+            adjacentWalls env pt
+        guard $ not $ any (doWallsCross wall) walls
+        return $ Place wall
+
+floodFill :: Env -> Int -> A.Array Point Double
+floodFill env@Env{..} plID = STA.runSTArray $ do
+    grid <- STA.newArray ((0,0),(boardWidth-1,boardHeight-1)) infinity
+    let goalEdge = case plID of
+            0 -> [ (boardWidth-1,y)  | y <- [0..boardHeight-1] ] -- right
+            1 -> [ (0,y)             | y <- [0..boardHeight-1] ] -- left
+            2 -> [ (x,boardHeight-1) | x <- [0..boardWidth-1]  ] -- bottom
+            3 -> [ (x,0)             | x <- [0..boardWidth-1]  ] -- top
+    forM_ goalEdge $ flip (MA.writeArray grid) $ 0
+    flip evalStateT (map (,0) goalEdge) $ untilM (null <$> get) $ do
+        pts <- get
+        put []
+        forM_ pts $ \(pt, new) -> do
+            let new' = new + 1
+            forM_ (neighborGrid!pt) $ \pt' -> do
+                old <- lift $ MA.readArray grid pt'
+                when (new' < old) $ do
+                    lift $ MA.writeArray grid pt' new'
+                    modify ((pt', new'):)
+    return grid
+
+simulate :: Env -> Int -> Move -> Env
+simulate env plID move =
+    case move of
+        Place wall -> updateGrid (modPlayer env decPlWalls) (wall : walls env)
+        Move  dir  -> checkEsc $ modPlayer env $ \p@(Player { plPt = (x,y) }) ->
+            case dir of
+                LEFT  -> p { plPt = (x-1,y) }
+                RIGHT -> p { plPt = (x+1,y) }
+                UP    -> p { plPt = (x,y-1) }
+                DOWN  -> p { plPt = (x,y+1) }
+    where modPlayer e f = e { players = modifyAt plID f (players e) }
+          decPlWalls p = p { plWalls = plWalls p - 1 }
+          checkEsc e
+            | escaped plID e = modPlayer e (\p -> p { plPt = (-1,-1), plWalls = -1 })
+            | otherwise      = e
+
+updateGrid :: Env -> [Wall] -> Env
+updateGrid env walls = env'
+    where env' = env { walls = walls, neighborGrid = neighborGrid, grids = grids }
+          neighborGrid = A.array gridIx $ map (id &&& neighbors env') $ A.range gridIx
+          grids = map (floodFill env') [0..(playerCount env)-1]
+          gridIx = ((0,0), ((boardWidth env)-1,(boardHeight env)-1))
+
+neighbors :: Env -> Point -> [Point]
+neighbors Env{..} (myX, myY) = do
+    (nx, ny) <- [ (myX-1, myY), (myX+1, myY), (myX, myY-1), (myX, myY+1) ]
+    guard $ (nx >= 0) && (ny >= 0) && (nx < boardWidth) && (ny < boardHeight)
+    let wallBetween (Wall (wx, wy) hv) =
+            (hv == H && (nx == wx || nx == wx+1) &&
+                ((ny == wy-1 && myY == wy) || (myY == wy-1 && ny == wy))) ||
+            (hv == V && (ny == wy || ny == wy+1) &&
+                ((nx == wx-1 && myX == wx) || (myX == wx-1 && nx == wx)))
+    guard $ not $ any wallBetween walls
+    return (nx, ny)
+
+adjacentWalls :: Env -> Point -> [Wall]
+adjacentWalls env@Env{..} (x, y) = do
+    (x', y') <- neighborGrid ! (x, y)
+    if y' == y then do
+        top <- [ y - 1, y ]
+        guard $ top >= 0 && top < boardHeight - 1
+        return $ Wall (max x x', top) V
+    else do
+        left <- [ x - 1, x ]
+        guard $ left >= 0 && left < boardWidth - 1
+        return $ Wall (left, max y y') H
+
+doWallsCross :: Wall -> Wall -> Bool
+doWallsCross (Wall (x1, y1) d1) (Wall (x2, y2) d2) =
+    case (d1, d2) of
+        (H, H) -> (y1 == y2) && (x1 == x2 || x1 == x2 + 1 || x2 == x1 + 1)
+        (V, V) -> (x1 == x2) && (y1 == y2 || y1 == y2 + 1 || y2 == y1 + 1)
+        (V, H) -> (x1 == x2 + 1) && (y2 == y1 + 1)
+        (H, V) -> (x2 == x1 + 1) && (y1 == y2 + 1)
+
+escaped :: Int -> Env -> Bool
+escaped pid Env{..} = plWalls (players !! pid) < 0 || case pid of
+        0 -> x == boardWidth - 1
+        1 -> x == 0
+        2 -> y == boardHeight - 1
+        3 -> y == 0
+    where (x, y) = plPt (players !! pid)
+
+dirFromPoints :: Point -> Point -> Dir
+dirFromPoints from@(x0,y0) to@(x1,y1)
+    | x1 < x0 = LEFT
+    | x1 > x0 = RIGHT
+    | y1 < y0 = UP
+    | True    = DOWN
+
+intP :: Stream s m Char => ParsecT s u m Int
+intP = spaces *> (read <$> ((++) <$> (string "-" <|> pure "") <*> some digit))
+
+tok s   = spaces *> string s
+pointP  = (,) <$> intP <*> intP
+orientP = (H <$ try (tok "H")) <|> (V <$ tok "V")
+
+wallP   = Wall <$> ((,) <$> intP <*> intP) <*> orientP
+playerP = \plID -> Player plID <$> pointP <*> intP
+
+parseE :: Stream s Identity t => Parsec s () a -> SourceName -> s -> a
+parseE p src s = either (error . show) id $ parse p src s
+
+modifyAt :: Int -> (a -> a) -> [a] -> [a]
+modifyAt ix f xs = let (as, b:cs) = splitAt ix xs in as ++ [f b] ++ cs
+
+removeAt :: Int -> [a] -> (a, [a])
+removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)
+
+rotateL :: Int -> [a] -> [a]
+rotateL _ [] = []
+rotateL n xs = let (as, bs) = splitAt (n `mod` length xs) xs in bs ++ as
+
+untilM :: Monad m => m Bool -> m a -> m ()
+untilM mc m = do { c <- mc; if c then return () else m >> untilM mc m }
+
+iterateM :: Monad m => (a -> m (Either b a)) -> a -> m b
+iterateM m a = m a >>= \r -> case r of
+    Left  b  -> return b
+    Right a' -> iterateM m a'
+
+infinity :: Double
+infinity = read "Infinity"
+
+instance Show Move where
+    show (Move dir)              = show dir
+    show (Place (Wall (x, y) o)) = unwords [ show x, show y, show o ]
+
+showGrid :: A.Array Point Double -> String
+showGrid grid = unlines . map (unwords . map (\x -> if isInfinite x then "X" else show (truncate x))) $
+                flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
+    where ((x0,y0),(xN,yN)) = A.bounds grid

Contests/TheGreatEscape/TheGreatEscape.hs

@@ -0,0 +1,171 @@
+{-# LANGUAGE FlexibleContexts, RecordWildCards, TupleSections #-}
+{-# OPTIONS_GHC -O2 #-}
+
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.DeepSeq
+import Control.Monad
+import Control.Monad.ST
+import Data.Array.IArray ((!), (//))
+import Data.Either
+import Data.Function
+import Data.Functor.Identity
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Debug.Trace
+import System.IO
+import Text.Parsec hiding (many, (<|>))
+
+import qualified Data.Array.IArray as A
+
+type Point  = (Int, Int)
+
+data Orient = H | V deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Dir    = LEFT | RIGHT | UP | DOWN deriving (Eq, Ord, Enum, Bounded, Read, Show)
+data Player = Player { plID :: Int, plPt :: Point, plWalls :: Int } deriving (Eq, Show)
+data Wall   = Wall { wallPt :: Point, wallOrient :: Orient } deriving (Eq, Show)
+
+data Env = Env { boardWidth   :: Int
+               , boardHeight  :: Int
+               , playerCount  :: Int
+               , myID         :: Int
+               , walls        :: [Wall]
+               , neighborGrid :: A.Array Point [Point]
+               , grids        :: [A.Array Point (Maybe Double)]
+               } deriving (Show)
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+
+    (boardWidth, boardHeight, playerCount, myID) <-
+        parseE ((,,,) <$> intP <*> intP <*> intP <*> intP) "environment" <$> getLine
+
+    repeatM $ do
+        players <- forM [0..playerCount-1] $ \i -> parseE (playerP i) "player" <$> getLine
+        wallCount <- parseE intP "wallCount" <$> getLine -- number of walls on the board
+        walls <- replicateM wallCount $ parseE wallP "wall" <$> getLine
+        let env = updateGrid Env { neighborGrid = undefined, grids = [], .. } walls
+
+        -- action: LEFT, RIGHT, UP, DOWN or "putX putY putOrientation" to place a wall
+        putStrLn $ showMove $ fst $ maximumBy (compare `on` snd) $ findMoves players env
+
+findMoves :: [Player] -> Env -> [(Either Dir Wall, Double)]
+findMoves players env = dirMoves ++ wallMoves
+    where
+        dirMoves = do
+            pt <- neighbors env $ plPt me
+            let players' = map (\p -> if p == me then p { plPt = pt } else p) players
+            let costs = zipWith (\grid pt -> if pt >= (0,0) then grid!pt else Just 0) (grids env) $ map plPt players'
+            let dir = dirFromPoints (plPt me) pt
+            return $ {-traceShowId-} (Left dir, 3 + score (map fromJust costs))
+        wallMoves = if plWalls me == 0 then [] else do
+            wall <- nub $ do
+                pl <- players
+                guard $ plPt pl >= (0,0)
+                pt <- (plPt pl) : (neighborGrid env ! (plPt pl))
+                adjacentWalls env $ pt
+            guard $ not $ any (doWallsCross wall) (walls env)
+            let env' = updateGrid env (wall : walls env)
+            let costs = zipWith (\grid pt -> if pt >= (0,0) then grid!pt else Just 0) (grids env') $ map plPt players
+            guard $ all isJust costs
+            return $ {-traceShowId-} (Right wall, score (map fromJust costs))
+        score costs = myScore myCost - sum (map oppScore oppCosts)
+            where (myCost, oppCosts) = removeAt (myID env) costs
+        oppScore cost = 80 / (max 2 cost - 1)
+        myScore  cost = negate $ cost^2
+        me = players !! myID env
+
+floodFill :: Env -> Int -> A.Array Point (Maybe Double)
+floodFill env@Env{..} plID = go initGrid
+    where
+        go :: A.Array Point (Maybe Double) -> A.Array Point (Maybe Double)
+        go grid = let grid' = force $ A.array (A.bounds grid) $ map (kernel grid) $ A.indices grid
+                  in if grid' == grid then grid' else go grid'
+        kernel grid pt = (pt,) . minimumBy cmpCost . ((grid!pt):) . map (fmap (1+) . (grid!)) $ neighborGrid!pt
+        initGrid :: A.Array Point (Maybe Double)
+        initGrid = A.array (A.bounds neighborGrid) (map (,Nothing) (A.indices neighborGrid)) //
+            case plID of
+                0 -> [ ((boardWidth-1,y),Just 1)  | y <- [0..boardHeight-1] ] -- right edge
+                1 -> [ ((0,y),Just 1)             | y <- [0..boardHeight-1] ] -- left edge
+                2 -> [ ((x,boardHeight-1),Just 1) | x <- [0..boardWidth-1]  ] -- bottom edge
+                3 -> [ ((x,0),Just 1)             | x <- [0..boardWidth-1]  ] -- top edge
+
+updateGrid :: Env -> [Wall] -> Env
+updateGrid env walls = env'
+    where env' = env { walls = walls, neighborGrid = neighborGrid, grids = grids }
+          neighborGrid = A.array gridIx $ map (id &&& neighbors env') $ A.range gridIx
+          grids = map (floodFill env') [0..(playerCount env)-1]
+          gridIx = ((0,0), ((boardWidth env)-1,(boardHeight env)-1))
+
+neighbors :: Env -> Point -> [Point]
+neighbors Env{..} (myX, myY) = do
+    (nx, ny) <- [ (myX-1, myY), (myX+1, myY), (myX, myY-1), (myX, myY+1) ]
+    guard $ (nx >= 0) && (ny >= 0) && (nx < boardWidth) && (ny < boardHeight)
+    let wallBetween (Wall (wx, wy) hv) =
+            (hv == H && (nx `elem` [wx, wx+1]) && sort [ny, myY] == [wy-1, wy]) ||
+            (hv == V && (ny `elem` [wy, wy+1]) && sort [nx, myX] == [wx-1, wx])
+    guard $ not $ any wallBetween walls
+    return (nx, ny)
+
+adjacentWalls :: Env -> Point -> [Wall]
+adjacentWalls env@Env{..} (x, y) = do
+    (x', y') <- neighborGrid ! (x, y)
+    if y' == y then do
+        top <- [ y - 1, y ]
+        guard $ top >= 0 && top < boardHeight - 1
+        return $ Wall (max x x', top) V
+    else do
+        left <- [ x - 1, x ]
+        guard $ left >= 0 && left < boardWidth - 1
+        return $ Wall (left, max y y') H
+
+doWallsCross :: Wall -> Wall -> Bool
+doWallsCross (Wall (x1, y1) d1) (Wall (x2, y2) d2) =
+    case (d1, d2) of
+        (H, H) -> (y1 == y2) && (x1 == x2 || x1 == x2 + 1 || x2 == x1 + 1)
+        (V, V) -> (x1 == x2) && (y1 == y2 || y1 == y2 + 1 || y2 == y1 + 1)
+        (V, H) -> (x1 == x2 + 1) && (y2 == y1 + 1)
+        (H, V) -> (x2 == x1 + 1) && (y1 == y2 + 1)
+
+cmpCost :: Maybe Double -> Maybe Double -> Ordering
+Nothing `cmpCost` Nothing = EQ
+Nothing `cmpCost` _       = GT
+_       `cmpCost` Nothing = LT
+Just x  `cmpCost` Just y  = x `compare` y
+
+dirFromPoints :: Point -> Point -> Dir
+dirFromPoints from@(x0,y0) to@(x1,y1)
+    | x1 < x0 = LEFT
+    | x1 > x0 = RIGHT
+    | y1 < y0 = UP
+    | True    = DOWN
+
+intP :: Stream s m Char => ParsecT s u m Int
+intP = spaces *> (read <$> ((++) <$> (string "-" <|> pure "") <*> some digit))
+
+tok s   = spaces *> string s
+pointP  = (,) <$> intP <*> intP
+orientP = (H <$ try (tok "H")) <|> (V <$ tok "V")
+
+wallP   = Wall <$> ((,) <$> intP <*> intP) <*> orientP
+playerP = \plID -> Player plID <$> pointP <*> intP
+
+parseE :: Stream s Identity t => Parsec s () a -> SourceName -> s -> a
+parseE p src s = either (error . show) id $ parse p src s
+
+repeatM :: Monad m => m a -> m b
+repeatM m = m >> repeatM m
+
+removeAt :: Int -> [a] -> (a, [a])
+removeAt ix xs = let (as, b:cs) = splitAt ix xs in (b, as ++ cs)
+
+showMove :: Either Dir Wall -> String
+showMove (Left  dir)             = show dir
+showMove (Right (Wall (x, y) o)) = unwords [ show x, show y, show o ]
+
+showGrid :: A.Array Point (Maybe Double) -> String
+showGrid grid = unlines . map (unwords . map (maybe "X" (show . truncate))) $
+                flip map [y0..yN] $ \y -> flip map [x0..xN] $ \x -> (grid!(x,y))
+    where ((x0,y0),(xN,yN)) = A.bounds grid

LICENSE

@@ -0,0 +1,39 @@
+Creative Commons CC0 1.0 Universal
+CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED HEREUNDER.
+Statement of Purpose
+
+The laws of most jurisdictions throughout the world automatically confer exclusive Copyright and Related Rights (defined below) upon the creator and subsequent owner(s) (each and all, an "owner") of an original work of authorship and/or a database (each, a "Work").
+
+Certain owners wish to permanently relinquish those rights to a Work for the purpose of contributing to a commons of creative, cultural and scientific works ("Commons") that the public can reliably and without fear of later claims of infringement build upon, modify, incorporate in other works, reuse and redistribute as freely as possible in any form whatsoever and for any purposes, including without limitation commercial purposes. These owners may contribute to the Commons to promote the ideal of a free culture and the further production of creative, cultural and scientific works, or to gain reputation or greater distribution for their Work in part through the use and efforts of others.
+
+For these and/or other purposes and motivations, and without any expectation of additional consideration or compensation, the person associating CC0 with a Work (the "Affirmer"), to the extent that he or she is an owner of Copyright and Related Rights in the Work, voluntarily elects to apply CC0 to the Work and publicly distribute the Work under its terms, with knowledge of his or her Copyright and Related Rights in the Work and the meaning and intended legal effect of CC0 on those rights.
+
+1. Copyright and Related Rights. A Work made available under CC0 may be protected by copyright and related or neighboring rights ("Copyright and Related Rights"). Copyright and Related Rights include, but are not limited to, the following:
+
+i. the right to reproduce, adapt, distribute, perform, display, communicate, and translate a Work;
+
+ii. moral rights retained by the original author(s) and/or performer(s);
+
+iii. publicity and privacy rights pertaining to a person's image or likeness depicted in a Work;
+
+iv. rights protecting against unfair competition in regards to a Work, subject to the limitations in paragraph 4(a), below;
+
+v. rights protecting the extraction, dissemination, use and reuse of data in a Work;
+
+vi. database rights (such as those arising under Directive 96/9/EC of the European Parliament and of the Council of 11 March 1996 on the legal protection of databases, and under any national implementation thereof, including any amended or successor version of such directive); and
+
+vii. other similar, equivalent or corresponding rights throughout the world based on applicable law or treaty, and any national implementations thereof.
+
+2. Waiver. To the greatest extent permitted by, but not in contravention of, applicable law, Affirmer hereby overtly, fully, permanently, irrevocably and unconditionally waives, abandons, and surrenders all of Affirmer's Copyright and Related Rights and associated claims and causes of action, whether now known or unknown (including existing as well as future claims and causes of action), in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each member of the public at large and to the detriment of Affirmer's heirs and successors, fully intending that such Waiver shall not be subject to revocation, rescission, cancellation, termination, or any other legal or equitable action to disrupt the quiet enjoyment of the Work by the public as contemplated by Affirmer's express Statement of Purpose.
+
+3. Public License Fallback. Should any part of the Waiver for any reason be judged legally invalid or ineffective under applicable law, then the Waiver shall be preserved to the maximum extent permitted taking into account Affirmer's express Statement of Purpose. In addition, to the extent the Waiver is so judged Affirmer hereby grants to each affected person a royalty-free, non transferable, non sublicensable, non exclusive, irrevocable and unconditional license to exercise Affirmer's Copyright and Related Rights in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "License"). The License shall be deemed effective as of the date CC0 was applied by Affirmer to the Work. Should any part of the License for any reason be judged legally invalid or ineffective under applicable law, such partial invalidity or ineffectiveness shall not invalidate the remainder of the License, and in such case Affirmer hereby affirms that he or she will not (i) exercise any of his or her remaining Copyright and Related Rights in the Work or (ii) assert any associated claims and causes of action with respect to the Work, in either case contrary to Affirmer's express Statement of Purpose.
+
+4. Limitations and Disclaimers.
+
+a. No trademark or patent rights held by Affirmer are waived, abandoned, surrendered, licensed or otherwise affected by this document.
+
+b. Affirmer offers the Work as-is and makes no representations or warranties of any kind concerning the Work, express, implied, statutory or otherwise, including without limitation warranties of title, merchantability, fitness for a particular purpose, non infringement, or the absence of latent or other defects, accuracy, or the present or absence of errors, whether or not discoverable, all to the greatest extent permissible under applicable law.
+
+c. Affirmer disclaims responsibility for clearing rights of other persons that may apply to the Work or any use thereof, including without limitation any person's Copyright and Related Rights in the Work. Further, Affirmer disclaims responsibility for obtaining any necessary consents, permissions or other rights required for any use of the Work.
+
+d. Affirmer understands and acknowledges that Creative Commons is not a party to this document and has no duty or obligation with respect to this CC0 or use of the Work.

Labyrinth/Labyrinth.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE TupleSections, LambdaCase #-}
+
+import Control.Applicative
+import Control.Arrow (first, second, (&&&))
+import Control.Monad
+import Data.Array
+import Data.List
+import Data.Maybe
+import Data.IORef
+import System.IO
+
+import qualified Data.Set as S
+
+data Direction = UP | DOWN | LEFT | RIGHT deriving (Eq,Ord,Enum,Bounded,Show)
+data Cell = Wall | Hollow | Start | Control | Unknown deriving (Eq,Ord,Enum,Bounded,Show)
+type Maze = Array (Int,Int) Cell
+
+main :: IO ()
+main = do
+   hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+   [rows,columns,alarmDelay] <- liftM (map read . words) getLine :: IO [Int]
+   leaving <- newIORef False
+
+   forever $ do
+      [row,column] <- liftM (map read . words) getLine :: IO [Int]
+      maze <- getMaze (rows, columns)
+
+      let cds = snd <$> findCell (\p c -> c == Control) (row,column) maze
+      when (cds == Just []) $ writeIORef leaving True
+
+      readIORef leaving >>= \case
+         True -> case snd <$> findCell (\p c -> c == Start) (row,column) maze of
+            Just (d:_) -> print d
+         False -> case cds of
+            Nothing -> case snd <$> findCell (\p c -> c == Unknown) (row,column) maze of
+               Just (d:_) -> print d
+            Just (d:_) -> print d
+
+findCell :: ((Int,Int) -> Cell -> Bool) -> (Int,Int) -> Maze -> Maybe ((Int,Int),[Direction])
+findCell f (sr,sc) mz = go [(sr,sc,[])] S.empty
+   where go []            _                    = Nothing
+         go ((r,c,ds):ps) vs
+            | not (inRange (bounds mz) (r,c))  = go ps vs
+            | f (r,c) (mz!(r,c))               = Just ((r,c), reverse ds)
+            | S.member (r,c) vs                = go ps vs
+            | (mz!(r,c)) `elem` [Wall,Unknown] = go ps (S.insert (r,c) vs)
+            | otherwise = let ns = [(r-1,c,UP:ds),(r+1,c,DOWN:ds),(r,c-1,LEFT:ds),(r,c+1,RIGHT:ds)]
+                          in go (ps ++ ns) (S.insert (r,c) vs)
+
+getMaze :: (Int, Int) -> IO Maze
+getMaze (rows, columns) = array ((0,0),(rows-1,columns-1)) . concat <$>
+   forM [0..rows-1] (\r -> zipWith (\c x -> ((r,c),x)) [0..] . map decodeCell <$> getLine)
+
+decodeCell :: Char -> Cell
+decodeCell '#' = Wall
+decodeCell '.' = Hollow
+decodeCell 'T' = Start
+decodeCell 'C' = Control
+decodeCell '?' = Unknown
+decodeCell _   = error "expected one of '#.TC?'"

MarsLander/MarsLander.hs

@@ -0,0 +1,81 @@
+import System.IO
+import Control.Monad
+import Data.Function
+import Data.List
+
+main :: IO ()
+main = do
+   hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+   
+   n <- liftM read getLine :: IO Int -- the number of points used to draw the surface of Mars.
+   
+   pts <- replicateM n $ do
+      -- land_x - X coordinate of a surface point. (0 to 6999)
+      -- land_y - Y coordinate of a surface point.
+      -- By linking all the points together in a sequential fashion, you form the surface of Mars.
+      (land_x:land_y:_) <- liftM (map read . words) getLine :: IO [Double]
+      return (land_x, land_y)
+
+   let flats = [ ((x0, x1), y0) | ((x0,y0),(x1,y1)) <- zip pts (tail pts), y1 == y0 ]
+   let ((lzX0, lzX1), lzY) = maximumBy (compare `on` (uncurry (-) . fst)) flats
+
+   interact $ unlines . map (unwords . map show)
+            . calculateOutput (lzX0, lzX1, lzY)
+            . map (map read . words) . lines
+
+calculateOutput :: (Double, Double, Double) -> [[Double]] -> [[Int]]
+calculateOutput (lzX0, lzX1, lzY) = snd . refoldl step (0, 0)
+   where
+      targetX = (lzX0 + lzX1) / 2.0
+      targetY = lzY + 50
+
+      step :: (Double, Double) -> [Double] -> ((Double, Double), Maybe [Int])
+      step (lostX, lostY) (x:y:hs:vs:f:r:p:_) = ((lostX', lostY'), Just [r', p'])
+         -- x  - the current horizontal position (0 to 6999).
+         -- y  - the current vertical position.
+         -- hs - the horizontal speed (in m/s), can be negative.
+         -- vs - the vertical speed (in m/s), can be negative.
+         -- f  - the quantity of remaining fuel in liters.
+         -- r  - the rotation angle in degrees (-90 to 90).
+         -- p  - the thrust power (0 to 4).
+         where
+            angle = (r + 90) * (pi/180)
+            (accelX, accelY) = fromPolar (p, angle)
+
+            targetVS = (-38)
+            accelY'  = max 0 $
+                if y < targetY then 4
+                else if abs (targetX - x) > (y - targetY) then 3.711 - 0.2*vs
+                else if vs > targetVS then 3
+                else 3.711 + 0.5*(targetVS^2 - vs^2)/(targetY - y)
+
+            rangeX     = if accelY' >= 4 then 0 else sqrt (4^2 - accelY'^2)
+            decelTimeX = (abs hs + 0.0001) / rangeX
+            projectedX = x + hs * decelTimeX - 0.5 * (signum hs * rangeX) * decelTimeX^2
+            accelX' = max (-rangeX) $ min rangeX $ 0.2 * (-hs) + 0.02 * (targetX - projectedX)
+            
+            (power', angle') = toPolar (accelX' + lostX, accelY' + lostY)
+
+            landing = (x >= lzX0 && x <= lzX1) && (y <= lzY + 100)
+            rightDirection = max 0 $ cos (angle - angle')
+
+            p' = max 0 $ min 4 $ round (rightDirection * power')
+            r' = if landing then 0 else max (-90) $ min 90 $ truncate $ ((angle' * (180/pi)) - 90)
+
+            (accelX'', accelY'') = fromPolar (fromIntegral p', fromIntegral (r'+90) * (pi/180))
+
+            lostX' = 0.8*(accelX'-accelX'')
+            lostY' = 0.8*(accelY'-accelY'')
+
+fromPolar :: Floating a => (a, a) -> (a, a)
+fromPolar (r, th) = (r * cos th, r * sin th)
+
+toPolar :: RealFloat a => (a, a) -> (a, a)
+toPolar (x, y) = (sqrt (x^2 + y^2), atan2 y x)
+
+-- Like `unfoldl` combined with `foldl`, or a stateful `map`.
+refoldl :: (a -> b -> (a, Maybe c)) -> a -> [b] -> (a, [c])
+refoldl _ a []     = (a, [])
+refoldl f a (b:bs) = case f a b of
+   (a', Nothing) -> (a', [])
+   (a', Just c ) -> let ~(a'', cs) = refoldl f a' bs in (a'', c:cs)

MarsLander/MarsLander.orig.hs

@@ -0,0 +1,104 @@
+import System.IO
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.IORef
+
+infinity :: Floating a => a
+infinity = 1.0/0.0
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering -- DO NOT REMOVE
+    
+    -- Auto-generated code below aims at helping you parse
+    -- the standard input according to the problem statement.
+    
+    input_line <- getLine
+    let n = read input_line :: Int -- the number of points used to draw the surface of Mars.
+    
+    pts <- replicateM n $ do
+        input_line <- getLine
+        let input = words input_line
+        let land_x = read (input!!0) :: Int -- X coordinate of a surface point. (0 to 6999)
+        let land_y = read (input!!1) :: Int -- Y coordinate of a surface point. By linking all the points together in a sequential fashion, you form the surface of Mars.
+        return (land_x, land_y)
+    let flats = [ ((x0, x1, y0), x1-x0) | ((x0,y0),(x1,y1)) <- zip pts (tail pts), y1 == y0 ]
+    let ((lzX0, lzX1, lzY), _) = maximumBy (compare `on` snd) flats
+
+    lostPower <- newIORef (0.0, 0.0)
+    
+    fix $ \loop -> do
+            input_line <- getLine
+            let input = words input_line
+            let x = read (input!!0) :: Int
+            let y = read (input!!1) :: Int
+            let hs = read (input!!2) :: Int -- the horizontal speed (in m/s), can be negative.
+            let vs = read (input!!3) :: Int -- the vertical speed (in m/s), can be negative.
+            let f = read (input!!4) :: Int -- the quantity of remaining fuel in liters.
+            let r = read (input!!5) :: Int -- the rotation angle in degrees (-90 to 90).
+            let p = read (input!!6) :: Int -- the thrust power (0 to 4).
+    
+            -- hPutStrLn stderr "Debug messages..."
+
+            let currentX = fromIntegral x
+            let currentY = fromIntegral y
+            let targetX  = fromIntegral (lzX0 + lzX1) / 2.0
+            let targetY  = fromIntegral lzY + 50
+            let veloX    = fromIntegral hs
+            let veloY    = fromIntegral vs
+            let accelX   = fromIntegral p * sin (pi * fromIntegral (-r) / 180)
+            let accelY   = fromIntegral p * cos (pi * fromIntegral (-r) / 180)
+            
+            let maxAccelY = 0.1
+            let decelTimeY = if veloY >= 0 then 0
+                             else (-veloY) / maxAccelY
+            let decelDistY = (-veloY) * decelTimeY - 0.5 * maxAccelY * decelTimeY^2
+        
+            let descend = currentY - targetY > decelDistY
+                       || (currentX >= fromIntegral lzX0 + 100
+                        && currentX <= fromIntegral lzX1 - 100
+                        && abs veloX <= 40)
+            let targetVeloY = if currentY > targetY + 300 then -60
+                              else if descend then -30
+                              else if currentY < targetY then 4
+                              else 0
+                              
+            let projectedY = currentY + veloY * (2 * (targetX - currentX) / veloX)
+
+            let minAccelY = 3.711 + (38^2 + 38 * veloY) / (targetY - projectedY)
+
+            let accelY' = min 3.95 $ max minAccelY $
+                          if targetVeloY < veloY then 0
+                          else 3.711 + min maxAccelY (0.04 * (targetVeloY - veloY))
+
+            let rangeX     = if accelY' >= 4 then 0.0 else sqrt (4^2 - accelY'^2)
+            let decelTimeX = if rangeX < 0.001 then infinity else abs veloX / rangeX
+            let projectedX = currentX + veloX * decelTimeX
+                           - 0.5 * (signum veloX * rangeX) * decelTimeX^2
+
+            let accelX' = if projectedX > fromIntegral lzX1 - 200 then -rangeX
+                          else if projectedX < fromIntegral lzX0 + 200 then rangeX
+                          else max (-rangeX) $ min rangeX $ 0.2 * (-veloX)
+
+            (lpX, lpY) <- readIORef lostPower
+
+            let landing = currentX >= fromIntegral lzX0
+                       && currentY <= fromIntegral lzX1
+                       && currentY <= fromIntegral lzY + 100
+            let angle' = if landing then 0 else (atan2 (accelY'+lpY) (accelX'+lpX) * (180.0/pi)) - 90
+            let rightDirection = max 0 $ cos (pi / 180 * (fromIntegral r - angle'))
+
+            let power' = rightDirection * sqrt ((accelX'+lpX)^2 + (accelY'+lpY)^2)
+            let p' = max 0 $ min 4 $ round power'
+            let r' = max (-90) $ min 90 $ truncate $ angle'
+
+            let accelX'' = fromIntegral p' * sin (pi * fromIntegral (-r') / 180)
+            let accelY'' = fromIntegral p' * cos (pi * fromIntegral (-r') / 180)
+
+            writeIORef lostPower (0.8*(accelX'-accelX''), 0.8*(accelY'-accelY''))
+
+            -- R P. R is the desired rotation angle. P is the desired thrust power.
+            putStrLn $ show r' ++ " " ++ show p'
+    
+            loop

README.md

@@ -0,0 +1,5 @@
+# CodinGame
+
+Archive of puzzle and contest submissions to the CodinGame online programming competition.
+
+https://www.codingame.com/profile/313267ebd6e0310ee969b07d409b4024627815