comonad2.hs

#! /usr/bin/env nix-shell
#! nix-shell -p haskellPackages.ghcid
#! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [req casing comonad])"
#! nix-shell -i "ghcid -W -c 'ghci -Wall' -T main"

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module Coscala where

import Prelude
import Control.Monad.Trans.State
import Control.Comonad.Store
import Data.Functor.Identity
import Data.List

-- | The Pairing type class.
class Pairing m w | m -> w, w -> m where
  pair :: (a -> b -> c) -> m a -> w b -> c

-- | It's a list of values with a focused element.
data Strip a = Strip [a] Int
  deriving (Show, Functor)

-- | Here we can see that duplicate is a Strip of Strips each focused on a different element.
instance Comonad Strip where
  extract (Strip as n) = as !! n
  duplicate (Strip as n) = Strip focusEach n
    where
      focusEach = Strip as <$> [0 .. (length as - 1)]

-- | Shift a strip to the left...
shiftLeft :: Strip a -> Strip a
shiftLeft (Strip as 0) = Strip as (length as - 1)
shiftLeft (Strip as n) = Strip as (n - 1)

-- | And to the right!
shiftRight :: Strip a -> Strip a
shiftRight (Strip as n)
  | n == length as - 1 = Strip as 0
  | otherwise          = Strip as (n + 1)

-- | Wolfram rule30 to calculate a cell value.
w30 :: Strip Bool -> Strip Bool
w30 = extend $ \s ->
  let l = extract $ shiftLeft s
      m = extract s
      r = extract $ shiftRight s
  in
       (l     && not m && not r)
    || (not l &&     m &&     r)
    || (not l &&     m && not r)
    || (not l && not m     && r)

-- | A simple function to render a row.
renderRow :: Strip Bool -> String
renderRow (Strip as _) = fmap (\x -> if x then 'X' else ' ') as

-- | A starting seed.
seed1 :: Strip Bool
seed1 = Strip (replicate 30 False ++ [True] ++ replicate 30 False) 0

-- | We create a Strip piramid and render it.
main1 =
  again 30 seed1
  where
    again 0 v = print $ renderRow v
    again n v = do
      print $ renderRow v
      again (n-1) (w30 v)


-- | No we'll try a different approach to render
-- a series of Strips.
-- We use a State / Store Pairing.
instance Pairing (State s) (Store s) where
  pair f (StateT run) (StoreT get state) =
    let (a, next) = runIdentity $ run state
    in f a $ runIdentity get next

-- | Does select always have to be like this?
-- What are possible different uses?
select :: Pairing m w => m b -> w (w a) -> w a
select = pair (\_ wa -> wa)

-- | This is our Strip Store.
-- The (s -> a) function renders the Strips and we pass a starting state.
w :: Store [Strip Bool] String
w = StoreT (pure (intercalate "\n" . map renderRow)) [seed1]

-- | A way to manipulate the State.
actions :: Int -> State [Strip Bool] ()
actions 0 = pure ()
actions steps = do
  ls <- get
  modify (++ [w30 $ last ls])
  actions (steps - 1)

-- | Here we obtain the same as `main1` in a cooler (?) way.
main = do
  let (StoreT f s) = select (actions 30) (duplicate w)
  putStrLn $ runIdentity f s