Main.hs

{-# LANGUAGE LambdaCase, GADTs #-}
module Main where

import Control.Object
import Control.Applicative
import Buttons
import Control.Monad
import Graphics.Gloss.Interface.IO.Game

data Async a b r where
  Push :: a -> Async a b ()
  Pull :: Async a b b

foldO :: Monad m => (a -> r -> r) -> r -> Object (Async a r) m
foldO c r = Object $ \case
  Pull -> return (r, foldO c r)
  Push a -> return ((), foldO c (c a r))

bool :: a -> a -> Bool -> a
bool a _ False = a
bool _ b True = b

count0 :: IO (Instance (Async ButtonClick Int) IO)
count0 = do
  counter <- newSettle $ \case { Click -> (+1); Toggle -> const 0 } `foldO` (0 :: Int)
  mode <- newSettle $ \case { Click -> id; Toggle -> not } `foldO` True
  new $ liftO $ \case
    Push b -> do
      counter .- Push b
      mode .- Push b
    Pull -> pull mode >>= bool (return (-1)) (pull counter)

count0D :: IO (Instance (Async ButtonClick Int) IO)
count0D = do
  let counter = \case { Click -> (+1); Toggle -> id } `foldO` (0 :: Int)
  holder <- newSettle counter >>= newSettle . foldO const
  mode <- newSettle $ \case { Click -> id; Toggle -> not } `foldO` True
  new $ liftO $ \case
    Push b -> do
      pull holder >>= (.- Push b)
      mode .- Push b
      when (b == Toggle) $ new counter >>= (holder .-) . Push
    Pull -> pull mode >>= bool (return (-1)) (pull holder >>= pull)

count5 :: IO (Instance (Async ButtonClick Int) IO)
count5 = do
  counter <- newSettle $ \case { Click -> (+1); Toggle -> id } `foldO` (0 :: Int)
  mode <- newSettle $ \case { Click -> id; Toggle -> not } `foldO` True
  new $ liftO $ \case
    Push b -> do
      mode .- Push b
      pull mode >>= bool (return ()) (counter .- Push b)
    Pull -> pull mode >>= bool (return (-1)) (pull counter)

count10 :: IO (Instance (Async ButtonClick Int) IO)
count10 = do
  counter <- newSettle $ \case { Click -> (+1); Toggle -> id } `foldO` (0 :: Int)
  mode <- newSettle $ \case { Click -> id; Toggle -> not } `foldO` True
  new $ liftO $ \case
    Push b -> do
      counter .- Push b
      mode .- Push b
    Pull -> pull mode >>= bool (return (-1)) (pull counter)

pull :: Instance (Async a b) IO -> IO b
pull = (.-Pull)

main = do
  c0 <- count0
  c0' <- count0D
  c5 <- count5
  c10 <- count10
  let push i (Just a) = i .- Push a
      push _ _ = return ()

  playIO (InWindow "Objective Example" (320, 240) (800, 200))
           white
           30
           ()
           (const $ renderButtons <$> (c0 .- Pull) <*> (fmap Just $ c0' .- Pull)
            <*> (c5 .- Pull) <*> pure Nothing
            <*> (c10 .- Pull) <*> pure Nothing)
           (\e () -> do
              push c0  $ filter0 e
              push c0' $ filter0 e
              push c5  $ filter5 e
              push c10 $ filter10 e)
           (\_ _ -> return ())