module Main where

import Nove
import Nove.Verse

import Zero.Queue

import Data.Bifunctor ( bimap )
import Data.List ( find, intersperse )
import Data.Foldable ( toList )
import Data.IntMap as IntMap ( filter, keys )
import Data.Map as Map ( Map, (!), filterWithKey, keys )
import Control.Monad ( join )
import Terminal.Game
import System.Random ( randoms, initStdGen )

-- Game IO loop

main :: IO ()
main = do
   (rs,r) <- splitAt (length units) . randoms <$> initStdGen
   playGame $ Game {
      gTPS = 2 ,
      gInitState = (State { rand = r , center = 0 , input = (Nothing,mempty) , mode = Full } , generate (verse 11) rs) ,
      gLogicFunction = logic ,
      gDrawFunction = draw }
   where

   --Demo Universe
   generate :: Verse Unit -> [Int] -> Verse Unit
   generate v rs = foldr ($) (verse 11)
      $ set Robot { name = "@" , ops = mempty } 0
      : set Robot { name = "t0" , ops = Move <$> cycle [U,N,L] } (shift v 1 U 0)
      : set Robot { name = "t1" , ops = Move <$> cycle [N,L,U] } (shift v 2 U 0)
      : set Robot { name = "t2" , ops = Move <$> cycle [L,U,N] } (shift v 1 U $ shift v 1 H 0)
      : set Robot { name = "i" , ops = Move <$> repeat N } (shift v 8 I 0)
      : set Robot { name = "n" , ops = Move <$> repeat I } (shift v 2 I 0)
      : set Robot { name = "x" , ops = mempty } (shift v 7 M 0)
      : set Robot { name = "L0" , ops = Move <$> repeat L } (shift v 17 H 0)
      : set Robot { name = "L1" , ops = Move <$> repeat L } (shift v 18 H 0)
      : set Robot { name = "L2" , ops = Move <$> repeat L } (shift v 19 H 0)
      : zipWith set units (flip mod (length $ nodes v) <$> rs)

   units :: [Unit]
   units = replicate 4 Wall <> replicate 6 Box { pushed = Nothing } <> replicate 6 Ball { pushed = Nothing }

data Unit = None | Wall | Box { pushed :: Maybe Dir } | Ball { pushed :: Maybe Dir } | Robot { name :: String , ops :: [Op] }
   deriving Show

data Op = Lock | Move Dir
   deriving Show

instance Atom Unit where
   void = None
   move a
      | Robot {} <- a , Move d : _ <- ops a = Just d
      | Box {} <- a = pushed a
      | Ball {} <- a = pushed a
      | otherwise = Nothing
   lock a
      | Wall <- a = True
      | Robot {} <- a = True
      | Box {} <- a = True
      | Ball {} <- a = True
      | otherwise = False

data Mode = Dumb | Full

data State = State
   { rand :: [Int]
   , center :: Int
   , input :: (Maybe Char,Queue Char)
   , mode :: Mode
   }

-- Logic

logic :: GEnv -> (State,Verse Unit) -> Event -> Either () (State,Verse Unit)
logic _ _ (KeyPress 'q') = Left ()
logic _ (s,v) (KeyPress k) = Right (s { input = input' } , v)
   where

   -- prevent repeat before tick
   input' :: (Maybe Char,Queue Char)
   -- | Just (q,_) <- dequeue $ snd $ input s , k == q = input s
      | otherwise = enqueue k <$> input s

logic _ (s,v) Tick = Right (s' , sim demo s' v)
   where

   z :: State
      | Just (c,q) <- dequeue (snd $ input s) = s { input = (Just c , q) }
      | otherwise = s { input = (Nothing,snd $ input s) }

   s' :: State
      | Just 'H' <- k = z { center = shift v 1 H $ center s } | Just 'J' <- k = z { center = shift v 1 N $ center s } | Just 'K' <- k = z { center = shift v 1 I $ center s }
      | Just 'L' <- k = z { center = shift v 1 L $ center s }
      | otherwise = z
      where
      k :: Maybe Char
      k = fst $ input z

-- Draw

draw :: GEnv -> (State,Verse Unit) -> Plane
draw e (s,v) = centerFull e $ hcat [hex,ui] & (1,1) % makeTransparent ' ' (word "nove demo")
   where

   r :: Int
   r = radius v

   write :: (Int,Int) -> Draw
   write (x,y) = c %.< cell (grapheme a) # style a
      where

      a :: Unit
      a = node v n

      -- get index of node taking scroll into account
      n :: Int
      n = shift v mx L . shift v my I $ coordToIndex v (mod (x - div y r * r) (3 * r) , mod y r)
         where

         (mx,my) = indexToCoord v (center s)

      -- stretch, tilt, margin, translate to library coordinate system (1-based (y,x))
      c :: (Int,Int)
      c = join bimap succ (y + r , 2 * (x + r) + y)

   canvas :: Plane
   canvas = blankPlane (2 * succ (2 * r) + 2) (succ (2 * r) + 2)

   hex :: Plane
   hex = foldl (&) canvas [ write (x,y) | x <- [-r..r] , y <- [-r..r] , abs (x + y) <= r ]

   ui :: Plane
-- ui = word "> ui content here <"
   ui = foldl (&) canvas
      [ (1,1) % vcat (intersperse (cell ' ')
         [ key
         , hcat
            [ scope $ take 1 $ IntMap.keys $ IntMap.filter me $ nodes v
            , cell ' '
            , vcat [word "",info]
            ]
         ])
      ]
      where

      (c,q) = input s

      key :: Plane
      key = word (maybe id (:) c $ toList q) # color Black Vivid

      info :: Plane
         | Just m <- find me $ nodes v = word $ show m
         | otherwise = word "no robot found!" # color Red Vivid

   scope :: [Int] -> Plane
   scope n
      | i : _ <- n = foldl (&) (blankPlane 5 3)
         [ (1,2) % let a = adjacents v i Map.! U in cell (grapheme a) # style a
         , (1,4) % let a = adjacents v i Map.! I in cell (grapheme a) # style a
         , (2,1) % let a = adjacents v i Map.! H in cell (grapheme a) # style a
         , (2,3) % let a = node v i in cell (grapheme a)
         , (2,5) % let a = adjacents v i Map.! L in cell (grapheme a) # style a
         , (3,2) % let a = adjacents v i Map.! N in cell (grapheme a) # style a
         , (3,4) % let a = adjacents v i Map.! M in cell (grapheme a) # style a

         ]
      | otherwise = blankPlane 5 3

   -- render

   grapheme :: Unit -> Char
   grapheme a

      | Dumb <- mode s , None     <- a = '.'
      | Dumb <- mode s , Wall     <- a = '#'
      | Dumb <- mode s , Box {}   <- a = 'x'
      | Dumb <- mode s , Ball {}  <- a = 'o'
      | Dumb <- mode s , Robot {} <- a = '@'

      | Full <- mode s , None     <- a = '∙'
      | Full <- mode s , Wall     <- a = '#'
      | Full <- mode s , Box {}   <- a = 'x'
      | Full <- mode s , Ball {}  <- a = 'o'
      | Full <- mode s , Robot {} <- a = '@'

   style :: Unit -> Draw
   style a

      | Dumb <- mode s , me a = color White Dull
      | Dumb <- mode s , Nothing <- move a = color Black Vivid
      | Dumb <- mode s , Robot {} <- a , "t0"  <- name a = color Blue Dull
      | Dumb <- mode s , Robot {} <- a , "t1"  <- name a = color Magenta Dull
      | Dumb <- mode s , Robot {} <- a , "t2"  <- name a = color Red Dull
      | Dumb <- mode s , Robot {} <- a , "n"   <- name a = color Yellow Dull
      | Dumb <- mode s , Robot {} <- a , "i"   <- name a = color Green Dull
      | Dumb <- mode s , Robot {} <- a , 'L':_ <- name a = color Cyan Dull
      | Dumb <- mode s = color White Vivid

      | Full <- mode s , me a = rgbColor $ sRGB24 0x21 0xb2 0x8e  -- #21b28e
      | Full <- mode s , Nothing <- move a = rgbColor $ sRGB24 0x66 0x66 0x66  -- #666666
      | Full <- mode s , Robot {} <- a , "t0"  <- name a = rgbColor $ sRGB24 0x66 0x66 0x99  -- #666699
      | Full <- mode s , Robot {} <- a , "t1"  <- name a = rgbColor $ sRGB24 0x99 0x66 0x99  -- #996699
      | Full <- mode s , Robot {} <- a , "t2"  <- name a = rgbColor $ sRGB24 0x99 0x66 0x66  -- #996666
      | Full <- mode s , Robot {} <- a , "n"   <- name a = rgbColor $ sRGB24 0x99 0x99 0x66  -- #999966
      | Full <- mode s , Robot {} <- a , "i"   <- name a = rgbColor $ sRGB24 0x66 0x99 0x66  -- #669966
      | Full <- mode s , Robot {} <- a , 'L':_ <- name a = rgbColor $ sRGB24 0x66 0x99 0x99  -- #669999
      | Full <- mode s = rgbColor $ sRGB24 0x99 0x99 0x99  -- #999999

-- util

me :: Unit -> Bool
me a
   | Robot {} <- a , "@" <- name a = True
   | otherwise = False

-- Unit Automata

demo :: Automata State Unit
demo = Automata f
   where

   f :: State -> Map Dir Unit -> Unit -> Unit
   f s ns u
      | me u                                = me'
      | Robot {} <- u                       = u { ops = drop 1 $ ops u }
      | Box {}   <- u                       = u { pushed = push }
      | Ball {}  <- u , Nothing <- pushed u = u { pushed = push }
      | Ball {}  <- u , Just _ <- push      = u { pushed = push }
      | Ball {}  <- u                       = u { pushed = Nothing }
      | otherwise                           = u
      where

      me' :: Unit
         | Just 'h' <- fst $ input s = u { ops = [Move H] }
         | Just 'j' <- fst $ input s = u { ops = [Move N] }
         | Just 'k' <- fst $ input s = u { ops = [Move I] }
         | Just 'l' <- fst $ input s = u { ops = [Move L] }
         | otherwise = u { ops = [] }

      push :: Maybe Dir
         | [d] <- Map.keys $ Map.filterWithKey (\k w -> move w == Just (opposite k)) ns = Just $ opposite d
         | otherwise = Nothing