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