Skip to content

Instantly share code, notes, and snippets.

@divarvel
Last active December 26, 2021 15:37
Show Gist options
  • Save divarvel/00c9392896c1da9a4685b786ae3b2b15 to your computer and use it in GitHub Desktop.
Save divarvel/00c9392896c1da9a4685b786ae3b2b15 to your computer and use it in GitHub Desktop.
#!/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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment