CodinGame „There is no Spoon“ World Cup entry

Main.hs

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
    
    
                    
    

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 :-)

Haskell is a great imperative language.