{-# LANGUAGE LambdaCase, TupleSections, UnicodeSyntax, Rank2Types #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}

import Control.Applicative
import Control.Arrow (first, second, (&&&))
import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Control.Monad.Writer
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Array (Array, (!), (//))
import System.IO
import System.Random
import System.Time
import System.Timeout
import System.CPUTime

import Debug.Trace

import qualified Data.Array       as A
import qualified Data.Foldable    as F
import qualified Data.Traversable as T

{-# ANN module "HLint: ignore Use if" #-}
{-# ANN module "HLint: ignore Redundant $" #-}
{-# ANN module "HLint: ignore Redundant do" #-}

type Color    = Int
type Rotation = Int
type Block    = (Color, Color)
type Column   = Int
type Row      = Int
data Cell     = Empty | Skull | Color Color deriving (Eq, Ord, Show)
type Grid     = Array (Column, Row) Cell

main ∷ IO ()
main = do
   hSetBuffering stdout NoBuffering -- DO NOT REMOVE

   threadDelay =<< randomRIO (0,800000)

   forever $ do
      blocks ← liftIO (replicateM 8 getBlock)

      start ← liftIO getClockTime

      myGrid ← liftIO getGrid
      opGrid ← liftIO getGrid

      let limiter = evaluateListWithTimeout 88000
      (col, rot) ← step limiter blocks myGrid

      end ← col `seq` rot `seq` liftIO getClockTime
      let ms = round ((end `diffSeconds` start) * 1000)

      liftIO $ hPutStrLn stderr $ show ms ++ "ms"
      liftIO $ putStrLn $ unwords [show col, show rot]

getBlock ∷ IO Block
getBlock = do
   [colorA, colorB] ← map read . words <$> getLine
   pure (colorA, colorB)

getGrid ∷ IO Grid
getGrid = fmap (A.array ((0,0),(5,11)) . concat) $
      forM [0..11] $ \row → do
         line ← getLine
         pure [ ((col, row), cell ch) | (col, ch) ← zip [0..] line ]
   where
      cell '.' = Empty
      cell '0' = Skull
      cell ch  = Color (read [ch])

newtype Candidates = Candidates [(Int, ((Column, Rotation), Candidates))]

step ∷ Functor f ⇒ (∀a. [a] → f [a]) → [Block] → Grid → f (Column, Rotation)
step limiter blocks myGrid = select <$> limiter stream
   where
      Candidates start = candidates blocks myGrid
      stream = deepen (take 11 start)
      deepen cs = (cs ++) $ do
         k ← [0..]
         n ← [0..8]
         mapMaybe (follow n <=< other k) cs
      dummy = (-1000000, ((0, 0), Candidates []))
      follow 0 c = Just c
      follow _ (_, (_, Candidates [])) = Nothing
      follow n (_, (_, Candidates (c':_))) = follow (n-1) c'
      other n c@(_, (_, Candidates cs)) = listToMaybe (drop n cs)
      select cs = trace (show $ length cs)
                $ fst $ snd $ maximumBy (compare `on` fst) (dummy:cs)

candidates ∷ [Block] → Grid → Candidates
candidates []             _    = Candidates []
candidates (block:blocks) grid = Candidates best
   where
      try c rot = do
         (grid', points) ← simulate grid block c rot
         let score1 = score grid' points
         let adjust (score2, (mv', cs')) =
               let scoreAvg = (2 * score1 + 3 * score2) `div` 5
               in (scoreAvg, ((c, rot), cs'))
         let Candidates cs = candidates blocks grid'
         pure $! score1 `seq` (score1, ((c, rot), Candidates (map adjust cs)))
      hint = uncurry (+) block `div` 2
      columns = filter (\c → c >= 0 && c <= 5) $ map (hint +) [0,-1,1,-2,2,-3,3,-4,4,-5,5]
      rotations = [1,0,3,2]
      best = sortBy (flip compare `on` fst) . catMaybes
           $ try <$> columns <*> rotations

score ∷ Grid → Int → Int
score grid points = 10*points + matches -- + 50*nonSkulls
   where
      free      = length $ filter (== Empty) $ A.elems grid
      nonSkulls = length $ filter (/= Skull) $ A.elems grid
      levels    = length $ takeWhile emptyLevel [0..11]
      matches   = sum . map (^2) . filter (> 1) . map length $ colorGroups
      emptyLevel r = all (\c → grid!(c,r) == Empty) [0..5]
      colorCells   = filter (isColor . snd) $ A.assocs grid
      colorGroups  = connectedGroups adjacentMatch colorCells

simulate ∷ Grid → Block → Column → Rotation → Maybe (Grid, Int)
simulate grid (colorA, colorB) col rot
   | not (A.inRange (A.bounds grid) crA) ||
     not (A.inRange (A.bounds grid) crB) ||
     grid!crA /= Empty || grid!crB /= Empty = Nothing
   | otherwise = Just . second getSum . runWriter $ simFall startGrid 1
   where
      (crA, crB) = case rot of
         0 → ((col,0), (col+1,0))
         1 → ((col,1), (col,  0))
         2 → ((col,0), (col-1,0))
         3 → ((col,0), (col,  1))
      startGrid = grid // [ (crB, Color colorB), (crA, Color colorA) ]

addSkulls ∷ Int → Grid → Grid
addSkulls nskulls grid = newGrid
   where
      packColumn c = zipWith (\r x → ((c,r),x)) [11,10..0]
                   $ (++ repeat Empty)
                   $ (++ replicate nskulls Skull)
                   $ takeWhile (/= Empty)
                   $ map (\r → grid!(c,r)) [11,10..0]
      newGrid = A.array ((0,0),(5,11)) $ concatMap packColumn [0..5]

simFall ∷ (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid
simFall grid = simDisappear newGrid
   where
      packColumn c = zipWith (\r x → ((c,r),x)) [11,10..0]
                   $ (++ repeat Empty)
                   $ filter (/= Empty)
                   $ map (\r → grid!(c,r)) [11,10..0]
      newGrid = A.array ((0,0),(5,11)) $ concatMap packColumn [0..5]

simDisappear ∷ (Applicative m, MonadWriter (Sum Int) m) ⇒ Grid → Int → m Grid
simDisappear grid stage = case null erased of
      True  → pure grid
      False → do
         tell . Sum $ 10 * blocksCleared * scale
         simFall erasedGrid (stage + 1)
   where
      colorCells = filter (isColor    . snd) $ A.assocs grid
      skullCells = filter ((== Skull) . snd) $ A.assocs grid
      groups = connectedGroups adjacentMatch colorCells
      largeGroups = filter ((>= 4) . length) groups
      erasedColors = concat largeGroups
      erasedSkulls = filter (\(cr,_) → any (adjacent cr . fst) erasedColors) skullCells
      erased = erasedColors ++ erasedSkulls
      erasedGrid = grid // map (second (const Empty)) erased
      blocksCleared = length erasedColors
      chainPower = if stage < 2 then 0 else 8 * 2^(stage-2)
      uniqueColors = length . nub $ map snd erasedColors
      colorBonus = if uniqueColors < 2 then 0 else 2^(uniqueColors-1)
      groupBonus = sum (map (perGroupBonus . length) largeGroups)
      perGroupBonus n = if n >= 11 then 8 else n - 4
      scale = max 1 $ min 999 $ chainPower + colorBonus + groupBonus

isColor ∷ Cell → Bool
isColor Empty     = False
isColor Skull     = False
isColor (Color _) = True

adjacent ∷ (Column,Row) → (Column,Row) → Bool
adjacent (c1,r1) (c2,r2) = (c1 == c2 && (r1 == r2 - 1 || r1 == r2 + 1)) ||
                           (r1 == r2 && (c1 == c2 - 1 || c1 == c2 + 1))

adjacentMatch ∷ ((Column, Row), Cell) → ((Column, Row), Cell) → Bool
adjacentMatch (cr1,x1) (cr2,x2) = x1 == x2 && adjacent cr1 cr2

connectedGroups ∷ (a → a → Bool) → [a] → [[a]]
connectedGroups p rem = case rem of
   [] → []
   (x:rem') →
      let go fringe others = case fringe of
             [] → ([], others)
             (y:fringe') →
                let (adj, notAdj) = partition (p y) others
                in first (y:) $ go (fringe' ++ adj) notAdj
          (conn, notConn) = go [x] rem'
      in conn : connectedGroups p notConn

diffSeconds ∷ ClockTime → ClockTime → Double
diffSeconds (TOD s' p') (TOD s p) =
   fromIntegral ((s' - s) * 1000000000000 + (p' - p)) / 1e12

-- From package "random", not available in CodinGame
class Monad m ⇒ MonadRandom m where
   getRandom   ∷ Random a ⇒ m a
   getRandoms  ∷ Random a ⇒ m [a]
   getRandomR  ∷ Random a ⇒ (a, a) → m a
   getRandomRs ∷ Random a ⇒ (a, a) → m [a]

instance MonadIO m ⇒ MonadRandom m where
   getRandom     = liftIO randomIO
   getRandoms    = liftIO $ fmap randoms newStdGen
   getRandomR    = liftIO . randomRIO
   getRandomRs r = liftIO $ fmap (randomRs r) newStdGen

shuffle ∷ MonadRandom m ⇒ [a] → m [a]
shuffle []  = return []
shuffle [x] = return [x]
shuffle xs  = do
   i ← getRandomR (0, length xs - 1)
   let (as, x:bs) = splitAt i xs
   xs' ← shuffle (as ++ bs)
   return (x: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