packages feed

array-memoize (empty) → 0.5.0

raw patch · 5 files changed

+349/−0 lines, 5 filesdep +arraydep +basesetup-changed

Dependencies added: array, base

Files

+ Data/Function/ArrayMemoize.hs view
@@ -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)
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ array-memoize.cabal view
@@ -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
+ example.hs view
@@ -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