chimera-0.4.1.0/0000755000000000000000000000000007346545000011453 5ustar0000000000000000chimera-0.4.1.0/LICENSE0000644000000000000000000000275007346545000012464 0ustar0000000000000000Copyright Bodigrim (c) 2017 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. * Neither the name of Bodigrim nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. 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.chimera-0.4.1.0/README.md0000644000000000000000000001544207346545000012740 0ustar0000000000000000# chimera [![Hackage](http://img.shields.io/hackage/v/chimera.svg)](https://hackage.haskell.org/package/chimera) [![Stackage LTS](http://stackage.org/package/chimera/badge/lts)](http://stackage.org/lts/package/chimera) [![Stackage Nightly](http://stackage.org/package/chimera/badge/nightly)](http://stackage.org/nightly/package/chimera) Lazy infinite compact streams with cache-friendly O(1) indexing and applications for memoization. ## Introduction Imagine having a function `f :: Word -> a`, which is expensive to evaluate. We would like to _memoize_ it, returning `g :: Word -> a`, which does effectively the same, but transparently caches results to speed up repetitive re-evaluation. There are plenty of memoizing libraries on Hackage, but they usually fall into two categories: * Store cache as a flat array, enabling us to obtain cached values in O(1) time, which is nice. The drawback is that one must specify the size of the array beforehand, limiting an interval of inputs, and actually allocate it at once. * Store cache as a lazy binary tree. Thanks to laziness, one can freely use the full range of inputs. The drawback is that obtaining values from a tree takes logarithmic time and is unfriendly to CPU cache, which kinda defeats the purpose. This package intends to tackle both issues, providing a data type `Chimera` for lazy infinite compact streams with cache-friendly O(1) indexing. Additional features include: * memoization of recursive functions and recurrent sequences, * memoization of functions of several, possibly signed arguments, * efficient memoization of boolean predicates. ## Example 1 Consider the following predicate: ```haskell isOdd :: Word -> Bool isOdd n = if n == 0 then False else not (isOdd (n - 1)) ``` Its computation is expensive, so we'd like to memoize it: ```haskell isOdd' :: Word -> Bool isOdd' = memoize isOdd ``` This is fine to avoid re-evaluation for the same arguments. But `isOdd` does not use this cache internally, going all the way of recursive calls to `n = 0`. We can do better, if we rewrite `isOdd` as a `fix` point of `isOddF`: ```haskell isOddF :: (Word -> Bool) -> Word -> Bool isOddF f n = if n == 0 then False else not (f (n - 1)) ``` and invoke `memoizeFix` to pass cache into recursive calls as well: ```haskell isOdd' :: Word -> Bool isOdd' = memoizeFix isOddF ``` ## Example 2 Define a predicate, which checks whether its argument is a prime number, using trial division. ```haskell isPrime :: Word -> Bool isPrime n = n > 1 && and [ n `rem` d /= 0 | d <- [2 .. floor (sqrt (fromIntegral n))], isPrime d] ``` This is certainly an expensive recursive computation and we would like to speed up its evaluation by wrappping into a caching layer. Convert the predicate to an unfixed form such that `isPrime = fix isPrimeF`: ```haskell isPrimeF :: (Word -> Bool) -> Word -> Bool isPrimeF f n = n > 1 && and [ n `rem` d /= 0 | d <- [2 .. floor (sqrt (fromIntegral n))], f d] ``` Now create its memoized version for rapid evaluation: ```haskell isPrime' :: Word -> Bool isPrime' = memoizeFix isPrimeF ``` ## Example 3 No manual on memoization is complete without Fibonacci numbers: ```haskell fibo :: Word -> Integer fibo = memoizeFix $ \f n -> if n < 2 then toInteger n else f (n - 1) + f (n - 2) ``` No cleverness involved: just write a recursive function and let `memoizeFix` take care about everything else: ```haskell > fibo 100 354224848179261915075 ``` ## What about non-`Word` arguments? `Chimera` itself can memoize only `Word -> a` functions, which sounds restrictive. That is because we decided to outsource enumerating of user's datatypes to other packages, e. g., [`cantor-pairing`](http://hackage.haskell.org/package/cantor-pairing). Use `fromInteger . fromCantor` to convert data to `Word` and `toCantor . toInteger` to go back. Also, `Data.Chimera.ContinuousMapping` covers several simple cases, such as `Int`, pairs and triples. ## Benchmarks How important is to store cached data as a flat array instead of a lazy binary tree? Let us measure the maximal length of [Collatz sequence](https://oeis.org/A006577), using `chimera` and `memoize` packages. ```haskell #!/usr/bin/env cabal {- cabal: build-depends: base, chimera, memoize, time -} {-# LANGUAGE TypeApplications #-} import Data.Chimera import Data.Function.Memoize import Data.Ord import Data.List import Data.Time.Clock collatzF :: Integral a => (a -> a) -> (a -> a) collatzF f n = if n <= 1 then 0 else 1 + f (if even n then n `quot` 2 else 3 * n + 1) measure :: (Integral a, Show a) => String -> (((a -> a) -> (a -> a)) -> (a -> a)) -> IO () measure name memo = do t0 <- getCurrentTime print $ maximumBy (comparing (memo collatzF)) [0..1000000] t1 <- getCurrentTime putStrLn $ name ++ " " ++ show (diffUTCTime t1 t0) main :: IO () main = do measure "chimera" Data.Chimera.memoizeFix measure "memoize" (Data.Function.Memoize.memoFix @Int) ``` Here `chimera` appears to be 20x faster than `memoize`: ``` 837799 chimera 0.428015s 837799 memoize 8.955953s ``` ## Magic and its exposure Internally `Chimera` is represented as a _boxed_ vector of growing (possibly, _unboxed_) vectors `v a`: ```haskell newtype Chimera v a = Chimera (Data.Vector.Vector (v a)) ``` Assuming 64-bit architecture, the outer vector consists of 65 inner vectors of sizes 1, 1, 2, 2², ..., 2⁶³. Since the outer vector is boxed, inner vectors are allocated on-demand only: quite fortunately, there is no need to allocate all 2⁶⁴ elements at once. To access an element by its index it is enough to find out to which inner vector it belongs, which, thanks to the doubling pattern of sizes, can be done instantly by [`ffs`](https://en.wikipedia.org/wiki/Find_first_set) instruction. The caveat here is that accessing an inner vector first time will cause its allocation, taking O(n) time. So to restore _amortized_ O(1) time we must assume a dense access. `Chimera` is no good for sparse access over a thin set of indices. One can argue that this structure is not infinite, because it cannot handle more than 2⁶⁴ elements. I believe that it is _infinite enough_ and no one would be able to exhaust its finiteness any time soon. Strictly speaking, to cope with indices out of `Word` range and `memoize` [Ackermann function](https://en.wikipedia.org/wiki/Ackermann_function), one could use more layers of indirection, raising access time to O([log ⃰](https://en.wikipedia.org/wiki/Iterated_logarithm) n). I still think that it is morally correct to claim O(1) access, because all asymptotic estimates of data structures are usually made under an assumption that they contain less than `maxBound :: Word` elements (otherwise you can not even treat pointers as a fixed-size data). ## Additional resources * [Lazy streams with O(1) access](https://github.com/Bodigrim/my-talks/raw/master/londonhaskell2020/slides.pdf), London Haskell, 25.02.2020. chimera-0.4.1.0/bench/0000755000000000000000000000000007346545000012532 5ustar0000000000000000chimera-0.4.1.0/bench/Bench.hs0000644000000000000000000000022407346545000014103 0ustar0000000000000000module Main where import Test.Tasty.Bench import Memoize import Read main :: IO () main = defaultMain [ readBenchmark , memoizeBenchmark ] chimera-0.4.1.0/bench/Memoize.hs0000644000000000000000000000312407346545000014473 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} module Memoize ( memoizeBenchmark ) where import Data.Bits import Data.Chimera import Data.Foldable import Data.Function import qualified Data.Vector.Unboxed as U import Test.Tasty.Bench memoizeBenchmark :: Benchmark memoizeBenchmark = bgroup "memoize" [ bgroup "memoizeFix" $ memoizeFixBenchmark memoizeFix , bgroup "memoizeFix unboxed" $ memoizeFixBenchmark (index . tabulateFix @U.Vector) , bgroup "fix memoize" $ memoizeFixBenchmark (fix . (memoize .)) ] memoizeFixBenchmark :: (forall a. U.Unbox a => ((Word -> a) -> Word -> a) -> Word -> a) -> [Benchmark] memoizeFixBenchmark fixer = [ bench "isOdd" $ nf (\f -> let isOdd = fixer f in foldl' (\acc n -> xor acc (isOdd n)) False [0..10000]) isOddF , bench "isPrime" $ nf (\f -> let isPrime = fixer f in foldl' (\acc n -> xor acc (isPrime n)) False [0..10000]) isPrimeF , bench "fibo" $ nf (\f -> let fibo = fixer f in foldl' (\acc n -> acc + fibo n) 0 [0..10000]) fiboF , bench "collatz" $ nf (\f -> let collatz = fixer f in foldl' (\acc n -> acc + collatz n) 0 [0..1000]) collatzF ] isOddF :: (Word -> Bool) -> Word -> Bool isOddF f n = n /= 0 && not (f (n - 1)) isPrimeF :: (Word -> Bool) -> Word -> Bool isPrimeF f n = n > 1 && and [ n `rem` d /= 0 | d <- [2 .. floor (sqrt (fromIntegral n :: Double))], f d] fiboF :: (Word -> Word) -> Word -> Word fiboF f n = if n < 2 then fromIntegral n else f (n - 1) + f (n - 2) collatzF :: (Word -> Word) -> Word -> Word collatzF f n = if n <= 1 then 0 else 1 + f (if even n then n `quot` 2 else 3 * n + 1) chimera-0.4.1.0/bench/Read.hs0000644000000000000000000000372607346545000013751 0ustar0000000000000000{-# LANGUAGE CPP #-} module Read ( readBenchmark ) where import Control.Monad.State (evalState, put, get) import Data.Bits import Data.Chimera import Test.Tasty.Bench import Test.Tasty.Patterns.Printer import System.Random #ifdef MIN_VERSION_ral import qualified Data.RAList as RAL #endif sizes :: Num a => [a] sizes = [7, 8, 9, 10] readBenchmark :: Benchmark readBenchmark = mapLeafBenchmarks addCompare $ bgroup "read" [ bgroup chimeraBenchName (map benchReadChimera sizes) , bgroup "List" (map benchReadList sizes) #ifdef MIN_VERSION_ral , bgroup "RAL" (map benchReadRAL sizes) #endif ] chimeraBenchName :: String chimeraBenchName = "Chimera" addCompare :: ([String] -> Benchmark -> Benchmark) addCompare (size : name : path) | name /= chimeraBenchName = bcompare (printAwkExpr (locateBenchmark (size : chimeraBenchName : path))) addCompare _ = id randomChimera :: UChimera Int randomChimera = flip evalState (mkStdGen 42) $ tabulateM $ const $ do g <- get let (x, g') = random g put g' pure x randomList :: [Int] randomList = randoms (mkStdGen 42) #ifdef MIN_VERSION_ral randomRAL :: RAL.RAList Int randomRAL = RAL.fromList $ take (1 `shiftL` (maximum sizes)) $ randoms (mkStdGen 42) #endif randomIndicesWord :: [Word] randomIndicesWord = randoms (mkStdGen 42) randomIndicesInt :: [Int] randomIndicesInt = randoms (mkStdGen 42) benchReadChimera :: Int -> Benchmark benchReadChimera k = bench (show n) $ nf (sum . map (index randomChimera)) $ map (.&. (n - 1)) $ take (fromIntegral n) randomIndicesWord where n = 1 `shiftL` k benchReadList :: Int -> Benchmark benchReadList k = bench (show n) $ nf (sum . map (randomList !!)) $ map (.&. (n - 1)) $ take n randomIndicesInt where n = 1 `shiftL` k #ifdef MIN_VERSION_ral benchReadRAL :: Int -> Benchmark benchReadRAL k = bench (show n) $ nf (sum . map (randomRAL RAL.!)) $ map (.&. (n - 1)) $ take n randomIndicesInt where n = 1 `shiftL` k #endif chimera-0.4.1.0/cbits/0000755000000000000000000000000007346545000012557 5ustar0000000000000000chimera-0.4.1.0/cbits/aarch64.c0000644000000000000000000000033007346545000014147 0ustar0000000000000000#include uint64_t umulh(uint64_t x, uint64_t y) { return ((unsigned __int128)x * y) >> 64; } uint64_t umodh(uint64_t lo, uint64_t hi, uint64_t m) { return (((unsigned __int128)hi << 64) + lo) % m; } chimera-0.4.1.0/cbits/aarch64.h0000644000000000000000000000016407346545000014161 0ustar0000000000000000#include uint64_t umulh(uint64_t x, uint64_t y); uint64_t umodh(uint64_t lo, uint64_t hi, uint64_t m); chimera-0.4.1.0/changelog.md0000644000000000000000000000327107346545000013727 0ustar0000000000000000# 0.4.1.0 * Fix divergence of `fromInfinite` and `fromListWithDef` on infinite inputs. # 0.4.0.0 * Remove instances `Foldable` and `Traversable`, they are too dangerous to diverge. * Add `HalfWord` and `ThirdWord` types, change types of `toZCurve`, `fromZCurve`, `toZCurve3`, `fromZCurve3` accordingly. * Add `throughZCurveFix` and `throughZCurveFix3`. * Add `imapSubvectors`. * Add `prependVector`. # 0.3.4.0 * Breaking change: remove deprecated `zipSubvectors`, use `zipWithSubvectors`. * Add `foldr` catamorphism and `fromInfinite` / `toInfinite` conversions. * Add `iterateWithIndex` and `iterateWithIndexM`. # 0.3.3.0 * Add `fromListWithDef`, `fromVectorWithDef`, `interleave`. * Add `unfoldr` and `unfoldrM`. * Export `tabulateFixM'`. * Add `sliceSubvectors`, `traverseSubvectors`, `zipWithSubvectors` and `zipWithMSubvectors`. * Deprecate `zipSubvectors` in favor of `zipWithSubvectors`. # 0.3.2.0 * Implement `tabulateFix'`. * Compatibility fixes. # 0.3.1.0 * Define `Monad`, `MonadFix`, `MonadZip` instances. * Define `Distributive` and `Representable` instances. * Speed up `index`. # 0.3.0.0 * Make `Chimera` polymorphic by vector type * Implement `memoize` and `memoizeFix`. * Implement `cycle` and `iterate`. * Implement `mapSubvectors` and `zipSubvectors` * Make boxed `tabulateFix` even lazier. * Speed up `Data.Chimera.WheelMapping`. * Remove `mapWithKey`, `traverseWithKey`, `zipWithKey`, `zipWithKeyM`. # 0.2.0.0 * Generalize bit streams to `Chimera` datatype. * Define `Applicative` instance. * Implement `toList`, `trueIndices` and `falseIndices`. * Make boxed `tabulateFix` lazier. # 0.1.0.2 * Compatibility fixes. # 0.1.0.1 * Compatibility fixes. # 0.1.0.0 * Initial release. chimera-0.4.1.0/chimera.cabal0000644000000000000000000000663707346545000014063 0ustar0000000000000000cabal-version: 2.2 name: chimera version: 0.4.1.0 license: BSD-3-Clause license-file: LICENSE copyright: 2017-2019 Bodigrim maintainer: andrew.lelechenko@gmail.com author: Bodigrim tested-with: ghc ==9.8.1 ghc ==9.6.3 ghc ==9.4.8 ghc ==9.2.8 ghc ==9.0.2 ghc ==8.10.7 ghc ==8.8.4 ghc ==8.6.5 ghc ==8.4.4 ghc ==8.2.2 homepage: https://github.com/Bodigrim/chimera#readme synopsis: Lazy infinite streams with O(1) indexing and applications for memoization description: There are plenty of memoizing libraries on Hackage, but they usually fall into two categories: . * Store cache as a flat array, enabling us to obtain cached values in O(1) time, which is nice. The drawback is that one must specify the size of the array beforehand, limiting an interval of inputs, and actually allocate it at once. * Store cache as a lazy binary tree. Thanks to laziness, one can freely use the full range of inputs. The drawback is that obtaining values from a tree takes logarithmic time and is unfriendly to CPU cache, which kinda defeats the purpose. . This package intends to tackle both issues, providing a data type 'Chimera' for lazy infinite compact streams with cache-friendly O(1) indexing. . Additional features include: . * memoization of recursive functions and recurrent sequences, * memoization of functions of several, possibly signed arguments, * efficient memoization of boolean predicates. category: Data build-type: Simple extra-source-files: cbits/aarch64.h extra-doc-files: README.md changelog.md source-repository head type: git location: https://github.com/Bodigrim/chimera flag representable description: Define Representable instance from adjunctions package library exposed-modules: Data.Chimera Data.Chimera.ContinuousMapping Data.Chimera.WheelMapping hs-source-dirs: src other-modules: Data.Chimera.Compat Data.Chimera.FromIntegral Data.Chimera.Internal Data.Chimera.Memoize default-language: Haskell2010 ghc-options: -Wall -Wcompat build-depends: base >=4.10 && <5, infinite-list <0.2, primitive <0.10, transformers <0.7, vector <0.14, if arch(aarch64) c-sources: cbits/aarch64.c include-dirs: cbits if flag(representable) build-depends: adjunctions <4.5, distributive <0.7, mtl <2.4, test-suite chimera-test type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall -Wcompat build-depends: base >=4.5 && <5, chimera, infinite-list, QuickCheck >=2.10 && <2.15, tasty <1.6, tasty-hunit <0.11, tasty-quickcheck <0.11, tasty-smallcheck <0.9, vector, benchmark chimera-bench type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: bench other-modules: Memoize Read default-language: Haskell2010 ghc-options: -Wall -Wcompat build-depends: base, chimera, mtl, random <1.3, tasty >=1.4.2, tasty-bench >=0.3.2 && <0.4, vector, chimera-0.4.1.0/src/Data/0000755000000000000000000000000007346545000013113 5ustar0000000000000000chimera-0.4.1.0/src/Data/Chimera.hs0000644000000000000000000000530507346545000015022 0ustar0000000000000000-- | -- Module: Data.Chimera -- Copyright: (c) 2018-2019 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko -- -- Lazy infinite streams with O(1) indexing. module Data.Chimera ( -- * Memoization memoize, memoizeFix, -- * Chimera Chimera, VChimera, UChimera, -- * Construction tabulate, tabulateFix, tabulateFix', iterate, iterateWithIndex, unfoldr, cycle, fromListWithDef, fromVectorWithDef, fromInfinite, -- * Manipulation interleave, prependVector, -- * Elimination index, foldr, toList, toInfinite, -- * Monadic construction -- $monadic tabulateM, tabulateFixM, tabulateFixM', iterateM, iterateWithIndexM, unfoldrM, -- * Subvectors -- $subvectors mapSubvectors, imapSubvectors, traverseSubvectors, zipWithSubvectors, zipWithMSubvectors, sliceSubvectors, ) where import Prelude hiding (Applicative (..), and, cycle, div, drop, foldr, fromIntegral, iterate, not, or, (*), (^)) import Data.Chimera.Internal import Data.Chimera.Memoize -- $monadic -- Be careful: the stream is infinite, so -- monadic effects must be lazy -- in order to be executed in a finite time. -- -- For instance, lazy state monad works fine: -- -- >>> import Control.Monad.State.Lazy -- >>> ch = evalState (tabulateM (\i -> do modify (+ i); get)) 0 :: UChimera Word -- >>> take 10 (toList ch) -- [0,1,3,6,10,15,21,28,36,45] -- -- But the same computation in the strict state -- monad "Control.Monad.State.Strict" diverges. -- $subvectors -- Internally 'Chimera' consists of a number of subvectors. -- Following functions provide a low-level access to them. -- This ability is especially important for streams of booleans. -- -- Let us use 'Chimera' to memoize predicates @f1@, @f2@ @::@ 'Word' @->@ 'Bool'. -- Imagine them both already -- caught in amber as @ch1@, @ch2@ @::@ 'UChimera' 'Bool', -- and now we want to memoize @f3 x = f1 x && f2 x@ as @ch3@. -- One can do it in as follows: -- -- > ch3 = tabulate (\i -> index ch1 i && index ch2 i) -- -- There are two unsatisfactory things here. Firstly, -- even unboxed vectors store only one boolean per byte. -- We would rather reach out for 'Data.Bit.Bit' wrapper, -- which provides an instance of unboxed vector -- with one boolean per bit. Secondly, combining -- existing predicates by indexing them and tabulating again -- becomes relatively expensive, given how small and simple -- our data is. Fortunately, there is an ultra-fast 'Data.Bit.zipBits' -- to zip bit vectors. We can combine it altogether like this: -- -- > import Data.Bit -- > import Data.Bits -- > ch1 = tabulate (Bit . f1) -- > ch2 = tabulate (Bit . f2) -- > ch3 = zipWithSubvectors (zipBits (.&.)) ch1 ch2 chimera-0.4.1.0/src/Data/Chimera/0000755000000000000000000000000007346545000014463 5ustar0000000000000000chimera-0.4.1.0/src/Data/Chimera/Compat.hs0000644000000000000000000000237707346545000016253 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-} -- | -- Module: Data.Chimera.Compat -- Copyright: (c) 2023 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko -- -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22933 -- and https://gitlab.haskell.org/ghc/ghc/-/issues/22966 module Data.Chimera.Compat ( timesWord2#, remWord2#, ) where #ifdef aarch64_HOST_ARCH import GHC.Exts (Word(..), Word#, timesWord#) timesWord2# :: Word# -> Word# -> (# Word#, Word# #) timesWord2# x y = (# z, timesWord# x y #) where !(W# z) = c_umulh (W# x) (W# y) {-# INLINE timesWord2# #-} foreign import capi unsafe "aarch64.h umulh" c_umulh :: Word -> Word -> Word remWord2# :: Word# -> Word# -> Word# -> Word# remWord2# lo hi m = r where !(W# r) = c_umodh (W# lo) (W# hi) (W# m) {-# INLINE remWord2# #-} foreign import capi unsafe "aarch64.h umodh" c_umodh :: Word -> Word -> Word -> Word #else import GHC.Exts (Word#, timesWord2#, quotRemWord2#) remWord2# :: Word# -> Word# -> Word# -> Word# remWord2# lo hi m = r where !(# _, r #) = quotRemWord2# hi lo m {-# INLINE remWord2# #-} #endif chimera-0.4.1.0/src/Data/Chimera/ContinuousMapping.hs0000644000000000000000000002771307346545000020513 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} -- | -- Module: Data.Chimera.ContinuousMapping -- Copyright: (c) 2017 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko -- -- Helpers for continuous mappings, useful to memoize -- functions on 'Int' (instead of 'Word' only) and -- functions over two and three arguments. -- -- __Example 1__ -- -- Imagine writing a program to simulate -- . -- This is a cellular automaton, -- which consists of an infinite one-dimensional line of cells, -- each being either dead ('False') or alive ('True'). -- If two neighbours of a cell are equal, -- it becomes dead on the next step, otherwise alive. -- -- Usually cellular automata are modelled by a finite vector. -- This is a bit suboptimal, because cellular automata -- may grow in different directions over time, but with -- a finite vector one has to define a bounding segment well beforehand. -- Moreover, what if we are interested to explore -- an evolution of an essentially infinite initial configuration? -- -- It would be natural to encode an initial configuration -- as a function 'Int' @->@ 'Bool', which takes a coordinate -- and returns the status of the corresponding cell. Define -- a function, which translates the automaton to the next step: -- -- > step :: (Int -> Bool) -> (Int -> Bool) -- > step current = \n -> current (n - 1) /= current (n + 1) -- -- Unfortunately, iterating @step@ would be extremely slow -- because of branching recursion. One -- could suggest to introduce a caching layer: -- -- > step :: (Int -> Bool) -> (Int -> Bool) -- > step current = \n -> current' (n - 1) /= current' (n + 1) -- > where -- > current' = memoize (current . fromIntegral) . fromIntegral -- -- Unfortunately, it would not work well, -- because 'fromIntegral' @::@ 'Int' @->@ 'Word' -- maps @-1@ to 'maxBound' and it would take ages to memoize -- everything up to 'maxBound'. -- But continuous mappings 'intToWord' and 'wordToInt' avoid this issue: -- -- > step :: (Int -> Bool) -> (Int -> Bool) -- > step current = \n -> current' (n - 1) /= current' (n + 1) -- > where -- > current' = memoize (current . wordToInt) . intToWord -- -- __Example 2__ -- -- What about another famous cellular automaton: -- ? -- It is two-dimensional, so its state can be represented as -- a function 'Int' @->@ 'Int' @->@ 'Bool'. Following the approach above, -- we would like to memoize such functions. -- Namely, cast the state to 'Word' @->@ 'Bool', ready for memoization: -- -- > cast :: (Int -> Int -> Bool) -> (Word -> Bool) -- > cast f = \n -> let (x, y) = fromZCurve n in f (fromHalf x) (fromHalf y) -- > where -- > fromHalf :: HalfWord -> Int -- > fromHalf = wordToInt . fromIntegral @HalfWord @Word -- -- and then back: -- -- > uncast :: (Word -> Bool) -> (Int -> Int -> Bool) -- > uncast g = \x y -> g (toZCurve (toHalf x) (toHalf y)) -- > where -- > toHalf :: Int -> HalfWord -- > toHalf = fromIntegral @Word @HalfWord . intToWord module Data.Chimera.ContinuousMapping ( intToWord, wordToInt, HalfWord, toZCurve, fromZCurve, throughZCurveFix, ThirdWord, toZCurve3, fromZCurve3, throughZCurveFix3, ) where import Data.Bifunctor import Data.Bits import Data.Chimera.FromIntegral import Data.Coerce import Data.Word #include "MachDeps.h" -- | Total map, which satisfies -- -- prop> abs (intToWord x - intToWord y) <= 2 * abs (x - y) -- -- Note that usual 'fromIntegral' @::@ 'Int' @->@ 'Word' does not -- satisfy this inequality, -- because it has a discontinuity between −1 and 0. -- -- >>> map intToWord [-5..5] -- [9,7,5,3,1,0,2,4,6,8,10] -- -- @since 0.2.0.0 intToWord :: Int -> Word intToWord i = (if sign == 0 then id else complement) (int2word i) `shiftL` 1 + sign where sign = int2word i `shiftR` (finiteBitSize i - 1) {-# INLINE intToWord #-} -- | Inverse for 'intToWord'. -- -- >>> map wordToInt [0..10] -- [0,-1,1,-2,2,-3,3,-4,4,-5,5] -- -- @since 0.2.0.0 wordToInt :: Word -> Int wordToInt w = word2int $ (if w .&. 1 == 0 then id else complement) (w `shiftR` 1) {-# INLINE wordToInt #-} -- | 32 bits on 64-bit architecture, 16 bits on 32-bit architecture. -- -- To create a value of type 'HalfWord' use 'fromIntegral'. -- -- @since 0.4.0.0 #if WORD_SIZE_IN_BITS == 64 newtype HalfWord = HalfWord Word32 deriving newtype (Eq, Ord, Show, Read, Bits, FiniteBits, Bounded, Enum, Num, Integral, Real) #else newtype HalfWord = HalfWord Word16 deriving newtype (Eq, Ord, Show, Read, Bits, FiniteBits, Bounded, Enum, Num, Integral, Real) #endif -- | Total map from plain to line, continuous almost everywhere. -- See . -- -- >>> [ toZCurve x y | x <- [0..3], y <- [0..3] ] -- [0,2,8,10,1,3,9,11,4,6,12,14,5,7,13,15] -- -- @since 0.2.0.0 toZCurve :: HalfWord -> HalfWord -> Word toZCurve x y = part1by1 y `shiftL` 1 .|. part1by1 x -- | Inverse for 'toZCurve'. -- See . -- -- >>> map fromZCurve [0..15] -- [(0,0),(1,0),(0,1),(1,1),(2,0),(3,0),(2,1),(3,1),(0,2),(1,2),(0,3),(1,3),(2,2),(3,2),(2,3),(3,3)] -- -- @since 0.2.0.0 fromZCurve :: Word -> (HalfWord, HalfWord) fromZCurve z = (compact1by1 z, compact1by1 (z `shiftR` 1)) -- | Convert a function of two 'HalfWord's to a function of one 'Word'. contramapFromZCurve :: (HalfWord -> HalfWord -> a) -> (Word -> a) contramapFromZCurve f = uncurry f . fromZCurve -- | Convert a function of one 'Word' to a function of two 'HalfWord's. contramapToZCurve :: (Word -> a) -> (HalfWord -> HalfWord -> a) contramapToZCurve f = (f .) . toZCurve -- | For an input function @f@ return function @g@ such that -- 'Data.Function.fix' @f@ = ('Data.Function.fix' @g@ '.') '.' 'toZCurve'. -- -- @since 0.4.0.0 throughZCurveFix :: ((HalfWord -> HalfWord -> a) -> (HalfWord -> HalfWord -> a)) -> (Word -> a) -> (Word -> a) throughZCurveFix f = contramapFromZCurve . f . contramapToZCurve -- | 21 bits on 64-bit architecture, 10 bits on 32-bit architecture. -- -- To create a value of type 'ThirdWord' use 'fromIntegral'. -- -- @since 0.4.0.0 newtype ThirdWord = ThirdWord Word32 deriving newtype (Eq, Ord, Show) mkThirdWord :: Word32 -> ThirdWord mkThirdWord n = t where t = ThirdWord (n .&. ((1 `shiftL` finiteBitSize t) - 1)) instance Read ThirdWord where readsPrec = (fmap (first mkThirdWord) .) . readsPrec instance Bits ThirdWord where (.&.) = coerce ((.&.) @Word32) (.|.) = coerce ((.|.) @Word32) xor = coerce (xor @Word32) complement (ThirdWord n) = mkThirdWord (complement n) shift (ThirdWord n) k = mkThirdWord (shift n k) bitSize = finiteBitSize bitSizeMaybe = Just . finiteBitSize isSigned = coerce (isSigned @Word32) testBit = coerce (testBit @Word32) bit = mkThirdWord . bit popCount = coerce (popCount @Word32) rotate t k' | k == 0 = t | otherwise = (t `shiftL` k) .|. (t `shiftR` (fbs - k)) where fbs = finiteBitSize t k = k' `mod` fbs instance FiniteBits ThirdWord where finiteBitSize = const $ finiteBitSize (0 :: Word) `quot` 3 instance Bounded ThirdWord where minBound = mkThirdWord minBound maxBound = mkThirdWord maxBound instance Enum ThirdWord where toEnum = mkThirdWord . toEnum fromEnum = coerce (fromEnum @Word32) instance Num ThirdWord where ThirdWord x + ThirdWord y = mkThirdWord (x + y) ThirdWord x * ThirdWord y = mkThirdWord (x * y) negate (ThirdWord x) = mkThirdWord (negate x) abs = coerce (abs @Word32) signum = coerce (signum @Word32) fromInteger = mkThirdWord . fromInteger instance Real ThirdWord where toRational = coerce (toRational @Word32) instance Integral ThirdWord where quotRem = coerce (quotRem @Word32) toInteger = coerce (toInteger @Word32) -- | Total map from space to line, continuous almost everywhere. -- See . -- -- >>> [ toZCurve3 x y z | x <- [0..3], y <- [0..3], z <- [0..3] ] -- [0,4,32,36,2,6,34,38,16,20,48,52,18,22,50,54,1,5,33,37,3,7,35,39,17,21,49,53,19,23,51,55, -- 8,12,40,44,10,14,42,46,24,28,56,60,26,30,58,62,9,13,41,45,11,15,43,47,25,29,57,61,27,31,59,63] -- -- @since 0.2.0.0 toZCurve3 :: ThirdWord -> ThirdWord -> ThirdWord -> Word toZCurve3 x y z = part1by2 z `shiftL` 2 .|. part1by2 y `shiftL` 1 .|. part1by2 x -- | Inverse for 'toZCurve3'. -- See . -- -- >>> map fromZCurve3 [0..63] -- [(0,0,0),(1,0,0),(0,1,0),(1,1,0),(0,0,1),(1,0,1),(0,1,1),(1,1,1),(2,0,0),(3,0,0),(2,1,0),(3,1,0),(2,0,1),(3,0,1),(2,1,1),(3,1,1), -- (0,2,0),(1,2,0),(0,3,0),(1,3,0),(0,2,1),(1,2,1),(0,3,1),(1,3,1),(2,2,0),(3,2,0),(2,3,0),(3,3,0),(2,2,1),(3,2,1),(2,3,1),(3,3,1), -- (0,0,2),(1,0,2),(0,1,2),(1,1,2),(0,0,3),(1,0,3),(0,1,3),(1,1,3),(2,0,2),(3,0,2),(2,1,2),(3,1,2),(2,0,3),(3,0,3),(2,1,3),(3,1,3), -- (0,2,2),(1,2,2),(0,3,2),(1,3,2),(0,2,3),(1,2,3),(0,3,3),(1,3,3),(2,2,2),(3,2,2),(2,3,2),(3,3,2),(2,2,3),(3,2,3),(2,3,3),(3,3,3)] -- -- @since 0.2.0.0 fromZCurve3 :: Word -> (ThirdWord, ThirdWord, ThirdWord) fromZCurve3 z = (compact1by2 z, compact1by2 (z `shiftR` 1), compact1by2 (z `shiftR` 2)) -- | Convert a function of two 'ThirdWord's to a function of one 'Word'. contramapFromZCurve3 :: (ThirdWord -> ThirdWord -> ThirdWord -> a) -> (Word -> a) contramapFromZCurve3 f = uncurry3 f . fromZCurve3 where uncurry3 func (a, b, c) = func a b c -- | Convert a function of one 'Word' to a function of two 'ThirdWord's. contramapToZCurve3 :: (Word -> a) -> (ThirdWord -> ThirdWord -> ThirdWord -> a) contramapToZCurve3 f = ((f .) .) . toZCurve3 -- | For an input function @f@ return function @g@ such that -- 'Data.Function.fix' @f@ = (('Data.Function.fix' @g@ '.') '.') '.' 'toZCurve3'. -- -- @since 0.4.0.0 throughZCurveFix3 :: ((ThirdWord -> ThirdWord -> ThirdWord -> a) -> (ThirdWord -> ThirdWord -> ThirdWord -> a)) -> (Word -> a) -> (Word -> a) throughZCurveFix3 f = contramapFromZCurve3 . f . contramapToZCurve3 -- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ part1by1 :: HalfWord -> Word part1by1 x = fromIntegral (x5 :: Word64) where x0 = fromIntegral x .&. 0x00000000ffffffff x1 = (x0 `xor` (x0 `shiftL` 16)) .&. 0x0000ffff0000ffff x2 = (x1 `xor` (x1 `shiftL` 8)) .&. 0x00ff00ff00ff00ff x3 = (x2 `xor` (x2 `shiftL` 4)) .&. 0x0f0f0f0f0f0f0f0f x4 = (x3 `xor` (x3 `shiftL` 2)) .&. 0x3333333333333333 x5 = (x4 `xor` (x4 `shiftL` 1)) .&. 0x5555555555555555 -- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ part1by2 :: ThirdWord -> Word part1by2 x = fromIntegral (x5 :: Word64) where x0 = fromIntegral x .&. 0x00000000ffffffff x1 = (x0 `xor` (x0 `shiftL` 32)) .&. 0xffff00000000ffff x2 = (x1 `xor` (x1 `shiftL` 16)) .&. 0x00ff0000ff0000ff x3 = (x2 `xor` (x2 `shiftL` 8)) .&. 0xf00f00f00f00f00f x4 = (x3 `xor` (x3 `shiftL` 4)) .&. 0x30c30c30c30c30c3 x5 = (x4 `xor` (x4 `shiftL` 2)) .&. 0x1249249249249249 -- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ compact1by1 :: Word -> HalfWord compact1by1 x = fromIntegral (x5 :: Word64) where x0 = fromIntegral x .&. 0x5555555555555555 x1 = (x0 `xor` (x0 `shiftR` 1)) .&. 0x3333333333333333 x2 = (x1 `xor` (x1 `shiftR` 2)) .&. 0x0f0f0f0f0f0f0f0f x3 = (x2 `xor` (x2 `shiftR` 4)) .&. 0x00ff00ff00ff00ff x4 = (x3 `xor` (x3 `shiftR` 8)) .&. 0x0000ffff0000ffff x5 = (x4 `xor` (x4 `shiftR` 16)) .&. 0x00000000ffffffff -- Inspired by https://fgiesen.wordpress.com/2009/12/13/decoding-morton-codes/ compact1by2 :: Word -> ThirdWord compact1by2 x = fromIntegral (x5 :: Word64) where x0 = fromIntegral x .&. 0x1249249249249249 x1 = (x0 `xor` (x0 `shiftR` 2)) .&. 0x30c30c30c30c30c3 x2 = (x1 `xor` (x1 `shiftR` 4)) .&. 0xf00f00f00f00f00f x3 = (x2 `xor` (x2 `shiftR` 8)) .&. 0x00ff0000ff0000ff x4 = (x3 `xor` (x3 `shiftR` 16)) .&. 0xffff00000000ffff x5 = (x4 `xor` (x4 `shiftR` 32)) .&. 0x00000000ffffffff chimera-0.4.1.0/src/Data/Chimera/FromIntegral.hs0000644000000000000000000000063707346545000017416 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK hide #-} -- | -- Module: Data.Chimera.FromIntegral -- Copyright: (c) 2018 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko module Data.Chimera.FromIntegral ( word2int, int2word, ) where word2int :: Word -> Int word2int = fromIntegral int2word :: Int -> Word int2word = fromIntegral chimera-0.4.1.0/src/Data/Chimera/Internal.hs0000644000000000000000000006010607346545000016576 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module: Data.Chimera.Internal -- Copyright: (c) 2018-2019 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko module Data.Chimera.Internal ( -- * Chimera Chimera, VChimera, UChimera, -- * Construction tabulate, tabulateFix, tabulateFix', iterate, iterateWithIndex, unfoldr, cycle, fromListWithDef, fromVectorWithDef, fromInfinite, -- * Manipulation interleave, prependVector, -- * Elimination index, foldr, toList, toInfinite, -- * Monadic construction tabulateM, tabulateFixM, tabulateFixM', iterateM, iterateWithIndexM, unfoldrM, -- * Subvectors mapSubvectors, imapSubvectors, traverseSubvectors, zipWithSubvectors, zipWithMSubvectors, sliceSubvectors, ) where import Control.Applicative import Control.Monad.Fix import Control.Monad.Trans.Class import qualified Control.Monad.Trans.State.Lazy as LazyState import Control.Monad.Zip import Data.Bits import Data.Coerce import qualified Data.Foldable as F import Data.Functor.Identity import Data.List.Infinite (Infinite (..)) import qualified Data.List.Infinite as Inf import qualified Data.Primitive.Array as A import Data.Typeable import qualified Data.Vector as V import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import GHC.Exts (fromListN) import Prelude hiding (Applicative (..), and, cycle, div, drop, foldr, fromIntegral, iterate, not, or, (*), (^)) #ifdef MIN_VERSION_mtl import Control.Monad.Reader (MonadReader, ask, local) #endif #ifdef MIN_VERSION_distributive import Data.Distributive #ifdef MIN_VERSION_adjunctions import qualified Data.Functor.Rep as Rep #endif #endif import Data.Chimera.FromIntegral -- | Lazy infinite streams with elements from @a@, -- backed by a 'G.Vector' @v@ (boxed, unboxed, storable, etc.). -- Use 'tabulate', 'tabulateFix', etc. to create a stream -- and 'index' to access its arbitrary elements -- in constant time. -- -- @since 0.2.0.0 newtype Chimera v a = Chimera {unChimera :: A.Array (v a)} deriving ( Functor -- ^ @since 0.2.0.0 ) -- | Streams backed by boxed vectors. -- -- @since 0.3.0.0 type VChimera = Chimera V.Vector -- | Streams backed by unboxed vectors. -- -- @since 0.3.0.0 type UChimera = Chimera U.Vector -- | 'pure' creates a constant stream. -- -- @since 0.2.0.0 instance Applicative (Chimera V.Vector) where pure a = Chimera $ A.arrayFromListN (bits + 1) $ G.singleton a : map (\k -> G.replicate (1 `shiftL` k) a) [0 .. bits - 1] (<*>) = zipWithSubvectors (<*>) liftA2 f = zipWithSubvectors (liftA2 f) -- | @since 0.3.1.0 instance Monad (Chimera V.Vector) where m >>= f = tabulate $ \w -> index (f (index m w)) w -- | @since 0.3.1.0 instance MonadFix (Chimera V.Vector) where mfix = tabulate . mfix . fmap index -- | @since 0.3.1.0 instance MonadZip (Chimera V.Vector) where mzip = zipWithSubvectors mzip mzipWith = zipWithSubvectors . mzipWith #ifdef MIN_VERSION_mtl -- | @since 0.3.1.0 instance MonadReader Word (Chimera V.Vector) where ask = tabulate id local = flip $ (tabulate .) . (.) . index #endif #ifdef MIN_VERSION_distributive -- | @since 0.3.1.0 instance Distributive (Chimera V.Vector) where distribute = tabulate . flip (fmap . flip index) collect f = tabulate . flip ((<$>) . (. f) . flip index) #ifdef MIN_VERSION_adjunctions -- | @since 0.3.1.0 instance Rep.Representable (Chimera V.Vector) where type Rep (Chimera V.Vector) = Word tabulate = tabulate index = index #endif #endif bits :: Int bits = finiteBitSize (0 :: Word) -- | Create a stream of values of a given function. -- Once created it can be accessed via 'index' or 'toList'. -- -- >>> ch = tabulate (^ 2) :: UChimera Word -- >>> index ch 9 -- 81 -- >>> take 10 (toList ch) -- [0,1,4,9,16,25,36,49,64,81] -- -- Note that @a@ could be a function type itself, -- so one can tabulate a function of multiple arguments -- as a nested 'Chimera' of 'Chimera's. -- -- @since 0.2.0.0 tabulate :: G.Vector v a => (Word -> a) -> Chimera v a tabulate f = runIdentity $ tabulateM (coerce f) {-# INLINEABLE tabulate #-} -- | Similar to 'V.generateM', but for raw arrays. generateArrayM :: Monad m => Int -> (Int -> m a) -> m (A.Array a) generateArrayM n f = A.arrayFromListN n <$> traverse f [0 .. n - 1] -- | Monadic version of 'tabulate'. -- -- @since 0.2.0.0 tabulateM :: (Monad m, G.Vector v a) => (Word -> m a) -> m (Chimera v a) tabulateM f = Chimera <$> generateArrayM (bits + 1) tabulateSubVector where tabulateSubVector 0 = G.singleton <$> f 0 tabulateSubVector i = G.generateM ii (\j -> f (int2word (ii + j))) where ii = 1 `unsafeShiftL` (i - 1) {-# INLINEABLE tabulateM #-} {-# SPECIALIZE tabulateM :: G.Vector v a => (Word -> Identity a) -> Identity (Chimera v a) #-} -- | For a given @f@ create a stream of values of a recursive function 'Data.Function.fix' @f@. -- Once created it can be accessed via 'index' or 'toList'. -- -- For example, imagine that we want to tabulate -- : -- -- >>> catalan n = if n == 0 then 1 else sum [ catalan i * catalan (n - 1 - i) | i <- [0 .. n - 1] ] -- -- Can we find @catalanF@ such that @catalan@ = 'Data.Function.fix' @catalanF@? -- Just replace all recursive calls to @catalan@ with @f@: -- -- >>> catalanF f n = if n == 0 then 1 else sum [ f i * f (n - 1 - i) | i <- [0 .. n - 1] ] -- -- Now we are ready to use 'tabulateFix': -- -- >>> ch = tabulateFix catalanF :: VChimera Integer -- >>> index ch 9 -- 4862 -- >>> take 10 (toList ch) -- [1,1,2,5,14,42,132,429,1430,4862] -- -- __Note__: Only recursive function calls with decreasing arguments are memoized. -- If full memoization is desired, use 'tabulateFix'' instead. -- -- Using unboxed \/ storable \/ primitive vectors with 'tabulateFix' is not always a win: -- the internal memoizing routine necessarily uses boxed vectors to achieve -- a certain degree of laziness, so converting to 'UChimera' is extra work. -- This could pay off in a long run by reducing memory residence though. -- -- @since 0.2.0.0 tabulateFix :: (G.Vector v a, Typeable v) => ((Word -> a) -> Word -> a) -> Chimera v a tabulateFix uf = runIdentity $ tabulateFixM (coerce uf) {-# INLINEABLE tabulateFix #-} -- | Fully memoizing version of 'tabulateFix'. -- This function will tabulate every recursive call, -- but might allocate a lot of memory in doing so. -- For example, the following piece of code calculates the -- highest number reached by the -- -- of a given number, but also allocates tens of gigabytes of memory, -- because the Collatz sequence will spike to very high numbers. -- -- >>> collatzF :: (Word -> Word) -> (Word -> Word) -- >>> collatzF _ 0 = 0 -- >>> collatzF f n = if n <= 2 then 4 else n `max` f (if even n then n `quot` 2 else 3 * n + 1) -- >>> -- >>> maximumBy (comparing $ index $ tabulateFix' collatzF) [0..1000000] -- ... -- -- Using 'Data.Chimera.memoizeFix' instead fixes the problem: -- -- >>> maximumBy (comparing $ memoizeFix collatzF) [0..1000000] -- 56991483520 -- -- Since 'tabulateFix'' memoizes all recursive calls, even with increasing argument, -- you most likely do not want to use it with anything else than boxed vectors ('VChimera'). -- -- @since 0.3.2.0 tabulateFix' :: (G.Vector v a, Typeable v) => ((Word -> a) -> Word -> a) -> Chimera v a tabulateFix' uf = runIdentity $ tabulateFixM' (coerce uf) {-# INLINEABLE tabulateFix' #-} -- | Monadic version of 'tabulateFix'. -- There are no particular guarantees about the order of recursive calls: -- they may be executed more than once or executed in different order. -- That said, monadic effects must be idempotent and commutative. -- -- @since 0.2.0.0 tabulateFixM :: (Monad m, G.Vector v a, Typeable v) => ((Word -> m a) -> Word -> m a) -> m (Chimera v a) tabulateFixM = tabulateFixM_ Downwards {-# INLINEABLE tabulateFixM #-} {-# SPECIALIZE tabulateFixM :: (G.Vector v a, Typeable v) => ((Word -> Identity a) -> Word -> Identity a) -> Identity (Chimera v a) #-} -- | Monadic version of 'tabulateFix''. -- -- @since 0.3.3.0 tabulateFixM' :: forall m v a . (Monad m, G.Vector v a, Typeable v) => ((Word -> m a) -> Word -> m a) -> m (Chimera v a) tabulateFixM' = tabulateFixM_ Full {-# INLINEABLE tabulateFixM' #-} {-# SPECIALIZE tabulateFixM' :: (G.Vector v a, Typeable v) => ((Word -> Identity a) -> Word -> Identity a) -> Identity (Chimera v a) #-} -- | Memoization strategy, only used by @tabulateFixM_@. data Strategy = Full | Downwards -- | Internal implementation for 'tabulateFixM' and 'tabulateFixM''. tabulateFixM_ :: forall m v a . (Monad m, G.Vector v a, Typeable v) => Strategy -> ((Word -> m a) -> Word -> m a) -> m (Chimera v a) tabulateFixM_ strat f = result where result :: m (Chimera v a) result = Chimera <$> generateArrayM (bits + 1) tabulateSubVector tabulateSubVector :: Int -> m (v a) tabulateSubVector 0 = G.singleton <$> case strat of Downwards -> fix f 0 Full -> f (\k -> flip index k <$> result) 0 tabulateSubVector i = subResult where subResult = fromBoxedVector <$> subResultBoxed subResultBoxed = V.generateM ii (\j -> f fixF (int2word (ii + j))) ii = 1 `unsafeShiftL` (i - 1) fixF :: Word -> m a fixF k | k < int2word ii = flip index k <$> result | k <= int2word ii `shiftL` 1 - 1 = (`V.unsafeIndex` (word2int k - ii)) <$> subResultBoxed | otherwise = case strat of Downwards -> f fixF k Full -> flip index k <$> result -- It's crucial to inline into tabulateFixM and tabulateFixM'. {-# INLINE tabulateFixM_ #-} fromBoxedVector :: forall v a. (G.Vector v a, Typeable v) => V.Vector a -> v a fromBoxedVector = case eqT @V.Vector @v of Just Refl -> id Nothing -> G.convert -- | 'iterate' @f@ @x@ returns an infinite stream, generated by -- repeated applications of @f@ to @x@. -- -- It holds that 'index' ('iterate' @f@ @x@) 0 is equal to @x@. -- -- >>> ch = iterate (+ 1) 0 :: UChimera Int -- >>> take 10 (toList ch) -- [0,1,2,3,4,5,6,7,8,9] -- -- @since 0.3.0.0 iterate :: G.Vector v a => (a -> a) -> a -> Chimera v a iterate f = runIdentity . iterateM (coerce f) -- | Similar to 'G.iterateNM'. iterateListNM :: forall a m. Monad m => Int -> (a -> m a) -> a -> m [a] iterateListNM n f = if n <= 0 then const (pure []) else go (n - 1) where go :: Int -> a -> m [a] go 0 s = pure [s] go k s = do fs <- f s (s :) <$> go (k - 1) fs -- | Monadic version of 'iterate'. -- -- @since 0.3.0.0 iterateM :: (Monad m, G.Vector v a) => (a -> m a) -> a -> m (Chimera v a) iterateM f seed = do nextSeed <- f seed let z = G.singleton seed zs <- iterateListNM bits go (G.singleton nextSeed) pure $ Chimera $ fromListN (bits + 1) (z : zs) where go vec = do nextSeed <- f (G.unsafeLast vec) G.iterateNM (G.length vec `shiftL` 1) f nextSeed {-# SPECIALIZE iterateM :: G.Vector v a => (a -> Identity a) -> a -> Identity (Chimera v a) #-} -- | 'unfoldr' @f@ @x@ returns an infinite stream, generated by -- repeated applications of @f@ to @x@, similar to `Data.List.unfoldr`. -- -- >>> ch = unfoldr (\acc -> (acc * acc, acc + 1)) 0 :: UChimera Int -- >>> take 10 (toList ch) -- [0,1,4,9,16,25,36,49,64,81] -- -- @since 0.3.3.0 unfoldr :: G.Vector v b => (a -> (b, a)) -> a -> Chimera v b unfoldr f = runIdentity . unfoldrM (coerce f) -- | This is not quite satisfactory, see https://github.com/haskell/vector/issues/447 unfoldrExactVecNM :: forall m a b v. (Monad m, G.Vector v b) => Int -> (a -> m (b, a)) -> a -> m (v b, a) unfoldrExactVecNM n f s = flip LazyState.evalStateT s $ do vec <- G.replicateM n f' seed <- LazyState.get pure (vec, seed) where f' :: LazyState.StateT a m b f' = do seed <- LazyState.get (value, newSeed) <- lift (f seed) LazyState.put newSeed pure value -- | Monadic version of 'unfoldr'. -- -- @since 0.3.3.0 unfoldrM :: (Monad m, G.Vector v b) => (a -> m (b, a)) -> a -> m (Chimera v b) unfoldrM f seed = do let go n s = if n >= bits then pure [] else do (vec, s') <- unfoldrExactVecNM (1 `shiftL` n) f s rest <- go (n + 1) s' pure $ vec : rest (z, seed') <- unfoldrExactVecNM 1 f seed zs <- go 0 seed' pure $ Chimera $ fromListN (bits + 1) (z : zs) {-# SPECIALIZE unfoldrM :: G.Vector v b => (a -> Identity (b, a)) -> a -> Identity (Chimera v b) #-} -- | 'iterateWithIndex' @f@ @x@ returns an infinite stream, generated by -- applications of @f@ to a current index and previous value, starting from @x@. -- -- It holds that 'index' ('iterateWithIndex' @f@ @x@) 0 is equal to @x@. -- -- >>> ch = iterateWithIndex (+) 100 :: UChimera Word -- >>> take 10 (toList ch) -- [100,101,103,106,110,115,121,128,136,145] -- -- @since 0.3.4.0 iterateWithIndex :: G.Vector v a => (Word -> a -> a) -> a -> Chimera v a iterateWithIndex f = runIdentity . iterateWithIndexM (coerce f) iterateWithIndexExactVecNM :: forall m a v. (Monad m, G.Vector v a) => Int -> (Word -> a -> m a) -> a -> m (v a) iterateWithIndexExactVecNM n f s = G.unfoldrExactNM n go (int2word n, s) where go :: (Word, a) -> m (a, (Word, a)) go (i, x) = do x' <- f i x pure (x', (i + 1, x')) -- | Monadic version of 'iterateWithIndex'. -- -- @since 0.3.4.0 iterateWithIndexM :: (Monad m, G.Vector v a) => (Word -> a -> m a) -> a -> m (Chimera v a) iterateWithIndexM f seed = do nextSeed <- f 1 seed let z = G.singleton seed zs <- iterateListNM bits go (G.singleton nextSeed) pure $ Chimera $ fromListN (bits + 1) (z : zs) where go vec = iterateWithIndexExactVecNM (G.length vec `shiftL` 1) f (G.unsafeLast vec) {-# SPECIALIZE iterateWithIndexM :: G.Vector v a => (Word -> a -> Identity a) -> a -> Identity (Chimera v a) #-} interleaveVec :: G.Vector v a => v a -> v a -> v a interleaveVec as bs = G.generate (G.length as `shiftL` 1) (\n -> (if even n then as else bs) G.! (n `shiftR` 1)) -- | Intertleave two streams, sourcing even elements from the first one -- and odd elements from the second one. -- -- >>> ch = interleave (tabulate id) (tabulate (+ 100)) :: UChimera Word -- >>> take 10 (toList ch) -- [0,100,1,101,2,102,3,103,4,104] -- -- @since 0.3.3.0 interleave :: G.Vector v a => Chimera v a -> Chimera v a -> Chimera v a interleave (Chimera as) (Chimera bs) = Chimera $ A.arrayFromListN (bits + 1) vecs where vecs = A.indexArray as 0 : A.indexArray bs 0 : map (\i -> interleaveVec (A.indexArray as i) (A.indexArray bs i)) [1 .. bits - 1] -- | Index a stream in a constant time. -- -- >>> ch = tabulate (^ 2) :: UChimera Word -- >>> index ch 9 -- 81 -- -- @since 0.2.0.0 index :: G.Vector v a => Chimera v a -> Word -> a index (Chimera vs) i = (vs `A.indexArray` (bits - lz)) `G.unsafeIndex` word2int (i .&. complement ((1 `shiftL` (bits - 1)) `unsafeShiftR` lz)) where lz :: Int !lz = countLeadingZeros i {-# INLINE index #-} -- | Convert a stream to an infinite list. -- -- >>> ch = tabulate (^ 2) :: UChimera Word -- >>> take 10 (toList ch) -- [0,1,4,9,16,25,36,49,64,81] -- -- @since 0.3.0.0 toList :: G.Vector v a => Chimera v a -> [a] toList (Chimera vs) = foldMap G.toList vs -- | Convert a stream to a proper infinite list. -- -- @since 0.3.4.0 toInfinite :: G.Vector v a => Chimera v a -> Infinite a toInfinite = foldr (:<) -- | Right-associative fold, necessarily lazy in the accumulator. -- Any unconditional attempt to force the accumulator even to WHNF -- will hang the computation. E. g., the following definition isn't productive: -- -- > import Data.List.NonEmpty (NonEmpty(..)) -- > toNonEmpty = foldr (\a (x :| xs) -> a :| x : xs) :: VChimera a -> NonEmpty a -- -- One should use lazy patterns, e. g., -- -- > toNonEmpty = foldr (\a ~(x :| xs) -> a :| x : xs) foldr :: G.Vector v a => (a -> b -> b) -> Chimera v a -> b foldr f (Chimera vs) = F.foldr (flip $ G.foldr f) undefined vs measureOff :: Int -> [a] -> Either Int ([a], [a]) measureOff n | n <= 0 = Right . ([],) | otherwise = go n where go m [] = Left m go 1 (x : xs) = Right ([x], xs) go m (x : xs) = case go (m - 1) xs of l@Left {} -> l Right (xs', xs'') -> Right (x : xs', xs'') measureOffVector :: G.Vector v a => Int -> v a -> Either Int (v a, v a) measureOffVector n xs | n <= l = Right (G.splitAt n xs) | otherwise = Left (n - l) where l = G.length xs -- | Create a stream of values from a given prefix, followed by default value -- afterwards. -- -- @since 0.3.3.0 fromListWithDef :: G.Vector v a => a -- ^ Default value -> [a] -- ^ Prefix -> Chimera v a fromListWithDef a = Chimera . fromListN (bits + 1) . go0 where go0 = \case [] -> G.singleton a : map (\k -> G.replicate (1 `shiftL` k) a) [0 .. bits - 1] x : xs -> G.singleton x : go 0 xs go k xs = if k == bits then [] else v : go (k + 1) zs where kk = 1 `shiftL` k (v, zs) = case measureOff kk xs of Left l -> ( if l == kk then G.replicate kk a else G.fromListN kk (xs ++ replicate l a) , [] ) Right (ys, zs') -> (G.fromListN kk ys, zs') -- | Create a stream of values from a given infinite list. -- -- @since 0.3.4.0 fromInfinite :: G.Vector v a => Infinite a -> Chimera v a fromInfinite = Chimera . fromListN (bits + 1) . go0 where go0 (x :< xs) = G.singleton x : go 0 xs go k xs = if k == bits then [] else G.fromListN kk ys : go (k + 1) zs where kk = 1 `shiftL` k (ys, zs) = Inf.splitAt kk xs -- | Create a stream of values from a given prefix, followed by default value -- afterwards. -- -- @since 0.3.3.0 fromVectorWithDef :: G.Vector v a => a -- ^ Default value -> v a -- ^ Prefix -> Chimera v a fromVectorWithDef a = Chimera . fromListN (bits + 1) . go0 where go0 xs = case G.uncons xs of Nothing -> G.singleton a : map (\k -> G.replicate (1 `shiftL` k) a) [0 .. bits - 1] Just (y, ys) -> G.singleton y : go 0 ys go k xs = case measureOffVector kk xs of Left l -> (xs G.++ G.replicate l a) : map (\n -> G.replicate (1 `shiftL` n) a) [k + 1 .. bits - 1] Right (ys, zs) -> ys : go (k + 1) zs where kk = 1 `shiftL` k -- | Prepend a given vector to a stream of values. -- -- @since 0.4.0.0 prependVector :: forall v a . G.Vector v a => v a -> Chimera v a -> Chimera v a prependVector (G.uncons -> Nothing) ch = ch prependVector (G.uncons -> Just (pref0, pref)) (Chimera as) = Chimera $ fromListN (bits + 1) $ fmap sliceAndConcat $ [LazySlice 0 1 $ G.singleton pref0] : go 0 1 0 inputs where inputs :: [(Word, v a)] inputs = (int2word $ G.length pref, pref) : zip (1 : map (1 `unsafeShiftL`) [0 .. bits - 1]) (F.toList as) go :: Int -> Word -> Word -> [(Word, t)] -> [[LazySlice t]] go _ _ _ [] = [] go n need off orig@((lt, t) : rest) | n >= bits = [] | otherwise = case compare (off + need) lt of LT -> [LazySlice off need t] : go (n + 1) (1 `shiftL` (n + 1)) (off + need) orig EQ -> [LazySlice off need t] : go (n + 1) (1 `shiftL` (n + 1)) 0 rest GT -> case go n (off + need - lt) 0 rest of [] -> error "prependVector: the stream should not get exhausted prematurely" hd : tl -> (LazySlice off (lt - off) t : hd) : tl data LazySlice a = LazySlice !Word !Word a sliceAndConcat :: G.Vector v a => [LazySlice (v a)] -> v a sliceAndConcat = G.concat . map (\(LazySlice from len vec) -> G.slice (word2int from) (word2int len) vec) -- | Return an infinite repetition of a given vector. -- Throw an error on an empty vector. -- -- >>> ch = cycle (Data.Vector.fromList [4, 2]) :: VChimera Int -- >>> take 10 (toList ch) -- [4,2,4,2,4,2,4,2,4,2] -- -- @since 0.3.0.0 cycle :: G.Vector v a => v a -> Chimera v a cycle vec = case l of 0 -> error "Data.Chimera.cycle: empty list" _ -> tabulate (G.unsafeIndex vec . word2int . (`rem` l)) where l = int2word $ G.length vec -- | Map subvectors of a stream, using a given length-preserving function. -- -- @since 0.3.0.0 mapSubvectors :: (G.Vector u a, G.Vector v b) => (u a -> v b) -> Chimera u a -> Chimera v b mapSubvectors f = runIdentity . traverseSubvectors (coerce f) -- | Map subvectors of a stream, using a given length-preserving function. -- The first argument of the function is the index of the first element of subvector -- in the 'Chimera'. -- -- @since 0.4.0.0 imapSubvectors :: (G.Vector u a, G.Vector v b) => (Word -> u a -> v b) -> Chimera u a -> Chimera v b imapSubvectors f (Chimera bs) = Chimera $ mzipWith safeF (fromListN (bits + 1) [0 .. bits]) bs where -- Computing vector length is cheap, so let's check that @f@ preserves length. safeF i x = if xLen == G.length fx then fx else error "imapSubvectors: the function is not length-preserving" where xLen = G.length x fx = f (if i == 0 then 0 else 1 `unsafeShiftL` (i - 1)) x -- | Traverse subvectors of a stream, using a given length-preserving function. -- -- Be careful, because similar to 'tabulateM', only lazy monadic effects can -- be executed in a finite time: lazy state monad is fine, but strict one is -- not. -- -- @since 0.3.3.0 traverseSubvectors :: (G.Vector u a, G.Vector v b, Applicative m) => (u a -> m (v b)) -> Chimera u a -> m (Chimera v b) traverseSubvectors f (Chimera bs) = Chimera <$> traverse safeF bs where -- Computing vector length is cheap, so let's check that @f@ preserves length. safeF x = ( \fx -> if G.length x == G.length fx then fx else error "traverseSubvectors: the function is not length-preserving" ) <$> f x {-# SPECIALIZE traverseSubvectors :: (G.Vector u a, G.Vector v b) => (u a -> Identity (v b)) -> Chimera u a -> Identity (Chimera v b) #-} -- | Zip subvectors from two streams, using a given length-preserving function. -- -- @since 0.3.3.0 zipWithSubvectors :: (G.Vector u a, G.Vector v b, G.Vector w c) => (u a -> v b -> w c) -> Chimera u a -> Chimera v b -> Chimera w c zipWithSubvectors f = (runIdentity .) . zipWithMSubvectors (coerce f) -- | Zip subvectors from two streams, using a given monadic length-preserving function. -- Caveats for 'tabulateM' and 'traverseSubvectors' apply. -- -- @since 0.3.3.0 zipWithMSubvectors :: (G.Vector u a, G.Vector v b, G.Vector w c, Applicative m) => (u a -> v b -> m (w c)) -> Chimera u a -> Chimera v b -> m (Chimera w c) zipWithMSubvectors f (Chimera bs1) (Chimera bs2) = Chimera <$> sequenceA (mzipWith safeF bs1 bs2) where -- Computing vector length is cheap, so let's check that @f@ preserves length. safeF x y = ( \fx -> if G.length x == G.length fx then fx else error "traverseSubvectors: the function is not length-preserving" ) <$> f x y {-# SPECIALIZE zipWithMSubvectors :: (G.Vector u a, G.Vector v b, G.Vector w c) => (u a -> v b -> Identity (w c)) -> Chimera u a -> Chimera v b -> Identity (Chimera w c) #-} -- | Take a slice of 'Chimera', represented as a list on consecutive subvectors. -- -- @since 0.3.3.0 sliceSubvectors :: G.Vector v a => Int -- ^ How many initial elements to drop? -> Int -- ^ How many subsequent elements to take? -> Chimera v a -> [v a] sliceSubvectors off len = doTake len . doDrop off . F.toList . unChimera where doTake !_ [] = [] doTake n (x : xs) | n <= 0 = [] | n >= l = x : doTake (n - l) xs | otherwise = [G.take n x] where l = G.length x doDrop !_ [] = [] doDrop n (x : xs) | n <= 0 = x : xs | l <= n = doDrop (n - l) xs | otherwise = G.drop n x : xs where l = G.length x chimera-0.4.1.0/src/Data/Chimera/Memoize.hs0000644000000000000000000000572407346545000016434 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module: Data.Chimera.Memoize -- Copyright: (c) 2018-2019 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko -- -- High-level functions for memoization. module Data.Chimera.Memoize ( memoize, memoizeFix, ) where import qualified Data.Vector as V import Prelude hiding (Applicative (..), and, cycle, div, drop, foldr, fromIntegral, iterate, not, or, (*), (^)) import Data.Chimera.Internal -- | Memoize a function: -- repeating calls to 'memoize' @f@ @n@ -- would compute @f@ @n@ only once -- and cache the result in 'VChimera'. -- This is just a shortcut for 'index' '.' 'tabulate'. -- -- prop> memoize f n = f n -- -- Note that @a@ could be a function type itself. This allows, for instance, -- to define -- -- > memoize2 :: (Word -> Word -> a) -> Word -> Word -> a -- > memoize2 = memoize . (memoize .) -- > -- > memoize3 :: (Word -> Word -> Word -> a) -> Word -> Word -> Word -> a -- > memoize3 = memoize . (memoize2 .) -- -- @since 0.3.0.0 memoize :: (Word -> a) -> (Word -> a) memoize = index @V.Vector . tabulate -- | For a given @f@ memoize a recursive function 'Data.Function.fix' @f@, -- caching results in 'VChimera'. -- This is just a shortcut for 'index' '.' 'tabulateFix'. -- -- prop> memoizeFix f n = fix f n -- -- For example, imagine that we want to memoize -- : -- -- >>> fibo n = if n < 2 then toInteger n else fibo (n - 1) + fibo (n - 2) -- -- Can we find @fiboF@ such that @fibo@ = 'Data.Function.fix' @fiboF@? -- Just replace all recursive calls to @fibo@ with @f@: -- -- >>> fiboF f n = if n < 2 then toInteger n else f (n - 1) + f (n - 2) -- -- Now we are ready to use 'memoizeFix': -- -- >>> memoizeFix fiboF 10 -- 55 -- >>> memoizeFix fiboF 100 -- 354224848179261915075 -- -- This function can be used even when arguments -- of recursive calls are not strictly decreasing, -- but they might not get memoized. -- For example, here is a routine to measure the length of -- : -- -- >>> collatzF f n = if n <= 1 then 0 else 1 + f (if even n then n `quot` 2 else 3 * n + 1) -- >>> memoizeFix collatzF 27 -- 111 -- -- If you want to memoize all recursive calls, even with increasing arguments, -- you can employ another function of the same signature: -- 'Data.Function.fix' '.' ('memoize' '.'). It is less efficient though. -- -- To memoize recursive functions of multiple arguments, one can use -- -- > memoizeFix2 :: ((Word -> Word -> a) -> Word -> Word -> a) -> Word -> Word -> a -- > memoizeFix2 = let memoize2 = memoize . (memoize .) in Data.Function.fix . (memoize2 .) -- -- @since 0.3.0.0 memoizeFix :: ((Word -> a) -> Word -> a) -> (Word -> a) memoizeFix = index @V.Vector . tabulateFix chimera-0.4.1.0/src/Data/Chimera/WheelMapping.hs0000644000000000000000000002015107346545000017376 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} -- | -- Module: Data.Chimera.WheelMapping -- Copyright: (c) 2017 Andrew Lelechenko -- Licence: BSD3 -- Maintainer: Andrew Lelechenko -- -- Helpers for mapping to -- and back. This has various applications in number theory. -- -- __Example__ -- -- Let @isPrime@ be an expensive predicate, -- which checks whether its argument is a prime number. -- We can memoize it as usual: -- -- > isPrimeCache1 :: UChimera Bool -- > isPrimeCache1 = tabulate isPrime -- > -- > isPrime1 :: Word -> Bool -- > isPrime1 = index isPrimeCache1 -- -- But one may argue that since the only even prime number is 2, -- it is quite wasteful to cache @isPrime@ for even arguments. -- So we can save half the space by memoizing it for odd -- numbers only: -- -- > isPrimeCache2 :: UChimera Bool -- > isPrimeCache2 = tabulate (isPrime . (\n -> 2 * n + 1)) -- > -- > isPrime2 :: Word -> Bool -- > isPrime2 n -- > | n == 2 = True -- > | even n = False -- > | otherwise = index isPrimeCache2 ((n - 1) `quot` 2) -- -- Here @\\n -> 2 * n + 1@ maps n to the (n+1)-th odd number, -- and @\\n -> (n - 1) \`quot\` 2@ takes it back. These functions -- are available below as 'fromWheel2' and 'toWheel2'. -- -- Odd numbers are the simplest example of numbers, lacking -- small prime factors (so called -- ). -- Removing numbers, having small prime factors, is sometimes -- called . -- -- One can go further and exclude not only even numbers, -- but also integers, divisible by 3. -- To do this we need a function which maps n to the (n+1)-th number coprime with 2 and 3 -- (thus, with 6) and its inverse: namely, 'fromWheel6' and 'toWheel6'. Then write -- -- > isPrimeCache6 :: UChimera Bool -- > isPrimeCache6 = tabulate (isPrime . fromWheel6) -- > -- > isPrime6 :: Word -> Bool -- > isPrime6 n -- > | n `elem` [2, 3] = True -- > | n `gcd` 6 /= 1 = False -- > | otherwise = index isPrimeCache6 (toWheel6 n) -- -- Thus, the wheel of 6 saves more space, improving memory locality. -- -- (If you need to reduce memory consumption even further, -- consider using 'Data.Bit.Bit' wrapper, -- which provides an instance of unboxed vector, -- packing one boolean per bit instead of one boolean per byte for 'Bool') module Data.Chimera.WheelMapping ( fromWheel2, toWheel2, fromWheel6, toWheel6, fromWheel30, toWheel30, fromWheel210, toWheel210, ) where import Data.Bits import Data.Chimera.Compat import GHC.Exts hiding (timesWord2#) bits :: Int bits = finiteBitSize (0 :: Word) -- | Left inverse for 'fromWheel2'. Monotonically non-decreasing function. -- -- prop> toWheel2 . fromWheel2 == id -- -- @since 0.2.0.0 toWheel2 :: Word -> Word toWheel2 i = i `shiftR` 1 {-# INLINE toWheel2 #-} -- | 'fromWheel2' n is the (n+1)-th positive odd number. -- Sequence . -- -- prop> map fromWheel2 [0..] == [ n | n <- [0..], n `gcd` 2 == 1 ] -- -- >>> map fromWheel2 [0..9] -- [1,3,5,7,9,11,13,15,17,19] -- -- @since 0.2.0.0 fromWheel2 :: Word -> Word fromWheel2 i = i `shiftL` 1 + 1 {-# INLINE fromWheel2 #-} -- | Left inverse for 'fromWheel6'. Monotonically non-decreasing function. -- -- prop> toWheel6 . fromWheel6 == id -- -- @since 0.2.0.0 toWheel6 :: Word -> Word toWheel6 i@(W# i#) = case bits of 64 -> W# z1# `shiftR` 1 _ -> i `quot` 3 where m# = 12297829382473034411## -- (2^65+1) / 3 !(# z1#, _ #) = timesWord2# m# i# {-# INLINE toWheel6 #-} -- | 'fromWheel6' n is the (n+1)-th positive number, not divisible by 2 or 3. -- Sequence . -- -- prop> map fromWheel6 [0..] == [ n | n <- [0..], n `gcd` 6 == 1 ] -- -- >>> map fromWheel6 [0..9] -- [1,5,7,11,13,17,19,23,25,29] -- -- @since 0.2.0.0 fromWheel6 :: Word -> Word fromWheel6 i = i `shiftL` 1 + i + (i .&. 1) + 1 {-# INLINE fromWheel6 #-} -- | Left inverse for 'fromWheel30'. Monotonically non-decreasing function. -- -- prop> toWheel30 . fromWheel30 == id -- -- @since 0.2.0.0 toWheel30 :: Word -> Word toWheel30 i@(W# i#) = q `shiftL` 3 + (r + r `shiftR` 4) `shiftR` 2 where (q, r) = case bits of 64 -> (q64, r64) _ -> i `quotRem` 30 m# = 9838263505978427529## -- (2^67+7) / 15 !(# z1#, _ #) = timesWord2# m# i# q64 = W# z1# `shiftR` 4 r64 = i - q64 `shiftL` 5 + q64 `shiftL` 1 {-# INLINE toWheel30 #-} -- | 'fromWheel30' n is the (n+1)-th positive number, not divisible by 2, 3 or 5. -- Sequence . -- -- prop> map fromWheel30 [0..] == [ n | n <- [0..], n `gcd` 30 == 1 ] -- -- >>> map fromWheel30 [0..9] -- [1,7,11,13,17,19,23,29,31,37] -- -- @since 0.2.0.0 fromWheel30 :: Word -> Word fromWheel30 i = ((i `shiftL` 2 - i `shiftR` 2) .|. 1) + ((i `shiftL` 1 - i `shiftR` 1) .&. 2) {-# INLINE fromWheel30 #-} -- | Left inverse for 'fromWheel210'. Monotonically non-decreasing function. -- -- prop> toWheel210 . fromWheel210 == id -- -- @since 0.2.0.0 toWheel210 :: Word -> Word toWheel210 i@(W# i#) = q `shiftL` 5 + q `shiftL` 4 + W# tableEl# where !(q, W# r#) = case bits of 64 -> (q64, r64) _ -> i `quotRem` 210 m# = 5621864860559101445## -- (2^69+13) / 105 !(# z1#, _ #) = timesWord2# m# i# q64 = W# z1# `shiftR` 6 r64 = i - q64 * 210 tableEl# = word8ToWord# (indexWord8OffAddr# table# (word2Int# r#)) table# :: Addr# table# = "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\SOH\STX\STX\STX\STX\ETX\ETX\EOT\EOT\EOT\EOT\ENQ\ENQ\ENQ\ENQ\ENQ\ENQ\ACK\ACK\a\a\a\a\a\a\b\b\b\b\t\t\n\n\n\n\v\v\v\v\v\v\f\f\f\f\f\f\r\r\SO\SO\SO\SO\SO\SO\SI\SI\SI\SI\DLE\DLE\DC1\DC1\DC1\DC1\DC1\DC1\DC2\DC2\DC2\DC2\DC3\DC3\DC3\DC3\DC3\DC3\DC4\DC4\DC4\DC4\DC4\DC4\DC4\DC4\NAK\NAK\NAK\NAK\SYN\SYN\ETB\ETB\ETB\ETB\CAN\CAN\EM\EM\EM\EM\SUB\SUB\SUB\SUB\SUB\SUB\SUB\SUB\ESC\ESC\ESC\ESC\ESC\ESC\FS\FS\FS\FS\GS\GS\GS\GS\GS\GS\RS\RS\US\US\US\US !!\"\"\"\"\"\"######$$$$%%&&&&''''''(())))))****++,,,,--........../"# -- map Data.Char.chr [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 2, 2, 2, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 9, 9, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 13, 13, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 19, 19, 19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 23, 23, 23, 23, 24, 24, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 30, 30, 31, 31, 31, 31, 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, 34, 34, 34, 34, 35, 35, 35, 35, 35, 35, 36, 36, 36, 36, 37, 37, 38, 38, 38, 38, 39, 39, 39, 39, 39, 39, 40, 40, 41, 41, 41, 41, 41, 41, 42, 42, 42, 42, 43, 43, 44, 44, 44, 44, 45, 45, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 47] {-# INLINE toWheel210 #-} -- | 'fromWheel210' n is the (n+1)-th positive number, not divisible by 2, 3, 5 or 7. -- Sequence . -- -- prop> map fromWheel210 [0..] == [ n | n <- [0..], n `gcd` 210 == 1 ] -- -- >>> map fromWheel210 [0..9] -- [1,11,13,17,19,23,29,31,37,41] -- -- @since 0.2.0.0 fromWheel210 :: Word -> Word fromWheel210 i@(W# i#) = q * 210 + W# tableEl# where !(q, W# r#) = case bits of 64 -> (q64, r64) _ -> i `quotRem` 48 m# = 12297829382473034411## -- (2^65+1) / 3 !(# z1#, _ #) = timesWord2# m# i# q64 = W# z1# `shiftR` 5 r64 = i - q64 `shiftL` 5 - q64 `shiftL` 4 tableEl# = word8ToWord# (indexWord8OffAddr# table# (word2Int# r#)) table# :: Addr# table# = "\SOH\v\r\DC1\DC3\ETB\GS\US%)+/5;=CGIOSYaegkmqy\DEL\131\137\139\143\149\151\157\163\167\169\173\179\181\187\191\193\197\199\209"# -- map Data.Char.chr [1, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, 121, 127, 131, 137, 139, 143, 149, 151, 157, 163, 167, 169, 173, 179, 181, 187, 191, 193, 197, 199, 209] {-# INLINE fromWheel210 #-} #if !MIN_VERSION_base(4,16,0) word8ToWord# :: Word# -> Word# word8ToWord# x = x #endif chimera-0.4.1.0/test/0000755000000000000000000000000007346545000012432 5ustar0000000000000000chimera-0.4.1.0/test/Test.hs0000644000000000000000000002101407346545000013703 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where import Test.QuickCheck.Function import Test.Tasty import Test.Tasty.HUnit as H import Test.Tasty.QuickCheck as QC hiding ((.&.)) import Data.Bits import Data.Foldable import Data.Function (fix) import qualified Data.List.Infinite as I import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Vector.Generic as G import Data.Chimera.ContinuousMapping import Data.Chimera.WheelMapping import Data.Chimera (UChimera, VChimera) import qualified Data.Chimera as Ch instance (G.Vector v a, Arbitrary a) => Arbitrary (Ch.Chimera v a) where arbitrary = Ch.tabulateM (const arbitrary) main :: IO () main = defaultMain $ testGroup "All" [ contMapTests , wheelMapTests , chimeraTests ] contMapTests :: TestTree contMapTests = testGroup "ContinuousMapping" [ testGroup "wordToInt . intToWord" [ QC.testProperty "random" $ \i -> w2i_i2w i === i , H.testCase "maxBound" $ assertEqual "should be equal" maxBound (w2i_i2w maxBound) , H.testCase "minBound" $ assertEqual "should be equal" minBound (w2i_i2w minBound) ] , testGroup "intToWord . wordToInt" [ QC.testProperty "random" $ \i -> i2w_w2i i === i , H.testCase "maxBound" $ assertEqual "should be equal" maxBound (i2w_w2i maxBound) , H.testCase "minBound" $ assertEqual "should be equal" minBound (i2w_w2i minBound) ] , testGroup "to . from Z-curve 2D" [ QC.testProperty "random" $ \z -> let mask = (1 `shiftL` ((finiteBitSize (0 :: Word) `shiftR` 1) `shiftL` 1)) - 1 in uncurry toZCurve (fromZCurve z) === z .&. mask ] , testGroup "from . to Z-curve 2D" [ QC.testProperty "random" $ \x y -> let mask = (1 `shiftL` (finiteBitSize (0 :: Word) `shiftR` 1)) - 1 in fromZCurve (toZCurve x y) === (x .&. mask, y .&. mask) ] , testGroup "to . from Z-curve 3D" [ QC.testProperty "random" $ \t -> let mask = (1 `shiftL` (finiteBitSize (0 :: Word) `quot` 3) * 3) - 1 in (\(x, y, z) -> toZCurve3 x y z) (fromZCurve3 t) === t .&. mask ] , testGroup "from . to Z-curve 3D" [ QC.testProperty "random" $ \x y z -> let mask = (1 `shiftL` (finiteBitSize (0 :: Word) `quot` 3)) - 1 in fromZCurve3 (toZCurve3 x y z) === (x .&. mask, y .&. mask, z .&. mask) ] ] wheelMapTests :: TestTree wheelMapTests = testGroup "WheelMapping" [ testGroup "toWheel . fromWheel" [ QC.testProperty "2" $ \(Shrink2 x) -> x < maxBound `div` 2 ==> toWheel2 (fromWheel2 x) === x , QC.testProperty "6" $ \(Shrink2 x) -> x < maxBound `div` 3 ==> toWheel6 (fromWheel6 x) === x , QC.testProperty "30" $ \(Shrink2 x) -> x < maxBound `div` 4 ==> toWheel30 (fromWheel30 x) === x , QC.testProperty "210" $ \(Shrink2 x) -> x < maxBound `div` 5 ==> toWheel210 (fromWheel210 x) === x ] ] chimeraTests :: TestTree chimeraTests = testGroup "Chimera" [ QC.testProperty "index . tabulate = id" $ \(Fun _ (f :: Word -> Bool)) ix -> let jx = ix `mod` 65536 in f jx === Ch.index (Ch.tabulate f :: UChimera Bool) jx , QC.testProperty "memoize = id" $ \(Fun _ (f :: Word -> Bool)) ix -> let jx = ix `mod` 65536 in f jx === Ch.memoize f jx , QC.testProperty "index . tabulateFix = fix" $ \(Fun _ g) ix -> let jx = ix `mod` 65536 in let f = mkUnfix g in fix f jx === Ch.index (Ch.tabulateFix f :: UChimera Bool) jx , QC.testProperty "index . tabulateFix' = fix" $ \(Fun _ g) ix -> let jx = ix `mod` 65536 in let f = mkUnfix g in fix f jx === Ch.index (Ch.tabulateFix' f :: UChimera Bool) jx , QC.testProperty "memoizeFix = fix" $ \(Fun _ g) ix -> let jx = ix `mod` 65536 in let f = mkUnfix g in fix f jx === Ch.memoizeFix f jx , QC.testProperty "iterate" $ \(Fun _ (f :: Word -> Word)) seed ix -> let jx = ix `mod` 65536 in iterate f seed !! fromIntegral jx === Ch.index (Ch.iterate f seed :: UChimera Word) jx , QC.testProperty "head . iterate" $ \(Fun _ (f :: Word -> Word)) seed -> seed === Ch.index (Ch.iterate f seed :: UChimera Word) 0 , QC.testProperty "iterateWithIndex" $ \(Fun _ (f :: (Word, Int) -> Int)) seed ix -> let jx = ix `mod` 65536 in iterateWithIndex (curry f) seed !! fromIntegral jx === Ch.index (Ch.iterateWithIndex (curry f) seed :: UChimera Int) jx , QC.testProperty "head . iterateWithIndex" $ \(Fun _ (f :: (Word, Int) -> Int)) seed -> seed === Ch.index (Ch.iterateWithIndex (curry f) seed :: UChimera Int) 0 , QC.testProperty "unfoldr" $ \(Fun _ (f :: Word -> (Int, Word))) seed ix -> let jx = ix `mod` 65536 in L.unfoldr (Just . f) seed !! fromIntegral jx === Ch.index (Ch.unfoldr f seed :: UChimera Int) jx , QC.testProperty "interleave" $ \(Fun _ (f :: Word -> Bool)) (Fun _ (g :: Word -> Bool)) ix -> let jx = ix `mod` 65536 in (if even jx then f else g) (jx `quot` 2) === Ch.index (Ch.interleave (Ch.tabulate f) (Ch.tabulate g) :: UChimera Bool) jx , QC.testProperty "pure" $ \x ix -> let jx = ix `mod` 65536 in x === Ch.index (pure x :: VChimera Word) jx , QC.testProperty "cycle" $ \xs ix -> not (null xs) ==> let jx = ix `mod` 65536 in let vs = G.fromList xs in vs G.! (fromIntegral jx `mod` G.length vs) === Ch.index (Ch.cycle vs :: UChimera Bool) jx , QC.testProperty "toList" $ \x xs -> xs === take (length xs) (Ch.toList (Ch.fromListWithDef x xs :: UChimera Bool)) , testGroup "fromListWithDef" [ QC.testProperty "finite list" $ \x xs ix -> let jx = ix `mod` 65536 in (if fromIntegral jx < length xs then xs !! fromIntegral jx else x) === Ch.index (Ch.fromListWithDef x xs :: UChimera Bool) jx , QC.testProperty "infinite list" $ \x xs ix -> let jx = ix `mod` 65536 in let xs' = QC.getInfiniteList xs in (xs' !! fromIntegral jx) === Ch.index (Ch.fromListWithDef x xs' :: UChimera Bool) jx ] , QC.testProperty "fromInfinite" $ \x xs ix -> let jx = ix `mod` 65536 in let ys = I.cycle (x NE.:| xs) in (ys I.!! jx) === Ch.index (Ch.fromInfinite ys :: UChimera Bool) jx , QC.testProperty "fromVectorWithDef" $ \x xs ix -> let jx = ix `mod` 65536 in let vs = G.fromList xs in (if fromIntegral jx < length xs then vs G.! fromIntegral jx else x) === Ch.index (Ch.fromVectorWithDef x vs :: UChimera Bool) jx , QC.testProperty "prependVector" $ \(Blind bs) xs ix -> let jx = ix `mod` 65536 in let vs = G.fromList xs in (if fromIntegral jx < length xs then vs G.! fromIntegral jx else Ch.index bs (min 65555 $ jx - fromIntegral (length xs))) === Ch.index (Ch.prependVector vs bs :: UChimera Bool) jx , QC.testProperty "mapSubvectors" $ \(Blind bs) (Fun _ (g :: Word -> Word)) ix -> let jx = ix `mod` 65536 in g (Ch.index bs jx) === Ch.index (Ch.mapSubvectors (G.map g) bs :: UChimera Word) jx , QC.testProperty "imapSubvectors" $ \(Blind bs) (Fun _ (g :: (Word, Int) -> Char)) ix -> let jx = ix `mod` 65536 in curry g jx (Ch.index bs jx) === Ch.index (Ch.imapSubvectors (\off -> G.imap (curry g . (+ off) . fromIntegral)) bs :: UChimera Char) jx , QC.testProperty "zipWithSubvectors" $ \(Blind bs1) (Blind bs2) (Fun _ (g :: (Word, Word) -> Word)) ix -> let jx = ix `mod` 65536 in g (Ch.index bs1 jx, Ch.index bs2 jx) === Ch.index (Ch.zipWithSubvectors (G.zipWith (curry g)) bs1 bs2 :: UChimera Word) jx , QC.testProperty "sliceSubvectors" $ \x xs ix -> let vs = G.fromList xs in fold (Ch.sliceSubvectors ix (G.length vs - max 0 ix) (Ch.fromVectorWithDef x vs :: UChimera Bool)) === G.drop ix vs ] ------------------------------------------------------------------------------- -- Utils w2i_i2w :: Int -> Int w2i_i2w = wordToInt . intToWord i2w_w2i :: Word -> Word i2w_w2i = intToWord . wordToInt mkUnfix :: (Word -> [Word]) -> (Word -> Bool) -> Word -> Bool mkUnfix splt f x = foldl' (==) True $ map f $ takeWhile (\y -> 0 <= y && y < x) $ splt x iterateWithIndex :: (Word -> a -> a) -> a -> [a] iterateWithIndex f seed = L.unfoldr (\(ix, a) -> let a' = f (ix + 1) a in Just (a, (ix + 1, a'))) (0, seed) instance Arbitrary HalfWord where arbitrary = fromIntegral <$> (arbitrary :: Gen Word) instance Arbitrary ThirdWord where arbitrary = fromIntegral <$> (arbitrary :: Gen Word)