CoAlgebraPrompts.hs

module Main where

--------------------------------------------------------------------------------

import Data.Distributive
import Data.Foldable
import Data.Functor.Rep
import Data.Machine.Moore
import Control.Comonad.Cofree

--------------------------------------------------------------------------------

main :: IO ()
main =
 -- coalgMain
 -- mooreMain
 -- cofreeMain
 -- cofreeRepMain
 -- cofreeMain'
  cofreeRepMain'
--------------------------------------------------------------------------------

data PromptState = PromptState
  { prompt :: String
  , choices :: [String]
  , highlighted :: Int
  , halt :: Maybe String
  } deriving (Show)

data Command = Up | Down | Choose

parseCommand :: String -> Command
parseCommand "u" = Up
parseCommand "d" = Down
parseCommand "" = Choose
parseCommand _ = undefined


highlight :: Int -> [String] -> [String]
highlight _ [] = []
highlight 0 (x:xs) = ("* " <> x) : xs
highlight n (x:xs) = x : highlight (n-1) xs

--------------------------------------------------------------------------------
-- Direct use of a Co-Algebra

data InteractionF next = Input (Command -> next)
  deriving stock Functor

type CoAlgebra f s = s -> f s

interactionStep :: CoAlgebra InteractionF PromptState
interactionStep ps@(PromptState {..}) = Input $ \case
  Up -> ps { highlighted = (highlighted - 1) `mod` length choices }
  Down -> ps { highlighted = (highlighted + 1) `mod` length choices }
  Choose -> ps { halt = Just $ "You chose: " <> (choices !! highlighted) }

runInteraction :: PromptState -> IO ()
runInteraction state = do
  case halt state of
    Just msg -> putStrLn msg
    Nothing -> do
      let Input next = interactionStep state
      putStrLn $ prompt state
      traverse_ putStrLn (highlight (highlighted state) $ choices state)

      nextInput <- getLine
      runInteraction (next $ parseCommand nextInput)

coalgMain :: IO ()
coalgMain = do
  let choices = ["red", "green", "blue"]
  runInteraction $ PromptState "Pick a color" choices 0 Nothing

--------------------------------------------------------------------------------
-- Moore

mkMoore :: PromptState -> Moore Command PromptState
mkMoore s = flip unfoldMoore s $ \ps@PromptState {..} ->
  let next :: Command -> PromptState
      next = \case
        Up -> ps { highlighted = (highlighted - 1) `mod` length choices }
        Down -> ps { highlighted = (highlighted + 1) `mod` length choices }
        Choose -> ps { halt = Just $ "You chose: " <> (choices !! highlighted) }
   in (ps, next) 

runMoore :: Moore Command PromptState -> IO ()
runMoore (Moore ps next) = 
  case halt ps of
    Just msg -> putStrLn msg
    Nothing -> do
      putStrLn $ prompt ps
      traverse_ putStrLn (highlight (highlighted ps) $ choices ps)

      nextInput <- getLine
      runMoore (next $ parseCommand nextInput)

mooreMain :: IO ()
mooreMain = do
  let choices = ["red", "green", "blue"]
  runMoore $ mkMoore $ PromptState "Pick a color" choices 0 Nothing

--------------------------------------------------------------------------------
-- Cofree

data CommandF a = 
  CommandF {up :: a, down :: a, choose :: a}
  deriving stock (Functor)

mkCofree :: PromptState -> Cofree CommandF PromptState
mkCofree ps@PromptState {..} = ps :< CommandF
  { up = mkCofree $ ps { highlighted = (highlighted - 1) `mod` length choices },
    down = mkCofree $ ps { highlighted = (highlighted + 1) `mod` length choices },
    choose = mkCofree $ ps { halt = Just $ "You chose: " <> (choices !! highlighted) }
  }

runCofree :: Cofree CommandF PromptState -> IO ()
runCofree (ps :< next) =
  case halt ps of
    Just msg -> putStrLn msg
    Nothing -> do
      putStrLn $ prompt ps
      traverse_ putStrLn (highlight (highlighted ps) $ choices ps)

      nextInput <- getLine
      case parseCommand nextInput of 
        Up -> runCofree (up next)
        Down -> runCofree (down next)
        Choose -> runCofree (choose next)

cofreeMain :: IO ()
cofreeMain = do
  let choices = ["red", "green", "blue"]
  runCofree $ mkCofree $ PromptState "Pick a color" choices 0 Nothing

--------------------------------------------------------------------------------
-- Cofree with Representable

instance Distributive CommandF where
  distribute m =
    CommandF 
      { up = fmap up m,
        down = fmap down m,
        choose = fmap choose m
      }

instance Representable CommandF where
  type Rep CommandF = Command

  index CommandF {..} = \case
    Up -> up
    Down -> down
    Choose -> choose
  tabulate f = 
    CommandF 
      { up = f Up,
        down = f Down,
        choose = f Choose
      }

step :: PromptState -> Command -> PromptState
step ps@PromptState {..} = \case
  Up -> ps { highlighted = (highlighted - 1) `mod` length choices }
  Down -> ps { highlighted = (highlighted + 1) `mod` length choices }
  Choose -> ps { halt = Just $ "You chose: " <> (choices !! highlighted) }

mkCofreeRep :: PromptState -> Cofree CommandF PromptState
mkCofreeRep ps = ps :< (mkCofreeRep <$> tabulate (step ps))

cofreeRepMain :: IO ()
cofreeRepMain = do
  let choices = ["red", "green", "blue"]
  runCofree $ mkCofreeRep $ PromptState "Pick a color" choices 0 Nothing

--------------------------------------------------------------------------------
-- Cofree With Termination in the Co-Algebra

data CommandF' a = 
    CommandF' {up' :: a, down' :: a, choose' :: a}
  | TerminateF'
  deriving stock Functor

mkCofree' :: PromptState -> Cofree CommandF' PromptState
mkCofree' ps@PromptState {..} = ps :< CommandF'
  { up' = mkCofree' $ ps { highlighted = (highlighted - 1) `mod` length choices },
    down' = mkCofree' $ ps { highlighted = (highlighted + 1) `mod` length choices },
    choose' = ps :< TerminateF'
  }

runCofree' :: Cofree CommandF' PromptState -> IO ()
runCofree' (ps@PromptState {..} :< next) =
  case next of
    TerminateF' -> putStrLn $ "You chose: " <> (choices !! highlighted)
    CommandF' {..} -> do
      putStrLn prompt
      traverse_ putStrLn (highlight highlighted choices)

      nextInput <- getLine
      case parseCommand nextInput of 
        Up -> runCofree' up'
        Down -> runCofree' down'
        Choose -> runCofree' choose'

cofreeMain' :: IO ()
cofreeMain' = do
  let choices = ["red", "green", "blue"]
  runCofree' $ mkCofree' $ PromptState "Pick a color" choices 0 Nothing

--------------------------------------------------------------------------------
-- Cofree With Termination in the Co-Algebra and Representable

instance Distributive CommandF' where
  distribute m =
    CommandF'
      { up' = fmap up' m,
        down' = fmap down' m,
        choose' = fmap choose' m
      }

instance Representable CommandF' where
  type Rep CommandF' = Command

  index CommandF' {..} = \case
    Up -> up'
    Down -> down'
    Choose -> choose'
  index TerminateF' = \case

  
  tabulate f = 
    CommandF' 
      { up' = f Up,
        down' = f Down,
        choose' = f Choose
      }

step' :: PromptState -> Command -> PromptState
step' ps@PromptState {..} = \case
  Up -> ps { highlighted = (highlighted - 1) `mod` length choices }
  Down -> ps { highlighted = (highlighted + 1) `mod` length choices }
  Choose -> ps { halt = Just $ "You chose: " <> (choices !! highlighted) }

mkCofreeRep' :: PromptState -> Cofree CommandF' PromptState
mkCofreeRep' ps = ps :< (mkCofreeRep' <$> tabulate (step' ps))

cofreeRepMain' :: IO ()
cofreeRepMain' = do
  let choices = ["red", "green", "blue"]
  runCofree' $ mkCofreeRep' $ PromptState "Pick a color" choices 0 Nothing