{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Main (main, showLayout) where

import Data.List (sortBy, transpose, intercalate, tails)
import Data.Foldable (toList)
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes, listToMaybe, fromJust)
import Data.Ord (Down(..), comparing)
import qualified Data.Set as Set
import Data.Set (Set)

import Input
import Util


data V4 a = V4 a a a a
  deriving (Show, Functor)

instance Applicative V4 where
    pure x = V4 x x x x
    V4 f1 f2 f3 f4 <*> V4 x1 x2 x3 x4 = V4 (f1 x1) (f2 x2) (f3 x3) (f4 x4)

instance Foldable V4 where
    foldr f z (V4 a b c d) = f a (f b (f c (f d z)))

ifmap :: (Int -> a -> b) -> V4 a -> V4 b
ifmap f (V4 a b c d) = fmap (uncurry f) (V4 (0, a) (1, b) (2, c) (3, d))

(!*) :: V4 a -> Int -> a
V4 a b c d !* i = [a, b, c, d] !! i

data B = F | T
  deriving (Eq, Ord)

instance Show B where
    show F = "."
    show T = "#"

newtype Border' a = Border { unBorder :: [a] }
  deriving (Eq, Ord, Functor)
type Border = Border' B

instance Show a => Show (Border' a) where
    show (Border l) =
        let l' = map show l
        in if all ((== 1) . length) l' then concat l' else show l

data Rotation = R Int B  -- rotated n, then possibly horizontally flipped
  deriving (Show)

data Tile' a = Tile Int Rotation (V4 (Border' a)) [[a]]
  deriving (Functor)

type Tile = Tile' B

instance Show a => Show (Tile' a) where
    showsPrec p (Tile i r v _) = showParen (p > 10) (showString ("Tile " ++ show i ++ " (" ++ show r ++ ") ") . showsPrec 11 v . showString " {...}")

boolb :: Bool -> B
boolb True = T
boolb False = F

notB :: B -> B
notB F = T
notB T = F

tileID :: Tile -> Int
tileID (Tile i _ _ _) = i

parseTile :: [String] -> Tile
parseTile [] = error "empty tile"
parseTile (hdr:lns) =
    fmap (boolb . (== '#')) $
         Tile (if take 5 hdr == "Tile " then read (take 4 (drop 5 hdr)) else error ("tile header?" ++ show hdr))
              (R 0 F)
              (V4 (Border (head lns))
                  (Border (map last lns))
                  (Border (reverse (last lns)))
                  (Border (reverse (map head lns))))
              lns

-- Rotates clockwise 90 degrees
rotArray :: [[a]] -> [[a]]
rotArray = map reverse . transpose

-- Flips horizontally
flipArray :: [[a]] -> [[a]]
flipArray = map reverse

-- Rotates clockwise 90 degrees
rotate :: Tile -> Tile
rotate (Tile i (R rotn rotf) (V4 a b c d) e) = Tile i (R (rotn+1) rotf) (V4 d a b c) (rotArray e)

-- Flips horizontally
flipTile :: Tile -> Tile
flipTile (Tile i (R rotn rotf) (V4 (Border a) (Border b) (Border c) (Border d)) e) =
    Tile i (R rotn (notB rotf)) (V4 (Border (reverse a)) (Border (reverse d)) (Border (reverse c)) (Border (reverse b))) (flipArray e)

type Cd = (Int, Int)  -- coordinate

data Layout = Layout (Map Cd Tile) (Set Cd)
  deriving (Show)

lput :: Cd -> Tile -> Layout -> Layout
lput pos tile (Layout mp bd) =
    Layout (Map.insertWith (error "lput: taken") pos tile mp)
           (Set.delete pos bd <> (Set.fromList (toList (neighbours pos)) Set.\\ Map.keysSet mp))

neighbours :: Cd -> V4 Cd
neighbours (x, y) = V4 (x, y-1) (x+1, y) (x, y+1) (x-1, y)

borderAt :: Cd -> Layout -> V4 (Maybe Border)
borderAt pos (Layout mp _) =
    ifmap (\i pos' -> (\(Tile _ _ bd _) -> Border (reverse (unBorder (bd !* mod (i + 2) 4)))) <$> Map.lookup pos' mp) (neighbours pos)

densityAt :: Layout -> Cd -> Int
densityAt ly pos = length (catMaybes (toList (borderAt pos ly)))

matchesOutline :: Tile -> V4 (Maybe Border) -> Bool
matchesOutline (Tile _ _ bd _) outl =
    all id ((\b -> maybe True (== b)) <$> bd <*> outl)

rotrefls :: Tile -> [Tile]
rotrefls = concatMap (\t -> [t, flipTile t]) . take 4 . iterate rotate

matchesAtPos :: Layout -> [Tile] -> Cd -> [(Tile, [Tile])]
matchesAtPos ly ts pos =
    [(t', rest)
    | (t, rest) <- splits' ts
    , t' <- rotrefls t
    , matchesOutline t' (borderAt pos ly)]

allCandidates :: Layout -> [Tile] -> [(Cd, Tile, [Tile])]
allCandidates ly@(Layout _ bd) ts =
    catMaybes
        [case matchesAtPos ly ts pos of
           [(t, ts')] -> Just (pos, t, ts')
           _ -> Nothing
        | pos <- sortBy (comparing (Down . densityAt ly)) (toList bd)]

findCandidate :: Layout -> [Tile] -> Maybe (Cd, Tile, [Tile])
findCandidate ly ts = listToMaybe (allCandidates ly ts)

placeAll :: Layout -> [Tile] -> (Layout, [Tile])
placeAll ly ts
  | Just (pos, t, ts') <- findCandidate ly ts = placeAll (lput pos t ly) ts'
  | otherwise = (ly, ts)

extents :: Map Cd a -> ((Int, Int), (Int, Int))
extents mp =
    let keys = Map.keys mp
    in ((minimum (map fst keys), maximum (map fst keys))
       ,(minimum (map snd keys), maximum (map snd keys)))

showLayout :: Layout -> String
showLayout (Layout mp bd) =
    let mp' = foldr (uncurry Map.insert) (Map.map Just mp) (map (,Nothing) (toList bd))
        ((xmin, xmax), (ymin, ymax)) = extents mp'
    in unlines [intercalate " "
                    [maybe "...." (maybe "----" (show . tileID)) (Map.lookup (x, y) mp')
                    | x <- [xmin..xmax]]
               | y <- [ymin..ymax]]

cornerProd :: Layout -> Int
cornerProd (Layout mp _) =
    let ((xmin, xmax), (ymin, ymax)) = extents mp
    in product (map (tileID . fromJust . (`Map.lookup` mp)) [(xmin,ymin), (xmin,ymax), (xmax,ymin), (xmax,ymax)])

squareOfTiles :: Layout -> [[Tile]]
squareOfTiles (Layout mp _) =
    let ((xmin, xmax), (ymin, ymax)) = extents mp
    in [[mp Map.! (x, y) | x <- [xmin..xmax]] | y <- [ymin..ymax]]

removeEdges :: [[B]] -> [[B]]
removeEdges = map trim . trim
  where trim = tail . reverse . tail . reverse

joinEdges :: [[Tile]] -> [[B]]
joinEdges tiles =
    concat [map concat (transpose [removeEdges body | Tile _ _ _ body <- tilerow])
           | tilerow <- tiles]

monster :: [[B]]
monster = map (map (\case '#' -> T ; ' ' -> F ; _ -> undefined)) pat
  where pat = ["                  # "
              ,"#    ##    ##    ###"
              ," #  #  #  #  #  #   "]

fieldParts :: [[a]] -> [[[a]]]
fieldParts bd = concatMap maptails (tails bd)
  where maptails [] = []
        maptails ([]:_) = []
        maptails l = l : maptails (map tail l)

exceedsLength :: [a] -> [a] -> Bool
_ `exceedsLength` [] = True
[] `exceedsLength` _ = False
(_:xs) `exceedsLength` (_:ys) = xs `exceedsLength` ys

matchPattern :: [[B]] -> [[B]] -> Bool
matchPattern bd pat =
    bd `exceedsLength` pat &&
        all (\(bdrow, patrow) -> bdrow `exceedsLength` patrow &&
                                    all (\(b, p) -> (p == F) || (b == T)) (zip bdrow patrow))
            (zip bd pat)

countPattern :: [[B]] -> [[B]] -> Int
countPattern bd pat = length (filter (`matchPattern` pat) (fieldParts bd))

numTrue :: [[B]] -> Int
numTrue = length . concat . map (filter (== T))

main :: IO ()
main = do
    tile0:tiles <- map parseTile . filter (not . null) . toList . splitOn null <$> getInput 20
    let initLayout = lput (0, 0) tile0 (Layout mempty (Set.singleton (0, 0)))
        (ly', _) = placeAll initLayout tiles
    print (cornerProd ly')
    let image = joinEdges (squareOfTiles ly')
        images = concatMap (\b -> [b, flipArray b]) (take 4 (iterate rotArray image))
    print (numTrue image - numTrue monster * maximum (map (`countPattern` monster) images))