module Data.MemoCombinators
( Memo
, wrap
, memo2, memo3, memoSecond, memoThird
, bool, char, list, boundedList, either, maybe, unit, pair
, enum, integral, bits
, switch
, RangeMemo
, arrayRange, unsafeArrayRange, chunks
)
where
import Prelude hiding (either, maybe)
import Data.Bits
import qualified Data.Array as Array
import Data.Char (ord,chr)
import qualified Data.IntTrie as IntTrie
type Memo a = forall r. (a -> r) -> (a -> r)
wrap :: (a -> b) -> (b -> a) -> Memo a -> Memo b
wrap :: forall a b. (a -> b) -> (b -> a) -> Memo a -> Memo b
wrap a -> b
i b -> a
j Memo a
m b -> r
f = Memo a
m (b -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
j
memo2 :: Memo a -> Memo b -> (a -> b -> r) -> (a -> b -> r)
memo2 :: forall a b r. Memo a -> Memo b -> (a -> b -> r) -> a -> b -> r
memo2 Memo a
a Memo b
b = Memo a
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Memo b
b forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
memo3 :: Memo a -> Memo b -> Memo c -> (a -> b -> c -> r) -> (a -> b -> c -> r)
memo3 :: forall a b c r.
Memo a
-> Memo b -> Memo c -> (a -> b -> c -> r) -> a -> b -> c -> r
memo3 Memo a
a Memo b
b Memo c
c = Memo a
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b r. Memo a -> Memo b -> (a -> b -> r) -> a -> b -> r
memo2 Memo b
b Memo c
c forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
memoSecond :: Memo b -> (a -> b -> r) -> (a -> b -> r)
memoSecond :: forall b a r. Memo b -> (a -> b -> r) -> a -> b -> r
memoSecond Memo b
b = (Memo b
b forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
memoThird :: Memo c -> (a -> b -> c -> r) -> (a -> b -> c -> r)
memoThird :: forall c a b r. Memo c -> (a -> b -> c -> r) -> a -> b -> c -> r
memoThird Memo c
c = (forall b a r. Memo b -> (a -> b -> r) -> a -> b -> r
memoSecond Memo c
c forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
bool :: Memo Bool
bool :: Memo Bool
bool Bool -> r
f = forall {p}. p -> p -> Bool -> p
cond (Bool -> r
f Bool
True) (Bool -> r
f Bool
False)
where
cond :: p -> p -> Bool -> p
cond p
t p
f Bool
True = p
t
cond p
t p
f Bool
False = p
f
list :: Memo a -> Memo [a]
list :: forall a. Memo a -> Memo [a]
list Memo a
m [a] -> r
f = forall {p} {t}. p -> (t -> [t] -> p) -> [t] -> p
table ([a] -> r
f []) (Memo a
m (\a
x -> forall a. Memo a -> Memo [a]
list Memo a
m ([a] -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xforall a. a -> [a] -> [a]
:))))
where
table :: p -> (t -> [t] -> p) -> [t] -> p
table p
nil t -> [t] -> p
cons [] = p
nil
table p
nil t -> [t] -> p
cons (t
x:[t]
xs) = t -> [t] -> p
cons t
x [t]
xs
char :: Memo Char
char :: Memo Char
char = forall a b. (a -> b) -> (b -> a) -> Memo a -> Memo b
wrap Int -> Char
chr Char -> Int
ord forall a. Integral a => Memo a
integral
boundedList :: Int -> Memo a -> Memo [a]
boundedList :: forall a. Int -> Memo a -> Memo [a]
boundedList Int
0 Memo a
m [a] -> r
f = [a] -> r
f
boundedList Int
n Memo a
m [a] -> r
f = forall {p} {t}. p -> (t -> [t] -> p) -> [t] -> p
table ([a] -> r
f []) (Memo a
m (\a
x -> forall a. Int -> Memo a -> Memo [a]
boundedList (Int
nforall a. Num a => a -> a -> a
-Int
1) Memo a
m ([a] -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xforall a. a -> [a] -> [a]
:))))
where
table :: p -> (t -> [t] -> p) -> [t] -> p
table p
nil t -> [t] -> p
cons [] = p
nil
table p
nil t -> [t] -> p
cons (t
x:[t]
xs) = t -> [t] -> p
cons t
x [t]
xs
either :: Memo a -> Memo b -> Memo (Either a b)
either :: forall a b. Memo a -> Memo b -> Memo (Either a b)
either Memo a
m Memo b
m' Either a b -> r
f = forall {t} {t} {t}. (t -> t) -> (t -> t) -> Either t t -> t
table (Memo a
m (Either a b -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)) (Memo b
m' (Either a b -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right))
where
table :: (t -> t) -> (t -> t) -> Either t t -> t
table t -> t
l t -> t
r (Left t
x) = t -> t
l t
x
table t -> t
l t -> t
r (Right t
x) = t -> t
r t
x
maybe :: Memo a -> Memo (Maybe a)
maybe :: forall a. Memo a -> Memo (Maybe a)
maybe Memo a
m Maybe a -> r
f = forall {p} {t}. p -> (t -> p) -> Maybe t -> p
table (Maybe a -> r
f forall a. Maybe a
Nothing) (Memo a
m (Maybe a -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just))
where
table :: p -> (t -> p) -> Maybe t -> p
table p
n t -> p
j Maybe t
Nothing = p
n
table p
n t -> p
j (Just t
x) = t -> p
j t
x
unit :: Memo ()
unit :: Memo ()
unit () -> r
f = let m :: r
m = () -> r
f () in \() -> r
m
pair :: Memo a -> Memo b -> Memo (a,b)
pair :: forall a b. Memo a -> Memo b -> Memo (a, b)
pair Memo a
m Memo b
m' (a, b) -> r
f = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Memo a
m (\a
x -> Memo b
m' (\b
y -> (a, b) -> r
f (a
x,b
y))))
enum :: (Enum a) => Memo a
enum :: forall a. Enum a => Memo a
enum = forall a b. (a -> b) -> (b -> a) -> Memo a -> Memo b
wrap forall a. Enum a => Int -> a
toEnum forall a. Enum a => a -> Int
fromEnum forall a. Integral a => Memo a
integral
integral :: (Integral a) => Memo a
integral :: forall a. Integral a => Memo a
integral = forall a b. (a -> b) -> (b -> a) -> Memo a -> Memo b
wrap forall a. Num a => Integer -> a
fromInteger forall a. Integral a => a -> Integer
toInteger forall a. (Num a, Ord a, Bits a) => Memo a
bits
bits :: (Num a, Ord a, Bits a) => Memo a
bits :: forall a. (Num a, Ord a, Bits a) => Memo a
bits a -> r
f = forall b a. (Ord b, Num b, Bits b) => IntTrie a -> b -> a
IntTrie.apply (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> r
f forall a. (Num a, Bits a) => IntTrie a
IntTrie.identity)
switch :: (a -> Bool) -> Memo a -> Memo a -> Memo a
switch :: forall a. (a -> Bool) -> Memo a -> Memo a -> Memo a
switch a -> Bool
p Memo a
m Memo a
m' a -> r
f = forall {t}. (a -> t) -> (a -> t) -> a -> t
table (Memo a
m a -> r
f) (Memo a
m' a -> r
f)
where
table :: (a -> t) -> (a -> t) -> a -> t
table a -> t
t a -> t
f a
x | a -> Bool
p a
x = a -> t
t a
x
| Bool
otherwise = a -> t
f a
x
type RangeMemo a = (a,a) -> Memo a
arrayRange :: (Array.Ix a) => RangeMemo a
arrayRange :: forall a. Ix a => RangeMemo a
arrayRange (a, a)
rng = forall a. (a -> Bool) -> Memo a -> Memo a -> Memo a
switch (forall a. Ix a => (a, a) -> a -> Bool
Array.inRange (a, a)
rng) (forall a. Ix a => RangeMemo a
unsafeArrayRange (a, a)
rng) forall a. a -> a
id
unsafeArrayRange :: (Array.Ix a) => RangeMemo a
unsafeArrayRange :: forall a. Ix a => RangeMemo a
unsafeArrayRange (a, a)
rng a -> r
f = (forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (a, a)
rng (forall a b. (a -> b) -> [a] -> [b]
map a -> r
f (forall a. Ix a => (a, a) -> [a]
Array.range (a, a)
rng)) forall i e. Ix i => Array i e -> i -> e
Array.!)
chunks :: (Array.Ix a) => RangeMemo a -> [(a,a)] -> Memo a
chunks :: forall a. Ix a => RangeMemo a -> [(a, a)] -> Memo a
chunks RangeMemo a
rmemo [(a, a)]
cs a -> r
f = forall {t} {a}. Ix t => [((t, t), t -> a)] -> t -> a
lookup ([(a, a)]
cs forall a b. [a] -> [b] -> [(a, b)]
`zip` forall a b. (a -> b) -> [a] -> [b]
map (\(a, a)
rng -> RangeMemo a
rmemo (a, a)
rng a -> r
f) [(a, a)]
cs)
where
lookup :: [((t, t), t -> a)] -> t -> a
lookup [] t
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Element non in table"
lookup (((t, t)
r,t -> a
c):[((t, t), t -> a)]
cs) t
x | forall a. Ix a => (a, a) -> a -> Bool
Array.inRange (t, t)
r t
x = t -> a
c t
x
| Bool
otherwise = [((t, t), t -> a)] -> t -> a
lookup [((t, t), t -> a)]
cs t
x