Tumble.hs

#!/usr/bin/env stack
-- stack --resolver lts-14.20 --install-ghc ghci --package containers --package mtl --package optics
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedLabels           #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
module Tumble
 {-( game
 , reviewGame
 , challenge1
 , brbrbr
 , startLeft
 , startRight

 ) -}where

import           Optics
import           Optics.State.Operators

import           Control.Monad.Except   (ExceptT (..), runExceptT, throwError)
import           Control.Monad.Identity (Identity)
import           Control.Monad.State    (MonadState (..), State, StateT (..),
                                         modify, runState)
import           Data.Foldable          (traverse_)
import           Data.List              (intercalate)
import           Data.List.NonEmpty     (NonEmpty)
import qualified Data.List.NonEmpty     as NE
import           Data.Map.Strict        (Map)
import qualified Data.Map.Strict        as Map
import           Numeric.Natural        (Natural)

data Position
  = Position
  { vertical   :: Natural
  , horizontal :: Natural
  }
  deriving (Eq, Ord)

instance Show Position where
  show Position{..} = show vertical
            <> "x" <> show horizontal

data Color = Red | Blue
  deriving Show
data Direction = Left' | Right'
  deriving Show

newtype Ball = Ball Color
instance Show Ball where
  show (Ball Blue) = "b"
  show (Ball Red)  = "r"

type MovingBall = (Ball, Position, Direction)

newtype Input = Input Direction
  deriving Show
newtype Output = Output Direction
  deriving Show
newtype Arm = Arm Color
  deriving Show

startLeft, startRight :: Arm
startLeft  = Arm Blue
startRight = Arm Red

data Elem =
    Ramp Direction
  | Bit Bool
  | GearBit Bool Natural
  | Crisscross
  | Interceptor [Ball]

instance Show Elem where
  show (Ramp Left')      = "⤦"
  show (Ramp Right')     = "⤥"
  show (Bit False)       = "⬁"
  show (Bit True)        = "⬀"
  show (GearBit False _) = "⬁"
  show (GearBit True _)  = "⬀"
  show Crisscross        = "⇆"
  show (Interceptor _)   = "⥎"

showElem :: Maybe Direction -> Elem -> String
showElem Nothing e                  = show e
showElem (Just _) (Ramp Left')      = "⇙"
showElem (Just _) (Ramp Right')     = "⇘"
showElem (Just _) (Bit False)       = "⬉"
showElem (Just _) (Bit True)        = "⬈"
showElem (Just _) (GearBit False _) = "⬉"
showElem (Just _) (GearBit True _)  = "⬈"
showElem (Just _) (Interceptor _)   = "↮"
showElem (Just Left') Crisscross    = "⇐"
showElem (Just Right') Crisscross   = "⇒"

type Elems = Map Position Elem

data Board
  = Board
  { boardElems     :: Elems
  , boardBlueBalls :: Natural
  , boardRedBalls  :: Natural
  , boardOutput    :: [Ball]
  , boardLiveBall  :: Maybe (Ball, Position, Direction)
  }
makeFieldLabels ''Board

newtype HistoryT s m a
  = HistoryT
  { runHistoryT :: StateT (NonEmpty s) m a
  }
  deriving newtype (Functor, Applicative, Monad)

instance Monad m => MonadState s (HistoryT s m) where
  get = HistoryT $ NE.head <$> get
  put p = HistoryT $ modify (p NE.<|)

runHistory :: History s a -> State (NonEmpty s) a
runHistory = runHistoryT

type History s = HistoryT s Identity
type Game = ExceptT String (History Board)

instance Show Board where
  show b@Board{..} =
    let bbs = show boardBlueBalls
        rbs = show boardRedBalls
        spc = replicate (22 - length bbs - length rbs) ' '
        output' = foldMap show  boardOutput
        elem' v h =
          let currentPos = Position v h
              activePos = case boardLiveBall of
                Just (_, p, d) | p == currentPos -> Just d
                               | otherwise       -> Nothing
                Nothing -> Nothing
          in maybe "◦" (showElem activePos) (elemAt (Position v h) b)
        showL = intercalate " · "
        showFirstLine = "   " <> showL
                        [ " "
                        , elem' 0 3
                        , " "
                        , elem' 0 7
                        , " "
                        ]

        showSecondLine = " "
          <> showL ([" "] <> (elem' 1 <$> [2,4..8]))
        showLine n | odd n = " " <> showL (elem' n <$> [0,2..10])
                   | otherwise = showL $ [""] <> (elem' n <$> [1,3..9]) <> [""]
        showLastLine = unwords
          [ replicate 10 '_'
          , elem' 10 5
          , replicate 10 '_'
          ]
    in unlines $
         [ ""
         , bbs <> spc <> rbs
         , replicate 7 '_' <> replicate 9 ' ' <> replicate 7 '_'
         , showFirstLine
         , showSecondLine
         ] <> (showLine <$> [2..9]) <>
         [ showLastLine
         , ""
         , replicate (21 - length output') ' ' <> output'
         ]

initBoard :: Natural -> Natural -> Elems
          -> Board
initBoard boardBlueBalls boardRedBalls boardElems =
  let boardOutput = []
      boardLiveBall = Nothing
  in Board{..}

withinBounds :: Position -> Bool
withinBounds Position{..}
  | vertical == 0  = horizontal `elem` [3, 7]
  | vertical == 1  = horizontal `elem` [2,4..8]
  | vertical == 10 = horizontal == 5
  | even vertical  = horizontal `elem` [1,3..9]
  | otherwise      = horizontal `elem` [0,2..10]

left :: Position -> MoveResult
left Position{..}
  | vertical == 10 = Trigger $ Arm Blue
  | vertical == 9 && horizontal <= 4 = Trigger $ Arm Blue
  | vertical == 9 && horizontal >= 8 = Trigger $ Arm Red
  | otherwise =
      let next = Position
                   { vertical = vertical + 1
                   , horizontal = horizontal - 1
                   }
      in if withinBounds next
          then Down Left' next
          else OutOfBounds

right :: Position -> MoveResult
right Position{..}
  | vertical == 10 = Trigger $ Arm Red
  | vertical == 9 && horizontal <= 2 = Trigger $ Arm Blue
  | vertical == 9 && horizontal >= 6 = Trigger $ Arm Red
  | otherwise =
      let next = Position
                   { vertical = vertical + 1
                   , horizontal = horizontal + 1
                   }
      in if withinBounds next
          then Down Right' next
          else OutOfBounds

addOutput :: Ball -> Board -> Board
addOutput ball =
  over #output (ball :)

data MoveResult
  = OutOfBounds
  | Down Direction Position
  | Trigger Arm

elemAt :: Position -> Board -> Maybe Elem
elemAt p = view $ #elems % at p

updateBoardAt :: Position -> Elem
              -> Board -> Board
updateBoardAt p e =
  over #elems $ Map.insert p e

bitDirection :: Bool -> Output
bitDirection True  = Output Left'
bitDirection False = Output Right'

data Modified
  = CurrentElem
  | BitGroup Natural

step :: Elem
     -> Input
     -> Ball
     -> (Maybe Output, Maybe (Elem, Modified))
step (Ramp d) _ _           = (Just $ Output d, Nothing)
step (Bit v) _ _             = (Just $ bitDirection v, Just (Bit (not v), CurrentElem))
step (GearBit v g) _ _       = (Just $ bitDirection v, Just (GearBit (not v) g, BitGroup g))
step Crisscross (Input d)  _ = (Just $ Output d, Nothing)
step (Interceptor bs) _ b    = (Nothing, Just (Interceptor (b : bs), CurrentElem))

runGame :: Arm -> Game Board
runGame arm = do
  let go = do
        current <- use #liveBall
        case current of
          Nothing -> pure ()
          Just c  -> runStep c >> go
  trigger Nothing arm
  go
  get

game :: Arm
      -- ^ Start Here
      -> Natural
      -- ^ Blue balls
      -> Natural
      -- ^ Red balls
      -> Elems
      -- ^ Initial elements
      -> (Either String Board, NonEmpty Board)
game arm blues reds elems =
  let board = initBoard blues reds elems
  in (`runState` pure board) $ runHistory $ runExceptT (runGame arm)

hasGroup :: Natural
         -> Elem -> Bool
hasGroup n (GearBit _ n') = n == n'
hasGroup _ _              = False

filtered' :: Traversable t
          => (a -> Bool)
          -> Traversal (t a) (t a) a a
filtered' predicate = traversalVL $ \f ->
  traverse (\x -> if predicate x then f x
                                 else pure x)

updateElems :: Position -> (Elem, Modified) -> Game ()
updateElems p (e, CurrentElem) = #elems % at p .= Just e
updateElems _ (e, BitGroup n)  =
  #elems % filtered' (hasGroup n) .= e

runStep :: MovingBall -> Game ()
runStep  (ball, p, d) = do
  let orFall = maybe (throwError "Fall") pure
      next (Output Left')  = left p
      next (Output Right') = right p
  elem' <- orFall =<< use (#elems % at p)
  let (o, update) = step elem' (Input d) ball
  traverse_ (updateElems p) update
  case next <$> o of
    (Just OutOfBounds)  -> throwError "OutOfBounds"
    (Just (Down d' p')) -> #liveBall .= Just (ball, p', d')
    (Just (Trigger a))  -> trigger (Just ball) a
    Nothing             -> #liveBall .= Nothing

trigger' :: Maybe Ball -> Arm
         -> Board -> Board
trigger' mb arm board =
  let st = startPos arm
      field = case arm of
                (Arm Blue) -> #blueBalls
                (Arm Red)  -> #redBalls
      remaining = view field board
      withBall  = board & over #output (maybe id (:) mb)
  in if remaining > 0 then
      withBall & set field (remaining - 1)
               & set #liveBall (Just st)
     else
      withBall & set #liveBall Nothing


trigger :: Maybe Ball -> Arm -> Game ()
trigger mb arm =
  modify $ trigger' mb arm

startPos :: Arm -> MovingBall
startPos (Arm Blue) = (Ball Blue, Position 0 3, Right')
startPos (Arm Red)  = (Ball Red, Position 0 7, Left')

challenge1 :: Elems
challenge1 = Map.fromList
  [ (Position 0 3, Ramp Right')
  , (Position 1 4, Ramp Left')
  , (Position 2 3, Ramp Right')
  , (Position 3 4, Ramp Left')
  , (Position 4 3, Ramp Right')
  , (Position 5 4, Ramp Left')
  , (Position 6 3, Ramp Right')
  , (Position 7 4, Ramp Left')
  , (Position 8 3, Ramp Right')
  , (Position 9 4, Ramp Left')
  ]

brbrbr :: Elems
brbrbr = Map.fromList
  [ (Position 0 3, Ramp Right')
  , (Position 0 7, Ramp Left')
  , (Position 1 4, Ramp Right')
  , (Position 1 6, Ramp Left')
  , (Position 2 5, GearBit False 0)
  , (Position 3 4, Ramp Left')
  , (Position 3 6, Ramp Right')
  , (Position 4 3, Ramp Right')
  , (Position 4 7, Ramp Left')
  , (Position 4 5, GearBit False 0)
  , (Position 5 4, Ramp Left')
  , (Position 5 6, Ramp Right')
  , (Position 6 3, Ramp Right')
  , (Position 6 7, Ramp Left')
  , (Position 7 4, Ramp Left')
  , (Position 7 6, Ramp Right')
  , (Position 8 3, Ramp Right')
  , (Position 8 7, Ramp Left')
  , (Position 9 4, Ramp Left')
  , (Position 9 6, Ramp Right')
  ]

reviewGame :: (Either String Board, NonEmpty Board) -> IO ()
reviewGame (res, history) = do
  print res
  _ <- getLine
  interactiveHistory (reverse $ NE.toList history)

interactiveHistory :: [Board] -> IO ()
interactiveHistory [] = putStrLn "Done!"
interactiveHistory (b : bs) = do
  print b
  _ <- getLine
  interactiveHistory bs