107 lines
4.1 KiB
Haskell
107 lines
4.1 KiB
Haskell
{-# 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
|