5outh

class (Functor w) => Comonad w where
  coreturn :: w a -> a
  cojoin   :: w a -> w (w a)
  (=>>)    ::  w a -> (w a -> b) -> w b

5outh

data Tree a = Node a [Tree a] | Leaf a deriving (Show, Eq)

instance Functor Tree where
  fmap f (Leaf a) = Leaf $ f a
  fmap f (Node a b) = Node (f a) (map (fmap f) b)

5outh

instance Comonad Tree where
  coreturn (Leaf a) = a
  coreturn (Node a _) = a
  cojoin l@(Leaf a)   = Leaf l
  cojoin n@(Node a b) = Node n (map cojoin b)
  x =>> f = fmap f $ cojoin x

5outh

shortest :: (Num a, Ord a) => Tree a -> a
shortest (Leaf x) = x
shortest (Node x xs) = x + (minimum $ map shortest xs)

5outh

minimumDist = trip =>> shortest

5outh

simplify :: (Num a, Eq a, Floating a) => Expr a -> Expr a
simplify (Const a :+: Const b) = Const (a + b)
simplify (a       :+: Const 0) = simplify a
simplify (Const 0 :+: a      ) = simplify a

simplify (Const a :*: Const b) = Const (a*b)
simplify (a :*: Const 1)         = simplify a
simplify (Const 1 :*: a)         = simplify a
simplify (a :*: Const 0)         = Const 0
simplify (Const 0 :*: a)         = Const 0

5outh

infixl 4 :+:
infixl 5 :*:, :/:
infixr 6 :^:

data Expr a = Var Char
             | Const a 
             | (Expr a) :+: (Expr a) 
             | (Expr a) :*: (Expr a)
             | (Expr a) :^: (Expr a)
             | (Expr a) :/: (Expr a)

5outh

derivative :: (Num a) => Expr a -> Expr a
derivative (Var c)           = Const 1
derivative (Const x)         = Const 0
--product rule (ab' + a'b)
derivative (a :*: b)         = (a :*: (derivative b)) :+:  (b :*: (derivative a)) -- product rule
 --power rule (xa^(x-1) * a')
derivative (a :^: (Const x)) = ((Const x) :*: (a :^: (Const $ x-1))) :*: (derivative a)
derivative (a :+: b)         = (derivative a) :+: (derivative b)
 -- quotient rule ( (a'b - b'a) / b^2 )
derivative (a :/: b)         = ((derivative a :*: b) :+: (negate' (derivative b :*: a))) 

5outh

negate' :: (Num a) => Expr a -> Expr a
negate' (Var c)    = (Const (-1)) :*: (Var c)
negate' (Const a)  = Const (-a)
negate' (a :+: b)  = (negate' a) :+: (negate' b)
negate' (a :*: b)  = (negate' a) :*: b
negate' (a :^: b)  = Const (-1) :*: a :^: b
negate' (a :/: b)  = (negate' a) :/: b

5outh

mapVar :: (Char -> Expr a) => Expr a -> Expr a
mapVar f (Var d)   = f d
mapVar _ (Const a) = Const a
mapVar f (a :+: b) = (mapVar f a) :+: (mapVar f b)
mapVar f (a :*: b) = (mapVar f a) :*: (mapVar f b)
mapVar f (a :^: b) = (mapVar f a) :^: (mapVar f b)
mapVar f (a :/: b) = (mapVar f a) :/: (mapVar f b)

plugIn :: Char -> a -> Expr a -> Expr a
plugIn c val = mapVar (\x -> if x == c then Const val else Var x)