{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeOperators #-}
{-# LANGUAGE DataKinds, PolyKinds, FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE RankNTypes, ExistentialQuantification, StrictData #-}
{-# LANGUAGE BangPatterns #-}

module Demos  where

import Data.Kind (Type)
import CPS (CPS(..))
import WhyNot
  ( type (?)
  , Handles(..)
  , Result
  , Return
  , handle
  , whynot )

import Prelude hiding (take)
import Data.List (intersperse)
import Data.Bool (bool)
import Data.Time
  ( Day
  , ZonedTime
  , TimeZone
  , utctDay
  , getCurrentTime
  , utcToZonedTime )

import Orc (Orc, runOrc, putStrLine, publish, delay, (<|>))
import Control.Concurrent.MonadIO (MonadIO(..))
import Control.Concurrent (threadDelay)
import Lists (Counted(..), (:-:))
import qualified Lists as Lists
import Sheet
import Nested (NestedNTimes)
import Servant
  ( HasServer(..)
  , Get
  , (:<|>)(..)
  , Capture
  , (:/)
  , Proxy(..)
  , serve )

import Data.Functor.Rep (Representable(..))
import Control.Comonad (Comonad(..))
import Control.Comonad.Representable.Store (StoreT(..), Store, store, runStore, experiment)
import Control.Arrow ((***))
import Data.Functor.Identity

type MyAPI
  =    "date"     :/ Get Day
  :<|> "time"     :/ Capture TimeZone :/ Get ZonedTime
  :<|> "delayed"  :/ Capture Float    :/ Get String

handle_date :: Orc Day
handle_date :: Orc Day
handle_date = do
  forall a. (RealFrac a, Show a) => a -> Orc ()
delay Double
4
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ UTCTime -> Day
utctDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime

handle_time :: TimeZone -> Orc ZonedTime
handle_time :: TimeZone -> Orc ZonedTime
handle_time TimeZone
tz = do
  forall a. (RealFrac a, Show a) => a -> Orc ()
delay Double
2
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
tz forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime

handle_delayed :: Float -> Orc String
handle_delayed :: Float -> Orc String
handle_delayed Float
n = do
  ZonedTime
start_time <- TimeZone -> Orc ZonedTime
handle_time (forall a. Read a => String -> a
read String
"UTC")
  forall a. (RealFrac a, Show a) => a -> Orc ()
delay Float
n
  ZonedTime
now_time <- TimeZone -> Orc ZonedTime
handle_time (forall a. Read a => String -> a
read String
"UTC")
  forall a. NFData a => a -> Orc a
publish forall a b. (a -> b) -> a -> b
$ String
"Request received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ZonedTime
start_time forall a. [a] -> [a] -> [a]
++
    String
", delayed " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Float
n forall a. [a] -> [a] -> [a]
++ String
" seconds and finally completed at " forall a. [a] -> [a] -> [a]
++
    forall a. Show a => a -> String
show ZonedTime
now_time

serve_my_api :: [String] -> Orc String
serve_my_api :: [String] -> Orc String
serve_my_api = forall {k} (layout :: k).
HasServer layout =>
Proxy layout -> Server layout -> [String] -> Orc String
serve (forall k (a :: k). Proxy a
Proxy :: Proxy MyAPI) forall a b. (a -> b) -> a -> b
$
  Orc Day
handle_date forall a b. a -> b -> a :<|> b
:<|> TimeZone -> Orc ZonedTime
handle_time forall a b. a -> b -> a :<|> b
:<|> Float -> Orc String
handle_delayed

servant_main :: IO ()
servant_main :: IO ()
servant_main = forall a. Orc a -> IO ()
runOrc forall a b. (a -> b) -> a -> b
$ do
  String
response <- ([String] -> Orc String
serve_my_api [String
"delayed", String
"3"]
           forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [String] -> Orc String
serve_my_api [String
"delayed", String
"5"]
           forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [String] -> Orc String
serve_my_api [String
"date"]
           forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [String] -> Orc String
serve_my_api [String
"time",String
"CST"])
  String -> Orc ()
putStrLine String
response

-- * Effects demo.

-- | Operation to load an implicit, dynamic state value.
data Load (e :: Type) (u :: Type) = forall s. (e ~ s, u ~ ()) => Load
type instance Return (Load s ()) = s

load :: h `Handles` Load => h ? (Ex h Load)
load :: forall h. Handles h Load => h ? Ex h Load
load = forall {k1} {k2} h (op :: k1 -> k2 -> *) (e :: k1) (u :: k2).
(Handles h op, e ~ Ex h op) =>
op e u -> h ? Return (op e u)
whynot forall e u s. (e ~ s, u ~ ()) => Load e u
Load

-- | Operation to save an implicit, dynamic state value.
data Save (e :: Type) (u :: Type) = forall s. (e ~ s, u ~ ()) => Save s
type instance Return (Save s ()) = ()

save :: h `Handles` Save => (Ex h Save) -> h ? ()
save :: forall h. Handles h Save => Ex h Save -> h ? ()
save Ex h Save
s = forall {k1} {k2} h (op :: k1 -> k2 -> *) (e :: k1) (u :: k2).
(Handles h op, e ~ Ex h op) =>
op e u -> h ? Return (op e u)
whynot (forall e u s. (e ~ s, u ~ ()) => s -> Save e u
Save Ex h Save
s)

data Edit (e :: Type) (u :: Type) = forall s. (e ~ s, u ~ ()) => Edit (s -> s)
type instance Return (Edit s ()) = ()

edit :: (h `Handles` Edit, s ~ Ex h Edit) => (s -> s) -> h ? ()
edit :: forall h s. (Handles h Edit, s ~ Ex h Edit) => (s -> s) -> h ? ()
edit s -> s
f = forall {k1} {k2} h (op :: k1 -> k2 -> *) (e :: k1) (u :: k2).
(Handles h op, e ~ Ex h op) =>
op e u -> h ? Return (op e u)
whynot (forall e u s. (e ~ s, u ~ ()) => (s -> s) -> Edit e u
Edit s -> s
f)

-- | Computations which may 'load' or 'save' an implicit, dynamic state value.
type Stateful s a = forall h.
  ( h `Handles` Load
  , h `Handles` Save
  , h `Handles` Edit
  , s ~ Ex h Load
  , s ~ Ex h Save
  , s ~ Ex h Edit )
  => h ? a

-- | An endofunctor corresponding to 'Stateful' effect handlers.
newtype StateHandler (s :: Type) (a :: Type) = StateHandler s
-- a coeffect comonad is hiding above 0_0
type instance Result (StateHandler s a) = (s, a)

-- | 'StateHandler' fulfills the 'Load' operation.
instance ((StateHandler s a) `Handles` Load) where
  type Ex (StateHandler s a) Load = s
  clause :: forall e u.
(e ~ Ex (StateHandler s a) Load) =>
Load e u
-> (Return (Load e u)
    -> StateHandler s a -> Result (StateHandler s a))
-> StateHandler s a
-> Result (StateHandler s a)
clause Load e u
Load Return (Load e u) -> StateHandler s a -> Result (StateHandler s a)
k (StateHandler s
s) = Return (Load e u) -> StateHandler s a -> Result (StateHandler s a)
k s
s (forall s a. s -> StateHandler s a
StateHandler s
s)

-- | 'StateHandler' also fulfills the 'Save' operation.
instance ((StateHandler s a) `Handles` Save) where
  type Ex (StateHandler s a) Save = s
  clause :: forall e u.
(e ~ Ex (StateHandler s a) Save) =>
Save e u
-> (Return (Save e u)
    -> StateHandler s a -> Result (StateHandler s a))
-> StateHandler s a
-> Result (StateHandler s a)
clause (Save s
s) Return (Save e u) -> StateHandler s a -> Result (StateHandler s a)
k StateHandler s a
_ = Return (Save e u) -> StateHandler s a -> Result (StateHandler s a)
k () (forall s a. s -> StateHandler s a
StateHandler s
s)

instance ((StateHandler s a) `Handles` Edit) where
  type Ex (StateHandler s a) Edit = s
  clause :: forall e u.
(e ~ Ex (StateHandler s a) Edit) =>
Edit e u
-> (Return (Edit e u)
    -> StateHandler s a -> Result (StateHandler s a))
-> StateHandler s a
-> Result (StateHandler s a)
clause (Edit s -> s
f) Return (Edit e u) -> StateHandler s a -> Result (StateHandler s a)
k (StateHandler s
s) = Return (Edit e u) -> StateHandler s a -> Result (StateHandler s a)
k () (forall s a. s -> StateHandler s a
StateHandler (s -> s
f s
s))

-- | Handles 'Stateful' computations. Usage:
--
-- >>> let (nine, three) = state_handler 3 (load >>= \n -> save (n * n) >> return n)
-- >>> nine
-- 9
-- >>> three
-- 3
state_handler :: s -> (StateHandler s a) ? a -> (s, a)
state_handler :: forall s a. s -> (StateHandler s a ? a) -> (s, a)
state_handler s
s StateHandler s a ? a
comp =
  forall h a. (h ? a) -> (a -> h -> Result h) -> h -> Result h
handle StateHandler s a ? a
comp (\a
v (StateHandler s
s) -> (s
s, a
v)) (forall s a. s -> StateHandler s a
StateHandler s
s)

-- | A "forwarding" state-handler.
newtype FStateHandler (h :: Type) (s :: Type) (a :: Type) = FStateHandler s
type instance Result (FStateHandler h s a) = a

instance (FStateHandler h s a) `Handles` Load where
  type Ex (FStateHandler h s a) Load = s
  clause :: forall e u.
(e ~ Ex (FStateHandler h s a) Load) =>
Load e u
-> (Return (Load e u)
    -> FStateHandler h s a -> Result (FStateHandler h s a))
-> FStateHandler h s a
-> Result (FStateHandler h s a)
clause Load e u
Load Return (Load e u)
-> FStateHandler h s a -> Result (FStateHandler h s a)
k (FStateHandler s
s) = Return (Load e u)
-> FStateHandler h s a -> Result (FStateHandler h s a)
k s
s (forall h s a. s -> FStateHandler h s a
FStateHandler s
s)

instance (FStateHandler h s a) `Handles` Save where
  type Ex (FStateHandler h s a) Save = s
  clause :: forall e u.
(e ~ Ex (FStateHandler h s a) Save) =>
Save e u
-> (Return (Save e u)
    -> FStateHandler h s a -> Result (FStateHandler h s a))
-> FStateHandler h s a
-> Result (FStateHandler h s a)
clause (Save s
s) Return (Save e u)
-> FStateHandler h s a -> Result (FStateHandler h s a)
k FStateHandler h s a
_ = Return (Save e u)
-> FStateHandler h s a -> Result (FStateHandler h s a)
k () (forall h s a. s -> FStateHandler h s a
FStateHandler s
s)

-- | A state-handler which forwards unsupported operations to another handler. Usage:
--
-- >>> (nine, unit) <- f_state_handler 3 (load >>= \n -> save (n * n))
-- >>> nine
-- 9
-- >>> unit
-- ()
f_state_handler
  :: Monad m
  => a
  -> CPS (m (a, b)) ((->) (FStateHandler h a (m (a, b)))) b
  -> m (a, b)
f_state_handler :: forall (m :: * -> *) a b h.
Monad m =>
a
-> CPS (m (a, b)) ((->) (FStateHandler h a (m (a, b)))) b
-> m (a, b)
f_state_handler a
s CPS (m (a, b)) ((->) (FStateHandler h a (m (a, b)))) b
comp = forall h a. (h ? a) -> (a -> h -> Result h) -> h -> Result h
handle CPS (m (a, b)) ((->) (FStateHandler h a (m (a, b)))) b
comp (\b
v (FStateHandler a
s) -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
s, b
v)) (forall h s a. s -> FStateHandler h s a
FStateHandler a
s)

-- | Operation to 'throw' a specified value in 'Except'ional circumstances.
data Throw (e :: Type) (u :: Type) = forall err a. (e ~ err, u ~ a) => Throw err
type instance Return (Throw err a) = a

throw :: h `Handles` Throw => (Ex h Throw) -> h ? a
throw :: forall h a. Handles h Throw => Ex h Throw -> h ? a
throw Ex h Throw
m = forall {k1} {k2} h (op :: k1 -> k2 -> *) (e :: k1) (u :: k2).
(Handles h op, e ~ Ex h op) =>
op e u -> h ? Return (op e u)
whynot (forall e u err a. (e ~ err, u ~ a) => err -> Throw e u
Throw Ex h Throw
m)

-- | A computation which evaluates to 'a' 'Except' for 'err'ors.
type Except err a = forall h.
  ( h `Handles` Throw
  , Ex h Throw ~ err )
  => h ? a

-- | This handler 'Result's in 'Either' an 'err' value or answer 'a'.
newtype ExceptHandler (err :: Type) (a :: Type) = ExceptHandler ()
type instance Result (ExceptHandler err a) = Either err a
instance (ExceptHandler err a) `Handles` Throw where
  type Ex (ExceptHandler err a) Throw = err
  clause :: forall e u.
(e ~ Ex (ExceptHandler err a) Throw) =>
Throw e u
-> (Return (Throw e u)
    -> ExceptHandler err a -> Result (ExceptHandler err a))
-> ExceptHandler err a
-> Result (ExceptHandler err a)
clause (Throw err
m) Return (Throw e u)
-> ExceptHandler err a -> Result (ExceptHandler err a)
_ (ExceptHandler ()
_) = forall a b. a -> Either a b
Left err
m

-- | Evaluates an exception-handling computation.
except_handler :: (ExceptHandler err a ? a) -> Either err a
except_handler :: forall err a. (ExceptHandler err a ? a) -> Either err a
except_handler ExceptHandler err a ? a
comp = forall h a. (h ? a) -> (a -> h -> Result h) -> h -> Result h
handle ExceptHandler err a ? a
comp (\a
v ExceptHandler err a
_ -> forall a b. b -> Either a b
Right a
v) (forall err a. () -> ExceptHandler err a
ExceptHandler ())

-- | A more conventional 'throw'-receiving idiom.
catch :: Monad m => (ExceptHandler err a ? a) -> (err -> m a) -> m a
catch :: forall (m :: * -> *) err a.
Monad m =>
(ExceptHandler err a ? a) -> (err -> m a) -> m a
catch ExceptHandler err a ? a
comp err -> m a
hndl = case forall err a. (ExceptHandler err a ? a) -> Either err a
except_handler ExceptHandler err a ? a
comp of
  Left err
err -> err -> m a
hndl err
err
  Right a
v -> forall (m :: * -> *) a. Monad m => a -> m a
return a
v


-- | With a little elbow grease this could be derived automatically.
type StatefulExcept err s a = forall h.
  ( h `Handles` Load, Ex h Load ~ s
  , h `Handles` Save, Ex h Save ~ s
  , h `Handles` Throw, Ex h Throw ~ err)
  => h ? a

-- | Example computation combining 'Stateful' and 'Except' effects, which were
-- defined in a separate module.
-- The parlor trick here is that this type-checks without defining any handlers,
-- combining 3 operations from 2 distinct effect types with existing,
-- independent handlers.
ex1 :: StatefulExcept String Int Bool
ex1 :: StatefulExcept String Int Bool
ex1 = do
  Int
n <- forall h. Handles h Load => h ? Ex h Load
load
  if Int
0 forall a. Ord a => a -> a -> Bool
>= Int
n
    then forall h a. Handles h Throw => Ex h Throw -> h ? a
throw String
"error"
    else forall h. Handles h Save => Ex h Save -> h ? ()
save (Int
n forall a. Num a => a -> a -> a
- Int
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0 forall a. Eq a => a -> a -> Bool
== Int
n forall a. Integral a => a -> a -> a
`mod` Int
2)

-- | Interprets 'StatefulExcept' @err s a@ as the type @s -> (s, Either err a)@.
newtype StateExceptHandler (err :: Type) (s :: Type) (a :: Type) = SEH s
type instance Result (StateExceptHandler err s a) = (s, Either err a)

instance (StateExceptHandler err s a) `Handles` Load where
  type Ex (StateExceptHandler err s a) Load = s
  clause :: forall e u.
(e ~ Ex (StateExceptHandler err s a) Load) =>
Load e u
-> (Return (Load e u)
    -> StateExceptHandler err s a
    -> Result (StateExceptHandler err s a))
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
clause Load e u
Load Return (Load e u)
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
k (SEH s
s) = Return (Load e u)
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
k s
s (forall err s a. s -> StateExceptHandler err s a
SEH s
s)

instance (StateExceptHandler err s a) `Handles` Save where
  type Ex (StateExceptHandler err s a) Save = s
  clause :: forall e u.
(e ~ Ex (StateExceptHandler err s a) Save) =>
Save e u
-> (Return (Save e u)
    -> StateExceptHandler err s a
    -> Result (StateExceptHandler err s a))
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
clause (Save s
s) Return (Save e u)
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
k StateExceptHandler err s a
_ = Return (Save e u)
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
k () (forall err s a. s -> StateExceptHandler err s a
SEH s
s)

instance (StateExceptHandler err s a) `Handles` Throw where
  type Ex (StateExceptHandler err s a) Throw = err
  clause :: forall e u.
(e ~ Ex (StateExceptHandler err s a) Throw) =>
Throw e u
-> (Return (Throw e u)
    -> StateExceptHandler err s a
    -> Result (StateExceptHandler err s a))
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
clause (Throw err
m) Return (Throw e u)
-> StateExceptHandler err s a
-> Result (StateExceptHandler err s a)
_ (SEH s
s) = (s
s, forall a b. a -> Either a b
Left err
m)

-- | A handler for both 'Stateful' and 'Except'ional computations.
-- If the typeclass instances above are the case-statements for different
-- effects, this is more or less the case-statement for "return" / termination.
state_except_handler
  :: s
  -> (StateExceptHandler err s a ? a)
  -> (s, Either err a)
state_except_handler :: forall s err a.
s -> (StateExceptHandler err s a ? a) -> (s, Either err a)
state_except_handler s
s StateExceptHandler err s a ? a
comp = forall h a. (h ? a) -> (a -> h -> Result h) -> h -> Result h
handle StateExceptHandler err s a ? a
comp (\a
v (SEH s
s) -> (s
s, forall a b. b -> Either a b
Right a
v)) (forall err s a. s -> StateExceptHandler err s a
SEH s
s)

-- |
--
-- >>> effects_demo
-- (0,Right ())
-- (0,Left "error")
effects_demo :: IO ()
effects_demo :: IO ()
effects_demo = do
  String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall s err a.
s -> (StateExceptHandler err s a ? a) -> (s, Either err a)
state_except_handler Int
1 StatefulExcept String Int Bool
ex1
  String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall s err a.
s -> (StateExceptHandler err s a ? a) -> (s, Either err a)
state_except_handler Int
0 StatefulExcept String Int Bool
ex1

-- * Sheets demo

-- | A 'Cell' is either "on" ('I') or "off" ('O').
data Cell = I | O deriving (Cell -> Cell -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cell -> Cell -> Bool
$c/= :: Cell -> Cell -> Bool
== :: Cell -> Cell -> Bool
$c== :: Cell -> Cell -> Bool
Eq, Int -> Cell -> ShowS
[Cell] -> ShowS
Cell -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cell] -> ShowS
$cshowList :: [Cell] -> ShowS
show :: Cell -> String
$cshow :: Cell -> String
showsPrec :: Int -> Cell -> ShowS
$cshowsPrec :: Int -> Cell -> ShowS
Show)

-- | A background pattern to evaluate in our CA
bg_pattern :: [Cell]
bg_pattern :: [Cell]
bg_pattern = [ Cell
O, Cell
O, Cell
O, Cell
I, Cell
O, Cell
O, Cell
I, Cell
I, Cell
O, Cell
I, Cell
I, Cell
I, Cell
I, Cell
I]

-- | Lifts a list of 'Cell's into a 'Tape'.
tape_from_pattern :: [Cell] -> Tape Cell
tape_from_pattern :: [Cell] -> Tape Cell
tape_from_pattern [Cell]
ptn =
  forall c a.
(c -> (a, c)) -> (c -> a) -> (c -> (a, c)) -> c -> Tape a
unfold
    ((Int -> Int) -> Int -> (Cell, Int)
go forall a. Enum a => a -> a
pred)
    ([Cell]
ptn forall a. [a] -> Int -> a
!!)
    ((Int -> Int) -> Int -> (Cell, Int)
go forall a. Enum a => a -> a
succ)
    Int
0
  where go :: (Int -> Int) -> Int -> (Cell, Int)
go Int -> Int
k Int
n = (([Cell]
ptn forall a. [a] -> Int -> a
!!) forall t a b. (t -> a) -> (t -> b) -> t -> (a, b)
&&& forall a. a -> a
id) ((Int -> Int
k Int
n) forall a. Integral a => a -> a -> a
`mod` (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cell]
ptn))

-- | The 2-dimensional cellular automaton "rule 110."
-- To evaluate one time-step, each cell along with its immediate left and right
-- neighbors is used to determine that cell's next value (@proceed@ below).
-- I believe it is the simplest Turing-complete CA.
rule110 :: Sheet2 Cell -> Cell
rule110 :: Sheet2 Cell -> Cell
rule110 Sheet2 Cell
me = Cell -> Cell -> Cell -> Cell
proceed Cell
l Cell
c Cell
r where
  (Cell
l:Cell
c:Cell
r:[Cell]
_) = forall (t :: * -> *) (w :: * -> *) r a.
(Traversable t, Comonad w, Go r w) =>
t (RefList r) -> w a -> t a
cells (forall a b. (a -> b) -> [a] -> [b]
map (RefList ('Relative :-: ('Relative :-: Nil))
above forall as bs.
CombineRefLists as bs =>
RefList as -> RefList bs -> RefList (as & bs)
&) [ RefList ('Relative :-: Nil)
left, RefList ('Relative :-: Nil)
here1, RefList ('Relative :-: Nil)
right ]) Sheet2 Cell
me
  proceed :: Cell -> Cell -> Cell -> Cell
proceed Cell
I Cell
I Cell
I = Cell
O
  proceed Cell
I Cell
O Cell
O = Cell
O
  proceed Cell
O Cell
O Cell
O = Cell
O
  proceed Cell
_ Cell
_ Cell
_ = Cell
I

-- | A 2-dimensional sheet ('Sheet2').
-- Each 'Cell' of the 'Sheet2' is a function which transforms a 'Sheet2' of
-- 'Cell's into a new value for that 'Cell'.
ether :: Sheet2 (Sheet2 Cell -> Cell)
ether :: Sheet2 (Sheet2 Cell -> Cell)
ether = forall (l :: * -> *) (t :: * -> *) x a.
(InsertNested l t, Applicative t, DimensionalAs x (t a),
 AsDimensionalAs x (t a) ~ l a) =>
a -> x -> t a
sheet Sheet2 Cell -> Cell
rule110 [ forall a b. a -> b -> a
const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cell] -> Tape Cell
tape_from_pattern [Cell]
bg_pattern ]

-- | This lifts a pattern of 'Cell' values into a 2-dimensional spreadsheet.
prepare :: [Cell] -> Sheet2 (Sheet2 Cell -> Cell)
prepare :: [Cell] -> Sheet2 (Sheet2 Cell -> Cell)
prepare [Cell]
ptn = forall {k} x (t :: k -> *) (a :: k) (l :: k -> *).
(DimensionalAs x (t a), InsertNested l t,
 AsDimensionalAs x (t a) ~ l a) =>
x -> t a -> t a
insert [ forall a b. a -> b -> a
const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cell]
ptn ] Sheet2 (Sheet2 Cell -> Cell)
ether

-- | Prints a given slice of the output stream, which represents the evolution
-- of the 2-D spreadsheet over time.
print_automaton
  :: Int
  -> Int
  -> Sheet2 (Sheet2 Cell -> Cell)
  -> IO ()
print_automaton :: Int -> Int -> Sheet2 (Sheet2 Cell -> Cell) -> IO ()
print_automaton Int
dx Int
dt = [[Cell]] -> IO ()
display forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nested (N (F Tape) Tape) Cell
-> ListFrom (Nested (N (F Tape) Tape)) Cell
selectionFrom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: * -> *) a. ComonadApply w => w (w a -> a) -> w a
evaluate where
  display :: [[Cell]] -> IO ()
display = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cell] -> String
frame)
  frame :: [Cell] -> String
frame = forall a. a -> [a] -> [a]
intersperse Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a -> Bool -> a
bool Char
' ' Char
'●' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cell
I forall a. Eq a => a -> a -> Bool
==))
  selectionFrom :: Nested (N (F Tape) Tape) Cell
-> ListFrom (Nested (N (F Tape) Tape)) Cell
selectionFrom = forall r (t :: * -> *) a.
Take r t =>
RefList r -> t a -> ListFrom t a
take (Int -> RefList ('Relative :-: Nil)
rightBy Int
dx forall as bs.
CombineRefLists as bs =>
RefList as -> RefList bs -> RefList (as & bs)
& Int -> RefList ('Relative :-: ('Relative :-: Nil))
belowBy Int
dt)

{-
print_automaton' :: Int -> Int -> Sheet2 (Sheet2 Cell -> Cell) -> [[Cell]]
print_automaton' dx dt = selectionFrom . evaluate where
  selectionFrom = take (rightBy dx & belowBy dt)
-}

-- | Constructs an interesting-ish Rule 110 scenario and prints a slice of the
-- output stream, showing the time-evolution of a 2-D spreadsheet.
-- This aims 'son_a' and 'son_b' at each other. They collide, entangle, and then
-- disentangle in swapped places.
sheets_demo :: IO ()
sheets_demo :: IO ()
sheets_demo = Int -> Int -> Sheet2 (Sheet2 Cell -> Cell) -> IO ()
print_automaton Int
80 Int
2000 forall a b. (a -> b) -> a -> b
$
  forall {k} r (t :: k -> *) (a :: k).
Go r t =>
RefList r -> t a -> t a
go (Int -> RefList ('Relative :-: Nil)
leftBy Int
10) forall a b. (a -> b) -> a -> b
$ [Cell] -> Sheet2 (Sheet2 Cell -> Cell)
prepare forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Cell]
son_a
    , [Cell]
bg_pattern
    , [Cell]
bg_pattern
    , [Cell]
bg_pattern
    , [Cell]
son_b ]

sheets_demo_A :: IO ()
sheets_demo_A :: IO ()
sheets_demo_A = Int -> Int -> Sheet2 (Sheet2 Cell -> Cell) -> IO ()
print_automaton Int
80 Int
200 forall a b. (a -> b) -> a -> b
$
  forall {k} r (t :: k -> *) (a :: k).
Go r t =>
RefList r -> t a -> t a
go (Int -> RefList ('Relative :-: Nil)
leftBy Int
10) forall a b. (a -> b) -> a -> b
$ [Cell] -> Sheet2 (Sheet2 Cell -> Cell)
prepare forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Cell]
son_a ]

sheets_demo_B :: IO ()
sheets_demo_B :: IO ()
sheets_demo_B = Int -> Int -> Sheet2 (Sheet2 Cell -> Cell) -> IO ()
print_automaton Int
80 Int
200 forall a b. (a -> b) -> a -> b
$
  forall {k} r (t :: k -> *) (a :: k).
Go r t =>
RefList r -> t a -> t a
go (Int -> RefList ('Relative :-: Nil)
leftBy Int
10) forall a b. (a -> b) -> a -> b
$ [Cell] -> Sheet2 (Sheet2 Cell -> Cell)
prepare forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Cell]
bg_pattern
    , [Cell]
bg_pattern
    , [Cell]
bg_pattern
    , [Cell]
son_b ]

sheets_demo_blank :: IO ()
sheets_demo_blank :: IO ()
sheets_demo_blank = Int -> Int -> Sheet2 (Sheet2 Cell -> Cell) -> IO ()
print_automaton Int
80 Int
200 forall a b. (a -> b) -> a -> b
$
  forall {k} r (t :: k -> *) (a :: k).
Go r t =>
RefList r -> t a -> t a
go (Int -> RefList ('Relative :-: Nil)
leftBy Int
10) forall a b. (a -> b) -> a -> b
$ [Cell] -> Sheet2 (Sheet2 Cell -> Cell)
prepare []

-- | Some 'Cell' patterns which happen to be interesting in Rule 110.
son_a, son_b, son_c :: [Cell]
son_a :: [Cell]
son_a = [Cell
O, Cell
O, Cell
O, Cell
I, Cell
I, Cell
I, Cell
O, Cell
I, Cell
I, Cell
I]
son_b :: [Cell]
son_b = [Cell
I, Cell
O, Cell
O, Cell
I, Cell
I, Cell
I, Cell
I]
son_c :: [Cell]
son_c = [Cell
I, Cell
I, Cell
I]

-- * representable indexed sheets ... fiddling
ish2D :: ISheet2 (Int, Int)
ish2D :: ISheet2 (Int, Int)
ish2D = forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\(Int
col ::: Int
row ::: Counted t Int
_) -> (Int
row, Int
col))

sh2D :: Sheet2 (Int, Int)
sh2D :: Sheet2 (Int, Int)
sh2D = forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\(Int
col ::: Int
row ::: Counted t Int
_) -> (Int
row, Int
col))

type Grid = Store Sheet2
type Coord = Counted Nat2 Int

fromPair :: (Int, Int) -> Coord
fromPair :: (Int, Int) -> Coord
fromPair ~(Int
x, Int
y) = Int
y forall n a t. (n ~ S t) => a -> Counted t a -> Counted n a
::: Int
x forall n a t. (n ~ S t) => a -> Counted t a -> Counted n a
::: forall n a. (n ~ Z) => Counted n a
CountedNil

mkGrid :: [Coord] -> Grid Bool
mkGrid :: [Coord] -> Grid Bool
mkGrid [Coord]
xs = forall (g :: * -> *) a.
Representable g =>
(Rep g -> a) -> Rep g -> Store g a
store Coord -> Bool
lookup Coord
focus where
  focus :: Coord
focus = (Int, Int) -> Coord
fromPair (Int
0, Int
0)
  lookup :: Coord -> Bool
lookup Coord
crd = Coord
crd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Coord]
xs

unGrid :: Grid a -> ISheet2 a
unGrid :: forall a. Grid a -> ISheet2 a
unGrid ~(StoreT ~(Identity Sheet2 a
sh) Rep (Nested (NestedNTimes Nat2 Tape))
crd) = forall ts a.
Coordinate (NestedCount ts) -> Nested ts a -> Indexed ts a
Indexed (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: RefType). (t ~ 'Absolute) => Int -> Ref t
Abs Rep (Nested (NestedNTimes Nat2 Tape))
crd) Sheet2 a
sh

type Rule = Grid Bool -> Bool

neighborCoords :: [Coord]
neighborCoords :: [Coord]
neighborCoords=
  [ (Int, Int) -> Coord
fromPair (Int
x, Int
y)
  | Int
x <- [-Int
1, Int
0, Int
1]
  , Int
y <- [-Int
1, Int
0, Int
1]
  , (Int
x, Int
y) forall a. Eq a => a -> a -> Bool
/= (Int
0, Int
0) ]

basicRule :: Rule
basicRule :: Rule
basicRule !Grid Bool
g =
  (Bool
alive Bool -> Bool -> Bool
&& Int
aliveNbors forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
2, Int
3]) Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
alive Bool -> Bool -> Bool
&& Int
aliveNbors forall a. Eq a => a -> a -> Bool
== Int
3)
  where
    alive :: Bool
alive = forall (w :: * -> *) a. Comonad w => w a -> a
extract Grid Bool
g
    addCoords :: Coord -> Coord -> Coord
    addCoords :: Coord -> Coord -> Coord
addCoords (Int
y ::: Int
x ::: Counted t Int
_) (Int
y' ::: Int
x' ::: Counted t Int
_) =
      (Int
y forall a. Num a => a -> a -> a
+ Int
y') forall n a t. (n ~ S t) => a -> Counted t a -> Counted n a
::: (Int
x forall a. Num a => a -> a -> a
+ Int
x') forall n a t. (n ~ S t) => a -> Counted t a -> Counted n a
::: forall n a. (n ~ Z) => Counted n a
CountedNil
    neighbors :: [Bool]
neighbors = forall s (w :: * -> *) (f :: * -> *) a.
(ComonadStore s w, Functor f) =>
(s -> f s) -> w a -> f a
experiment (\Coord
s -> Coord -> Coord -> Coord
addCoords Coord
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Coord]
neighborCoords) Grid Bool
g
    aliveNbors :: Int
aliveNbors = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter forall a. a -> a
id [Bool]
neighbors)

glider, blinker, beacon :: [Coord]
glider :: [Coord]
glider = (Int, Int) -> Coord
fromPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int
1, Int
0), (Int
2, Int
1), (Int
0, Int
2), (Int
1, Int
2), (Int
2, Int
2)]
blinker :: [Coord]
blinker = (Int, Int) -> Coord
fromPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int
0, Int
0), (Int
1, Int
0), (Int
2, Int
0)]
beacon :: [Coord]
beacon = (Int, Int) -> Coord
fromPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int
0, Int
0), (Int
1, Int
0), (Int
0, Int
1), (Int
3, Int
2), (Int
2, Int
3), (Int
3, Int
3)]

at :: [Coord] -> (Int, Int) -> [Coord]
at :: [Coord] -> (Int, Int) -> [Coord]
at [Coord]
xs ~(Int
x, Int
y) =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  (((Int, Int) -> Coord
fromPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Num a => a -> a -> a
+ Int
x) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (forall a. Num a => a -> a -> a
+ Int
y)))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (Int
y' ::: Int
x' ::: Counted t Int
_) -> (Int
x', Int
y')))
  [Coord]
xs

start :: Grid Bool
start :: Grid Bool
start = [Coord] -> Grid Bool
mkGrid forall a b. (a -> b) -> a -> b
$
     [Coord]
glider [Coord] -> (Int, Int) -> [Coord]
`at` (Int
0, Int
0)
  forall a. [a] -> [a] -> [a]
++ [Coord]
beacon [Coord] -> (Int, Int) -> [Coord]
`at` (Int
15, Int
5)
  forall a. [a] -> [a] -> [a]
++ [Coord]
blinker [Coord] -> (Int, Int) -> [Coord]
`at` (Int
16, Int
4)

render :: Grid Bool -> String
render :: Grid Bool -> String
render Grid Bool
grid =
  forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$
  forall r' (t :: * -> *) r a.
(Take r' t, Go r t) =>
RefList r -> RefList r' -> t a -> ListFrom t a
slice (Int -> RefList ('Relative :-: ('Relative :-: Nil))
aboveBy Int
2 forall as bs.
CombineRefLists as bs =>
RefList as -> RefList bs -> RefList (as & bs)
& Int -> RefList ('Relative :-: Nil)
leftBy Int
2) (Int -> RefList ('Relative :-: ('Relative :-: Nil))
belowBy Int
23 forall as bs.
CombineRefLists as bs =>
RefList as -> RefList bs -> RefList (as & bs)
& Int -> RefList ('Relative :-: Nil)
rightBy Int
12) forall a b. (a -> b) -> a -> b
$
  forall a. Grid a -> ISheet2 a
unGrid forall a b. (a -> b) -> a -> b
$
  (forall a. a -> a -> Bool -> a
bool String
"." String
"#") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  Grid Bool
grid

tickTime :: Int
tickTime :: Int
tickTime = Int
200000

lifeSim :: IO ()
lifeSim :: IO ()
lifeSim = (Grid Bool -> Grid Bool) -> Grid Bool -> IO ()
lifeLoop (forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend Rule
basicRule) Grid Bool
start

lifeLoop :: (Grid Bool -> Grid Bool) -> Grid Bool -> IO ()
lifeLoop :: (Grid Bool -> Grid Bool) -> Grid Bool -> IO ()
lifeLoop Grid Bool -> Grid Bool
stepper Grid Bool
g = do
  String -> IO ()
putStr String
"\ESC[2J" -- clear terminal
  String -> IO ()
putStrLn (Grid Bool -> String
render Grid Bool
g)
  Int -> IO ()
threadDelay Int
tickTime
  (Grid Bool -> Grid Bool) -> Grid Bool -> IO ()
lifeLoop Grid Bool -> Grid Bool
stepper (Grid Bool -> Grid Bool
stepper Grid Bool
g)