Hrm

Comonad.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wall #-}

-- $ nix-shell -p "haskellPackages.ghcWithPackages (pkgs: [ pkgs.random ])"
-- $ runhaskell Comonad.hs

module Main where

import Control.Monad (replicateM)
import Data.List (unfoldr, transpose)
import Prelude hiding (Monad)
import System.Random (randomIO)

type f ~> g = forall a. f a -> g a

type Id a = a

type (∘) f g a = f (g a)

class Functor m => Monad m where
  return :: Id ~> m
  join :: (m ∘ m) ~> m

bind :: Monad m => (a -> m b) -> m a -> m b
bind a2mb = join . fmap a2mb

class Functor w => Comonad w where
  extract :: w ~> Id
  duplicate :: w ~> (w ∘ w)

extend :: Comonad w => (w a -> b) -> w a -> w b
extend wa2b = fmap wa2b . duplicate

instance Monad ((->) r) where
  return = const
  join f r = f r r

data Zipper a = Zipper
  { lefts :: [a]
  , focus :: a
  , rights :: [a]
  } deriving (Show, Functor)

zipperToList :: Zipper ~> []
zipperToList z = lefts z ++ [focus z] ++ rights z

listToZipper :: [] ~> (Maybe ∘ Zipper)
listToZipper [] = Nothing
listToZipper (a : as) = Just $ Zipper [] a as

moveLeft :: Zipper ~> (Maybe ∘ Zipper)
moveLeft (Zipper [] _ _) = Nothing
moveLeft (Zipper (l : ls) a rs) = Just $ Zipper ls l (a : rs)

moveRight :: Zipper ~> (Maybe ∘ Zipper)
moveRight (Zipper _ _ []) = Nothing
moveRight (Zipper ls a (r : rs)) = Just $ Zipper (a : ls) r rs

instance Monad Zipper where
  return a = Zipper (repeat a) a (repeat a)
  join =
    Zipper
      <$> concatMap zipperToList . lefts
      <*> focus . focus
      <*> concatMap zipperToList . rights

instance Comonad Zipper where
  extract = focus
  duplicate =
    Zipper
      <$> unfoldr ((join (,) <$>) . moveLeft)
      <*> id
      <*> unfoldr ((join (,) <$>) . moveRight)

average :: (Foldable t, Fractional n) => t n -> n
average ns = sum ns / fromIntegral (length ns)

windowMovingAverage :: Int -> Zipper Double -> Double
windowMovingAverage n z =
  average $ take n (lefts z) ++ [focus z] ++ take n (rights z)

smooth :: [Double] -> [Double]
smooth = maybe [] (zipperToList . extend (windowMovingAverage 10)) . listToZipper

leftPad :: Int -> Char -> String -> String
leftPad n c str = replicate (n - length str) c <> str

showGraph :: Int -> Char -> Char -> [Int] -> String
showGraph y char fill = unlines . transpose . map (leftPad y fill . (`replicate` char))

main :: IO ()
main = do
  let x = 100
      y = 25
  example <- map (* fromIntegral y) <$> replicateM x (randomIO :: IO Double)
  putStrLn $ showGraph y '*' '.' $ map floor example
  putStrLn $ showGraph y '*' '.' $ map floor $ smooth example