import Zero ( total )
import Terminal.Game
import System.Random ( randoms, initStdGen )
import Data.Colour.RGBSpace ( RGB (..) )
import Data.Colour.RGBSpace.HSV ( hsv )
import Data.Maybe ( isJust )
import Data.Foldable ( find )
import Data.Bifunctor ( bimap )
import Data.Map as Map ( Map, assocs, toAscList, filterWithKey )
import Data.IntMap ( (!) )
import Control.Monad ( join )
import Control.Applicative ( (<|>) )
-- Game IO loop

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

executable maze
   import: opts
   ghc-options: -threaded -rtsopts
   hs-source-dirs: test
   main-is: Maze.hs
   build-depends: base
      , zero
      , nove
      , random
      , containers
      , ansi-terminal-game
      , colour