{-# LANGUAGE
      CPP,
      DeriveFunctor,
      GeneralizedNewtypeDeriving,
      TemplateHaskell,
      UnicodeSyntax
  #-}
{- |
  A function memoization library.

  This includes a class for memoizable argument types and a Template
  Haskell expander for deriving instances of the class.

  Note that most memoization in this style relies on assumptions about
  the implementation of non-strictness (as laziness) that are not
  guaranteed by the semantics. However, it appears to work.
-}
module Data.Function.Memoize (
  -- * Memoization class
  Memoizable(..),
  -- ** Operations
  -- *** Higher-arity memoize
  memoize2, memoize3, memoize4, memoize5, memoize6, memoize7,
  -- *** Memoizing open recursion
  memoFix, memoFix2, memoFix3, memoFix4, memoFix5, memoFix6, memoFix7,
  -- *** Tracing memoization
  traceMemoize,

  -- * For making instances for finite types
  memoizeFinite,

  -- * Deriving 'Memoizable'
  deriveMemoizable, deriveMemoizableParams, deriveMemoize,
) where

#if MIN_VERSION_base(4,16,0)
#  define COMPAT_HAS_SOLO
#endif

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad
import Debug.Trace

import Data.Function.Memoize.Class
import Data.Function.Memoize.TH

import qualified Data.Complex   as Complex
import qualified Data.Ratio     as Ratio
#ifdef COMPAT_HAS_SOLO
import qualified Data.Tuple     as Tuple
#endif
import qualified Data.Version   as Version
import qualified Data.Void      as Void
import qualified Data.Word      as Word

-- | Memoize a two argument function
memoize2 ∷ (Memoizable a, Memoizable b) ⇒
           (a → b → v) → a → b → v
memoize2 :: (a -> b -> v) -> a -> b -> v
memoize2 a -> b -> v
v = (a -> b -> v) -> a -> b -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((b -> v) -> b -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((b -> v) -> b -> v) -> (a -> b -> v) -> a -> b -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> v
v)

-- | Memoize a three argument function
memoize3 ∷ (Memoizable a, Memoizable b, Memoizable c) ⇒
           (a → b → c → v) → a → b → c → v
memoize3 :: (a -> b -> c -> v) -> a -> b -> c -> v
memoize3 a -> b -> c -> v
v = (a -> b -> c -> v) -> a -> b -> c -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((b -> c -> v) -> b -> c -> v
forall a b v.
(Memoizable a, Memoizable b) =>
(a -> b -> v) -> a -> b -> v
memoize2 ((b -> c -> v) -> b -> c -> v)
-> (a -> b -> c -> v) -> a -> b -> c -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> v
v)

-- | Memoize a four argument function
memoize4 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d) ⇒
           (a → b → c → d → v) →
           a → b → c → d → v
memoize4 :: (a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
memoize4 a -> b -> c -> d -> v
v = (a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((b -> c -> d -> v) -> b -> c -> d -> v
forall a b c v.
(Memoizable a, Memoizable b, Memoizable c) =>
(a -> b -> c -> v) -> a -> b -> c -> v
memoize3 ((b -> c -> d -> v) -> b -> c -> d -> v)
-> (a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> d -> v
v)

-- | Memoize a five argument function
memoize5 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d,
            Memoizable e) ⇒
           (a → b → c → d → e → v) →
           a → b → c → d → e → v
memoize5 :: (a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
memoize5 a -> b -> c -> d -> e -> v
v = (a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((b -> c -> d -> e -> v) -> b -> c -> d -> e -> v
forall a b c d v.
(Memoizable a, Memoizable b, Memoizable c, Memoizable d) =>
(a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
memoize4 ((b -> c -> d -> e -> v) -> b -> c -> d -> e -> v)
-> (a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> d -> e -> v
v)

-- | Memoize a six argument function
memoize6 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d,
            Memoizable e, Memoizable f) ⇒
           (a → b → c → d → e → f → v) →
           a → b → c → d → e → f → v
memoize6 :: (a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
memoize6 a -> b -> c -> d -> e -> f -> v
v = (a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((b -> c -> d -> e -> f -> v) -> b -> c -> d -> e -> f -> v
forall a b c d e v.
(Memoizable a, Memoizable b, Memoizable c, Memoizable d,
 Memoizable e) =>
(a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
memoize5 ((b -> c -> d -> e -> f -> v) -> b -> c -> d -> e -> f -> v)
-> (a -> b -> c -> d -> e -> f -> v)
-> a
-> b
-> c
-> d
-> e
-> f
-> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> d -> e -> f -> v
v)

-- | Memoize a seven argument function
memoize7 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d,
            Memoizable e, Memoizable f, Memoizable g) ⇒
           (a → b → c → d → e → f → g → v) →
           a → b → c → d → e → f → g → v
memoize7 :: (a -> b -> c -> d -> e -> f -> g -> v)
-> a -> b -> c -> d -> e -> f -> g -> v
memoize7 a -> b -> c -> d -> e -> f -> g -> v
v = (a -> b -> c -> d -> e -> f -> g -> v)
-> a -> b -> c -> d -> e -> f -> g -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((b -> c -> d -> e -> f -> g -> v)
-> b -> c -> d -> e -> f -> g -> v
forall a b c d e f v.
(Memoizable a, Memoizable b, Memoizable c, Memoizable d,
 Memoizable e, Memoizable f) =>
(a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
memoize6 ((b -> c -> d -> e -> f -> g -> v)
 -> b -> c -> d -> e -> f -> g -> v)
-> (a -> b -> c -> d -> e -> f -> g -> v)
-> a
-> b
-> c
-> d
-> e
-> f
-> g
-> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> c -> d -> e -> f -> g -> v
v)

-- | Memoizes the least fixed point of a function. This is like
-- 'Data.Function.fix', but it passes the fixed function a memoized
-- version of itself, so this memoizes using all recursive calls as well.
memoFix ∷ Memoizable a ⇒ ((a → v) → a → v) → a → v
memoFix :: ((a -> v) -> a -> v) -> a -> v
memoFix (a -> v) -> a -> v
ff = a -> v
f where f :: a -> v
f = (a -> v) -> a -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize ((a -> v) -> a -> v
ff a -> v
f)

-- | Two argument version of 'memoFix'.
memoFix2 ∷ (Memoizable a, Memoizable b) ⇒
           ((a → b → v) → a → b → v) → a → b → v
memoFix2 :: ((a -> b -> v) -> a -> b -> v) -> a -> b -> v
memoFix2 (a -> b -> v) -> a -> b -> v
ff = a -> b -> v
f where f :: a -> b -> v
f = (a -> b -> v) -> a -> b -> v
forall a b v.
(Memoizable a, Memoizable b) =>
(a -> b -> v) -> a -> b -> v
memoize2 ((a -> b -> v) -> a -> b -> v
ff a -> b -> v
f)

-- | Three argument version of 'memoFix'.
memoFix3 ∷ (Memoizable a, Memoizable b, Memoizable c) ⇒
           ((a → b → c → v) → a → b → c → v) → a → b → c → v
memoFix3 :: ((a -> b -> c -> v) -> a -> b -> c -> v) -> a -> b -> c -> v
memoFix3 (a -> b -> c -> v) -> a -> b -> c -> v
ff = a -> b -> c -> v
f where f :: a -> b -> c -> v
f = (a -> b -> c -> v) -> a -> b -> c -> v
forall a b c v.
(Memoizable a, Memoizable b, Memoizable c) =>
(a -> b -> c -> v) -> a -> b -> c -> v
memoize3 ((a -> b -> c -> v) -> a -> b -> c -> v
ff a -> b -> c -> v
f)

-- | Four argument version of 'memoFix'.
memoFix4 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d) ⇒
           ((a → b → c → d → v) → (a → b → c → d → v)) →
           a → b → c → d → v
memoFix4 :: ((a -> b -> c -> d -> v) -> a -> b -> c -> d -> v)
-> a -> b -> c -> d -> v
memoFix4 (a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
ff = a -> b -> c -> d -> v
f where f :: a -> b -> c -> d -> v
f = (a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
forall a b c d v.
(Memoizable a, Memoizable b, Memoizable c, Memoizable d) =>
(a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
memoize4 ((a -> b -> c -> d -> v) -> a -> b -> c -> d -> v
ff a -> b -> c -> d -> v
f)

-- | Five argument version of 'memoFix'.
memoFix5 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d,
            Memoizable e) ⇒
           ((a → b → c → d → e → v) → (a → b → c → d → e → v)) →
           a → b → c → d → e → v
memoFix5 :: ((a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v)
-> a -> b -> c -> d -> e -> v
memoFix5 (a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
ff = a -> b -> c -> d -> e -> v
f where f :: a -> b -> c -> d -> e -> v
f = (a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
forall a b c d e v.
(Memoizable a, Memoizable b, Memoizable c, Memoizable d,
 Memoizable e) =>
(a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
memoize5 ((a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v
ff a -> b -> c -> d -> e -> v
f)

-- | Six argument version of 'memoFix'.
memoFix6 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d,
            Memoizable e, Memoizable f) ⇒
           ((a → b → c → d → e → f → v) → (a → b → c → d → e → f → v)) →
           a → b → c → d → e → f → v
memoFix6 :: ((a -> b -> c -> d -> e -> f -> v)
 -> a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
memoFix6 (a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
ff = a -> b -> c -> d -> e -> f -> v
f where f :: a -> b -> c -> d -> e -> f -> v
f = (a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
forall a b c d e f v.
(Memoizable a, Memoizable b, Memoizable c, Memoizable d,
 Memoizable e, Memoizable f) =>
(a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
memoize6 ((a -> b -> c -> d -> e -> f -> v)
-> a -> b -> c -> d -> e -> f -> v
ff a -> b -> c -> d -> e -> f -> v
f)

-- | Seven argument version of 'memoFix'.
memoFix7 ∷ (Memoizable a, Memoizable b, Memoizable c, Memoizable d,
            Memoizable e, Memoizable f, Memoizable g) ⇒
           ((a → b → c → d → e → f → g → v) → (a → b → c → d → e → f → g → v)) →
           a → b → c → d → e → f → g → v
memoFix7 :: ((a -> b -> c -> d -> e -> f -> g -> v)
 -> a -> b -> c -> d -> e -> f -> g -> v)
-> a -> b -> c -> d -> e -> f -> g -> v
memoFix7 (a -> b -> c -> d -> e -> f -> g -> v)
-> a -> b -> c -> d -> e -> f -> g -> v
ff = a -> b -> c -> d -> e -> f -> g -> v
f where f :: a -> b -> c -> d -> e -> f -> g -> v
f = (a -> b -> c -> d -> e -> f -> g -> v)
-> a -> b -> c -> d -> e -> f -> g -> v
forall a b c d e f g v.
(Memoizable a, Memoizable b, Memoizable c, Memoizable d,
 Memoizable e, Memoizable f, Memoizable g) =>
(a -> b -> c -> d -> e -> f -> g -> v)
-> a -> b -> c -> d -> e -> f -> g -> v
memoize7 ((a -> b -> c -> d -> e -> f -> g -> v)
-> a -> b -> c -> d -> e -> f -> g -> v
ff a -> b -> c -> d -> e -> f -> g -> v
f)

-- | Give a one-argument function whose argument satisfies 'Show',
--   this memoizes the function such that the argument is shown (using
--   'Debug.Trace.trace') only when the function has to be applied, as
--   opposed to when the answer is available in the memo cache.
traceMemoize ∷ (Memoizable a, Show a) ⇒ (a → b) → a → b
traceMemoize :: (a -> b) -> a -> b
traceMemoize a -> b
f = (a -> b) -> a -> b
forall a v. Memoizable a => (a -> v) -> a -> v
memoize (\a
a → a -> b -> b
forall a b. Show a => a -> b -> b
traceShow a
a (a -> b
f a
a))

---
--- Binary-tree based memo caches
---

-- Used for both 'Integer' and arbitrary 'Int'-like types.

data BinaryTreeCache v
 = BinaryTreeCache {
    BinaryTreeCache v -> v
btValue         ∷ v,
    BinaryTreeCache v -> BinaryTreeCache v
btLeft, BinaryTreeCache v -> BinaryTreeCache v
btRight ∷ BinaryTreeCache v
   }
   deriving a -> BinaryTreeCache b -> BinaryTreeCache a
(a -> b) -> BinaryTreeCache a -> BinaryTreeCache b
(forall a b. (a -> b) -> BinaryTreeCache a -> BinaryTreeCache b)
-> (forall a b. a -> BinaryTreeCache b -> BinaryTreeCache a)
-> Functor BinaryTreeCache
forall a b. a -> BinaryTreeCache b -> BinaryTreeCache a
forall a b. (a -> b) -> BinaryTreeCache a -> BinaryTreeCache b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> BinaryTreeCache b -> BinaryTreeCache a
$c<$ :: forall a b. a -> BinaryTreeCache b -> BinaryTreeCache a
fmap :: (a -> b) -> BinaryTreeCache a -> BinaryTreeCache b
$cfmap :: forall a b. (a -> b) -> BinaryTreeCache a -> BinaryTreeCache b
Functor

---
--- 'Integer' memoization
---

instance Memoizable Integer where
  memoize :: (Integer -> v) -> Integer -> v
memoize Integer -> v
f = IntegerCache v -> Integer -> v
forall v. IntegerCache v -> Integer -> v
integerLookup (Integer -> v
f (Integer -> v) -> IntegerCache Integer -> IntegerCache v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntegerCache Integer
theIntegers)

-- | An integer cache stores a value for 0 and separate caches for the
--   positive and negative integers.
data IntegerCache v
  = IntegerCache {
      IntegerCache v -> v
icZero                 ∷ v,
      IntegerCache v -> PosIntCache v
icNegative, IntegerCache v -> PosIntCache v
icPositive ∷ PosIntCache v
    }
  deriving a -> IntegerCache b -> IntegerCache a
(a -> b) -> IntegerCache a -> IntegerCache b
(forall a b. (a -> b) -> IntegerCache a -> IntegerCache b)
-> (forall a b. a -> IntegerCache b -> IntegerCache a)
-> Functor IntegerCache
forall a b. a -> IntegerCache b -> IntegerCache a
forall a b. (a -> b) -> IntegerCache a -> IntegerCache b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IntegerCache b -> IntegerCache a
$c<$ :: forall a b. a -> IntegerCache b -> IntegerCache a
fmap :: (a -> b) -> IntegerCache a -> IntegerCache b
$cfmap :: forall a b. (a -> b) -> IntegerCache a -> IntegerCache b
Functor

-- | A positive integer cache is represented as a little-endian bitwise
--   trie
type PosIntCache v = BinaryTreeCache v

theIntegers ∷ IntegerCache Integer
theIntegers :: IntegerCache Integer
theIntegers
  = IntegerCache :: forall v. v -> PosIntCache v -> PosIntCache v -> IntegerCache v
IntegerCache {
      icZero :: Integer
icZero     = Integer
0,
      icNegative :: PosIntCache Integer
icNegative = Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> PosIntCache Integer -> PosIntCache Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PosIntCache Integer
thePosInts,
      icPositive :: PosIntCache Integer
icPositive = PosIntCache Integer
thePosInts
    }

thePosInts ∷ PosIntCache Integer
thePosInts :: PosIntCache Integer
thePosInts =
  BinaryTreeCache :: forall v.
v -> BinaryTreeCache v -> BinaryTreeCache v -> BinaryTreeCache v
BinaryTreeCache {
   btValue :: Integer
btValue = Integer
1,
   btLeft :: PosIntCache Integer
btLeft  = (Integer -> Integer) -> PosIntCache Integer -> PosIntCache Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2) PosIntCache Integer
thePosInts,
   btRight :: PosIntCache Integer
btRight = (Integer -> Integer) -> PosIntCache Integer -> PosIntCache Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer
forall a. Enum a => a -> a
succ (Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2)) PosIntCache Integer
thePosInts
 }

integerLookup ∷ IntegerCache v → Integer → v
integerLookup :: IntegerCache v -> Integer -> v
integerLookup IntegerCache v
cache Integer
n =
  case Integer
n Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Integer
0 of
    Ordering
EQ → IntegerCache v -> v
forall v. IntegerCache v -> v
icZero IntegerCache v
cache
    Ordering
GT → PosIntCache v -> Integer -> v
forall v. PosIntCache v -> Integer -> v
posIntLookup (IntegerCache v -> PosIntCache v
forall v. IntegerCache v -> PosIntCache v
icPositive IntegerCache v
cache) Integer
n
    Ordering
LT → PosIntCache v -> Integer -> v
forall v. PosIntCache v -> Integer -> v
posIntLookup (IntegerCache v -> PosIntCache v
forall v. IntegerCache v -> PosIntCache v
icNegative IntegerCache v
cache) (Integer -> Integer
forall a. Num a => a -> a
negate Integer
n)

-- PRECONDITION: @n@ is a positive 'Integer'
posIntLookup ∷ PosIntCache v → Integer → v
posIntLookup :: PosIntCache v -> Integer -> v
posIntLookup PosIntCache v
cache Integer
1 = PosIntCache v -> v
forall v. BinaryTreeCache v -> v
btValue PosIntCache v
cache
posIntLookup PosIntCache v
cache Integer
n
  | Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
n    = PosIntCache v -> Integer -> v
forall v. PosIntCache v -> Integer -> v
posIntLookup (PosIntCache v -> PosIntCache v
forall v. BinaryTreeCache v -> BinaryTreeCache v
btLeft PosIntCache v
cache) (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2)
  | Bool
otherwise = PosIntCache v -> Integer -> v
forall v. PosIntCache v -> Integer -> v
posIntLookup (PosIntCache v -> PosIntCache v
forall v. BinaryTreeCache v -> BinaryTreeCache v
btRight PosIntCache v
cache) (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2)

---
--- Enumerable types using binary search trees
---

newtype Finite a = ToFinite { Finite a -> a
fromFinite ∷ a }
  deriving (Finite a -> Finite a -> Bool
(Finite a -> Finite a -> Bool)
-> (Finite a -> Finite a -> Bool) -> Eq (Finite a)
forall a. Eq a => Finite a -> Finite a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Finite a -> Finite a -> Bool
$c/= :: forall a. Eq a => Finite a -> Finite a -> Bool
== :: Finite a -> Finite a -> Bool
$c== :: forall a. Eq a => Finite a -> Finite a -> Bool
Eq, Finite a
Finite a -> Finite a -> Bounded (Finite a)
forall a. a -> a -> Bounded a
forall a. Bounded a => Finite a
maxBound :: Finite a
$cmaxBound :: forall a. Bounded a => Finite a
minBound :: Finite a
$cminBound :: forall a. Bounded a => Finite a
Bounded, Int -> Finite a
Finite a -> Int
Finite a -> [Finite a]
Finite a -> Finite a
Finite a -> Finite a -> [Finite a]
Finite a -> Finite a -> Finite a -> [Finite a]
(Finite a -> Finite a)
-> (Finite a -> Finite a)
-> (Int -> Finite a)
-> (Finite a -> Int)
-> (Finite a -> [Finite a])
-> (Finite a -> Finite a -> [Finite a])
-> (Finite a -> Finite a -> [Finite a])
-> (Finite a -> Finite a -> Finite a -> [Finite a])
-> Enum (Finite a)
forall a. Enum a => Int -> Finite a
forall a. Enum a => Finite a -> Int
forall a. Enum a => Finite a -> [Finite a]
forall a. Enum a => Finite a -> Finite a
forall a. Enum a => Finite a -> Finite a -> [Finite a]
forall a. Enum a => Finite a -> Finite a -> Finite a -> [Finite a]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Finite a -> Finite a -> Finite a -> [Finite a]
$cenumFromThenTo :: forall a. Enum a => Finite a -> Finite a -> Finite a -> [Finite a]
enumFromTo :: Finite a -> Finite a -> [Finite a]
$cenumFromTo :: forall a. Enum a => Finite a -> Finite a -> [Finite a]
enumFromThen :: Finite a -> Finite a -> [Finite a]
$cenumFromThen :: forall a. Enum a => Finite a -> Finite a -> [Finite a]
enumFrom :: Finite a -> [Finite a]
$cenumFrom :: forall a. Enum a => Finite a -> [Finite a]
fromEnum :: Finite a -> Int
$cfromEnum :: forall a. Enum a => Finite a -> Int
toEnum :: Int -> Finite a
$ctoEnum :: forall a. Enum a => Int -> Finite a
pred :: Finite a -> Finite a
$cpred :: forall a. Enum a => Finite a -> Finite a
succ :: Finite a -> Finite a
$csucc :: forall a. Enum a => Finite a -> Finite a
Enum)

instance (Bounded a, Enum a) ⇒ Memoizable (Finite a) where
  memoize :: (Finite a -> v) -> Finite a -> v
memoize Finite a -> v
f = BinaryTreeCache v -> Finite a -> v
forall a v. (Bounded a, Enum a) => BinaryTreeCache v -> a -> v
finiteLookup (Finite a -> v
f (Finite a -> v) -> BinaryTreeCache (Finite a) -> BinaryTreeCache v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryTreeCache (Finite a)
forall a. (Bounded a, Enum a) => BinaryTreeCache a
theFinites)

-- | For finite 'Int'-like types, we use a balanced binary search tree
--   indexed to every element from 'minBound' to 'maxBound'
theFinites ∷ (Bounded a, Enum a) ⇒ BinaryTreeCache a
theFinites :: BinaryTreeCache a
theFinites = a -> a -> BinaryTreeCache a
forall t. (Bounded t, Enum t) => t -> t -> BinaryTreeCache t
loop a
forall a. Bounded a => a
minBound a
forall a. Bounded a => a
maxBound where
  loop :: t -> t -> BinaryTreeCache t
loop t
start t
stop =
    BinaryTreeCache :: forall v.
v -> BinaryTreeCache v -> BinaryTreeCache v -> BinaryTreeCache v
BinaryTreeCache {
      btValue :: t
btValue = t
mean,
      btLeft :: BinaryTreeCache t
btLeft  = t -> t -> BinaryTreeCache t
loop t
start (t -> t
forall a. Enum a => a -> a
pred t
mean),
      btRight :: BinaryTreeCache t
btRight = t -> t -> BinaryTreeCache t
loop (t -> t
forall a. Enum a => a -> a
succ t
mean) t
stop
    }
    where mean :: t
mean = t -> t -> t
forall a. (Bounded a, Enum a) => a -> a -> a
meanFinite t
start t
stop

finiteLookup ∷ (Bounded a, Enum a) ⇒ BinaryTreeCache v → a → v
finiteLookup :: BinaryTreeCache v -> a -> v
finiteLookup BinaryTreeCache v
cache0 a
a0 =
  Int -> Int -> BinaryTreeCache v -> v
forall v. Int -> Int -> BinaryTreeCache v -> v
loop Int
start0 Int
stop0 BinaryTreeCache v
cache0 where
    start0 :: Int
start0 = a -> Int
forall a. Enum a => a -> Int
fromEnum (a
forall a. Bounded a => a
minBound a -> a -> a
forall a. a -> a -> a
`asTypeOf` a
a0)
    stop0 :: Int
stop0  = a -> Int
forall a. Enum a => a -> Int
fromEnum (a
forall a. Bounded a => a
maxBound a -> a -> a
forall a. a -> a -> a
`asTypeOf` a
a0)
    a :: Int
a      = a -> Int
forall a. Enum a => a -> Int
fromEnum a
a0
    loop :: Int -> Int -> BinaryTreeCache v -> v
loop Int
start Int
stop BinaryTreeCache v
cache =
      let mean :: Int
mean = Int -> Int -> Int
forall a. (Bounded a, Enum a) => a -> a -> a
meanFinite Int
start Int
stop in
        case Int
a Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
mean of
          Ordering
EQ → BinaryTreeCache v -> v
forall v. BinaryTreeCache v -> v
btValue BinaryTreeCache v
cache
          Ordering
LT → Int -> Int -> BinaryTreeCache v -> v
loop Int
start (Int -> Int
forall a. Enum a => a -> a
pred Int
mean) (BinaryTreeCache v -> BinaryTreeCache v
forall v. BinaryTreeCache v -> BinaryTreeCache v
btLeft BinaryTreeCache v
cache)
          Ordering
GT → Int -> Int -> BinaryTreeCache v -> v
loop (Int -> Int
forall a. Enum a => a -> a
succ Int
mean) Int
stop (BinaryTreeCache v -> BinaryTreeCache v
forall v. BinaryTreeCache v -> BinaryTreeCache v
btRight BinaryTreeCache v
cache)

meanFinite     ∷ (Bounded a, Enum a) ⇒ a → a → a
meanFinite :: a -> a -> a
meanFinite a
a a
b = Int -> a
forall a. Enum a => Int -> a
toEnum (Int
ia Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ib Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                           if Int -> Bool
forall a. Integral a => a -> Bool
odd Int
ia Bool -> Bool -> Bool
&& Int -> Bool
forall a. Integral a => a -> Bool
odd Int
ib then Int
1 else Int
0)
  where
    ia :: Int
ia = a -> Int
forall a. Enum a => a -> Int
fromEnum a
a
    ib :: Int
ib = a -> Int
forall a. Enum a => a -> Int
fromEnum a
b

-- | Can be used to memoize over any "finite" type satisfying
-- 'Enum' and 'Bounded'.  This builds a binary search tree, treating
-- the memoized type as isomorphic to a range of 'Int', so it will be
-- only as efficient as 'toEnum', 'fromEnum', 'succ', and 'pred'.
--
-- This can be used to make instances for finite types. For example, the
-- instances for 'Int' and 'Char' are declared as:
--
-- @
--   instance Memoizable Int where memoize = memoizeFinite
--   instance Memoizable Char where memoize = memoizeFinite
-- @
memoizeFinite   ∷ (Enum a, Bounded a) ⇒ (a → v) → a → v
memoizeFinite :: (a -> v) -> a -> v
memoizeFinite a -> v
f = (Finite a -> v) -> Finite a -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize (a -> v
f (a -> v) -> (Finite a -> a) -> Finite a -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Finite a -> a
forall a. Finite a -> a
fromFinite) (Finite a -> v) -> (a -> Finite a) -> a -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Finite a
forall a. a -> Finite a
ToFinite

instance Memoizable Int where memoize :: (Int -> v) -> Int -> v
memoize = (Int -> v) -> Int -> v
forall a v. (Enum a, Bounded a) => (a -> v) -> a -> v
memoizeFinite
instance Memoizable Char where memoize :: (Char -> v) -> Char -> v
memoize = (Char -> v) -> Char -> v
forall a v. (Enum a, Bounded a) => (a -> v) -> a -> v
memoizeFinite
instance Memoizable Word.Word where memoize :: (Word -> v) -> Word -> v
memoize = (Word -> v) -> Word -> v
forall a v. (Enum a, Bounded a) => (a -> v) -> a -> v
memoizeFinite
instance Memoizable Word.Word8 where memoize :: (Word8 -> v) -> Word8 -> v
memoize = (Word8 -> v) -> Word8 -> v
forall a v. (Enum a, Bounded a) => (a -> v) -> a -> v
memoizeFinite
instance Memoizable Word.Word16 where memoize :: (Word16 -> v) -> Word16 -> v
memoize = (Word16 -> v) -> Word16 -> v
forall a v. (Enum a, Bounded a) => (a -> v) -> a -> v
memoizeFinite
instance Memoizable Word.Word32 where memoize :: (Word32 -> v) -> Word32 -> v
memoize = (Word32 -> v) -> Word32 -> v
forall a v. (Enum a, Bounded a) => (a -> v) -> a -> v
memoizeFinite
instance Memoizable Word.Word64 where memoize :: (Word64 -> v) -> Word64 -> v
memoize = (Word64 -> v) -> Word64 -> v
forall a v. (Enum a, Bounded a) => (a -> v) -> a -> v
memoizeFinite

---
--- Derived instances
---

deriveMemoizable ''()
deriveMemoizable ''Bool
deriveMemoizable ''Ordering
deriveMemoizable ''Maybe
deriveMemoizable ''Either
deriveMemoizable ''[]
deriveMemoizable ''Complex.Complex
deriveMemoizable ''Version.Version

#ifdef COMPAT_HAS_SOLO
deriveMemoizable ''Tuple.Solo
#endif
deriveMemoizable ''(,)
deriveMemoizable ''(,,)
deriveMemoizable ''(,,,)
deriveMemoizable ''(,,,,)
deriveMemoizable ''(,,,,,)
deriveMemoizable ''(,,,,,,)
deriveMemoizable ''(,,,,,,,)
deriveMemoizable ''(,,,,,,,,)
deriveMemoizable ''(,,,,,,,,,)
deriveMemoizable ''(,,,,,,,,,,)
deriveMemoizable ''(,,,,,,,,,,,)

---
--- Functions
---

instance (Eq a, Bounded a, Enum a, Memoizable b) ⇒ Memoizable (a → b) where
  memoize :: ((a -> b) -> v) -> (a -> b) -> v
memoize = FunctionCache b v -> (a -> b) -> v
forall a b v.
(Eq a, Bounded a, Enum a, Memoizable b) =>
FunctionCache b v -> (a -> b) -> v
functionLookup (FunctionCache b v -> (a -> b) -> v)
-> (((a -> b) -> v) -> FunctionCache b v)
-> ((a -> b) -> v)
-> (a -> b)
-> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> b) -> v) -> FunctionCache b v
forall a b v.
(Eq a, Bounded a, Enum a, Memoizable b) =>
((a -> b) -> v) -> FunctionCache b v
theFunctions

functionLookup ∷ (Eq a, Bounded a, Enum a, Memoizable b) ⇒
                 FunctionCache b v → (a → b) → v
functionLookup :: FunctionCache b v -> (a -> b) -> v
functionLookup FunctionCache b v
cache a -> b
f =
  FunctionCache b v -> v
forall b v. FunctionCache b v -> v
fcNil ((FunctionCache b v -> b -> FunctionCache b v)
-> FunctionCache b v -> [b] -> FunctionCache b v
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FunctionCache b v -> b -> FunctionCache b v
forall b v. FunctionCache b v -> b -> FunctionCache b v
fcCons FunctionCache b v
cache (a -> b
f (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]))

theFunctions ∷ (Eq a, Bounded a, Enum a, Memoizable b) ⇒
               ((a → b) → v) → FunctionCache b v
theFunctions :: ((a -> b) -> v) -> FunctionCache b v
theFunctions (a -> b) -> v
f =
  FunctionCache :: forall b v. v -> (b -> FunctionCache b v) -> FunctionCache b v
FunctionCache {
    fcNil :: v
fcNil  = (a -> b) -> v
f a -> b
forall a. HasCallStack => a
undefined,
    fcCons :: b -> FunctionCache b v
fcCons = (b -> FunctionCache b v) -> b -> FunctionCache b v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize (\b
b → ((a -> b) -> v) -> FunctionCache b v
forall a b v.
(Eq a, Bounded a, Enum a, Memoizable b) =>
((a -> b) -> v) -> FunctionCache b v
theFunctions ((a -> b) -> v
f ((a -> b) -> v) -> ((a -> b) -> a -> b) -> (a -> b) -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> (a -> b) -> a -> b
forall t p. (Eq t, Bounded t, Enum t) => p -> (t -> p) -> t -> p
extend b
b))
  }
    where
      extend :: p -> (t -> p) -> t -> p
extend p
b t -> p
g t
a
        | t
a t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
forall a. Bounded a => a
minBound = p
b
        | Bool
otherwise     = t -> p
g (t -> t
forall a. Enum a => a -> a
pred t
a)

data FunctionCache b v
  = FunctionCache {
      FunctionCache b v -> v
fcNil  ∷ v,
      FunctionCache b v -> b -> FunctionCache b v
fcCons ∷ b → FunctionCache b v
    }


---
--- Other instances
---

instance Memoizable Void.Void where
  memoize :: (Void -> v) -> Void -> v
memoize Void -> v
f = Void -> v
f (Void -> v) -> (Void -> Void) -> Void -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Void -> Void
forall a. Void -> a
Void.absurd

-- Data.Ratio.Ratio isn't derivable because it's an abstract type.
instance (Integral a, Memoizable a) => Memoizable (Ratio.Ratio a) where
  memoize :: (Ratio a -> v) -> Ratio a -> v
memoize Ratio a -> v
f = ((a, a) -> v) -> (a, a) -> v
forall a v. Memoizable a => (a -> v) -> a -> v
memoize (Ratio a -> v
f (Ratio a -> v) -> ((a, a) -> Ratio a) -> (a, a) -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> Ratio a
forall a. Integral a => (a, a) -> Ratio a
inj) ((a, a) -> v) -> (Ratio a -> (a, a)) -> Ratio a -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio a -> (a, a)
forall b. Ratio b -> (b, b)
prj
    where
      prj :: Ratio b -> (b, b)
prj Ratio b
r      = (Ratio b -> b
forall a. Ratio a -> a
Ratio.numerator Ratio b
r, Ratio b -> b
forall a. Ratio a -> a
Ratio.denominator Ratio b
r)
      inj :: (a, a) -> Ratio a
inj (a
n, a
d) = a
n a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
Ratio.% a
d


---
--- Example functions
---

-- Memoize on 'Integer'. If memoization doesn't work, this will be
-- horribly slow.
_fib ∷ Integer → Integer
_fib :: Integer -> Integer
_fib = ((Integer -> Integer) -> Integer -> Integer) -> Integer -> Integer
forall a v. Memoizable a => ((a -> v) -> a -> v) -> a -> v
memoFix (((Integer -> Integer) -> Integer -> Integer)
 -> Integer -> Integer)
-> ((Integer -> Integer) -> Integer -> Integer)
-> Integer
-> Integer
forall a b. (a -> b) -> a -> b
$ \Integer -> Integer
fib Integer
n → case Integer
n of
  Integer
0 → Integer
1
  Integer
1 → Integer
1
  Integer
_ → Integer -> Integer
fib (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer
fib (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
2)

-- Memoize on a function.  The use of 'trace' will indicate when
-- the function is called to fill in the memo cache.
_isNot       ∷ (Bool → Bool) → Bool
_isNot :: (Bool -> Bool) -> Bool
_isNot       = ((Bool -> Bool) -> Bool) -> (Bool -> Bool) -> Bool
forall a v. Memoizable a => (a -> v) -> a -> v
memoize (((Bool -> Bool) -> Bool) -> (Bool -> Bool) -> Bool)
-> ((Bool -> Bool) -> Bool) -> (Bool -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \Bool -> Bool
f →
  String -> Bool -> Bool
forall a. String -> a -> a
trace String
"_isNot" (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    Bool -> Bool
f Bool
True Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False Bool -> Bool -> Bool
&& Bool -> Bool
f Bool
False Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True

-- Memoize on a curried function!
_countTrue ∷ (Bool → Bool → Bool) → Integer
_countTrue :: (Bool -> Bool -> Bool) -> Integer
_countTrue = ((Bool -> Bool -> Bool) -> Integer)
-> (Bool -> Bool -> Bool) -> Integer
forall a v. Memoizable a => (a -> v) -> a -> v
memoize (((Bool -> Bool -> Bool) -> Integer)
 -> (Bool -> Bool -> Bool) -> Integer)
-> ((Bool -> Bool -> Bool) -> Integer)
-> (Bool -> Bool -> Bool)
-> Integer
forall a b. (a -> b) -> a -> b
$ \Bool -> Bool -> Bool
f →
  String -> Integer -> Integer
forall a. String -> a -> a
trace String
"_countTrue" (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$
    Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Bool -> Bool -> Bool
f (Bool -> Bool -> Bool) -> [Bool] -> [Bool -> Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bool
False,Bool
True] [Bool -> Bool] -> [Bool] -> [Bool]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Bool
False,Bool
True] [Bool] -> (Bool -> [()]) -> [()]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard))