main :: IO ()
main = do
(r:rs) <- randoms <$> initStdGen
playGame $ Game
{ gTPS = 70
, gInitState = set (Hex { look = pick r total , seed = rs , parent = Nothing , i = 1 }) 0 (verse size)
, gLogicFunction = logic
, gDrawFunction = draw
}
size :: Int
size = 17
pick :: Int -> [a] -> Maybe a
pick i ls
| null ls = Nothing
| otherwise = Just $ ls !! mod i (length ls)
data Hex = Hex { look :: Maybe Dir , seed :: [Int] , parent :: Maybe Dir , i :: Int }
instance Atom Hex where
void = Hex { look = Nothing , seed = [] , parent = Nothing , i = 0 }
move = const Nothing
lock = const True
logic :: GEnv -> Verse Hex -> Event -> Either () (Verse Hex)
logic _ v e
| Tick <- e = Right (sim maze () v)
| KeyPress 'r' <- e , r : rs <- seed (nodes v ! 0) = Right $ set (Hex { look = pick r total , seed = rs , parent = Nothing , i = 1 }) 0 (verse size)
| otherwise = Right v
draw :: GEnv -> Verse Hex -> Plane
draw e v = centerFull e $ hcat [hex,ui] & (1,1) % makeTransparent ' ' (word "hex maze")
where
canvas :: Plane
canvas = blankPlane (2 * succ (2 * size) + 2) (succ (2 * size) + 2)
hex :: Plane
hex = foldl (&) canvas [ write (x,y) | x <- [-size..size] , y <- [-size..size] , abs (x + y) <= size ]
write :: (Int,Int) -> Draw
write (x,y)
| Just _ <- look h = c %.< cell '*' # color White Dull
| 0 < i h = c %.< cell 'o' # rgbColor (spectrum $ i h)
| otherwise = c %.< cell ' '
where
h :: Hex
h = node v n
-- get index of node taking scroll into account
n :: Int
n = coordToIndex v (mod (x - div y size * size) (3 * size) , mod y size)
-- stretch, tilt, margin, translate to library coordinate system (1-based (y,x))
c :: (Int,Int)
c = join bimap succ (y + size , 2 * (x + size) + y)
ui :: Plane
-- ui = word "> ui content here <"
ui = foldl (&) canvas
[ (1,1) % vcat [word "look:",info]
]
where
info :: Plane
| Just h <- find (isJust . look) $ nodes v = word $ unwords $ [show $ i h,show $ look h,show $ parent h]
| otherwise = word "not looking" # color Red Vivid
spectrum :: Int -> Colour Float
spectrum i = sRGB r g b
where
RGB r g b = hsv (fromIntegral i / fromIntegral (6 * size ^ 2) * 360) 1 1
maze :: Automata () Hex
maze = Automata f
where
f :: () -> Map Dir Hex -> Hex -> Hex
f () ns h
-- new
| Just (dir,n) <- looker , r : rs <- seed n , 0 <- i h = h { look = go r <|> Just dir , seed = rs , parent = Just dir , i = succ (i n) }
-- backtrace/branch
| Just (dir,n) <- looker , r : rs <- seed h = h { look = go r <|> parent h , seed = rs }
-- sleep
| otherwise = h { look = Nothing }
where
-- backtrace/branch
go :: Int -> Maybe Dir
go r = pick r (fst <$> filter ((== 0) . i . snd) (toAscList ns))
looker :: Maybe (Dir,Hex)
looker
| a : _ <- assocs $ filterWithKey l ns = Just a
| otherwise = Nothing
where
l :: Dir -> Hex -> Bool
l dir n
| Just d <- look n = dir == opposite d
| otherwise = False