mirror of
https://github.com/unisonweb/unison.git
synced 2024-11-15 04:11:34 +03:00
Lots of additional mealy/moore combinators
This commit is contained in:
Paul Chiusano
parent
7ae58b275b
commit
618dc1969e
@ -9,22 +9,33 @@ type alias Mealy i o = i -> Moore i o
|
||||
ap : Mealy i (a -> b) -> Mealy i a -> Mealy i b
|
||||
ap = map2 (<|)
|
||||
|
||||
changesBy : (a -> a -> Maybe b) -> Mealy a (Maybe b)
|
||||
changesBy f = M.feed (M.changesBy f)
|
||||
|
||||
delay : a -> Mealy a a
|
||||
delay a0 a = moore a0 (delay a)
|
||||
|
||||
echo : Mealy a a
|
||||
echo = lift identity
|
||||
|
||||
first : Mealy a b -> Mealy (a,c) (b,c)
|
||||
first m (a,c) =
|
||||
let m' = m a
|
||||
in moore (M.extract m', c) (first (M.feed m'))
|
||||
|
||||
lift : (a -> b) -> Mealy a b
|
||||
lift f a = moore (f a) (lift f)
|
||||
|
||||
loop : c -> Mealy (a,c) (b,c) -> Mealy a b
|
||||
loop c m a = M.loop (m (a,c))
|
||||
|
||||
map : (b -> c) -> Mealy a b -> Mealy a c
|
||||
map f m a = M.map f (m a)
|
||||
|
||||
map2 : (a -> b -> c) -> Mealy i a -> Mealy i b -> Mealy i c
|
||||
map2 f a b i =
|
||||
let (ar,br) = (a i, b i)
|
||||
in moore (f (M.extract ar) (M.extract br)) (map2 f (M.step ar) (M.step br))
|
||||
in moore (f (M.extract ar) (M.extract br)) (map2 f (M.feed ar) (M.feed br))
|
||||
|
||||
mealy : (i -> Moore i o) -> Mealy i o
|
||||
mealy = identity
|
||||
@ -38,9 +49,6 @@ pipe ab bc a =
|
||||
m2 = bc (M.extract m1)
|
||||
in m1 `M.pipe` m2
|
||||
|
||||
-- first : Mealy a b -> Mealy (a,c) (b,c)
|
||||
-- second : Mealy a b -> Mealy (c,a) (c,b)
|
||||
|
||||
pipe1 : Mealy a (b,c) -> Mealy b b2 -> Mealy a (b2,c)
|
||||
pipe1 m1 m2 a =
|
||||
let m1' = m1 a
|
||||
@ -51,12 +59,14 @@ pipe2 i c =
|
||||
let swap (a,b) = (b,a)
|
||||
in map swap (pipe1 (map swap i) c)
|
||||
|
||||
second : Mealy a b -> Mealy (c,a) (c,b)
|
||||
second m (c,a) =
|
||||
let m' = m a
|
||||
in moore (c, M.extract m') (second (M.feed m'))
|
||||
|
||||
split : Mealy a b -> Mealy a (b,b)
|
||||
split = map (\b -> (b,b))
|
||||
|
||||
loop : c -> Mealy (a,c) (b,c) -> Mealy a b
|
||||
loop c m a = M.loop (m (a,c))
|
||||
|
||||
-- withInput : Mealy i o -> Mealy i (i,o)
|
||||
-- withInput m i = moore
|
||||
|
||||
|
||||
@ -7,63 +7,9 @@ import Maybe
|
||||
|
||||
type Moore i o = Moore o (i -> Maybe (Moore i o))
|
||||
|
||||
extract : Moore i o -> o
|
||||
extract (Moore o _) = o
|
||||
|
||||
step : Moore i o -> (i -> Maybe (Moore i o))
|
||||
step (Moore _ k) = k
|
||||
|
||||
duplicate : Moore i o -> Moore i (Moore i o)
|
||||
duplicate m = Moore m (\i -> Maybe.map duplicate (step m i))
|
||||
|
||||
moore : o -> (i -> Moore i o) -> Moore i o
|
||||
moore o k = Moore o (k >> Just)
|
||||
|
||||
contramap : (i0 -> i) -> Moore i o -> Moore i0 o
|
||||
contramap f (Moore o k) = Moore o (\i -> Maybe.map (contramap f) (k (f i)))
|
||||
|
||||
map : (o -> o2) -> Moore i o -> Moore i o2
|
||||
map f (Moore o k) = Moore (f o) (\i -> Maybe.map (map f) (k i))
|
||||
|
||||
unit : o -> Moore i o
|
||||
unit o = Moore o (always Nothing)
|
||||
|
||||
map2 : (o1 -> o2 -> o3) -> Moore i o1 -> Moore i o2 -> Moore i o3
|
||||
map2 f ((Moore o1 k1) as m1) ((Moore o2 k2) as m2) =
|
||||
Moore (f o1 o2)
|
||||
(\i -> case (k1 i, k2 i) of
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(m1', m2') -> Just <|
|
||||
map2 f (Maybe.withDefault m1 m1')
|
||||
(Maybe.withDefault m2 m2'))
|
||||
|
||||
ap : Moore i (a -> b) -> Moore i a -> Moore i b
|
||||
ap = map2 (<|)
|
||||
|
||||
emit : o -> Moore i o -> Moore i o
|
||||
emit oz (Moore o k) = Moore oz (\i -> Maybe.map (emit o) (k i))
|
||||
|
||||
echo : o -> Moore o o
|
||||
echo o = moore o echo
|
||||
|
||||
echo' : Moore (Maybe a) (Maybe a)
|
||||
echo' = echo Nothing
|
||||
|
||||
pipe : Moore a b -> Moore b c -> Moore a c
|
||||
pipe (Moore b k1) (Moore c k2) =
|
||||
let step a = k1 a `Maybe.andThen` \m1 -> Maybe.map (pipe m1) (k2 b)
|
||||
in Moore c step
|
||||
|
||||
split : Moore a b -> Moore a (b,b)
|
||||
split = map (\b -> (b,b))
|
||||
|
||||
{-
|
||||
withInput : i -> Moore i o -> Moore i (i,o)
|
||||
withInput i0 m = map2 (,) (echo i0) m
|
||||
|
||||
dropRepeats : o -> Moore o o
|
||||
dropRepeats prev = Moore ((==) prev) prev dropRepeats
|
||||
|
||||
changesBy : (a -> a -> Maybe b) -> Moore a (Maybe b)
|
||||
changesBy f =
|
||||
let prev = contramap Just (emit Nothing echo')
|
||||
@ -73,22 +19,82 @@ changesBy f =
|
||||
_ -> Nothing
|
||||
in map2 g prev cur
|
||||
|
||||
contramap : (i0 -> i) -> Moore i o -> Moore i0 o
|
||||
contramap f (Moore o k) = Moore o (\i -> Maybe.map (contramap f) (k (f i)))
|
||||
|
||||
duplicate : Moore i o -> Moore i (Moore i o)
|
||||
duplicate m = Moore m (\i -> Maybe.map duplicate (step m i))
|
||||
|
||||
extract : Moore i o -> o
|
||||
extract (Moore o _) = o
|
||||
|
||||
feed : Moore i o -> i -> Moore i o
|
||||
feed ((Moore _ k) as m) i = Maybe.withDefault m (k i)
|
||||
|
||||
focus : (a -> Maybe b) -> Moore b c -> Moore a c
|
||||
focus f ((Moore o k) as m) =
|
||||
let k' a = f a `Maybe.andThen` \b -> Maybe.map (focus f) (k b)
|
||||
in Moore o k'
|
||||
|
||||
loop : Moore (a,c) (b,c) -> Moore a b
|
||||
loop (Moore (b,c) k) =
|
||||
let step a = Maybe.map loop (k (a,c))
|
||||
in Moore b step
|
||||
|
||||
map2 : (o1 -> o2 -> o3) -> Moore i o1 -> Moore i o2 -> Moore i o3
|
||||
map2 f ((Moore o1 k1) as m1) ((Moore o2 k2) as m2) =
|
||||
Moore (f o1 o2)
|
||||
(\i -> case (k1 i, k2 i) of
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(m1', m2') -> Just <|
|
||||
map2 f (Maybe.withDefault m1 m1')
|
||||
(Maybe.withDefault m2 m2'))
|
||||
|
||||
moore : o -> (i -> Moore i o) -> Moore i o
|
||||
moore o k = Moore o (k >> Just)
|
||||
|
||||
map : (o -> o2) -> Moore i o -> Moore i o2
|
||||
map f (Moore o k) = Moore (f o) (\i -> Maybe.map (map f) (k i))
|
||||
|
||||
echo : o -> Moore o o
|
||||
echo o = moore o echo
|
||||
|
||||
echo' : Moore (Maybe a) (Maybe a)
|
||||
echo' = echo Nothing
|
||||
|
||||
emit : o -> Moore i o -> Moore i o
|
||||
emit oz (Moore o k) = Moore oz (\i -> Maybe.map (emit o) (k i))
|
||||
|
||||
pipe : Moore a b -> Moore b c -> Moore a c
|
||||
pipe (Moore b k1) (Moore c k2) =
|
||||
let step a = k1 a `Maybe.andThen` \m1 -> Maybe.map (pipe m1) (k2 b)
|
||||
in Moore c step
|
||||
|
||||
pipe1 : Moore a (b,c) -> Moore b b2 -> Moore a (b2,c)
|
||||
pipe1 (Moore same1 (b,c) k1) (Moore same2 b2 k2) =
|
||||
let step a = k1 a `pipe1` k2 b
|
||||
same a = same1 a && same2 b
|
||||
in Moore same (b2,c) step
|
||||
pipe1 (Moore (b,c) k1) (Moore b2 k2) =
|
||||
let step a = k1 a `Maybe.andThen` \m1 -> Maybe.map (pipe1 m1) (k2 b)
|
||||
in Moore (b2,c) step
|
||||
|
||||
pipe2 : Moore a (b,c) -> Moore c c2 -> Moore a (b,c2)
|
||||
pipe2 i c =
|
||||
let swap (a,b) = (b,a)
|
||||
in map swap (pipe1 (map swap i) c)
|
||||
|
||||
loop : Moore (a,c) (b,c) -> Moore a b
|
||||
loop (Moore s (b,c) k) =
|
||||
let same a = s (a,c)
|
||||
step a = loop (k (a,c))
|
||||
in Moore same b step
|
||||
split : Moore a b -> Moore a (b,b)
|
||||
split = map (\b -> (b,b))
|
||||
|
||||
step : Moore i o -> i -> Maybe (Moore i o)
|
||||
step (Moore _ k) = k
|
||||
|
||||
unit : o -> Moore i o
|
||||
unit o = Moore o (always Nothing)
|
||||
|
||||
{-
|
||||
withInput : i -> Moore i o -> Moore i (i,o)
|
||||
withInput i0 m = map2 (,) (echo i0) m
|
||||
|
||||
dropRepeats : o -> Moore o o
|
||||
dropRepeats prev = Moore ((==) prev) prev dropRepeats
|
||||
|
||||
foldResult : (a -> r) -> (b -> r) -> Result a b -> r
|
||||
foldResult f1 f2 e = case e of
|
||||
@ -106,16 +112,6 @@ either (Moore samei xy ki) left right =
|
||||
Ok y -> extract right
|
||||
in Moore same o st
|
||||
|
||||
focus : (a -> Maybe b) -> Moore b c -> Moore a c
|
||||
focus f ((Moore same o k) as m) =
|
||||
let same' a = case f a of
|
||||
Nothing -> True
|
||||
Just _ -> True
|
||||
k' a = case f a of
|
||||
Nothing -> focus f m
|
||||
Just b -> focus f (k b)
|
||||
in Moore same' o k'
|
||||
|
||||
{-| Run the first argument until it emits `Err s`, then switch permanently to `f s`. -}
|
||||
bind : Moore a (Result s b) -> (s -> Moore a b) -> Moore a b
|
||||
bind (Moore same sb k) f = case sb of
|
||||
|
||||
Loading…
Reference in New Issue
Block a user