{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE LambdaCase                 #-}

-- base
import Control.Applicative
import Data.Bits (xor)
import Data.Coerce
import Data.List hiding (insert)
import Data.List.NonEmpty (NonEmpty((:|)),(<|))
import Data.Functor
import System.Exit (exitFailure)
import System.IO
-- mtl
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Except

-- MonadFail not really needed for GCJ's rusty GHC (too old);
-- Control.Monad.Fail not needed with recent GHCs.
-- So this import is just the worst of worse world because I didn't
-- figure out a simple enough way of running an old haddock.
import Control.Monad.Fail

-- | Solve a @B=10@ problem case.
solve10 :: ReaderT BitWidth IO ()
solve10 = void $ runExceptT $ flip runStateT (QueryCount 0) $ do
  bits <- mapM (\i -> fmap (i,) (readBit i)) [Index 1 .. Index 10]
  liftIO $ provideAnswer $ reconstruct bits

-- | Represent a t'Pair'\'s quality,
--   depending on its relationship to its counterpart.
data PairType
  = Even -- ^ pairs are those where the counterpart is equal;
         --   such pairs are unaffected by reversals.
  | Odd  -- ^ pairs are those where the counterpart is the negation;
         --   database reversals and complements have
         --   the same effect on such pairs.

-- | Identify the 'PairType' from a given pair of 'Bool's.
pairType :: Bool -> Bool -> PairType
pairType x y | x == y = Even
             | x /= y = Odd

-- | The v'Pair' type represents a database bit and its symmetrical
-- counterpart.  For the bit in the first half of the database:
data PairF bool = Pair {
    pairIndex :: HalfIndex   -- ^ remember its index
  , pairValue :: bool        -- ^ remember its value
  } deriving Functor -- ^ a hacky derived instance to get 'fmap' at
                     -- little cost
type Pair = PairF Bool
-- ^ I'm lazily using a parametric @bool@ so I can @DeriveFunctor@ and
--   have a free 'fmap' on the relevant payload, namely the 'pairValue'.
--   In this code, it's only ever going to be used as a 'PairF' 'Bool',
--   hence the type synonym.

-- | Return a pair's left index.
pairIndexL :: Pair -> Index
pairIndexL = halfToFull . pairIndex

-- | Return a pair's right index.
pairIndexR :: BitWidth -> Pair -> Index
pairIndexR bw = halfToFullR bw . pairIndex

-- | In addition to `pairValue` which is a record accessor, pairValueR
-- returns the pair's symmetrical counterpart's value.
pairValueR :: PairType -> Pair -> Bool
pairValueR Even = pairValue
pairValueR Odd = not . pairValue

-- | Expand a pair back to its two known indexed bit values.
expand :: BitWidth -> PairType -> Pair -> [(Index,Bool)]
expand bw pt p = [ (pairIndexL p,pairValue p)
                 , (pairIndexR bw p,pairValueR pt p) ]

-- | Solve the @B=20@ case by qualifying each pair,
--   then probing all of them in a single block.
solve20 :: ReaderT BitWidth IO ()
solve20 = do
  let block = runExceptT . flip evalStateT (QueryCount 0)
  Right half1 <- block $ mapM readPair [HalfIndex 1 .. HalfIndex 5]
  Right half2 <- block $ mapM readPair [HalfIndex 6 .. HalfIndex 10]
  Right bits  <- block $ mapM readBit  [Index 1 .. Index 10]
  bw <- ask
  let (cs1,ps1) = unzip half1
      (cs2,ps2) = unzip half2
      currentHalf = zipWith ($>) (ps1 ++ ps2) bits
      bits' = concat $ zipWith (expand bw) (cs1 ++ cs2) currentHalf
  liftIO $ provideAnswer $ reconstruct bits'

-- | A Batch groups together t'Pair's of a same known (externally)
--   'PairType'.  If we successfully manage to track one of the batch's
--   representatives' value between 'QuantumFluctuation's, we're able to
--   deduce all the batch's other pairs with no further costly
--   information retrieval!
--
--   The @offset@ parameter enables us to explicitly mark a batch's
--   knowledge as outdated, so we don't accidentally miss a
--   'QuantumFluctuation' and go out of sync.
data Batch offset
  = Empty -- ^ An empty batch.  Note that those never hold an @offset@.
  | Batch offset (NonEmpty Pair) -- ^ A non-empty batch.
  deriving Functor -- ^ I use the same @DeriveFunctor@ trick, this
                   --   time less idiomatically as the @offset@ can't
                   --   really be considered the payload: this one makes
                   --   for a very easy batch 'float'ing implementation.
                   --   I'm ashamed of this one.

-- | A __floating__ batch is one whose pairs' values we currently
-- don't know, because a 'QuantumFluctuation' happened and we haven't
-- synchronized yet.
type FloatingBatch = Batch ()

-- | A __bound__ batch is one whose pairs' values are currently known.
-- To avoid having to update all of the values at each
-- 'QuantumFluctuation', we store this as a 'Bool' to be 'xor'ed with
-- them.
type BoundBatch = Batch Bool

-- | Bind a floating batch to a specific boolean offset.  This
-- consumes up to one query.
bind :: (MonadError QuantumFluctuation m,MonadState QueryCount m,MonadIO m)
     => FloatingBatch -> m BoundBatch
bind Empty = pure Empty
bind (Batch () ps@(p :| _)) = do v <- readBit (halfToFull (pairIndex p))
                                 pure (Batch (v `xor` pairValue p) ps)

-- | Loosen a bound batch back to a floating one.  To be used when we
-- know it'll expire before the next query returns.
float :: BoundBatch -> FloatingBatch
float = fmap (const ())

-- | Insert a pair in a batch.
--   Can only by done if the batch is currently bound.
insert :: Pair -> BoundBatch -> BoundBatch
insert p Empty = Batch False (pure p)
insert p (Batch b ps) = Batch b ((fmap (xor b) p) <| ps)

-- | Expand a batch to a list of @(Index,Bool)@ pairs.
--   Can only be done if the batch is currently bound.
assocs :: MonadReader BitWidth m => PairType -> BoundBatch -> m [(Index,Bool)]
assocs _ Empty = pure []
assocs pt (Batch b ps) = do
  bw <- ask
  pure (concatMap (expand bw pt . fmap (xor b)) ps)

-- | Read, classify and store pairs from the database until the next
-- query would result in a quantum fluctuation.
readPairs :: (MonadState QueryCount m,MonadReader BitWidth m,MonadIO m)
          => BoundBatch -> BoundBatch -> [HalfIndex]
          -> m (BoundBatch,BoundBatch,Maybe [HalfIndex])
readPairs evens odds [] = pure (evens,odds,Nothing)
readPairs evens odds is@(i:is') = runExceptT (readPair i) >>= \case
  Right (Even,p) -> readPairs (insert p evens) odds is'
  Right (Odd,p)  -> readPairs evens (insert p odds) is'
  Left QuantumFluctuation -> pure (evens,odds,Just is)

-- | Perform a block of queries, maintaining a knowledge base of pair
-- batches between two quantum fluctuations.
readBlocks :: (MonadFail m,MonadReader BitWidth m,MonadIO m)
           => FloatingBatch -> FloatingBatch -> [HalfIndex]
           -> m (BoundBatch,BoundBatch)
readBlocks ftEvens ftOdds indices = do
  (bdEvens',bdOdds',mbIndices') <- flip evalStateT (QueryCount 0) $ do
    -- Despite the MonadFail instance, the first two queries can't
    -- fail since the query count is 0 then 1 at this time.  Guarding
    -- against this statically without making the code three times as
    -- long reaches beyond what we have avilable on the GCJ platform.
    Right bdEvens <- runExceptT (bind ftEvens)
    Right bdOdds  <- runExceptT (bind ftOdds)
    readPairs bdEvens bdOdds indices
  case mbIndices' of
    Just indices' -> readBlocks (float bdEvens') (float bdOdds') indices'
    Nothing       -> pure (bdEvens',bdOdds')

-- | Solve the @B=100@ case.  Actually, this would solve any (lower)
-- case, but 'main' currently only calls it in that case.
solve100 :: ReaderT BitWidth IO ()
solve100 = do
  BitWidth bw <- ask
  let pairRange = [HalfIndex 1 .. HalfIndex (bw `div` 2)]
  (evens,odds) <- readBlocks Empty Empty pairRange
  bits <- liftA2 (++) (assocs Even evens) (assocs Odd odds)
  liftIO $ provideAnswer $ reconstruct bits

-- | Safely query a bit from the database.  If querying now would
-- cause a 'QuantumFluctuation', report it using the 'MonadError'
-- interface instead.
readBit :: (MonadError QuantumFluctuation m,MonadState QueryCount m,MonadIO m)
        => Index -> m Bool
readBit i = get >>= \case
  QueryCount 10 -> throwError QuantumFluctuation
  _             -> modify succ *> liftIO (rawReadBit i)

-- | The singleton event type to signal when bad things are happening.
data QuantumFluctuation = QuantumFluctuation

-- | Query a pair of bits from the database and classify it.
readPair :: ( MonadError QuantumFluctuation m, MonadState QueryCount m
            , MonadReader BitWidth m, MonadIO m)
            => HalfIndex -> m (PairType,Pair)
readPair i = do
  bw <- ask
  x <- readBit (halfToFull i)
  y <- readBit (halfToFullR bw i)
  pure (if x == y then Even else Odd,Pair { pairIndex = i, pairValue = x })

-- | A wrapper around problem-global variable @B@.  Converting to this
-- earlier would have spared me quite a few mix-ups between identifier
-- @b@ referring to the database width or identifier @b@ referring to
-- a generic bit/boolean value.
--
-- On the one hand I could just use more verbose identifiers.  On the
-- other hand, having the typesystem help is always good.
newtype BitWidth = BitWidth Int

-- | A wrapper around an index to the database.  Range from @1@ to @B@.
newtype Index = Index Int deriving ( Eq   -- ^ needed for 'Ord'
                                   , Ord  -- ^ needed to sort in 'reconstruct'
                                   , Enum -- ^ needed for the easy case agenda
                                   , Num  -- ^ needed to convert counterparts
                                   )

-- | A wrapper around an index to the first half of the database.
-- Range @1@ to @B/2@.
newtype HalfIndex = HalfIndex Int deriving Enum -- ^ needed for the agenda

-- | Conversion from a half-index to a full one is always safe.
halfToFull :: HalfIndex -> Index
halfToFull = coerce

-- | Conversion from a half-index to the full one of its right part
-- requires knowing @B@.
halfToFullR :: BitWidth -> HalfIndex -> Index
halfToFullR (BitWidth bw) = (Index bw+1 -) . halfToFull

-- | A wrapper around the query count for “managed” querying.
newtype QueryCount = QueryCount Int deriving ( Eq   -- ^ check for limit
                                             , Enum -- ^ increase
                                             )

-- | Turn an unordered list of indexed booleans from various batches
-- back into a nice bitstring.
reconstruct :: [(Index,Bool)] -> [Bool]
reconstruct = map snd . sort

-- | Query a bit from the database.
-- This is the raw protocol operation.
--
-- I used to label is as ‘unsafe’ to signal not to use it directly,
-- but I've since then written the easier variations of this puzzle,
-- so I'm now going with ‘raw’.
rawReadBit :: Index -> IO Bool
rawReadBit (Index i) = print i *>
                       checkLine >>= \case "0" -> pure False
                                           "1" -> pure True

-- | Provide an answer to the judge.
provideAnswer :: Foldable f => f Bool -> IO ()
provideAnswer answer = do
  putStrLn $ concatMap (show . fromEnum) answer
  "Y" <- checkLine  -- still not legal to end a void'ened
  pure undefined    -- block on a monadic pattern bind :-(

-- | Read a line from the judge.
--
-- As per protocol, if the line to be returned is an @\"N\"@, that's
-- an interaction-terminating signal as far as the judge is concerned,
-- whether they're caused my a protocol error or a wrong answer.  So
-- exit cleanly ('exitFailure') on those so the judge can return the
-- correct “wrong answer” result instead of “time limit exceeded”.
--
-- IMHO this is a bit lame from the organizers' part, they'd be
-- perfectly able to distinguish those without making the protocol any
-- more cumbersome than it already is.
checkLine :: IO String
checkLine = getLine >>= \case "N" -> exitFailure
                              s   -> pure s

-- | Perform the Code Jam judge I/O and tie the high-level pieces
-- together.
main :: IO ()
main = do
  hSetBuffering stdout LineBuffering
  [t,b] <- map read . words <$> getLine
  let solver = case b of 10  -> solve10
                         20  -> solve20
                         100 -> solve100
  replicateM_ t $ runReaderT solver (BitWidth b)