{-# LANGUAGE FlexibleContexts #-}
module Main (main) where

import Control.Comonad (Comonad(..), (=>>))
import Control.Comonad.Store (StoreT(..), runStoreT, pos)
import Control.Monad (forM_, when)
import Control.Monad.IO.Class (MonadIO(..))
import Day (Day(..))
import qualified UI
import qualified Termbox2 as Tb2
import Sheet ((&))
import qualified Sheet as S
import Demos (Grid, mkGrid, unGrid, Coord, fromPair, Rule, basicRule, start)

--------------------------------------------------------------------------------
-- Conway game!
--------------------------------------------------------------------------------

type App = UI.Store (Grid Bool)

page1 :: Grid Bool -> UI.Activity App IO
page1 :: Grid Bool -> Activity (StoreT (Grid Bool) Identity) IO
page1 = forall s a. (s -> a) -> s -> Store s a
UI.store Grid Bool
-> Interface IO (Action (StoreT (Grid Bool) Identity)) Console
render where

  render :: Grid Bool -> UI.Interface IO (UI.Action App) UI.Console
  render :: Grid Bool
-> Interface IO (Action (StoreT (Grid Bool) Identity)) Console
render Grid Bool
this Callback IO (Action (StoreT (Grid Bool) Identity))
send = (Event -> IO ()) -> UI () -> Console
UI.Console (Callback IO (Action (StoreT (Grid Bool) Identity))
send forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Action (StoreT (Grid Bool) Identity) IO ()
update) forall a b. (a -> b) -> a -> b
$ do
    Int
w <- UI Int
UI.width
    Int
h <- UI Int
UI.height
    let rows :: ListFrom (Indexed (N (F Tape) Tape)) Bool
rows = forall r (t :: * -> *) a.
Take r t =>
RefList r -> t a -> ListFrom t a
S.take (Int -> RefList ('Relative :-: ('Relative :-: Nil))
S.belowBy Int
h forall as bs.
CombineRefLists as bs =>
RefList as -> RefList bs -> RefList (as & bs)
& Int -> RefList ('Relative :-: Nil)
S.rightBy Int
w) forall a b. (a -> b) -> a -> b
$ forall a. Grid a -> ISheet2 a
unGrid Grid Bool
this
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [[Bool]]
rows) forall a b. (a -> b) -> a -> b
$ \(Int
row, [Bool]
cols) ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Bool]
cols) forall a b. (a -> b) -> a -> b
$ \(Int
col, Bool
isAlive) ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isAlive forall a b. (a -> b) -> a -> b
$ Int -> Int -> UI ()
UI.drawBlock Int
row Int
col

  update :: UI.Event -> UI.Action App IO ()
  update :: Event -> Action (StoreT (Grid Bool) Identity) IO ()
update (UI.Event Tb2Event
evt)
    | Tb2Event -> Tb2EventType
Tb2._type Tb2Event
evt forall a. Eq a => a -> a -> Bool
== Tb2EventType
Tb2.eventKey =
      if (Tb2Event -> Word32
Tb2._ch Tb2Event
evt forall a. Eq a => a -> a -> Bool
== forall n. Integral n => Char -> n
UI.glyphCode Char
' ')
        then forall s (w :: * -> *) (effect :: * -> *).
ComonadStore s w =>
(s -> s) -> Action w effect ()
UI.modify (forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend Rule
basicRule)
        else forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()

--------------------------------------------------------------------------------
-- Wraps a component in a tasteful border.
--------------------------------------------------------------------------------

withBorder
  :: Comonad space
  => UI.Activity space effect
  -> UI.Activity (StoreT () space) effect
withBorder :: forall (space :: * -> *) (effect :: * -> *).
Comonad space =>
Activity space effect -> Activity (StoreT () space) effect
withBorder Activity space effect
inner = forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT (Activity space effect
inner forall (w :: * -> *) a b. Comonad w => w a -> (w a -> b) -> w b
=>> forall {w :: * -> *} {v :: * -> *} {effect :: * -> *} {a} {c} {s}.
(Comonad w, Functor v) =>
w ((Action v effect a -> c) -> Console)
-> () -> (Action (StoreT s v) effect a -> c) -> Console
render) () where

  render :: w ((Action v effect a -> c) -> Console)
-> () -> (Action (StoreT s v) effect a -> c) -> Console
render w ((Action v effect a -> c) -> Console)
child () Action (StoreT s v) effect a -> c
send  =
    let ~(UI.Console Event -> IO ()
uC UI ()
rC) = forall (w :: * -> *) a. Comonad w => w a -> a
extract w ((Action v effect a -> c) -> Console)
child forall a b. (a -> b) -> a -> b
$ Action (StoreT s v) effect a -> c
send forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: * -> *) (v :: * -> *) (effect :: * -> *) a.
(forall x. w x -> v x) -> Action v effect a -> Action w effect a
UI.hoist forall {f :: * -> *} {s} {b}. Functor f => StoreT s f b -> f b
adapt
    in  (Event -> IO ()) -> UI () -> Console
UI.Console Event -> IO ()
uC forall a b. (a -> b) -> a -> b
$ UI ()
rC forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> UI ()
UI.screenBorder Int
0

  adapt :: StoreT s f b -> f b
adapt StoreT s f b
wrapped = let (f (s -> b)
idx, s
k) = forall s (w :: * -> *) a. StoreT s w a -> (w (s -> a), s)
runStoreT StoreT s f b
wrapped in (forall a b. (a -> b) -> a -> b
$ s
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (s -> b)
idx
  {-# INLINE adapt #-}

--------------------------------------------------------------------------------
-- Main
--------------------------------------------------------------------------------

main :: IO ()
IO ()
main = forall (space :: * -> *).
Comonad space =>
Activity space IO -> IO ()
UI.mount forall a b. (a -> b) -> a -> b
$ Grid Bool -> Activity (StoreT (Grid Bool) Identity) IO
page1 Grid Bool
start

--------------------------------------------------------------------------------
-- UNDER CONSTRUCTION
--------------------------------------------------------------------------------
-- Router: Combines multiple components
--------------------------------------------------------------------------------

{-
data RouterS
  = NoSelection
  | Page1
  | Page2
  deriving (Show, Eq)

router p1 p2 = StoreT (Day render p1 p2) NoSelection where

  render iface1 iface2 sel send =
    let ~(UI.Console u1 r1) = extract iface1
        ~(UI.Console u2 r2) = extract iface2
    in  UI.Console (send . update u1 u2) $ case sel of
      NoSelection -> UI.centerText "No Selection!"
      Page1 -> r1
      Page2 -> r2

  update u1 u2 (UI.Event evt)
    | Tb2._type evt == Tb2.eventKey = UI.modify $ \case
      NoSelection -> Page1
      Page1 -> Page2
      Page2 -> NoSelection
    | otherwise = return ()
-}