FP practice

cw1.hs

-- module Kata (highAndLow) where

import Data.List (sort)

highAndLow :: String -> String
highAndLow input = case (firstAndLast $ sort $ numbers input) of Just (low, high) -> show high ++ " " ++ show low

numbers :: String -> [Int]
numbers = help []
  where
    help xs "" = xs
    help xs (' ':str) = help xs str
    help xs str = let (num, rest) = head (reads str) in help (num:xs) rest

firstAndLast :: [a] -> Maybe (a, a)
firstAndLast = help Nothing
  where
    help fl [] = fl
    help Nothing (x:xs) = help (Just (x, x)) xs
    help (Just (f, l)) (x:xs) = help (Just (f, x)) xs

fp1.hs

import qualified Prelude
import Prelude (
    error, undefined, fst, snd, id,
    Num(..), Int, Show, Eq, const, ($),
    Bool(..), (.), otherwise, Ord(..),
    Maybe(..), flip)


data List a = Nil | Cons a (List a) deriving (Show, Eq)

makeList :: [a] -> List a
makeList = Prelude.foldr Cons Nil

fromList :: List a -> [a]
fromList = listCata [] (:)

append :: List a -> List a -> List a
append as Nil         = as
append (Cons a as) bs = Cons a (append as bs)
append Nil bs         = bs


listCata :: b -> (a -> b -> b) -> List a -> b
-- listCata base _ Nil         = base
-- listCata base f (Cons i is) = f i (listCata base f is)
listCata base f = go
  where
    go Nil         = base
    go (Cons i is) = f i (go is)

data Cata a b = Cata {b :: b, f :: (a -> b -> b)}

cata :: Cata a b -> List a -> b
cata (Cata b f) = listCata b f


l1 :: List Int
l1 = Cons 3 (Cons 18 (Cons 12 (Cons 39 Nil)))

eg1 :: [Int]
eg1 = listCata [] (:) l1


lengthCata :: Cata a Int
lengthCata = Cata 0 (const (+1))

sumCata :: Num a => Cata a a
sumCata = Cata 0 (+)

filterCata :: (a -> Bool) -> Cata a (List a)
-- filterCata pred = Cata Nil (\a b -> if pred a then (Cons a b) else b)
filterCata = Cata Nil . (\pred a b -> if pred a then (Cons a b) else b)

mapCata :: (a -> b) -> Cata a (List b)
mapCata = Cata Nil . (.) Cons
-- mapCata = Cata Nil . (\f a b -> Cons (f a) b)

length :: List a -> Int
length = cata lengthCata -- listCata 0 (const (+1))

sum :: Num a => List a -> a
sum = cata sumCata

filter :: (a -> Bool) -> List a -> List a
filter = cata . filterCata

map :: (a -> b) -> List a -> List b
map = cata . mapCata

reverseCata :: Cata a (List a -> List a)
reverseCata = Cata (\xs -> xs) (\a g -> \xs -> g (Cons a xs))

forwardCata :: Cata a (List a -> List a)
forwardCata = Cata (\xs -> xs) (\a g -> \xs -> Cons a (g xs))

reverse :: List a -> List a
reverse xs = (cata reverseCata xs) Nil

slowReverseCata :: Cata a (List a)
slowReverseCata = Cata Nil (\a as -> append as (Cons a Nil))

-- challenge: convert (List a) -> List Int, where ints are 1, 2, 3, 4
-- using a cata
reverseNumberCata :: Cata a (Int, List Int)
reverseNumberCata = Cata (1, Nil) (\_ (i, bs) -> (i + 1, Cons i bs))

reverseNumber :: List a -> List Int
reverseNumber xs = snd $ cata reverseNumberCata xs

numberCata :: Cata a ((Int, List Int) -> (Int, List Int))
-- numberCata = Cata (\(i, xs) -> (i, xs)) (\_ g -> \(i, xs) -> let (j, ys) = g (i, xs) in (i + 1, Cons i xs))
numberCata = Cata b f
  where
    b (i, xs) = (i, xs)
    f _ g (i, xs) = let 
                      (j, ys) = g (i, Cons j xs)
                    in
                      (j + 1, ys)

number :: List a -> List Int
number xs = snd (cata numberCata xs (1, Nil))

-- numberCata :: Cata a (Int -> Int, List a -> List a)
-- numberCata = Cata (id, id) (\_ (ff, fb) -> 

numberPlain :: List a -> List Int
numberPlain = go 1
  where
    go _         Nil = Nil
    go n (Cons _ xs) = Cons n (go (n + 1) xs)

takeCata :: (Ord i, Num i) => i -> Cata a ((i, List a) -> (i, List a))
takeCata limit = Cata b f
  where
    b (i, xs) = (i, xs)
    f a g (i, xs) = let 
                      (j, ys) = g (i, if i < limit then Cons a xs else Nil) -- Cons a xs)
                    in
                      (j + 1, ys) -- if i < limit then ys else Nil)


-- fusion law
-- TODO not sure how to implement this, or if it's even possible
{- listFusion :: (List b -> c) -> Cata a (List b) -> Cata
listFusion f (Cata b op) = Cata c op2
  where
    c = f b
    op2 q r -}

-- TODO foldr, foldl



listAna :: (b -> Bool) -> (b -> (a, b)) -> b -> List a
listAna pred next base
  | pred base = Nil
  | otherwise = let (a, b) = (next base) in Cons a (listAna pred next b)

data Ana b a = Ana {pred :: b -> Bool, next :: b -> (a, b)}

ana :: Ana b a -> b -> List a
ana (Ana pred next) = listAna pred next

-- this is really weird -- I wonder if its weirdness is a motivating reason behind paramorphisms?
rangeAna :: (Num a, Ord a) => a -> Ana a a
rangeAna high = Ana (>= high) (\b -> (b, b + 1))

rangeA :: (Num a, Ord a) => a -> a -> List a
rangeA low high = ana (rangeAna high) low

zipAna :: Ana (List a, List b) (a, b)
zipAna = Ana pred next
  where
    pred (_, Nil) = True
    pred (Nil, _) = True
    pred _        = False
    -- TODO note how next is a partial function; why not combine pred and next into a single function returning a Maybe?
    next (Cons a as, Cons b bs) = ((a, b), (as, bs))

zip :: List a -> List b -> List (a, b)
zip as bs = ana zipAna (as, bs)

iterateAna :: (a -> a) -> Ana a a
iterateAna f = Ana (const False) (\x -> (x, f x))

myTake :: Int -> List a -> List a
myTake 0  xs         = Nil
myTake _  Nil        = Nil
myTake n (Cons a as) = Cons a (myTake (n - 1) as)

iterate :: (a -> a) -> a -> List a
iterate = ana . iterateAna

mapAna :: (a -> b) -> Ana (List a) b
mapAna f = Ana pred next
  where
    pred Nil = True
    pred _   = False
    next (Cons a as) = (f a, as)

mapA :: (a -> b) -> List a -> List b
mapA = ana . mapAna




listHylo :: (b -> Bool) -> (b -> (a, b)) -> (a -> c -> c) -> b -> c -> c
listHylo pred next f start base = listCata base f (listAna pred next start)

data Hylo b a c = Hylo {hpred :: b -> Bool, hnext :: b -> (a, b), hf :: a -> c -> c, hstart :: b, hbase :: c}

hylo :: Hylo b a c -> c
hylo (Hylo pred next f start base) = listHylo pred next f start base

factorialHylo :: (Ord a, Num a) => a -> Hylo a a a
factorialHylo n = Hylo (> n) (\x -> (x, x + 1)) (*) 1 1

rangeSumHylo :: (Ord a, Num a) => a -> a -> Hylo a a a
rangeSumHylo low high = Hylo (> high) (\x -> (x, x + 1)) (+) low 0




listPara :: b -> (a -> List a -> b -> b) -> List a -> b
listPara base _ Nil         = base
listPara base f (Cons a as) = f a as (listPara base f as)

data Para a b = Para {paraBase :: b, paraF :: a -> List a -> b -> b}

para :: Para a b -> List a -> b
para (Para base f) xs = listPara base f xs

tailsPara :: Para a (List (List a))
tailsPara = Para Nil (const Cons) -- (\_ xs val -> Cons xs val)

tails :: List a -> List (List a)
tails = para tailsPara

lastPara :: Para a (Maybe a)
lastPara = Para Nothing g
  where 
    g x _ Nothing = Just x
    g _ _ val     = val

last :: List a -> Maybe a
last = para lastPara

tailPara :: Para a (Maybe (List a))
tailPara = Para Nothing g
  where
    g _ xs _ = Just xs

tail :: List a -> Maybe (List a)
tail = para tailPara



foldr :: b -> (a -> b -> b) -> List a -> b
foldr base _ Nil         = base
foldr base f (Cons x xs) = f x (foldr base f xs)

-- not really sure what this is ... is it just foldl?
notFoldr :: b -> (a -> b -> b) -> List a -> b
notFoldr base _ Nil         = base
notFoldr base f (Cons x xs) = notFoldr (f x base) f xs

-- foldlCata :: b -> (a -> b -> b) -> Cata a b
-- foldlCata base f = Cata base (\x h y -> h (f y x))

-- foldr 0 - 1,2,3,4    1 - (2 - (3 - (4 - 0))) => -2
-- foldl 0 - 1,2,3,4    (((0 - 1) - 2) - 3) - 4 => -10
-- foldr :: (b -> b) -> (a -> (b -> b) -> (b -> b)) -> List a -> (b -> b)
-- nope: foldl b f xs = foldr b (flip f) xs
foldl :: b -> (b -> a -> b) -> List a -> b
foldl base f xs = foldr (\x -> x) g xs base
  where
    g x h = \y -> h (f y x)

foldlNumber :: List a -> List Int
foldlNumber xs = fst $ foldl (\b -> b) g xs (Nil, 1)
  where
    g f y (ys, c) =
      let 
        (zs, d) = f (Cons d ys, c) 
      in
        (zs, d+1)

-- define foldr using para
-- para :: b -> (a -> List a -> b -> b) -> List a -> b
foldrFromPara :: b -> (a -> b -> b) -> List a -> b
foldrFromPara base f xs = listPara base (\x _ b -> f x b) xs

-- define para from foldr
-- foldr :: b -> (a -> b -> b) -> List a -> b
-- ((List a, b) -> (List a, b)) -> (a -> ((List a, b) -> (List a, b)) -> ((List a, b) -> (List a, b))) -> List a -> ((List a, b) -> (List a, b))
-- TODO why did I make this soooooo complicated?
paraFromFoldr :: b -> (a -> List a -> b -> b) -> List a -> b
paraFromFoldr base f vs = snd $ foldr (\v -> v) g vs (Nil, base)
  where
    g x h = \(ys, b) -> let (zs, c) = h (ys, b) in (Cons x zs, f x zs c)

-- foldr :: b -> (a -> b -> b) -> List a -> b
-- (List a, b) -> (a -> (List a, b) -> (List a, b)) -> List a -> (List a, b)
paraFromF :: (a -> List a -> b -> b) -> b -> List a -> b
paraFromF c base vs = snd $ foldr (Nil, base) g vs
  where
    g x (xs, b) = (Cons x xs, c x xs b)

paraFromFoldrGood :: (a -> List a -> b -> b) -> b -> List a -> b
paraFromFoldrGood c n xs = snd $ foldr (Nil, n) g xs
  where
    g x (xs, t) = (Cons x xs, c x xs t)

-- f x1 (f x2 (f x3 ... f xN base)
-- ??? define foldl using para ???

-- scanl :: (a -> b -> a) -> a -> [b] -> [a]
-- scanr :: (a -> b -> b) -> b -> [a] -> [b]

fp2.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveFunctor #-}

import Data.Set

fix :: (a -> a) -> a
fix f = let x = f x in x

fixCata :: (a -> b -> b) -> b -> [a] -> b
fixCata g base = fix (\f xs -> case xs of [] -> base; (y:ys) -> g y (f ys))


-- class Functor f where
  

class BiFunctor f where
  bimap :: (a -> b) -> (c -> d) -> f a c -> f b d
  bimap f g = first f . second g
  first :: (a -> b) -> f a c -> f b c
  first f = bimap f id
  second :: (c -> d) -> f a c -> f a d
  second g = bimap id g

instance BiFunctor Either where
--  first :: (e -> f) -> Either e a -> Either f a
  first f (Left e)  = Left (f e)
  first _ (Right x) = Right x
--  second :: (a -> b) -> Either e a -> Either e b
  second f (Right x) = Right (f x)
  second _ (Left e)  = Left e

instance BiFunctor (,) where
  bimap f g (x, y) = (f x, g y)

(<.>) :: BiFunctor f => (a -> b, k -> l) -> (b -> c, l -> m) -> f a k -> f c m
-- (f, g) <.> (h, i) = bimap h i . bimap f g
(f, g) <.> (h, i) = bimap (h . f) (i . g)



-- apply2 :: (a -> b, c -> d) -> (a, c) -> (b, d)
-- apply2 (f, g) (x, y) = (f x, g y)

-- pi with a thing pointing to the left
left :: (a, b) -> a
left = fst

-- pi with a thing pointing to the right
right :: (a, b) -> b
right = snd

-- small triangle pointing up
dup :: (a -> b) -> (a -> d) -> a -> (b, d)
dup f g x = (f x, g x)

-- f||g = apply2 f g
apply2 :: (a -> b, c -> d) -> (a, c) -> (b, d)
apply2 (f, g) = dup (f . left) (g . right)



sumLeft :: e -> Either e a
sumLeft = Left

sumRight :: a -> Either e a
sumRight = Right

-- applySum :: (a -> b, c -> d) -> Either a c -> Either b d
-- applySum (f, _) (Left e)  = Left (f e)
-- applySum (_, g) (Right x) = Right (g x)

-- this doesn't make any sense
-- sumDup :: (a -> b) -> (a -> d) -> a -> Either b d
sumDup :: (e -> b) -> (a -> b) -> Either e a -> b
sumDup f _ (Left e)  = f e
sumDup _ g (Right x) = g x

applySum :: (a -> b, c -> d) -> Either a c -> Either b d
applySum (f, g) = (sumLeft . f) `sumDup` (sumRight . g)



data Arrow b c a d = Arrow {arrowF :: a -> b, arrowG :: c -> d}

arrowApply :: Arrow b c a d -> (b -> c) -> (a -> d)
arrowApply (Arrow f g) h = g . h . f

arrowCompose :: Arrow b c a d -> Arrow e f b c -> Arrow e f a d
-- (a -> b, c -> d) -> (b -> e, f -> c) -> (a -> e, f -> d)
arrowCompose (Arrow f g) (Arrow h i) = Arrow (h . f) (g . i)



-- build Fix data type
-- build all other data types out of fix (list, pair (is that possible?), ????)

data Fix f = Fix (f (Fix f))

data Free f a
  = Free (f (Free f a))
  | Pure a

join :: Functor f => Free f (Free f a) -> Free f a
-- f (Free f (Free f a))
join (Free m) = Free (fmap join m)
join (Pure x) = x

deriving instance (Show a, Show (f a), Show (f (Free f a))) => Show (Free f a)

instance Functor f => Functor (Free f) where
  fmap f (Pure x) = Pure (f x)
  -- f :: a -> b, v :: f (Free f a)
  fmap f (Free v) = Free (fmap (fmap f) v)

instance Functor f => Applicative (Free f) where
  pure x = Pure x
  (<*>) :: forall a b. Free f (a -> b) -> Free f a -> Free f b
  Pure f <*> v = fmap f v
  Free f <*> v = Free (fmap g f)
    where
      g :: Free f (a -> b) -> Free f b
      g h = h <*> v

instance Functor f => Monad (Free f) where
  return :: forall a. a -> Free f a
  return x = Pure x
  (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b
  m >>= f = join (fmap f m)

-- have: Free m (Free m b)
-- want: Free m b

data Zero

data One = One deriving (Show, Eq)

data Pair a b = Pair a b deriving (Show, Eq)

type List a = Free (Pair a) One

nil :: List a
nil = Pure One

cons :: a -> List a -> List a
cons x xs = Free (Pair x xs)

len :: List a -> Int
len (Pure _) = 0
len (Free (Pair _ xs)) = 1 + len xs

listFoldr :: (a -> b -> b) -> b -> [a] -> b
listFoldr _ b []     = b
listFoldr f b (x:xs) = f x (listFoldr f b xs)

makeList :: [a] -> List a
makeList = listFoldr cons nil

list1 :: List Int
list1 = makeList [1..10]


foldFree :: (Functor f, Monad m) => (forall x. f x -> m x) -> Free f a -> m a
foldFree _ (Pure a) = return a
foldFree f (Free m) = f m >>= foldFree f

data AstF next
  = ANumber Int
  | AString String
  | AIf next next next
  | ASymbol String
  | ADef String next
  | ALambda [String] next
  | ABegin [next]
  deriving (Functor)

type Ast = Free AstF
-- Ast a => Free AstF a => AstF (Free AstF a) | a

interpret :: Ast a -> RWS [String] [Set String] (Set String) ()
interpret (Free (ANumber n))       = return ()
interpret (Free (AString s))       = rwslog ("string: " ++ s) >> return ()
interpret (Free (AIf pred th els)) = interpret pred >> interpret th >> interpret els >> return ()
interpret (Free (ASymbol x))       = rwshas x >>= \b -> rwslog ("use: (" ++ x ++ ") " ++ show b) >> return ()
interpret (Free (ADef sym val))    = define sym >> interpret val >> return ()
interpret (Free (ALambda xs val))  = push (fromList []) >> mapM define xs >> interpret val >> pop >> return ()
interpret (Free (ABegin vals))     = mapM interpret vals >> return ()
interpret (Pure _)                 = return ()

define :: String -> RWS [String] [Set String] s (Set String)
define sym = rwslog ("def:" ++ sym) >> rwsdef sym

num :: Int -> Ast a
num = Free . ANumber

str :: String -> Ast a
str = Free . AString

iff :: Ast a -> Ast a -> Ast a -> Ast a
iff a b c = Free (AIf a b c)

sym :: String -> Ast a
sym = Free . ASymbol

def :: String -> Ast a -> Ast a
def s a = Free (ADef s a)

func :: [String] -> Ast a -> Ast a
func names = Free . ALambda names

begin :: [Ast a] -> Ast a
begin = Free . ABegin

-- tree1 = Free $ AString "abc" (Pure "end")
-- (def id (fn [x] x))
tree1 = begin [
    sym "x",
    def "id" (func ["x"] (sym "x")),
    sym "x",
    iff
        (num 32)
        (iff
            (sym "qrs")
            (def "qrs" $ str "xxx")
            (sym "qrs"))
        (str "ghi")]
-- tree1 = def "abc" (str "def" $ Pure "?")

eg1 = interpret tree1

go1 = unRWS eg1 [empty] empty

-- reader: ((->) r)
-- writer: Monoid w => ((,) w)
-- state: forall a. s -> (s, a)

data RWS w s r a = RWS {unRWS :: s -> r -> (w, s, a)}

instance Functor (RWS w s r) where
  fmap f (RWS g) = RWS (\s r -> let (w, s2, x) = g s r in (w, s2, f x))

instance Monoid w => Applicative (RWS w s r) where
  pure x = RWS (\s _ -> (mempty, s, x))
  RWS f <*> RWS x = RWS (\s1 r -> let (w1, s2, g) = f s1 r in let (w2, s3, y) = x s2 r in (mappend w1 w2, s3, g y))

instance Monoid w => Monad (RWS w s r) where
  return x = pure x
  RWS m >>= f = RWS (\s1 r -> let (w1, s2, x) = m s1 r in let (w2, s3, y) = (unRWS (f x)) s2 r in (mappend w1 w2, s3, y))


-- string writer monad functions

rwslog :: String -> RWS [String] s r ()
rwslog string = RWS (\s _ -> ([string], s, ()))


-- functions for a specific interpreter

rwsdef :: Monoid w => String -> RWS w [Set String] r (Set String)
rwsdef name = pop >>= \env -> push (insert name env) -- RWS (\s r -> (mempty, insert name s, ()))

rwshas :: Monoid w => String -> RWS w [Set String] r Bool
rwshas name = fmap (\names -> member name names) peek -- RWS (\s r -> (mempty, s, member name s))

push :: Monoid w => Set String -> RWS w [Set String] r (Set String)
push newEnv = RWS (\s r -> (mempty, newEnv:s, newEnv))

pop :: Monoid w => RWS w [Set String] r (Set String)
pop = RWS (\s r -> let (top:rest) = s in (mempty, rest, top))

peek :: Monoid w => RWS w [Set String] r (Set String)
peek = RWS (\s r -> let (top:_) = s in (mempty, s, top))


-- reader monad functions

-- Retrieves the monad environment.
ask :: Monoid w => RWS w s r r
ask = RWS (\s r -> (mempty, s, r))

-- Executes a computation in a modified environment.
-- The function to modify the environment.
-- Reader to run in the modified environment.
-- Executes a computation in a modified environment.
local :: (r -> r) -> RWS w s r a -> RWS w s r a
local f m = RWS (\s r -> unRWS m s (f r))

-- Retrieves a function of the current environment.
-- The selector function to apply to the environment.
reader :: Monoid w => (r -> a) -> RWS w s r a
reader f = fmap f ask


-- state monad functions

get :: Monoid w => RWS w s r s
get = update id

put :: Monoid w => s -> RWS w s r s
put = update . const

update :: Monoid w => (s -> s) -> RWS w s r s
update f = RWS (\s r -> let s2 = f s in (mempty, s2, s2))

state :: Monoid w => (s -> (s, a)) -> RWS w s r a
state f = RWS (\s r -> let (s2, x) = f s in (mempty, s2, x))