diff --git a/Data/Function/ArrayMemoize.hs b/Data/Function/ArrayMemoize.hs new file mode 100644 --- /dev/null +++ b/Data/Function/ArrayMemoize.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeFamilies #-} + +module Data.Function.ArrayMemoize where + +import qualified Data.Array.MArray as MArray +import Data.Array.Unboxed +import Data.Array.IO (IOUArray) +import Data.Array.ST (STArray, STUArray, runSTArray) +import Control.Monad.ST + +import Debug.Trace + +{- + +Attempt at rewrite rules + +{-# RULES "disc-rw1" continuize = cont'; + "disc-rw2" discretize = disc'; + "disc1a" forall delta x . disc' delta (cont' delta x) = x; + "disc2a" forall delta x . cont' delta (disc' delta x) = x; + "disc1b" forall delta . (disc' delta) . (cont' delta) = id; + #-} + +{-# NOINLINE cont' #-} +cont' = continuize +{-# NOINLINE disc' #-} +disc' = discretize + +-} + +-- Memoize and quantize a function over a finite (sub)domain, using an array. + +{-# INLINE quantizedMemo #-} +quantizedMemo :: (Show a, ArrayMemoizable b, Discretize a) => (a, a) -> a -> (a -> b) -> (a -> b) +quantizedMemo (l, u) delta f = + let disc = discretize delta + cache = runSTArray (do cache <- newArray_ (disc l, succ (disc u)) + mapM_ (\x -> writeArray cache x (f (continuize delta x))) (enumFromTo (disc l) (succ (disc u))) + return cache) + in (\x -> cache ! disc x) + +{-# INLINE quantizedMemoFix #-} +quantizedMemoFix :: (ArrayMemoizable b, Discretize a, Show a) => (a, a) -> a -> ((a -> b) -> (a -> b)) -> (a -> b) +quantizedMemoFix (l, u) delta f = memo_f where memo_f = quantizedMemo (l, u) delta (f memo_f) + +{- +quantizedMemoFix :: (Show a, ArrayMemoizable b, Discretize a) => (a, a) -> a -> ((a -> b) -> (a -> b)) -> (a -> b) +quantizedMemoFix (l, u) delta f = + let disc = discretize delta + cache = runSTArray (do cache <- newArray_ (disc l, succ (disc u)) + mapM_ (\x -> writeArray cache x (f' (continuize delta x))) (enumFromTo (disc l) (succ (disc u))) + return cache) + f' = f (\x ->(show x) `trace` cache ! disc x) -- + in f'-} + + +{-# INLINE quantizedMemoFixMutual #-} +quantizedMemoFixMutual :: (ArrayMemoizable b, ArrayMemoizable d, Discretize a, Discretize c, Show a, Show c) => (a, a) -> a -> (c, c) -> c -> ((a -> b) -> (c -> d) -> (a -> b)) -> ((a -> b) -> (c -> d) -> (c -> d)) -> (a -> b) +quantizedMemoFixMutual (l, u) delta (l', u') delta' f g = + memo_f where memo_f = quantizedMemo (l, u) delta (f memo_f memo_g) + memo_g = quantizedMemo (l', u') delta' (g memo_f memo_g) + +-- Memoize and discretize a function over a finite (sub)domain, using an array. + +{-# INLINE discreteMemo #-} +discreteMemo :: (ArrayMemoizable b, Discretize a) => (a, a) -> a -> (a -> b) -> (Discrete a -> b) +discreteMemo (l, u) delta f = + let disc = discretize delta + cache = runSTArray (do cache <- newArray_ (disc l, disc u) + mapM_ (\x -> writeArray cache x (f (continuize delta x))) (enumFromTo (disc l) (disc u)) + return cache) + + in (\x -> cache ! x) + +{-# INLINE discreteMemoFix #-} +discreteMemoFix :: (ArrayMemoizable b, Discretize a) => (a, a) -> a -> ((a -> b) -> (a -> b)) ->(Discrete a -> b) +discreteMemoFix (l, u) delta f = + let disc = discretize delta + cache' = runSTArray (do cache <- newArray_ (disc l, disc u) + mapM_ (\x -> writeArray cache x (f (\x -> cache' ! (disc x)) (continuize delta x))) (enumFromTo (disc l) (disc u)) + return cache) + in (\x -> cache' ! x) + +-- Memoize a function over a finite (sub)domain, using an array. + +{-# INLINE arrayMemo #-} +arrayMemo :: (Ix a, ArrayMemoizable b) => (a, a) -> (a -> b) -> (a -> b) +arrayMemo (l, u) f = + let cache = runSTArray (do cache <- newArray_ (l, u) + mapM_ (\x -> writeArray cache x (f x)) (range (l, u)) + return cache) + in \x -> cache ! x + +{-# INLINE arrayMemoFix #-} +arrayMemoFix :: (Ix a, ArrayMemoizable b) => (a, a) -> ((a -> b) -> (a -> b)) -> a -> b +arrayMemoFix (l, u) f = memo_f where memo_f = arrayMemo (l, u) (f memo_f) + +{-# INLINE arrayMemoFixMutual #-} +arrayMemoFixMutual :: (ArrayMemoizable b, ArrayMemoizable d, Ix a, Ix c) => (a, a) -> (c, c) -> ((a -> b) -> (c -> d) -> (a -> b)) -> ((a -> b) -> (c -> d) -> (c -> d)) -> (a -> b) +arrayMemoFixMutual (l, u) (l', u') f g = + memo_f where memo_f = arrayMemo (l, u) (f memo_f memo_g) + memo_g = arrayMemo (l', u') (g memo_f memo_g) + + +-- Memoize an function over a finite (sub)domain, using an unboxed IO array +-- requires incoming function must return IO - but be otherwise pure + +{-# INLINE uarrayMemoFixIO #-} +uarrayMemoFixIO :: (Ix a, UArrayMemoizable b) => (a, a) -> ((a -> IO b) -> (a -> IO b)) -> a -> IO b +uarrayMemoFixIO (l, u) f = + \i -> do cache <- newUArray_ (l, u) + let f' = f (\x -> readUArray cache x) + mapM_ (\x -> (f' x) >>= (\val -> writeUArray cache x val)) (range (l, u)) + f' i + +{- + + The following defines the subset of types for which we can do array + memoization + +-} + +class ArrayMemoizable a where + newArray_ :: (Ix i) => (i, i) -> ST s (STArray s i a) + writeArray :: (Ix i) => STArray s i a -> i -> a -> ST s () + +instance ArrayMemoizable Float where + newArray_ = MArray.newArray_ + writeArray = MArray.writeArray + +instance ArrayMemoizable Double where + newArray_ = MArray.newArray_ + writeArray = MArray.writeArray + +instance ArrayMemoizable Int where + newArray_ = MArray.newArray_ + writeArray = MArray.writeArray + +-- Unboxed versions using IO + +class IArray UArray a => UArrayMemoizable a where + newUArray_ :: (Ix i) => (i, i) -> IO (IOUArray i a) + writeUArray :: (Ix i) => IOUArray i a -> i -> a -> IO () + readUArray :: (Ix i) => IOUArray i a -> i -> IO a + freeze :: (Ix i) => IOUArray i a -> IO (UArray i a) + +instance UArrayMemoizable Float where + newUArray_ = MArray.newArray_ + readUArray = MArray.readArray + writeUArray = MArray.writeArray + freeze = MArray.freeze + +instance UArrayMemoizable Double where + newUArray_ = MArray.newArray_ + readUArray = MArray.readArray + writeUArray = MArray.writeArray + freeze = MArray.freeze + +instance UArrayMemoizable Int where + newUArray_ = MArray.newArray_ + readUArray = MArray.readArray + writeUArray = MArray.writeArray + freeze = MArray.freeze + +{- + +Num and Enum classes for working with tuple domains + +-} + +instance (Enum a, Enum b) => Enum (a, b) where + toEnum = undefined + succ (a, b) = (succ a, succ b) + fromEnum (a, b) = fromEnum a * fromEnum b + + enumFromTo (lx, ly) (ux, uy) = + [ly..uy] >>= (\y -> [lx..ux] >>= (\x -> return (x, y))) + +instance (Enum a, Enum b, Enum c) => Enum (a, b, c) where + toEnum = undefined + succ (a, b, c) = (succ a, succ b, succ c) + fromEnum (a, b, c) = fromEnum a * fromEnum b * fromEnum c + + enumFromThenTo (lx, ly, lz) (nx, ny, nz) (ux, uy, uz) = + [lz,nz..uz] >>= (\z -> [ly,ny..uy] >>= (\y -> [lx,nx..ux] >>= (\x -> return (x, y, z)))) + +instance (Num a, Num b) => Num (a, b) where + (a1, b1) + (a2, b2) = (a1 + a2, b1 + b2) + (a1, b1) * (a2, b2) = (a1 * a2, b1 * b2) + negate (a, b) = (negate a, negate b) + abs (a, b) = (abs a, abs b) + signum (a, b) = (signum a, signum b) + fromInteger i = (0, fromInteger i) + + +instance (Num a, Num b, Num c) => Num (a, b, c) where + (a1, b1, c1) + (a2, b2, c2) = (a1 + a2, b1 + b2, c1 + c2) + (a1, b1, c1) * (a2, b2, c2) = (a1 * a2, b1 * b2, c1 * c2) + negate (a, b, c) = (negate a, negate b, negate c) + abs (a, b, c) = (abs a, abs b, abs c) + signum (a, b, c) = (signum a, signum b, signum c) + fromInteger i = (0, 0, fromInteger i) + +{- Discretization of float/double values and tuples -} + +class (Ix (Discrete t), Enum (Discrete t)) => Discretize t where + type Discrete t + discretize :: t -> t -> Discrete t + continuize :: t -> Discrete t -> t + +instance Discretize Float where + type Discrete Float = Int + discretize delta x = round' (x / delta) + where round' x = let (n,r) = properFraction x in n + (round r) + continuize delta x = (fromIntegral x) * delta + +instance Discretize Double where + type Discrete Double = Int + discretize delta x = round' (x / delta) + where round' x = let (n,r) = properFraction x in n + (round r) + continuize delta x = (fromIntegral x) * delta + +instance (Discretize a, Discretize b) => Discretize (a, b) where + type Discrete (a, b) = (Discrete a, Discrete b) + discretize (dx, dy) (x, y) = (discretize dx x, discretize dy y) + continuize (dx, dy) (x, y) = (continuize dx x, continuize dy y) + +instance (Discretize a, Discretize b, Discretize c) => Discretize (a, b, c) where + type Discrete (a, b, c) = (Discrete a, Discrete b, Discrete c) + discretize (dx, dy, dz) (x, y, z) = (discretize dx x, discretize dy y, discretize dz z) + continuize (dx, dy, dz) (x, y, z) = (continuize dx x, continuize dy y, continuize dz z) + +discrete :: Discretize a => (a -> b) -> a -> (Discrete a -> b) +discrete f delta = f . (continuize delta) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2014, Dominic Orchard + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/array-memoize.cabal b/array-memoize.cabal new file mode 100644 --- /dev/null +++ b/array-memoize.cabal @@ -0,0 +1,47 @@ +name: array-memoize +version: 0.5.0 +synopsis: Memoization combinators for finite subsets of function domains using arrays + +description: Memoization combinators are great for providing high-performance Haskell programs, + but they can be even faster if memoization is performed on a finite, discrete domain + as an array can then be used. + . + This package provides various combinators for doing just this, including also + combinators for quanitzing and discretizing Float/Double-valued functions. + . + Example: + . + @ + fibA :: Int -> Int + fibA 0 = 1 + fibA 1 = 1 + fibA n = fibB (n - 1) + fibB (n - 2) + + fibB = arrayMemo (0, 1000) fibA + @ + +license: BSD3 +license-file: LICENSE +category: Syntax, +copyright: Dominic Orchard, 2014 +author: Dominic Orchard +maintainer: Dominic Orchard +stability: experimental +build-type: Simple +cabal-version: >= 1.6 +tested-with: GHC >= 7.6 + +extra-source-files: example.hs + +source-repository head + type: git + location: https://github.com/dorchard/array-memoize + + +library + hs-source-dirs: . + + exposed-modules: Data.Function.ArrayMemoize + + build-depends: base < 5, + array >= 0.4 diff --git a/example.hs b/example.hs new file mode 100644 --- /dev/null +++ b/example.hs @@ -0,0 +1,36 @@ +import Data.Function.ArrayMemoize + +-- Example: + +-- Fibonacci (pre-fixed point) + +fib' :: (Int -> Int) -> Int -> Int +fib' _ 0 = 1 +fib' _ 1 = 1 +fib' rec n = rec (n - 1) + rec (n - 2) + +-- Memoizes fib between 0 and 100 (after that it is a run-time error) + +fib :: Int -> Int +fib = arrayMemoFix (0, 1000) fib' + +-- IO variant + +fibIO' :: (Int -> IO Int) -> Int -> IO Int +fibIO' _ 0 = return 1 +fibIO' _ 1 = return 1 +fibIO' rec n = do a <- rec (n - 1) + b <- rec (n - 2) + return (a + b) + +fibIO :: Int -> IO Int +fibIO = uarrayMemoFixIO (0,1000) fibIO' + +-- Manual fix versions + +fibA :: Int -> Int +fibA 0 = 1 +fibA 1 = 1 +fibA n = fibB (n - 1) + fibB (n - 2) + +fibB = arrayMemo (0, 1000) fibA