Conal Elliott » applicative functor

Fixing lists

infixr 5 :<

data Vec ∷ * → * → * where
  ZVec ∷                Vec Z     a
  (:<) ∷ a → Vec n a → Vec (S n) a

instance Functor (Vec n) where
  fmap _ ZVec     = ZVec
  fmap f (a :< u) = f a :< fmap f u

instance Applicative (Vec n) where
  pure a = ??
  ZVec      ⊛ ZVec      = ZVec
  (f :< fs) ⊛ (x :< xs) = f x :< (fs ⊛ xs)

  pure ∷ a → Vec n a

fmap ∷ (a → b) → Vec n a → Vec n b

class IsNat n

instance IsNat Z
instance IsNat n ⇒ IsNat (S n)

instance IsNat n ⇒ Applicative (Vec n) where
  ⋯

data Vec ∷ * → * → * where
  ZVec ∷ Vec Z a
  (:<) ∷ IsNat n ⇒ a → Vec n a → Vec (S n) a

instance IsNat n ⇒ Applicative (Vec n) where
  pure = ???
  (⊛)  = applyV

applyV ∷ Vec n (a → b) → Vec n a → Vec n b
ZVec      `applyV` ZVec      = ZVec
(f :< fs) `applyV` (x :< xs) = f x :< (fs `applyV` xs)

class IsNat n where pureN ∷ a → Vec n a

instance IsNat Z                where pureN a = ZVec
instance IsNat n ⇒ IsNat (S n) where pureN a = a :< pureN a

class IsNat n where units ∷ Vec n ()

instance            IsNat Z     where units = ZVec
instance IsNat n ⇒ IsNat (S n) where units = () :< units

  pure a = fmap (const a) units

data Nat ∷ * → * where
  Zero ∷                    Nat Z
  Succ ∷ IsNat n ⇒ Nat n → Nat (S n)

natToZ ∷ Nat n → Integer
natToZ Zero     = 0
natToZ (Succ n) = (succ ∘ natToZ) n

natToZ ∘ Succ = succ ∘ natToZ

instance Show (Nat n) where show = show ∘ natToZ

class IsNat n where nat ∷ Nat n

instance            IsNat Z     where nat = Zero
instance IsNat n ⇒ IsNat (S n) where nat = Succ nat

units ∷ IsNat n ⇒ Vec n ()
units = unitsN nat

unitsN ∷ Nat n → Vec n ()
unitsN Zero     = ZVec
unitsN (Succ n) = () :< unitsN n

data BNat ∷ * → * where
  BZero ∷          BNat (S n)
  BSucc ∷ BNat n → BNat (S n)

class HasBNat n where toBNat ∷ Integer → Maybe (BNat n)

instance HasBNat Z where toBNat _ = Nothing

instance HasBNat n ⇒ HasBNat (S n) where
  toBNat m | m < 1     = Just BZero
           | otherwise = fmap BSucc (toBNat (pred m))

toBNat ∷ ∀ n. IsNat n ⇒ Integer → Maybe (BNat n)
toBNat = loop n where
  n = nat ∷ Nat n
  loop ∷ Nat n' → Integer → Maybe (BNat n')
  loop Zero      _ = Nothing
  loop (Succ _)  0 = Just BZero
  loop (Succ n') m = fmap BSucc (loop n' (pred m))

instance IsNat n ⇒ Monad (Vec n) where
  return  = pure
  v >>= f = join (fmap f v)

join ∷ Vec n (Vec n a) → Vec n a
join ZVec      = ZVec
join (v :< vs) = headV v :< join (fmap tailV vs)

headV ∷ Vec (S n) a → a
headV (a :< _) = a

tailV ∷ Vec (S n) a → Vec n a
tailV (_ :< as) = as

data N = Zero | Succ N

data Stream a = Cons a (Stream a)

type L0 a = ()
type L1 a = (a)
type L2 a = (a,a)
type L3 a = (a,a,a)
⋯

data Z    -- zero
data S n  -- successor

infixr 5 :<

data Vec ∷ * → * → * where
  ZVec ∷                Vec Z     a
  (:<) ∷ a → Vec n a → Vec (S n) a

*Vec> :ty 'z' :< 'o' :< 'm' :< 'g' :< ZVec
'z' :< 'o' :< 'm' :< 'g' :< ZVec ∷ Vec (S (S (S (S Z)))) Char

instance Functor (Vec n) where
  fmap _ ZVec     = ZVec
  fmap f (a :< u) = f a :< fmap f u

instance Foldable (Vec n) where
  foldr _ b ZVec      = b
  foldr h b (a :< as) = a `h` foldr h b as

instance Applicative (Vec n) where
  ⋯

pure ∷ a → Vec n a
(⊛)  ∷ Vec n (a → b) → Vec n a → Vec n b

  ZVec      ⊛ ZVec      = ZVec
  (f :< fs) ⊛ (x :< xs) = f x :< (fs ⊛ xs)

data t :-># a = FS t (t -> a)

instance (Ord t, Num t) => Monoid (t :-># a) where
    mempty = FS 0 (error "sampling empty 't :-># a'")
    FS c f `mappend` FS d g =
      FS (c + d) ( t -> if t <= c then f t else g (t - c))

-- | Signal indexed by t with values of type a.
newtype t :-> a = S { unS :: [t :-># a] }

meaning :: (Ord t, Num t) => (t :-> a) -> (t :-># a)
meaning = mconcat . unS

inS  :: ([s :-># a] -> [t :-># b])
     -> ((s :->  a) -> (t :->  b))

inS2 :: ([s :-># a] -> [t :-># b] -> [u :-># c])
     -> ((s :->  a) -> (t :->  b) -> (u :->  c))

inS  = result   S . argument unS
inS2 = result inS . argument unS

instance Functor ((:->) t) where
    fmap h (S ss) = S (fmap (fmap h) ss)

instance Functor ((:->) t) where
    fmap = inS . fmap . fmap

 meaning . fmap h == fmap h . meaning

meaning . fmap h 

  == {- fmap definition -}

meaning . S . fmap (fmap h) . unS

  == {- meaning definition -}

mconcat . unS . S . fmap (fmap h) . unS

  == {- unS and S are inverses  -}

mconcat . fmap (fmap h) . unS

  == {- fmap h distributes over mappend -}

fmap h . mconcat . unS

  == {- meaning definition -}

fmap . meaning

meaning (pure a)    == pure a
meaning (bf <*> bx) == meaning bf <*> meaning bx

instance (Ord t, Num t, Bounded t) => Applicative ((:->) t) where
    pure  = S . pure . pure
    (<*>) = inS2 appl

appl :: (Ord t, Num t, Bounded t) =>
        [t :-># (a -> b)] -> [t :-># a] -> [t :-># b]

[] `appl` _  = []

_  `appl` [] = []

(fs:fss') `appl` (xs:xss')
   | fd == xd  = (fs  <*> xs ) : (fss' `appl`       xss' )
   | fd <  xd  = (fs  <*> xs') : (fss' `appl` (xs'':xss'))
   | otherwise = (fs' <*> xs ) : ((fs'':fss') `appl` xss')
 where
   fd         = length fs
   xd         = length xs
   (fs',fs'') = splitAt xd fs
   (xs',xs'') = splitAt fd xs

instance (Ord t, Num t, Bounded t) => Zip ((:->) t) where zip = liftA2 (,)

instance Monoid (t :-> a) where
  mempty = S []
  S xss `mappend` S yss = S (xss ++ yss)

instance Monoid (t :-> a) where
    mempty  = S mempty
    mappend = inS2 mappend

class Segment seg dur | seg -> dur where
    null    :: seg -> Bool
    length  :: seg -> dur
    take    :: dur -> seg -> seg
    drop    :: dur -> seg -> seg
    splitAt :: dur -> seg -> (seg,seg)
    -- Defaults:
    splitAt d s = (take d s, drop d s)
    take    d s = fst (splitAt d s)
    drop    d s = snd (splitAt d s)

instance (Ord t, Num t) => Segment (t :-> a) t where
  null   (S xss) = null xss
  length (S xss) = sum (length <$> xss)
  ...

  -- Alternative definition
  null (S xss) = all null xss

  splitAt _ (S [])  = (mempty,mempty)
  splitAt d b | d <= 0 = (mempty, b)
  splitAt d (S (xs:xss')) =
    case (d `compare` xd) of
      EQ -> (S [xs], S xss')
      LT -> let (xs',xs'') = splitAt d xs in
              (S [xs'], S (xs'':xss'))
      GT -> let (S uss, suffix) = splitAt (d-xd) (S xss') in
              (S (xs:uss), suffix)
   where
     xd = length xs

instance Num t => Copointed ((:->) t) where
    extract (S [])     = error "extract: empty S"
    extract (S (xs:_)) = extract xs

-- Alternative definition
instance Num t => Copointed ((:->) t) where
    extract (S []) = error "extract: empty S"
    extract (S (xs:xss'))
      | null xs     = extract (S xss')
      | otherwise   = extract xs

instance Num t => Copointed ((:->) t) where
    extract = extract . extract . unS

duplicate :: (t :-> a) -> (t :-> (t :-> a))

instance (Ord t, Num t) => Comonad ((:->) t) where
    duplicate = fmap S . inS dup

dup :: (Ord t, Num t) => [t :-># a] -> [t :-># [t :-># a]]

dup []        = []

dup (xs:xss') = ((: xss') <$> duplicate xs) : dup xss'

data Stream a = Cons a (Stream a)

instance Functor Stream where
    fmap f (Cons x xs) = Cons (f x) (fmap f xs)

instance Applicative Stream where
    pure  = repeat
    (<*>) = zipWith ($)

repeat :: a -> Stream a
repeat x = Cons x (repeat x)

return  :: Monad m     => a -> m a

extract :: Copointed w => w a -> a

a -> m b

w a -> b

(=<<) :: (Monad m) => (a -> m b) -> (m a -> m b)

(>>=) :: (Monad m) => m a -> (a -> m b) -> m b

extend :: (Comonad w) => (w a -> b) -> (w a -> w b)

(=>>) :: (Comonad w) => w a -> (w a -> b) -> w b

join      :: (Monad   m) => m (m a) -> m a

duplicate :: (Comonad w) => w a -> w (w a)

head :: Stream a -> a
head (Cons x _ ) = x

tails :: Stream a -> Stream (Stream a)
tails xs = Cons xs (tails (tail xs))

tail :: Stream a -> Stream a
tail (Cons _ xs) = xs

instance Copointed Stream where extract   = head
instance Comonad   Stream where duplicate = tails

class Monoid o where
    mempty  :: o
    mappend :: o -> o -> o

class Segment seg len where
    length :: seg -> len
    drop   :: len -> seg -> seg
    take   :: len -> seg -> seg

instance Segment [a] Int where
    length = Prelude.length
    drop   = Prelude.drop
    take   = Prelude.take

instance Integral i => Segment [a] i where
    length = genericLength
    drop   = genericDrop
    take   = genericTake

drop (length as) (as `mappend` bs) == bs
take (length as) (as `mappend` bs) == as

t <= length as ==> length (take t as) == t
t <= length as ==> length (drop t as) == length as - t

instance Functor ((->) t) where
    fmap = (.)

instance Applicative ((->) t) where
    pure = const
    (f <*> g) x = (f x) (g x)

instance Monad ((->) t) where
    return = const
    f >>= k =  t -> k (f t) t

  join f == f >>= id ==  t -> f t t

instance Monoid o => Copointed ((->) o) where
    extract f = f mempty

instance Monoid o => Comonad ((->) o) where
    duplicate f x =  y -> f (x `mappend` y)

data t :-># a = FS t (t -> a)

instance (Ord t, Num t) => Monoid (t :-># a) where
    mempty = FS 0 (error "sampling empty 't :-># a'")
    FS c f `mappend` FS d g =
      FS (c + d) ( t -> if t <= c then f t else g (t - c))

instance Num t => Segment (t :-># a) t where
    length (FS d _) = d
    drop t (FS d f) = FS (d - t) ( t' -> f (t + t'))
    take t (FS _ f) = FS t f

instance Functor ((:->#) t) where
    fmap h (FS d f) = FS d (h . f)

instance Ord t => Zip ((:->#) t) where
    FS xd xf `zip` FS yd yf = FS (xd `min` yd) (xf `zip` yf)

instance (Ord t, Bounded t) => Applicative ((:->#) t) where
    pure a = FS maxBound (const a)
    (<*>)  = zipWith ($)

instance Num t => Copointed ((:->#) t) where
    extract (FS _ f) = f 0

instance Num t => Comonad ((:->#) t) where
    duplicate s = FS (length s) (flip drop s)

v0 :: (Int, Char -> (String,Bool))
v0 = (3,  c -> ([c,'q',c,'r'], isDigit c))

v0 = (3,  c -> (['r',c,'q',c], isDigit c))

v1 = (second.result.first) reverse v0

> fst v0
3
> (snd v0) 'z'
("zqzr",False)

> :ty v1
v1 :: (Int, Char -> (String, Bool))
> fst v1
3
> (snd v1) 'z'
("rzqz",False)

double x   = x+x
swap (x,y) = (y,x)

-- negate the boolean,
v2 = (second.result.second) not v0

-- double the Int,
v3 = first double v0

-- swap the inner pair, or
v4 = (second.result) swap v0

-- swap the outer pair
v5 = swap v0

> :ty v2
v2 :: (Int, Char -> (String, Bool))
> fst v2
3
> (snd v2) 'z'
("zqzr",True)

> :ty v3
v3 :: (Int, Char -> (String, Bool))
> fst v3
6
> (snd v3) 'z'
("zqzr",False)

> :ty v4
v4 :: (Int, Char -> (Bool, String))
> fst v4
3
> (snd v4) 'z'
(False,"zqzr")

> :ty v5
v5 :: (Char -> (String, Bool), Int)
> fst v5
:1:0: No instance for (Show (Char -> (String, Bool))) ...
> snd v5
3
> fst v5 'z'
("zqzr",False)

v0 :: (Int, Char -> ([Char],Bool))

-- previous character
v6 = (second.result.first.element) pred v0

-- character value
v7 = (second.result.first.element) ord v0

> :ty v6
v6 :: (Int, Char -> ([Char], Bool))
> fst v6
3
> (snd v6) 'z'
("ypyq",False)

> :ty v7
v7 :: (Int, Char -> ([Int], Bool))
> fst v7
3
> (snd v7) 'z'
([122,113,122,114],False)

first  :: (a -> a') -> ((a,b) -> (a',b))
second :: (b -> b') -> ((a,b) -> (a,b'))

first  f =  (a,b) -> (f a, b)
second g =  (a,b) -> (a, g b)

result :: (b -> b') -> ((a -> b) -> (a -> b'))
result =  (.)

element :: (a -> b) -> ([a] -> [b])
element = fmap

newtype EventG t a = Event (FutureG t (ReactiveG t a))

instance Functor (EventG t) where fmap = inEvent.fmap.fmap

countE :: Num n => Event b -> Event (b,n)
countE = stateE 0 (+1)

countE_ :: Num n => Event b -> Event n
countE_ = (result.fmap) snd countE

snapshot :: Event a -> Reactive b -> Event (a,b)

snapshot_ :: Event a -> Reactive b -> Event b
snapshot_ = (result.result.fmap) snd snapshot

snapshot_ e b = fmap snd (snapshot e b)

withRestE :: Event a -> Event (a, Event a)

firstE :: Event a -> a

withNextE :: Event a -> Event (a,a)
withNextE = (result.fmap.second) firstE withRestE

argument :: (a' -> a) -> ((a -> b) -> (a' -> b))

argument = flip (.)

liftA2 :: (Applicative f) =>
          (a -> b -> c) -> (f a -> f b -> f c)

*Main Control.Applicative> :ty liftA2.liftA2.liftA2
liftA2.liftA2.liftA2 ::
  (Applicative f, Applicative g , Applicative h) =>
  (a -> b -> c) -> f (g (h a)) -> f (g (h b)) -> f (g (h c))

newtype (g :. f) a = O { unO :: g (f a) }

inO :: (g (f a) -> g' (f' a')) -> ((g :. f) a -> (g' :. f') a')
inO h (O gfa) = O (h gfa)

inO2 :: ( g (f a)   ->  g' (f' a')   ->  g'' (f'' a''))
     -> ((g :. f) a -> (g' :. f') a' -> (g'' :. f'') a'')
inO2 h (O gfa) (O gfa') = O (h gfa gfa')

...

inO  = (  O  .) . (. unO)
inO2 = (inO  .) . (. unO)
inO3 = (inO2 .) . (. unO)
...

instance (Functor g, Functor f) => Functor (g :. f) where
  fmap  = inO.fmap.fmap

instance (Applicative g, Applicative f) => Applicative (g :. f) where
  pure  = O . pure . pure
  (<*>) = (inO2.liftA2) (<*>)

first  :: Arrow (~>) => (a ~> a') -> ((a,b) ~> (a',b))
second :: Arrow (~>) => (b ~> b') -> ((a,b) ~> (a,b'))

data Fold b c = forall a. F (a -> b -> a) a (a -> c)  -- clever version

data Fold b a = F (a -> b -> a) a                     -- simple version

data WithCont z c = forall a. WC (z a) (a -> c)

type FoldC b = WithCont (Fold b)

cfoldlc :: FoldC b a -> [b] -> a
cfoldlc (WC f k) = k . cfoldl f

data WithCont' z c = forall a. WC' (z a) (a -> c)

type FoldC' b = WithCont' (Fold b)

cfoldlc' :: FoldC' b a -> [b] -> a
cfoldlc' (WC' f k) = k . cfoldl' f

instance Functor (WithCont z) where
  fmap g (WC f k) = WC f (g . k)

instance Zip z => Applicative (WithCont z) where
  pure a = WC undefined (const a)
  WC hf hk <*> WC xf xk =
    WC (hf `zip` xf) ( (a,a') -> (hk a) (xk a'))

instance Functor (WithCont' z) where
  fmap g (WC' f k) = WC' f (g . k)

instance Zip' z => Applicative (WithCont' z) where
  pure a = WC' undefined (const a)
  WC' hf hk <*> WC' xf xk =
    WC' (hf `zip'` xf) ( (P a a') -> (hk a) (xk a'))

cfoldlc (fmap g wc) == fmap g (cfoldlc wc)

cfoldlc (fmap g (WC f k)) == fmap g (cfoldlc (WC f k))

cfoldlc (fmap g (WC f k))

  == {- fmap on WithCont -}

cfoldlc (WC f (g . k))

  == {- cfoldlc def -}

(g . k) . cfoldl f

  == {- associativity of (.)  -}

g . (k . cfoldl f)

  == {- cfoldl def -}

g . cfoldlc (WC f k)

  == {- fmap on functions -}

fmap g (cfoldlc (WC f k))

cfoldlc (pure a) == pure a

cfoldlc (pure a)

  == {- pure on WithCont -}

cfoldlc (WC undefined (const a))

  == {- cfoldlc def -}

const a . cfoldl undefined

  == {- property of const -}

const a

  == {- pure on functions -}

pure a

cfoldlc (wch <*> wcx) == cfoldlc wch <*> cfoldlc wcx

cfoldlc ((WC hf hk) <*> (WC xf xk)) == cfoldlc (WC hf hk) <*> cfoldlc (WC xf xk)

cfoldlc ((WC hf hk) <*> (WC xf xk))

  == {- (<*>) on WithCont -}

cfoldlc (WC (hf `zip` xf) ( (a,a') -> (hk a) (xk a')))

  == {- cfoldlc def -}

( (a,a') -> (hk a) (xk a')) . cfoldl (hf `zip` xf)

  == {- Zip morphism law for Fold -}

( (a,a') -> (hk a) (xk a')) . (cfoldl hf `zip` cfoldl xf)

  == {- zip def on functions -}

( (a,a') -> (hk a) (xk a')) .  bs -> (cfoldl hf bs, cfoldl xf bs)

  == {- (.) def -}

 bs -> (hk (cfoldl hf bs)) (xk (cfoldl xf bs))

  == {- (<*>) on functions -}

(hk . cfoldl hf bs) <*> (xk . cfoldl xf)

  == {- cfoldlc def, twice -}

cfoldlc (WC hf hk) <*> cfoldlc (WC xf xk)

data Fold b c = forall a. F (a -> b -> a) a (a -> c)

cfoldl' :: Fold b c -> [b] -> c
cfoldl' (F op e k) = k . foldl' op e

foldl' :: (a -> b -> a) -> a -> [b] -> a
foldl' op a []     = a
foldl' op a (b:bs) =
  let a' = a `op` b in a' `seq` foldl' f a' bs

instance Functor (Fold b) where
  fmap h (F op e k) = F op e (h . k)

data Pair c c' = P !c !c'

instance Applicative (Fold b) where
  pure a = F (error "no op") (error "no e") (const a)

  F op e k <*> F op' e' k' = F op'' e'' k''
   where
     P a a' `op''` b = P (a `op` b) (a' `op'` b)
     e''             = P e e'
     k'' (P a a')    = (k a) (k' a')

forall c f g xs.
   h (cfoldl' f xs) (cfoldl' g xs) == cfoldl' (liftA2 h f g) xs

forall c f g.
  liftA2 h (cfoldl' f) (cfoldl' g) == cfoldl' (liftA2 h f g)

forall f g.
  cfoldl' f <*> cfoldl' g == cfoldl' (f <*> g)

cfoldl' (pure a  ) == pure a

cfoldl' (fmap h f) == fmap h (cfoldl' f)

cfoldl' (pure a  ) == const a

cfoldl' (fmap h f) == h . cfoldl' f

cfoldl' (pure a  ) xs == a

cfoldl' (fmap h f) xs == h (cfoldl' f xs)

cfoldl' (fmap h f) == fmap h (cfoldl' f)

cfoldl' (fmap h (F op e k)) == fmap h (cfoldl' (F op e k))

fmap h (cfoldl' (F op e k))

  ==  {- inline cfoldl' -}

fmap h (k . foldl' op e)

  ==  {- inline fmap on functions -}

h . (k . foldl' op e)

  ==  {- associativity of (.) -}

(h . k) . foldl' op e

  ==  {- uninline cfoldl' -}

cfoldl' (F op e (h . k))

  ==  {- uninline fmap on Fold  -}

cfoldl' (fmap h (F op e k))

data FoldS a b = FS (a -> b -> a) a

h . foldsl' op e

cfoldl' (pure a) == pure a

pure a

  ==  {- inline pure on functions -}

const a

  ==  {- property of const -}

const a . foldl op e

  ==  {- uninline cfoldl' -}

cfoldl' (F (const a) op e)

instance Applicative (Fold b) where
  pure a = F undefined undefined (const a)

data Dif a = D a (Dif a)

dConst :: Num a => a -> Dif a
dConst x0 = D x0 dZero

dZero :: Num a => Dif a
dZero = D 0 dZero

instance Num a => Num (Dif a) where
  fromInteger               = dConst . fromInteger
  D x0 x' + D y0 y'         = D (x0 + y0) (x' + y')
  D x0 x' - D y0 y'         = D (x0 - y0) (x' - y')
  x@(D x0 x') * y@(D y0 y') = D (x0 * y0) (x' * y + x * y')

lift :: Num a => [a -> a] -> Dif a -> Dif a
lift (f : f') p@(D x x') = D (f x) (x' * lift f' p)

instance Floating a => Floating (Dif a) where
  pi               = dConst pi
  exp (D x x')     = r where r = D (exp x) (x' * r)
  log p@(D x x')   = D (log x) (x' / p)
  sqrt (D x x')    = r where r = D (sqrt x) (x' / (2 * r))
  sin              = lift (cycle [sin, cos, negate . sin, negate . cos])
  cos              = lift (cycle [cos, negate . sin, negate . cos, sin])
  asin p@(D x x')  = D (asin x) ( x' / sqrt(1 - sqr p))
  acos p@(D x x')  = D (acos x) (-x' / sqrt(1 - sqr p))
  atan p@(D x x')  = D (atan x) ( x' / (sqr p - 1))

sqr :: Num a => a -> a
sqr x = x*x

dlift :: Num a => (a -> a) -> (Dif a -> Dif a) -> Dif a -> Dif a
dlift f f' =  u@(D u0 u') -> D (f u0) (f' u * u')

instance Floating a => Floating (Dif a) where
  pi    = dConst pi
  exp   = dlift exp exp
  log   = dlift log recip
  sqrt  = dlift sqrt (recip . (2*) . sqrt)
  sin   = dlift sin cos
  cos   = dlift cos (negate . sin)
  asin  = dlift asin ( x -> recip (sqrt (1 - sqr x)))
  acos  = dlift acos ( x -> - recip (sqrt (1 - sqr x)))
  atan  = dlift atan ( x -> recip (sqr x + 1))
  sinh  = dlift sinh cosh
  cosh  = dlift cosh sinh
  asinh = dlift asinh ( x -> recip (sqrt (sqr x + 1)))
  acosh = dlift acosh ( x -> - recip (sqrt (sqr x - 1)))
  atanh = dlift atanh ( x -> recip (1 - sqr x))

instance Num b => Num (a->b) where
  fromInteger = pure . fromInteger
  (+)         = liftA2 (+)
  (*)         = liftA2 (*)
  negate      = fmap negate
  abs         = fmap abs
  signum      = fmap signum

infix 0 >-<
(>-<) = dlift

instance Num a => Num (Dif a) where
  fromInteger               = dConst . fromInteger
  D x0 x' + D y0 y'         = D (x0 + y0) (x' + y')
  D x0 x' - D y0 y'         = D (x0 - y0) (x' - y')
  x@(D x0 x') * y@(D y0 y') = D (x0 * y0) (x' * y + x * y')

  negate = negate >-< -1
  abs    = abs    >-< signum
  signum = signum >-< 0

instance Fractional a => Fractional (Dif a) where
  fromRational = dConst . fromRational
  recip        = recip >-< - sqr recip

instance Floating a => Floating (Dif a) where
  pi    = dConst pi
  exp   = exp   >-< exp
  log   = log   >-< recip
  sqrt  = sqrt  >-< recip (2 * sqrt)
  sin   = sin   >-< cos
  cos   = cos   >-< - sin
  sinh  = sinh  >-< cosh
  cosh  = cosh  >-< sinh
  asin  = asin  >-< recip (sqrt (1-sqr))
  acos  = acos  >-< recip (- sqrt (1-sqr))
  atan  = atan  >-< recip (1+sqr)
  asinh = asinh >-< recip (sqrt (1+sqr))
  acosh = acosh >-< recip (- sqrt (sqr-1))
  atanh = atanh >-< recip (1-sqr)

2     :: Dif a -> Dif a
recip :: (Dif a -> Dif a) -> (Dif a -> Dif a)
(*)   :: (Dif a -> Dif a) -> (Dif a -> Dif a)
      -> (Dif a -> Dif a)

	infinite	finite
discrete	Stream	Sequence
continuous	Function	???

	infinite	finite
discrete	Stream	Sequence
continuous	Function	???

Conal Elliott » applicative functor

Doing more with length-typed vectors

An Applicative instance

Value-typed natural numbers

Revisiting type-bounded numbers

A Monad instance

Fixing lists

Fixing lists

Paper: Beautiful differentiation

Denotational design with type class morphisms

Sequences, segments, and signals

The problem with function segments

Sequences of segments

What does it mean?

Higher-order wrappers

Functor

Applicative and Zip

Monoid

Segment

Copointed and Comonad

Closing remarks

Sequences, streams, and segments

Streams

Comonads

The Stream comonad

Adding finiteness

Adding continuity

Finite and continuous

Monoid

Segment

Functor, Zip and Applicative

Copointed and Comonad

Monad

What’s ahead?

Semantic editor combinators

Example

What’s going on here?

Found in the wild

Who’s missing?

Higher arity

What’s ahead?

Enhancing a Zip

What’s missing?

From Zip to Functor and Applicative

Morphism proofs

Functor

Applicative

Another lovely example of type class morphisms

Folds as data

Standard classes

Beautiful properties

Rewrite rules

Inevitable instances

Functor

Applicative

Intermission

Beautiful differentiation

Automatic differentiation

Representation and overloadings

Reintroducing the chain rule

Prettier still, with function-level overloading

Try it

`Functor`

`Applicative` and `Zip`

`Monoid`

`Segment`

`Copointed` and `Comonad`

`Monoid`

`Segment`

`Functor`, `Zip` and `Applicative`

`Copointed` and `Comonad`

`Monad`

From `Zip` to `Functor` and `Applicative`