Skip to content

Instantly share code, notes, and snippets.

@nomeata nomeata/Main.hs
Created Apr 25, 2015

Embed
What would you like to do?
CodinGame „There is no Spoon“ World Cup entry
import System.IO
import Control.Monad
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Text.Printf
import Data.List
type Node = (Int,Int)
type Link = (Node, Node)
main :: IO ()
main = do
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
-- The machines are gaining ground. Time to show them what we're really made of...
input_line <- getLine
let width = read input_line :: Int -- the number of cells on the X axis
input_line <- getLine
let height = read input_line :: Int -- the number of cells on the Y axis
lines <- replicateM height getLine
let m :: M.Map (Int, Int) Int
m = M.fromList [ ((x,y),n)
| x <- [0..width-1], y <-[0..height-1],
let c = lines !! y !! x, c /= '.', let n = read [c]]
-- hPrint stderr m
let possible_links = [ (from,to) |
from <- M.keys m, to <- M.keys m, from < to,
fst from == fst to || snd from == snd to,
all (not . between from to) (M.keys m)
]
-- hPrint stderr possible_links
let links_of_node :: M.Map Node [Link]
links_of_node = M.fromListWith (++) [ (from, [link]) |
from <- M.keys m,
link <- possible_links,
fst link == from || snd link == from
]
-- hPrint stderr links_of_node
let lower_cap, upper_cap0, upper_cap1 :: M.Map Link Int
lower_cap = M.fromList [ (l,0) | l <- possible_links ]
upper_cap0 = M.fromList [ (l,2) | l <- possible_links ]
upper_cap1 | M.size m <= 2 = upper_cap0
| otherwise = flip M.mapWithKey upper_cap0 $ \l c ->
if m M.! fst l == 1 && m M.! snd l == 1 then 0 else
if m M.! fst l == 2 && m M.! snd l == 2 then 1 else c
Just solution <- go m links_of_node lower_cap upper_cap1
forM_ solution $ \((x1,y1),(x2,y2)) ->
printf "%d %d %d %d 1\n" x1 y1 x2 y2
go nodes links_of_node lower_cap upper_cap'
| not connectable = do
hPutStrLn stderr $ "Not connectable"
return Nothing
| all (\(n,m) -> m == 0) (M.toList missing) =
if connected then return $ Just $ concat [ replicate n l | (l,n) <- M.toList lower_cap]
else return $ Nothing
| not (null single_neighbor) = do
hPutStrLn stderr $ "Single neighbor: " ++ show single_neighbor
go nodes links_of_node (add single_neighbor lower_cap) upper_cap
| not (null full) = do
hPutStrLn stderr $ "Full: " ++ show single_neighbor
go nodes links_of_node (add full lower_cap) upper_cap
| otherwise = do
hPutStrLn stderr $ "Guessing"
--hPutStrLn stderr $ show (lower_cap)
--hPutStrLn stderr $ show (upper_cap)
-- hPutStrLn stderr $ show missing
-- hPutStrLn stderr $ show (available_links_of_node)
-- hPutStrLn stderr $ show guessable_links
tryList guessable_links
where
tryList [] = do
hPutStrLn stderr $ "Giving up"
return Nothing
tryList (l:ls) = do
hPutStrLn stderr $ "Trying " ++ show l
r <- go nodes links_of_node (add [l] lower_cap) upper_cap
case r of Nothing -> tryList ls
Just r -> return (Just r)
missing :: M.Map Node Int
missing = M.fromList
[(n,c - there) | (n,c) <- M.toList nodes,
let there = sum [ lc | l <- links_of_node M.! n, let lc = lower_cap M.! l]
]
upper_cap =
M.mapWithKey (\l c -> if any (crosses l) [l' | (l',c) <- M.toList lower_cap, c > 0, l' /= l] then 0 else c) $
M.mapWithKey (\l c -> c `min` (missing M.! fst l + lower_cap M.! l) `min` (missing M.! snd l + lower_cap M.! l)) $
upper_cap'
available_links_of_node =
M.map (filter (\l -> upper_cap M.! l > lower_cap M.! l)) links_of_node
guessable_links = [ l |
(l,lb) <- M.toList lower_cap,
let ub = upper_cap M.! l, lb < ub
]
single_neighbor = nub [ l |
(from, n) <- M.toList missing,
[l] <- return $ available_links_of_node M.! from
-- if snd l == from then m M.! fst l /= 1 else True
]
full = nub $ concat [ links |
(from, n) <- M.toList missing,
n > 0,
let links = available_links_of_node M.! from,
not (null links),
let available_but_one = sum $ tail $ sort [upper_cap M.! l - lower_cap M.! l | l <- links],
n > available_but_one
]
connected = go S.empty (S.singleton (head (M.keys nodes)))
where
go seen todo
| S.null todo = S.size seen == M.size nodes
| (t,odo) <- S.deleteFindMin todo, t `S.member` seen = go seen odo
| (t,odo) <- S.deleteFindMin todo
= go (S.insert t seen)
(todo `S.union` S.fromList (concat [ [fst l, snd l] | l <- links_of_node M.! t, lower_cap M.! l > 0]))
connectable = go S.empty (S.singleton (head (M.keys nodes)))
where
go seen todo
| S.null todo = S.size seen == M.size nodes
| (t,odo) <- S.deleteFindMin todo, t `S.member` seen = go seen odo
| (t,odo) <- S.deleteFindMin todo
= go (S.insert t seen)
(todo `S.union` S.fromList (concat [ [fst l, snd l] | l <- links_of_node M.! t, upper_cap M.! l > 0]))
add1 m l = M.adjust (+1) l m
add l m = foldl add1 m l
crosses :: Link -> Link -> Bool
crosses ((x1,y1),(x2,y2)) ((x3,y3),(x4,y4))
= x1 == x2 && y3 == y4 && between' y1 y2 y3 && between' x3 x4 x1
|| y1 == y2 && x3 == x4 && between' x1 x2 x3 && between' y3 y4 y1
between' a b c = a < c && c < b || b < c && c < a
between (x1,y1) (x2,y2) (x3,y3) =
x1 == x2 && x2 == x3 && between' y1 y2 y3 ||
y1 == y2 && y2 == y3 && between' x1 x2 x3
@nomeata

This comment has been minimized.

Copy link
Owner Author

nomeata commented Apr 25, 2015

Obviously, this is not the best Haskell code. The loop is in IO for no good reason but diagnostic output; the data structures could be made more suitable now that the algorithm is fixed. But it was a time-bound competition, so that’s an excuse, I hope :-)

@kmarekspartz

This comment has been minimized.

Copy link

kmarekspartz commented Apr 26, 2015

Haskell is a great imperative language.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.