subhask 0.1.0.1 → 0.1.1.0
raw patch · 16 files changed
+770/−312 lines, 16 filesdep +arraydep −pipesdep ~MonadRandomdep ~approximatedep ~bytes
Dependencies added: array
Dependencies removed: pipes
Dependency ranges changed: MonadRandom, approximate, bytes, cassava, hyperloglog, lens, semigroups
Files
- README.md +15/−12
- bench/Vector.hs +20/−19
- cbits/Lebesgue.c +120/−14
- examples/example0002-monad-instances-for-set.lhs +33/−18
- src/SubHask/Algebra.hs +83/−2
- src/SubHask/Algebra/Array.hs +238/−125
- src/SubHask/Algebra/Metric.hs +7/−7
- src/SubHask/Algebra/Ord.hs +35/−32
- src/SubHask/Algebra/Ring.hs +51/−0
- src/SubHask/Algebra/Vector.hs +26/−62
- src/SubHask/Algebra/Vector/FFI.hs +103/−0
- src/SubHask/Compatibility/ByteString.hs +3/−0
- src/SubHask/Internal/Prelude.hs +8/−2
- src/SubHask/TemplateHaskell/Deriving.hs +1/−2
- subhask.cabal +20/−14
- test/TestSuite.hs +7/−3
README.md view
@@ -1,4 +1,4 @@-# SubHask +# SubHask  SubHask is a radical rewrite of the Haskell [Prelude](https://www.haskell.org/onlinereport/standard-prelude.html). The goal is to make numerical computing in Haskell *fun* and *fast*.@@ -34,7 +34,7 @@ * [Examples](/examples) * [The category of polynomials](examples/example0001-polynomials.lhs) * [Sets are monads in the category `OrdHask` and `Mon`](examples/example0002-monad-instances-for-set.lhs)- * [The category `(+>)` and linear algebra](examples/example0003-liner-algebra.lhs)+ * [The category `(+>)` and linear algebra](examples/example0003-linear-algebra.lhs) * [New class hierarchies](#new-class-hierarchies) * [The category hierarchy](#category-hierarchy) * [The functor hierarchy](#functor-hierarchy)@@ -85,11 +85,11 @@ ``` The cabal install command takes about an hour to run on my laptop.-Then you can start ghci by running: -```-$ cabal repl-```+<!--Then you can start ghci by running:-->+<!--```-->+<!--$ cabal repl-->+<!--```--> ## Examples @@ -128,7 +128,7 @@ ### Functor hierarchy In the standard Prelude, the `Functor` type class corresponds to "endofunctors on the category Hask".-SubHask generalizes this definition to enfofunctors on any category:+SubHask generalizes this definition to endofunctors on any category: ``` class Category cat => Functor cat f where@@ -189,7 +189,7 @@ 1. A type in SubHask can be compared using non-classical logics. Consider the type of equality comparison: ```- (==) :: Eq a => a -> a -> Logic a+ (==) :: Eq_ a => a -> a -> Logic a ``` The return value is given by the type family `Logic a`, which specifies the logical system used on the type `a`. @@ -200,18 +200,21 @@ Classical equality over functions is uncomputable. But in SubHask, we define: ```- type instance Logic (a -> b) = Logic b+ type instance Logic (a -> b) = a -> Logic b - class Eq b => Eq (a -> b) where+ class Eq_ b => Eq_ (a -> b) where (f==g) a = f a == g a ``` This non-classical logic simplifies many situations. For example, we can use the `(&&)` and `(||)` operators on functions: ```- ghci> filter ( (>='c') && (<'f') || (/='q') ) ['a'..'z']+ ghci> filter ( (>='c') && (<'f') || (=='q') ) ['a'..'z'] "cdeq" ``` + I have a hunch this will make for a nice probabalistic programming interface,+ but I could turn out completely wrong.+ * The `Eq` type class corresponds to the idea of [equivalence classes](https://en.wikipedia.org/wiki/Equivalence_class) in algebra. There are much more general notions of equality that are well studied, e.g. [tolerance classes](https://en.wikipedia.org/wiki/Near_sets#Tolerance_classes_and_preclasses). I've been careful to design the existing comparison hierarchy so that it will be easy to add these more general notions of equality at some point in the future.@@ -387,7 +390,7 @@ 1. A lot of the type signatures within SubHask are messier than they need to be due to limitations with GHC's type system. In particular: - * I with I could use the `forall` keyword within constraints (see [#2893](https://ghc.haskell.org/trac/ghc/ticket/2893) and [#5927](https://ghc.haskell.org/trac/ghc/ticket/5927)).+ * I wish I could use the `forall` keyword within constraints (see [#2893](https://ghc.haskell.org/trac/ghc/ticket/2893) and [#5927](https://ghc.haskell.org/trac/ghc/ticket/5927)). * SubHask uses a lot of type families, some of which are injective. We can't currently take advantage of injectivity, but adding support to GHC is being actively worked on (see [#6018](https://ghc.haskell.org/trac/ghc/ticket/6018)).
bench/Vector.hs view
@@ -8,31 +8,22 @@ import SubHask import SubHask.Algebra.Vector+import SubHask.Algebra.Vector.FFI import SubHask.Monad -------------------------------------------------------------------------------- -{-# RULES--"subhask/distance_l2_m128_UVector_Dynamic" distance = distance_l2_m128_UVector_Dynamic-"subhask/distance_l2_m128_SVector_Dynamic" distance = distance_l2_m128_SVector_Dynamic--"subhask/distanceUB_l2_m128_UVector_Dynamic" distanceUB = distanceUB_l2_m128_UVector_Dynamic-"subhask/distanceUB_l2_m128_SVector_Dynamic" distanceUB = distanceUB_l2_m128_SVector_Dynamic-- #-}- main = do ----------------------------------- putStrLn "initializing variables" - let veclen = 100+ let veclen = 1000 xs1 <- P.fmap (P.take veclen) getRandoms xs2 <- P.fmap (P.take veclen) getRandoms xs3 <- P.fmap (P.take veclen) getRandoms - let s1 = unsafeToModule (xs1+xs2) :: SVector 200 Float+ let s1 = unsafeToModule (xs1+xs2) :: SVector 2000 Float s2 = unsafeToModule (xs1+xs3) `asTypeOf` s1 d1 = unsafeToModule (xs1+xs2) :: SVector "dynamic" Float@@ -46,16 +37,26 @@ deepseq s1 $ deepseq s2 $ return () + putStrLn $ "distance s1 s2 = " + show (distance s1 s2)+ putStrLn $ "distance d1 d2 = " + show (distance d1 d2)+ putStrLn $ "distance u1 u2 = " + show (distance u1 u2)+ putStrLn ""+ putStrLn $ "distanceUB s1 s2 1 = " + show (distanceUB s1 s2 1)+ putStrLn $ "distanceUB d1 d2 1 = " + show (distanceUB d1 d2 1)+ putStrLn $ "distanceUB u1 u2 1 = " + show (distanceUB u1 u2 1)+ putStrLn ""+ ----------------------------------- putStrLn "launching criterion" - defaultMainWith- ( defaultConfig- { verbosity = Normal- -- when run using `cabal bench`, this will put our results in the right location- , csvFile = Just "bench/Vector.csv"- }- )+-- defaultMainWith+-- ( defaultConfig+-- { verbosity = Normal+-- -- when run using `cabal bench`, this will put our results in the right location+-- , csvFile = Just "bench/Vector.csv"+-- }+-- )+ defaultMain -- [ bgroup "+" -- [ bench "static" $ nf (s1+) s2 -- , bench "dynamic" $ nf (d1+) d2
cbits/Lebesgue.c view
@@ -59,6 +59,7 @@ int i=0; for (i=0; i<len/4; i++) {+ /*printf("i=%d, i*4=%d\n",i,i*4);*/ __m128 diff; diff = _mm_sub_ps(p1[i],p2[i]); sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));@@ -67,20 +68,68 @@ _mm_store_ps(fsum,sum); ret = fsum[0] + fsum[1] + fsum[2] + fsum[3]; - /*for (i*=4; i<len; i++) {*/- /*ret += pow(((float*)p1)[i]-((float*)p2)[i],2);*/- /*}*/+ /*+ for (i*=4; i<len; i++) {+ ret += pow(((float*)p1)[i]-((float*)p2)[i],2);+ }+ */ return sqrt(ret); } ++float distanceUB_l2_m128_noub(__m128 *p1, __m128 *p2, int len, float dist)+{+ float ret=0;+ float dist2=dist*dist;+ __m128 sum={0,0,0,0};+ float fsum[4];+ int i=0;+ for (i=0; i<len/4; i++) {+ __m128 diff;+ diff = _mm_sub_ps(p1[i],p2[i]);+ sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));+ }+ _mm_store_ps(fsum,sum);+ ret = fsum[0] + fsum[1] + fsum[2] + fsum[3];+ return sqrt(ret);+}+ float distanceUB_l2_m128(__m128 *p1, __m128 *p2, int len, float dist) { float ret=0;- /*float dist2=dist*dist;*/+ float dist2=dist*dist; __m128 sum={0,0,0,0}; float fsum[4];+ int i=0;+ for (i=0; i<len/4; i++) {+ __m128 diff;+ diff = _mm_sub_ps(p1[i],p2[i]);+ sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));+ // moving information out of the simd registers is expensive,+ // so we don't do it on every iteration+ if (i%8==7) {+ _mm_store_ps(fsum,sum);+ if (fsum[0]+fsum[1]+fsum[2]+fsum[3] > dist2) {+ return dist2;+ }+ }+ }+ _mm_store_ps(fsum,sum);+ ret = fsum[0] + fsum[1] + fsum[2] + fsum[3];+ return sqrt(ret);+} ++float distanceUB_l2_m128_blurp(__m128 *p1, __m128 *p2, int len, float dist)+{+ /*printf("distance_l2_m128; p1=%d; p2=%d; len=%d\n", ((unsigned int)p1%16), ((unsigned int)p2%16), len);*/++ float ret=0;+ float dist2=dist*dist;+ __m128 sum={0,0,0,0};+ float fsum[4];+ int i=0; for (i=0; i<len/4; i++) { __m128 diff;@@ -90,18 +139,72 @@ // moving information out of the simd registers is expensive, // so we don't do it on every iteration- /*if (i%4==3) {- _mm_store_ss(fsum,sum);+ if (i%4==3) {+ /*_mm_store_ss(fsum,sum); if (fsum[0] > dist2/4) { return dist2;- }+ }*/ /* i++; diff = _mm_sub_ps(p1[i],p2[i]); diff = _mm_mul_ps(diff,diff); _mm_hadd_ps(sum- /+ */+++ /*_mm_store_ss(fsum,sum);*/+ /*if (fsum[0] > dist2/4) {*/+ _mm_store_ps(fsum,sum);+ float tmpsum=fsum[0]+fsum[1]+fsum[2]+fsum[3];+ if (tmpsum > dist2) {+ return tmpsum;+ }+ /*}*/++ }+ }++ _mm_store_ps(fsum,sum);+ ret = fsum[0] + fsum[1] + fsum[2] + fsum[3];++ /*+ for (i*=4; i<len; i++) {+ ret += pow(((float*)p1)[i]-((float*)p2)[i],2);+ }+ */++ return sqrt(ret);+}++float distanceUB_l2_m128_mine(__m128 *p1, __m128 *p2, int len, float dist)+{+ float ret=0;+ float dist2=dist*dist;+ __m128 sum={0,0,0,0};+ float fsum[4];++ int i=0;+ for (i=0; i<len/4; i++) {+ __m128 diff;+ diff = _mm_sub_ps(p1[i],p2[i]);+ /*sum = _mm_hadd_ps(sum,_mm_mul_ps(diff,diff));*/+ sum = _mm_add_ps(sum,_mm_mul_ps(diff,diff));++ // moving information out of the simd registers is expensive,+ // so we don't do it on every iteration+ /*if (i>4&&i%4==3) {*/+ if (i%4==1) {+ _mm_store_ss(fsum,sum);+ if (fsum[0] > dist2) {+ return fsum[0];+ } /*+ i++;+ diff = _mm_sub_ps(p1[i],p2[i]);+ diff = _mm_mul_ps(diff,diff);+ _mm_hadd_ps(sum++ _mm_store_ss(fsum,sum); if (fsum[0] > dist2/4) { _mm_store_ps(fsum,sum);@@ -110,8 +213,8 @@ return tmpsum; } }- /- }*/+ */+ } } _mm_store_ps(fsum,sum);@@ -119,7 +222,6 @@ return sqrt(ret); }- float isFartherThan_l2_m128(__m128 *p1, __m128 *p2, int len, float dist) { float ret=0;@@ -241,6 +343,7 @@ { double ret=0; __m128d sum={0,0};+ double fsum[2]; int i=0; for (i=0; i<len/2; i++) {@@ -249,7 +352,8 @@ sum = _mm_add_pd(sum,_mm_mul_pd(diff,diff)); } - ret = sum[0] + sum[1];+ _mm_store_pd(fsum,sum);+ ret = fsum[0] + fsum[1]; for (i*=2; i<len; i++) { ret += pow(((double*)p1)[i]-((double*)p2)[i],2);@@ -263,6 +367,7 @@ double ret=0; double dist2=dist*dist; __m128d sum={0,0};+ double fsum[2]; int i=0; for (i=0; i<len/2; i++) {@@ -270,14 +375,15 @@ diff = _mm_sub_pd(p1[i],p2[i]); sum = _mm_add_pd(sum,_mm_mul_pd(diff,diff)); + _mm_store_pd(fsum,sum); if (i%4==0) {- if (sum[0]+sum[1] > dist2) {+ if (fsum[0]+fsum[1] > dist2) { return NAN; } } } - ret = sum[0] + sum[1];+ ret = fsum[0] + fsum[1]; for (i*=2; i<len; i++) { ret += pow(((double*)p1)[i]-((double*)p2)[i],2);
examples/example0002-monad-instances-for-set.lhs view
@@ -26,37 +26,49 @@ > main = do Before we get into monads, let's take a quick look at the `Functor` instances.-Here we define a set, two functions, and map those functions onto the set.+We start by defining a set: > let xs = [1..5] :: LexSet Int++There are multiple types for sets in SubHask, each with slightly different semantics.+The `LexSet` type has semantics similar to the `Set` type from the containers package.+In particular, the `Lex` stands for "lexical" because the `Lattice` instance corresponds to a lexical ordering.+The `Set` type in SubHask uses the more traditional subset ordering for its `Lattice` instance.+`Set` is an instance of `Functor` but not of `Monad`, so we don't use it in this example.++Next, we'll create two set functions and map those functions onto the set `xs`.+The type signatures below are not mandatory, just added for clarity.++> -- f is monotonic+> let f :: Semigroup a => a -> a+> f x = x+x >-> let f x = x+x -- monotonic-> g x = if x`mod`2 == 0 then x else -x -- not monotonic+> fxs :: LexSet Int+> fxs = fmap (proveOrdHask f) $ xs >-> let fxs = fmap (proveOrdHask f) $ xs+> -- g is not monotonic+> let g :: (Eq a, Integral a) => a -> a+> g x = if x`mod`2 == 0 then x else -x+>+> gxs :: LexSet Int > gxs = fmap (proveOrdHask g) $ xs > > putStrLn $ "xs = " + show xs > putStrLn $ "fxs = " + show fxs > putStrLn $ "gxs = " + show gxs -There's a few important points about the code above:--* The `LexSet` type above is a simple wrapper around the `Set` container from the containers package.- In SubHask, the `Lattice` instance for `Set` (without the prefix) is based on the subset relation.- This ordering is not total,- which means `Set` is not an instance of `Ord`,- which means we cannot have a `Set` of a `Set`.- The `LexSet` uses lexical ordering.- This ordering is total, and therefore we can have sets of sets.--* When we map a function over a container, we must explicitly say which `Functor` instance we want to use.- The `proveOrdHask` functions transform the functions from arrows in `Hask` to arrows in the `OrdHask` category.- The program would not type check without these "proofs."+Notice in the code above that when we call `fmap`, we also called the function `proveOrdHask`.+When we map a function over a container, we must explicitly say which `Functor` instance we want to use.+The `proveOrdHask` function transform the functions from arrows in `Hask` to arrows in the `OrdHask` category.+The program would not type check without these "proofs." Now let's see the `Functor Mon LexSet` instance in action.+This instance applies monotonic functions to the elements of the set.+Monotonic functions can be applied in time O(n), whereas non-monotonic functions take time O(n*log n).+ GHC can mechanistically prove when a function in `Hask` belongs in `OrdHask`,-but there it cannot prove when functions in `OrdHask` also belong to `Mon`.+but it cannot always prove when functions in `OrdHask` also belong to `Mon`.+(This proof would require dependent types.) Therefore we must use the `unsafeProveMon` function, as follows: > let fxs' = fmap (unsafeProveMon f) $ xs@@ -76,10 +88,12 @@ We're now ready to talk about the `Monad` instances. To test it out, we'll create two functions, the latter of which is monotonic.+The type signatures are provided only to aide reading. > let oddneg :: Int `OrdHask` (LexSet Int) > oddneg = proveConstrained f > where+> f :: (Integral a, Ord a) => a -> LexSet a > f i = if i `mod` 2 == 0 > then [i] > else [-i]@@ -87,6 +101,7 @@ > let times3 :: (Ord a, Ring a) => a `OrdHask` (LexSet a) > times3 = proveConstrained f > where+> f :: (Ord a, Ring a) => a -> LexSet a > f a = [a,2*a,3*a] > > let times3mon :: (Ord a, Ring a) => a `Mon` (LexSet a)
src/SubHask/Algebra.hs view
@@ -96,6 +96,7 @@ , law_Container_preservation , Constructible (..)+ , Constructible0 , law_Constructible_singleton , defn_Constructible_cons , defn_Constructible_snoc@@ -105,6 +106,7 @@ , fromString , fromList , fromListN+ , generate , insert , empty , isEmpty@@ -150,9 +152,10 @@ , defn_IxConstructible_fromIxList , insertAt - -- * Maybe+ -- * Types , CanError (..) , Maybe' (..)+ , justs' , Labeled' (..) -- * Number-like@@ -202,6 +205,8 @@ , law_Integral_divMod , law_Integral_quotRem , law_Integral_toFromInverse+ , roundUpToNearest+-- , roundUpToNearestBase2 , fromIntegral , Field(..) , OrdField(..)@@ -255,6 +260,10 @@ , innerProductNorm , TensorAlgebra (..) + -- * Spatial programming+ , Any (..)+ , All+ -- * Helper functions , simpleMutableDefn , module SubHask.Mutable@@ -278,7 +287,7 @@ import Control.Parallel.Strategies import System.IO.Unsafe -- used in the parallel function -import GHC.Prim+import GHC.Prim hiding (Any) import GHC.Types import GHC.Magic @@ -1398,7 +1407,25 @@ fromIntegral :: (Integral a, Ring b) => a -> b fromIntegral = fromInteger . toInteger +-- | FIXME:+-- This should be moved into the class hierarchy and generalized.+-- -- FIXME:+-- There are more efficient implementations available if you restrict m to powers of 2.+-- Is GHC smart enough to convert `rem` into bit shifts?+-- See for more possibilities:+-- http://stackoverflow.com/questions/3407012/c-rounding-up-to-the-nearest-multiple-of-a-number+{-# INLINE roundUpToNearest #-}+roundUpToNearest :: Int -> Int -> Int+roundUpToNearest m x = x + m - 1 - (x-1)`rem`m+-- roundUpToNearest m x = if s==0+-- then+-- else x+r+-- where+-- s = x`rem`m+-- r = if s==0 then 0 else m-s++-- FIXME: -- need more RULES; need tests {-# RULES "subhask/fromIntegral/Int->Int" fromIntegral = id :: Int -> Int@@ -2276,6 +2303,8 @@ sizeDisjoint :: (Normed s, Constructible s) => s -> s -> Logic (Scalar s) sizeDisjoint s1 s2 = size s1 + size s2 == size (s1+s2) +type Constructible0 x = (Monoid x, Constructible x)+ -- | This is the class for any type that gets "constructed" from smaller types. -- It is a massive generalization of the notion of a constructable set in topology. --@@ -2336,14 +2365,22 @@ fromString = fromList -- | FIXME: if -XOverloadedLists is enabled, this causes an infinite loop for some reason+{-# INLINABLE fromList #-} fromList :: (Monoid s, Constructible s) => [Elem s] -> s fromList [] = zero fromList (x:xs) = fromList1 x xs +{-# INLINABLE fromListN #-} fromListN :: (Monoid s, Constructible s) => Int -> [Elem s] -> s fromListN 0 [] = zero fromListN i (x:xs) = fromList1N i x xs +{-# INLINABLE generate #-}+generate :: (Monoid v, Constructible v) => Int -> (Int -> Elem v) -> v+generate n f = if n <= 0+ then zero+ else fromList1N n (f 0) (map f [1..n-1])+ -- | This is a generalization of a "set". -- We do not require a container to be a boolean algebra, just a semigroup. class (ValidLogic s, Constructible s, ValidSetElem s) => Container s where@@ -2929,6 +2966,11 @@ data Maybe' a = Nothing' | Just' { fromJust' :: !a } +justs' :: [Maybe' a] -> [a]+justs' [] = []+justs' (Nothing':xs) = justs' xs+justs' (Just' x:xs) = x:justs' xs+ type instance Scalar (Maybe' a) = Scalar a type instance Logic (Maybe' a) = Logic a @@ -3018,6 +3060,9 @@ y <- arbitrary return $ Labeled' x y +instance (CoArbitrary x, CoArbitrary y) => CoArbitrary (Labeled' x y) where+ coarbitrary (Labeled' x y) = coarbitrary (x,y)+ type instance Scalar (Labeled' x y) = Scalar x type instance Actor (Labeled' x y) = x type instance Logic (Labeled' x y) = Logic x@@ -3058,6 +3103,42 @@ instance Normed x => Normed (Labeled' x y) where size (Labeled' x _) = size x ++--------------------------------------------------------------------------------+-- spatial programming+--+-- FIXME:+-- This is broken, partly due to type system limits.+-- It's being exported just for basic testing.++-- | The type of all containers satisfying the @cxt@ constraint with elements of type @x@.+type All cxt x = forall xs. (cxt xs, Elem xs~x) => xs++data Any cxt x where+ Any :: forall cxt x xs. (cxt xs, Elem xs~x) => xs -> Any cxt x+-- Any :: All cxt x -> Any cxt x++instance Show x => Show (Any Foldable x) where+ show (Any xs) = show $ toList xs++type instance Elem (Any cxt x) = x+type instance Scalar (Any cxt x) = Int++instance Semigroup (Any Foldable x) where+ (Any x1)+(Any x2)=Any (x1+(fromList.toList)x2)++instance Constructible (Any Foldable x) where++instance Normed (Any Foldable x) where+ size (Any xs) = size xs++instance Monoid (Any Foldable x) where+ zero = Any []++instance Foldable (Any Foldable x) where+ toList (Any xs) = toList xs++mkMutable [t| forall cxt x. Any cxt x |] --------------------------------------------------------------------------------
src/SubHask/Algebra/Array.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module SubHask.Algebra.Array ( BArray (..)- , UArray+ , UArray (..) , Unboxable ) where@@ -148,7 +148,9 @@ ------------------------------------------------------------------------------- -- unboxed arrays -newtype UArray e = UArray (VU.Vector e)+data UArray e+ = UArray {-#UNPACK#-}!(VU.Vector e)+-- | UArray_Zero type instance Index (UArray e) = Int type instance Logic (UArray e) = Logic e@@ -167,20 +169,28 @@ instance (Unboxable e, Arbitrary e) => Arbitrary (UArray e) where arbitrary = fmap fromList arbitrary -instance (Unbox e, NFData e) => NFData (UArray e) where+instance (NFData e) => NFData (UArray e) where rnf (UArray v) = rnf v+-- rnf UArray_Zero = () -instance (Unbox e, Show e) => Show (UArray e) where- show (UArray v) = "UArray " ++ show (VG.toList v)+instance (Unboxable e, Show e) => Show (UArray e) where+ show arr = "UArray " ++ show (toList arr) ---------------------------------------- -- algebra instance Unboxable e => Semigroup (UArray e) where- (UArray v1)+(UArray v2) = fromList $ VG.toList v1 ++ VG.toList v2+-- UArray_Zero + a = a+-- a + UArray_Zero = a+ (UArray v1) + (UArray v2) = fromList $ VG.toList v1 ++ VG.toList v2 +instance Unboxable e => Monoid (UArray e) where+ zero = UArray VG.empty+-- zero = UArray_Zero+ instance Unbox e => Normed (UArray e) where size (UArray v) = VG.length v+-- size UArray_Zero = 0 ---------------------------------------- -- comparison@@ -197,26 +207,18 @@ ---------------------------------------- -- container -type Unboxable e = (Monoid (UArray e), Constructible (UArray e), ClassicalLogic e, Eq_ e, Unbox e)+type Unboxable e = (Constructible (UArray e), Eq e, Unbox e) #define mkConstructible(e) \ instance Constructible (UArray e) where\- { fromList1 x xs = UArray $ VG.fromList (x:xs) } ; \-instance Monoid (UArray e) where \- zero = UArray $ P.mempty+ { fromList1 x xs = UArray $ VG.fromList (x:xs) } ; mkConstructible(Int)+mkConstructible(Float)+mkConstructible(Double) mkConstructible(Char) mkConstructible(Bool) -{--instance (Unboxable x, Unboxable y) => Constructible (UArray (Labeled' x y)) where- fromList1 x xs = UArray $ UMV_Labeled' $ VG.fromList (x:xs)--instance (Unboxable x, Unboxable y) => Monoid (UArray (Labeled' x y)) where- zero = UMV_Labeled' zero zero--}- instance ( ClassicalLogic r , Eq_ r@@ -245,69 +247,35 @@ return $ UArray v where rbytes=Prim.sizeOf (undefined::r)- size=dim x--instance- ( ClassicalLogic r- , Eq_ r- , Unbox r- , Prim r- , FreeModule r- , IsScalar r- ) => Monoid (UArray (UVector (s::Symbol) r)) where- zero = unsafeInlineIO $ do- marr <- safeNewByteArray 0 16- arr <- unsafeFreezeByteArray marr- return $ UArray $ UArray_UVector arr 0 0 0--instance- ( ClassicalLogic r- , Eq_ r- , Unbox r- , Prim r- , FreeModule r- , IsScalar r- , Prim y- , Unbox y- ) => Constructible (UArray (Labeled' (UVector (s::Symbol) r) y))- where-- {-# INLINABLE fromList1 #-}- fromList1 x xs = fromList1N (length $ x:xs) x xs-- {-# INLINABLE fromList1N #-}- fromList1N n x xs = unsafeInlineIO $ do- marr <- safeNewByteArray (n*(xsize+ysize)*rbytes) 16- let mv = UArray_Labeled'_MUVector marr 0 n xsize-- let go [] (-1) = return ()- go (x:xs) i = do- VGM.unsafeWrite mv i x- go xs (i-1)-- go (P.reverse $ x:xs) (n-1)- v <- VG.basicUnsafeFreeze mv- return $ UArray v- where- rbytes=Prim.sizeOf (undefined::r)+ size=roundUpToNearest 4 $ dim x - xsize=dim $ xLabeled' x- ysize=4 --Prim.sizeOf (undefined::y) `quot` rbytes+-- instance+-- ( ClassicalLogic r+-- , Eq_ r+-- , Unbox r+-- , Prim r+-- , FreeModule r+-- , IsScalar r+-- ) => Monoid (UArray (UVector (s::Symbol) r)) where+-- zero = unsafeInlineIO $ do+-- marr <- safeNewByteArray 0 16+-- arr <- unsafeFreezeByteArray marr+-- return $ UArray $ UArray_UVector arr 0 0 0 -instance- ( ClassicalLogic r- , Eq_ r- , Unbox r- , Prim r- , FreeModule r- , IsScalar r- , Prim y- , Unbox y- ) => Monoid (UArray (Labeled' (UVector (s::Symbol) r) y)) where- zero = unsafeInlineIO $ do- marr <- safeNewByteArray 0 16- arr <- unsafeFreezeByteArray marr- return $ UArray $ UArray_Labeled'_UVector arr 0 0 0+-- instance+-- ( ClassicalLogic r+-- , Eq_ r+-- , Unbox r+-- , Prim r+-- , FreeModule r+-- , IsScalar r+-- , Prim y+-- , Unbox y+-- ) => Monoid (UArray (Labeled' (UVector (s::Symbol) r) y)) where+-- zero = unsafeInlineIO $ do+-- marr <- safeNewByteArray 0 16+-- arr <- unsafeFreezeByteArray marr+-- return $ UArray $ UArray_Labeled'_UVector arr 0 0 0 instance Unboxable e => Container (UArray e) where elem e (UArray v) = elem e $ VG.toList v@@ -316,6 +284,7 @@ {-# INLINE toList #-} toList (UArray v) = VG.toList v+-- toList UArray_Zero = [] {-# INLINE uncons #-} uncons (UArray v) = if VG.null v@@ -351,11 +320,12 @@ slice i n (UArray v) = UArray $ VG.slice i n v instance Unboxable e => IxContainer (UArray e) where+ type ValidElem (UArray e) e = Unboxable e+ lookup i (UArray v) = v VG.!? i (!) (UArray v) = VG.unsafeIndex v indices (UArray v) = [0..VG.length v-1] values (UArray v) = VG.toList v--- imap = VG.imap instance Unboxable e => Partitionable (UArray e) where partition n arr = go 0@@ -370,31 +340,7 @@ lenmax = length arr `quot` n - ---------------------------------------------------------------------------------- unsafe globals--{--{-# NOINLINE ptsizeIO #-}-ptsizeIO = unsafeDupablePerformIO $ newIORef (5::Int)--{-# NOINLINE ptalignIO #-}-ptalignIO = unsafeDupablePerformIO $ newIORef (5::Int)--{-# NOINLINE ptsize #-}-ptsize = unsafeDupablePerformIO $ readIORef ptsizeIO--{-# NOINLINE ptalign #-}-ptalign = unsafeDupablePerformIO $ readIORef ptalignIO---- {-# NOINLINE setptsize #-}-setptsize :: Int -> IO ()-setptsize len = do- writeIORef ptsizeIO len- writeIORef ptalignIO (1::Int)--}--------------------------------------------------------------------------------- -- UVector instance@@ -462,14 +408,19 @@ basicLength (UArray_MUVector _ _ n _) = n {-# INLINABLE basicUnsafeSlice #-}- basicUnsafeSlice i lenM' (UArray_MUVector marr off n size) = UArray_MUVector marr (off+i*size) lenM' size+ basicUnsafeSlice i lenM' (UArray_MUVector marr off n size)+ = UArray_MUVector marr (off+i*size) lenM' size {-# INLINABLE basicOverlaps #-} basicOverlaps (UArray_MUVector marr1 off1 n1 size) (UArray_MUVector marr2 off2 n2 _) = sameMutableByteArray marr1 marr2 {-# INLINABLE basicUnsafeNew #-}- basicUnsafeNew lenM' = error "basicUnsafeNew not supported on UArray_MUVector"+ basicUnsafeNew 0 = do+ marr <- newByteArray 0+ return $ UArray_MUVector marr 0 0 0+ basicUnsafeNew n = error "basicUnsafeNew not supported on UArray_MUVector with nonzero size"+ -- basicUnsafeNew lenM' = do -- let elemsize=ptsize -- marr <- newPinnedByteArray (lenM'*elemsize*Prim.sizeOf (undefined::elem))@@ -501,7 +452,7 @@ where b = size1*Prim.sizeOf (undefined::elem) -----------------------------------------+-------------------------------------------------------------------------------- -- Labeled' instance@@ -537,20 +488,23 @@ basicUnsafeSlice i lenM' (UArray_Labeled'_MUVector marr off n size) = UArray_Labeled'_MUVector marr (off+i*(size+ysize)) lenM' size where- ysize=4--Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) {-# INLINABLE basicOverlaps #-} basicOverlaps (UArray_Labeled'_MUVector marr1 off1 n1 size) (UArray_Labeled'_MUVector marr2 off2 n2 _) = sameMutableByteArray marr1 marr2 {-# INLINABLE basicUnsafeNew #-}- basicUnsafeNew = error "basicUnsafeNew not supported on UArray_Labeled'_MUVector"+ basicUnsafeNew 0 = do+ marr <- newByteArray 0+ return $ UArray_Labeled'_MUVector marr 0 0 0+ basicUnsafeNew n = error "basicUnsafeNew not supported on UArray_MUVector with nonzero size" -- basicUnsafeNew lenM' = do -- let elemsize=ptsize -- marr <- newPinnedByteArray (lenM'*(elemsize+ysize)*Prim.sizeOf (undefined::elem)) -- return $ UArray_Labeled'_MUVector marr 0 lenM' elemsize -- where--- ysize=Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+-- ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) {-# INLINABLE basicUnsafeRead #-} basicUnsafeRead mv@(UArray_Labeled'_MUVector marr off n size) i = do@@ -558,11 +512,12 @@ copyMutableByteArray marr' 0 marr ((off+i*(size+ysize))*b) (size*b) arr <- unsafeFreezeByteArray marr' let x=UVector_Dynamic arr 0 size- y <- readByteArray marr $ (off+i*(size+ysize)+size) `quot` ysize+ y <- readByteArray marr $ (off+i*(size+ysize)+size) `quot` ysizereal return $ Labeled' x y where b=Prim.sizeOf (undefined::elem)- ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysizereal = Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysize=roundUpToNearest 4 $ ysizereal {-# INLINABLE basicUnsafeWrite #-} basicUnsafeWrite@@ -571,10 +526,11 @@ (Labeled' (UVector_Dynamic arr2 off2 _) y) = do copyByteArray marr1 ((off1+i*(size+ysize))*b) arr2 (off2*b) (size*b)- writeByteArray marr1 ((off1+i*(size+ysize)+size) `quot` ysize) y+ writeByteArray marr1 ((off1+i*(size+ysize)+size) `quot` ysizereal) y where b=Prim.sizeOf (undefined::elem)- ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysizereal = Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysize=roundUpToNearest 4 $ ysizereal {-# INLINABLE basicUnsafeCopy #-} basicUnsafeCopy@@ -583,7 +539,7 @@ = copyMutableByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) where b = (size1+ysize)*Prim.sizeOf (undefined::elem)- ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) {-# INLINABLE basicUnsafeMove #-} basicUnsafeMove@@ -592,7 +548,7 @@ = moveByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) where b = (size1+ysize)*Prim.sizeOf (undefined::elem)- ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) ---------------------------------------- @@ -617,7 +573,7 @@ basicUnsafeSlice i len' (UArray_Labeled'_UVector arr off n size) = UArray_Labeled'_UVector arr (off+i*(size+ysize)) len' size where- ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) {-# INLINABLE basicUnsafeFreeze #-} basicUnsafeFreeze (UArray_Labeled'_MUVector marr off n size) = do@@ -631,19 +587,176 @@ {-# INLINE basicUnsafeIndexM #-} basicUnsafeIndexM (UArray_Labeled'_UVector arr off n size) i =+-- trace ("off'="+show off') $ return $ Labeled' x y where off' = off+i*(size+ysize) x = UVector_Dynamic arr off' size- y = indexByteArray arr $ (off'+size) `quot` ysize- ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)--- y = indexByteArray arr $ (off'+size) `shiftR` 1--- ysize=2+ y = indexByteArray arr $ (off'+size) `quot` ysizereal+ ysizereal = Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem)+ ysize=roundUpToNearest 4 $ ysizereal +instance+ ( ClassicalLogic r+ , Eq_ r+ , Unbox r+ , Prim r+ , FreeModule r+ , IsScalar r+ , Prim y+ , Unbox y+ ) => Constructible (UArray (Labeled' (UVector (s::Symbol) r) y))+ where++ {-# INLINABLE fromList1 #-}+ fromList1 x xs = fromList1N (length $ x:xs) x xs++ {-# INLINABLE fromList1N #-}+ fromList1N n x xs = unsafeInlineIO $ do+ let arrlen = n*(xsize+ysize)+ marr <- safeNewByteArray (arrlen*rbytes) 16+ setByteArray marr 0 arrlen (0::r)+ let mv = UArray_Labeled'_MUVector marr 0 n xsize++ let go [] (-1) = return ()+ go (x:xs) i = do+ VGM.unsafeWrite mv i x+ go xs (i-1)++ go (P.reverse $ x:xs) (n-1)+ v <- VG.basicUnsafeFreeze mv+ return $ UArray v+ where+ rbytes=Prim.sizeOf (undefined::r)++ xsize=roundUpToNearest 4 $ dim $ xLabeled' x+ ysize=roundUpToNearest 4 $ Prim.sizeOf (undefined::y) `quot` rbytes++-- roundUpToNearest_ :: Int -> Int -> Int+-- roundUpToNearest_ m i = i -- +4-i`rem`4+-- roundUpToNearest_ m x = x+r+-- where+-- s = x`rem`m+-- r = if s==0 then 0 else m-s+ ------------------------------------------------------------------------------- -- Labeled' {-+instance (VU.Unbox x, VU.Unbox y) => VU.Unbox (Labeled' x y)++data instance VUM.MVector s (Labeled' x y) = UArray_Labeled'_MUVector+ !(VUM.MVector s x)+ !(VUM.MVector s y)++instance+ ( VUM.Unbox x+ , VUM.Unbox y+ ) => VGM.MVector VUM.MVector (Labeled' x y)+ where++ {-# INLINABLE basicLength #-}+ {-# INLINABLE basicUnsafeSlice #-}+ {-# INLINABLE basicOverlaps #-}+ {-# INLINABLE basicUnsafeNew #-}+ {-# INLINABLE basicUnsafeRead #-}+ {-# INLINABLE basicUnsafeWrite #-}+ {-# INLINABLE basicUnsafeCopy #-}+ {-# INLINABLE basicUnsafeMove #-}+ {-# INLINABLE basicSet #-}+ basicLength (UArray_Labeled'_MUVector xv yv) = VGM.basicLength xv++ basicUnsafeSlice i len (UArray_Labeled'_MUVector xv yv)+ = UArray_Labeled'_MUVector+ (VGM.basicUnsafeSlice i len xv)+ (VGM.basicUnsafeSlice i len yv)++ basicOverlaps (UArray_Labeled'_MUVector xv1 _) (UArray_Labeled'_MUVector xv2 _)+ = VGM.basicOverlaps xv1 xv2++ basicUnsafeNew n = do+ mvx <- VGM.basicUnsafeNew n+ mvy <- VGM.basicUnsafeNew n+ return $ UArray_Labeled'_MUVector mvx mvy++ basicUnsafeRead (UArray_Labeled'_MUVector xv yv) i = do+ x <- VGM.basicUnsafeRead xv i+ y <- VGM.basicUnsafeRead yv i+ return $ Labeled' x y++ basicUnsafeWrite (UArray_Labeled'_MUVector xv yv) i (Labeled' x y) = do+ VGM.basicUnsafeWrite xv i x+ VGM.basicUnsafeWrite yv i y++ basicUnsafeCopy (UArray_Labeled'_MUVector xv1 yv1) (UArray_Labeled'_MUVector xv2 yv2) = do+ VGM.basicUnsafeCopy xv1 xv2+ VGM.basicUnsafeCopy yv1 yv2++ basicUnsafeMove (UArray_Labeled'_MUVector xv1 yv1) (UArray_Labeled'_MUVector xv2 yv2) = do+ VGM.basicUnsafeMove xv1 xv2+ VGM.basicUnsafeMove yv1 yv2++ basicSet (UArray_Labeled'_MUVector xv yv) (Labeled' x y) = do+ VGM.basicSet xv x+ VGM.basicSet yv y++data instance VU.Vector (Labeled' x y) = UArray_Labeled'_UVector+ !(VU.Vector x)+ !(VU.Vector y)++instance+ ( VUM.Unbox x+ , VUM.Unbox y+ ) => VG.Vector VU.Vector (Labeled' x y)+ where++ {-# INLINABLE basicUnsafeFreeze #-}+ {-# INLINABLE basicUnsafeThaw #-}+ {-# INLINABLE basicLength #-}+ {-# INLINABLE basicUnsafeSlice #-}+ {-# INLINABLE basicUnsafeIndexM #-}+ basicUnsafeFreeze (UArray_Labeled'_MUVector mxv myv) = do+ xv <- VG.basicUnsafeFreeze mxv+ yv <- VG.basicUnsafeFreeze myv+ return $ UArray_Labeled'_UVector xv yv++ basicUnsafeThaw (UArray_Labeled'_UVector xv yv) = do+ mxv <- VG.basicUnsafeThaw xv+ myv <- VG.basicUnsafeThaw yv+ return ( UArray_Labeled'_MUVector mxv myv )++ basicLength (UArray_Labeled'_UVector xv _ ) = VG.basicLength xv++ basicUnsafeSlice i len (UArray_Labeled'_UVector xv yv) = UArray_Labeled'_UVector+ (VG.basicUnsafeSlice i len xv)+ (VG.basicUnsafeSlice i len yv)++ basicUnsafeIndexM (UArray_Labeled'_UVector xv yv) i = do+ x <- VG.basicUnsafeIndexM xv i+ y <- VG.basicUnsafeIndexM yv i+ return $ Labeled' x y++instance+ ( Unboxable x+ , Unboxable y+ ) => Constructible (UArray (Labeled' x y))+ where++ fromList1 z zs = UArray $ UArray_Labeled'_UVector+ ( unUArray $ fromList1 (xLabeled' z) (map xLabeled' zs) )+ ( unUArray $ fromList1 (yLabeled' z) (map yLabeled' zs) )+ where+ unUArray (UArray v) = v++ fromList1N n z zs = UArray $ UArray_Labeled'_UVector+ ( unUArray $ fromList1N n (xLabeled' z) (map xLabeled' zs) )+ ( unUArray $ fromList1N n (yLabeled' z) (map yLabeled' zs) )+ where+ unUArray (UArray v) = v++-}++{- instance (VUM.Unbox x, VUM.Unbox y) => VUM.Unbox (Labeled' x y) newtype instance VUM.MVector s (Labeled' x y) = UMV_Labeled' (VUM.MVector s (x,y))@@ -666,7 +779,8 @@ basicLength (UMV_Labeled' v) = VGM.basicLength v basicUnsafeSlice i len (UMV_Labeled' v) = UMV_Labeled' $ VGM.basicUnsafeSlice i len v basicOverlaps (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicOverlaps v1 v2- basicUnsafeNew len = liftM UMV_Labeled' $ VGM.basicUnsafeNew len+ basicUnsafeNew = error "basicUnsafeNew should never be called"+-- basicUnsafeNew len = liftM UMV_Labeled' $ VGM.basicUnsafeNew len basicUnsafeRead (UMV_Labeled' v) i = do (!x,!y) <- VGM.basicUnsafeRead v i return $ Labeled' x y@@ -687,8 +801,7 @@ {-# INLINABLE basicUnsafeThaw #-} {-# INLINABLE basicLength #-} {-# INLINABLE basicUnsafeSlice #-}--- {-# INLINABLE basicUnsafeIndexM #-}- {-# INLINE basicUnsafeIndexM #-}+ {-# INLINABLE basicUnsafeIndexM #-} basicUnsafeFreeze (UMV_Labeled' v) = liftM UV_Labeled' $ VG.basicUnsafeFreeze v basicUnsafeThaw (UV_Labeled' v) = liftM UMV_Labeled' $ VG.basicUnsafeThaw v basicLength (UV_Labeled' v) = VG.basicLength v@@ -696,4 +809,4 @@ basicUnsafeIndexM (UV_Labeled' v) i = do (!x,!y) <- VG.basicUnsafeIndexM v i return $ Labeled' x y- -}+-}
src/SubHask/Algebra/Metric.hs view
@@ -10,7 +10,7 @@ import SubHask.Internal.Prelude import Control.Monad -import Data.List (nubBy,permutations,sort)+import qualified Data.List as L import System.IO --------------------------------------------------------------------------------@@ -31,15 +31,15 @@ putStrLn $ match ++ " = " ++ show dist where- xs = nubBy (\(x,_) (y,_) -> x==y)- $ sort+ xs = L.nubBy (\(x,_) (y,_) -> x==y)+ $ L.sort $ map mkMatching- $ permutations [('1',m1),('2',m2),('3',m3),('4',m4)]+ $ L.permutations [('1',m1),('2',m2),('3',m3),('4',m4)] mkMatching [(i1,n1),(i2,n2),(i3,n3),(i4,n4)] =- ( (\[x,y] -> x++":"++y) $ sort- [ sort (i1:i2:[])- , sort (i3:i4:[])+ ( (\[x,y] -> x++":"++y) $ L.sort+ [ L.sort (i1:i2:[])+ , L.sort (i3:i4:[]) ] , distance n1 n2 + distance n3 n4 )
src/SubHask/Algebra/Ord.hs view
@@ -2,9 +2,16 @@ module SubHask.Algebra.Ord where --- import Control.Monad import qualified Prelude as P+import qualified Data.List as L +import qualified GHC.Arr as Arr+import Data.Array.ST hiding (freeze,thaw)+import Control.Monad+import Control.Monad.Random+import Control.Monad.ST+import Prelude (take)+ import SubHask.Algebra import SubHask.Category import SubHask.Mutable@@ -12,38 +19,10 @@ import SubHask.Internal.Prelude import SubHask.TemplateHaskell.Deriving -import Debug.Trace---- newtype Swap a = Swap a--- deriving (Read,Show,P.Eq)------ instance P.Ord a => P.Ord (Swap a) where--- a <= b = b P.<= a------ newtype With a = With a--- deriving (Read,Show)---- instance Show a => Show (With a)--- instance Read a => Read (With a)--- instance NFData a => NFData (With a)--- deriveHierarchy ''With [ ''Enum, ''Boolean, ''Ring, ''Metric ]---- instance Eq a => P.Eq (With a) where--- (==) = undefined--- (/=) = undefined------ instance (P.Eq a, Ord a) => P.Ord (With a) where--- -- compare = undefined--- -- (<=) = undefined--- compare (With a1) (With a2)--- = trace "compare" $ P.EQ--- -- = if a1 == a2--- -- then P.EQ--- -- else if a1 < a2--- -- then P.LT--- -- else P.GT--------------+-------------------------------------------------------------------------------- +-- | This wrapper let's us convert between SubHask's Ord type and the Prelude's.+-- See the "sort" function below for an example. newtype WithPreludeOrd a = WithPreludeOrd { unWithPreludeOrd :: a } deriving Storable @@ -61,3 +40,27 @@ instance Ord a => P.Ord (WithPreludeOrd a) where {-# INLINE (<=) #-} a<=b = a<=b+++-- | A wrapper around the Prelude's sort function.+--+-- FIXME:+-- We should put this in the container hierarchy so we can sort any data type+sort :: Ord a => [a] -> [a]+sort = map unWithPreludeOrd . L.sort . map WithPreludeOrd++-- | Randomly shuffles a list in time O(n log n); see http://www.haskell.org/haskellwiki/Random_shuffle+shuffle :: (Eq a, MonadRandom m) => [a] -> m [a]+shuffle xs = do+ let l = length xs+ rands <- take l `liftM` getRandomRs (0, l-1)+ let ar = runSTArray ( do+ ar <- Arr.thawSTArray (Arr.listArray (0, l-1) xs)+ forM_ (L.zip [0..(l-1)] rands) $ \(i, j) -> do+ vi <- Arr.readSTArray ar i+ vj <- Arr.readSTArray ar j+ Arr.writeSTArray ar j vi+ Arr.writeSTArray ar i vj+ return ar+ )+ return (Arr.elems ar)
+ src/SubHask/Algebra/Ring.hs view
@@ -0,0 +1,51 @@+module SubHask.Algebra.Ring+ where++import SubHask.Algebra+import SubHask.Category+import SubHask.Internal.Prelude++--------------------------------------------------------------------------------++-- | Every free module can be converted into a ring with this type.+-- Intuitively, this lets us use all our code designed for univariate operations on vectors.+newtype Componentwise v = Componentwise { unComponentwise :: v }++type instance Scalar (Componentwise v) = Scalar v+type instance Logic (Componentwise v) = Logic v+type instance Elem (Componentwise v) = Scalar v+type instance SetElem (Componentwise v) v' = Componentwise v'++instance IsMutable (Componentwise v)++instance Eq_ v => Eq_ (Componentwise v) where+ (Componentwise v1)==(Componentwise v2) = v1==v2++instance Semigroup v => Semigroup (Componentwise v) where+ (Componentwise v1)+(Componentwise v2) = Componentwise $ v1+v2++instance Monoid v => Monoid (Componentwise v) where+ zero = Componentwise zero++instance Abelian v => Abelian (Componentwise v)++instance Cancellative v => Cancellative (Componentwise v) where+ (Componentwise v1)-(Componentwise v2) = Componentwise $ v1-v2++instance Group v => Group (Componentwise v) where+ negate (Componentwise v) = Componentwise $ negate v++instance FreeModule v => Rg (Componentwise v) where+ (Componentwise v1)*(Componentwise v2) = Componentwise $ v1.*.v2++instance FiniteModule v => Rig (Componentwise v) where+ one = Componentwise $ ones++instance FiniteModule v => Ring (Componentwise v)++instance (FiniteModule v, VectorSpace v) => Field (Componentwise v) where+ (Componentwise v1)/(Componentwise v2) = Componentwise $ v1./.v2++-- instance (ValidLogic v, FiniteModule v) => IxContainer (Componentwise v) where+-- values (Componentwise v) = values v+
src/SubHask/Algebra/Vector.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE ForeignFunctionInterface #-}- -- | Dense vectors and linear algebra operations. -- -- NOTE:@@ -23,15 +21,6 @@ , SMatrix , unsafeMkSMatrix - -- * FFI- , distance_l2_m128- , distance_l2_m128_SVector_Dynamic- , distance_l2_m128_UVector_Dynamic-- , distanceUB_l2_m128- , distanceUB_l2_m128_SVector_Dynamic- , distanceUB_l2_m128_UVector_Dynamic- -- * Debug , safeNewByteArray )@@ -69,7 +58,6 @@ import System.IO.Unsafe import Unsafe.Coerce - -------------------------------------------------------------------------------- -- rewrite rules for faster static parameters --@@ -93,53 +81,11 @@ -------------------------------------------------------------------------------- -foreign import ccall unsafe "distance_l2_m128" distance_l2_m128- :: Ptr Float -> Ptr Float -> Int -> IO Float--foreign import ccall unsafe "distanceUB_l2_m128" distanceUB_l2_m128- :: Ptr Float -> Ptr Float -> Int -> Float -> IO Float--{-# INLINE sizeOfFloat #-}-sizeOfFloat :: Int-sizeOfFloat = sizeOf (undefined::Float)--{-# INLINE distance_l2_m128_UVector_Dynamic #-}-distance_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float-distance_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _)- = unsafeInlineIO $ distance_l2_m128 p1 p2 n- where- p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat)- p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat)--{-# INLINE distanceUB_l2_m128_UVector_Dynamic #-}-distanceUB_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float -> Float-distanceUB_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _) ub- = unsafeInlineIO $ distanceUB_l2_m128 p1 p2 n ub- where- p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat)- p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat)--distance_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float-distance_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _)- = unsafeInlineIO $- withForeignPtr fp1 $ \p1 ->- withForeignPtr fp2 $ \p2 ->- distance_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n--distanceUB_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float -> Float-distanceUB_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _) ub- = unsafeInlineIO $- withForeignPtr fp1 $ \p1 ->- withForeignPtr fp2 $ \p2 ->- distanceUB_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n ub----------------------------------------------------------------------------------- type Unbox = VU.Unbox -------------------------------------------------------------------------------- --- | The type of dynamic or statically sized vectors implemented using the FFI.+-- | The type of dynamic or statically sized unboxed vectors. data family UVector (n::k) r type instance Scalar (UVector n r) = Scalar r@@ -160,7 +106,7 @@ instance (Show r, Monoid r, Prim r) => Show (UVector (n::Symbol) r) where show (UVector_Dynamic arr off n) = if isZero n then "zero"- else show $ go (n-1) []+ else show $ go (extendDimensions n-1) [] where go (-1) xs = xs go i xs = go (i-1) (x:xs)@@ -173,6 +119,9 @@ , (9,fmap unsafeToModule $ replicateM 27 arbitrary) ] +instance (Show r, Monoid r, Prim r) => CoArbitrary (UVector (n::Symbol) r) where+ coarbitrary = coarbitraryShow+ instance (NFData r, Prim r) => NFData (UVector (n::Symbol) r) where rnf (UVector_Dynamic arr off n) = seq arr () @@ -238,16 +187,31 @@ -- algebra extendDimensions :: Int -> Int-extendDimensions i = i+i`rem`4+extendDimensions = roundUpToNearest 4 -- i+4-i`rem`4 +-- extendDimensions :: Int -> Int+-- extendDimensions x = x+r+-- where+-- m = 4+-- s = x`rem`m+-- r = if s==0 then 0 else m-s+ safeNewByteArray :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m)) safeNewByteArray b 16 = do- let n=extendDimensions $ b`rem`4+ let n=extendDimensions $ b`quot`4 marr <- newAlignedPinnedByteArray b 16- writeByteArray marr (n-0) (0::Float)- writeByteArray marr (n-1) (0::Float)- writeByteArray marr (n-2) (0::Float)- writeByteArray marr (n-3) (0::Float)+-- writeByteArray marr (n-0) (0::Float)+-- writeByteArray marr (n-1) (0::Float)+-- writeByteArray marr (n-2) (0::Float)+-- writeByteArray marr (n-3) (0::Float)+ setByteArray marr 0 n (0::Float)++-- trace ("n="++show n) $ return ()+-- a <- forM [0..n-1] $ \i -> do+-- v :: Float <- readByteArray marr i+-- return $ unsafeInlineIO $ P.putStrLn $ "marr!"+show i+" = "+show v+-- deepseq a $ return marr+ return marr {-# INLINE binopDynUV #-}
+ src/SubHask/Algebra/Vector/FFI.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Importing this module will activate RULES that use the FFI for vector ops.+module SubHask.Algebra.Vector.FFI+ ( distance_l2_m128+ , distance_l2_m128_SVector_Dynamic+ , distance_l2_m128_UVector_Dynamic++ , distanceUB_l2_m128+ , distanceUB_l2_m128_SVector_Dynamic+ , distanceUB_l2_m128_UVector_Dynamic+ )+ where++import qualified Prelude as P+import Control.Monad.Primitive+import Data.Primitive.ByteArray+import Foreign.C.Types+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal.Utils++import System.IO.Unsafe+import Unsafe.Coerce++import SubHask.Algebra+import SubHask.Algebra.Vector+import SubHask.Category+import SubHask.Internal.Prelude++-------------------------------------------------------------------------------++{-# RULES++"subhask/distance_l2_m128_UVector_Dynamic" distance = distance_l2_m128_UVector_Dynamic+"subhask/distance_l2_m128_SVector_Dynamic" distance = distance_l2_m128_SVector_Dynamic++"subhask/distanceUB_l2_m128_UVector_Dynamic" distanceUB = distanceUB_l2_m128_UVector_Dynamic+"subhask/distanceUB_l2_m128_SVector_Dynamic" distanceUB = distanceUB_l2_m128_SVector_Dynamic++ #-}++--------------------------------------------------------------------------------++{-# INLINE sizeOfFloat #-}+sizeOfFloat :: Int+sizeOfFloat = sizeOf (undefined::Float)++--------------------------------------------------------------------------------++foreign import ccall unsafe "distance_l2_m128" distance_l2_m128+ :: Ptr Float -> Ptr Float -> Int -> IO Float++foreign import ccall unsafe "distanceUB_l2_m128" distanceUB_l2_m128+ :: Ptr Float -> Ptr Float -> Int -> Float -> IO Float++-- foreign import ccall unsafe "distance_l2_m128" distance_l2_m128_c+-- :: Ptr Float -> Ptr Float -> CInt -> IO Float+--+-- distance_l2_m128 :: Ptr Float -> Ptr Float -> Int -> IO Float+-- distance_l2_m128 p1 p2 i = distance_l2_m128_c p1 p2 (P.fromIntegral i)+--+-- foreign import ccall unsafe "distanceUB_l2_m128" distanceUB_l2_m128_c+-- :: Ptr Float -> Ptr Float -> CInt -> Float -> IO Float+--+-- distanceUB_l2_m128 :: Ptr Float -> Ptr Float -> Int -> Float -> IO Float+-- distanceUB_l2_m128 p1 p2 i = distanceUB_l2_m128_c p1 p2 (P.fromIntegral i)++-----------------------------------------++{-# INLINE distance_l2_m128_UVector_Dynamic #-}+distance_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float+distance_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _)+ = {-# SCC distance_l2_m128_UVector_Dynamic #-} unsafeInlineIO $ distance_l2_m128 p1 p2 n+ where+ p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat)+ p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat)++{-# INLINE distanceUB_l2_m128_UVector_Dynamic #-}+distanceUB_l2_m128_UVector_Dynamic :: UVector (s::Symbol) Float -> UVector (s::Symbol) Float -> Float -> Float+distanceUB_l2_m128_UVector_Dynamic (UVector_Dynamic arr1 off1 n) (UVector_Dynamic arr2 off2 _) ub+ = {-# SCC distanceUB_l2_m128_UVector_Dynamic #-}unsafeInlineIO $ distanceUB_l2_m128 p1 p2 n ub+ where+ p1 = plusPtr (unsafeCoerce $ byteArrayContents arr1) (off1*sizeOfFloat)+ p2 = plusPtr (unsafeCoerce $ byteArrayContents arr2) (off2*sizeOfFloat)++-----------------------------------------++{-# INLINE distance_l2_m128_SVector_Dynamic #-}+distance_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float+distance_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _)+ = {-# SCC distance_l2_m128_SVector_Dynamic #-}unsafeInlineIO $+ withForeignPtr fp1 $ \p1 ->+ withForeignPtr fp2 $ \p2 ->+ distance_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n++{-# INLINE distanceUB_l2_m128_SVector_Dynamic #-}+distanceUB_l2_m128_SVector_Dynamic :: SVector (s::Symbol) Float -> SVector (s::Symbol) Float -> Float -> Float+distanceUB_l2_m128_SVector_Dynamic (SVector_Dynamic fp1 off1 n) (SVector_Dynamic fp2 off2 _) ub+ = {-# SCC distanceUB_l2_m128_SVector_Dynamic #-}unsafeInlineIO $+ withForeignPtr fp1 $ \p1 ->+ withForeignPtr fp2 $ \p2 ->+ distanceUB_l2_m128 (plusPtr p1 $ off1*sizeOfFloat) (plusPtr p2 $ off2*sizeOfFloat) n ub
src/SubHask/Compatibility/ByteString.hs view
@@ -1,3 +1,6 @@+-- |+--+-- FIXME: Add compatibility for "Text" module SubHask.Compatibility.ByteString where
src/SubHask/Internal/Prelude.hs view
@@ -45,13 +45,19 @@ , ifThenElse -- * Modules+ , module Control.DeepSeq , module Data.Proxy , module Data.Typeable , module GHC.TypeLits- , module Control.DeepSeq - -- * Non-base types+ -- * Non-Prelude types++ -- ** QuickCheck , Arbitrary (..)+ , CoArbitrary (..)+ , coarbitraryShow++ -- * Extensions , Constraint ) where
src/SubHask/TemplateHaskell/Deriving.hs view
@@ -285,6 +285,7 @@ typeL2patL :: Name -> Name -> [Type] -> [Pat] typeL2patL conname varname xs = map go $ zip (map (\a -> mkName [a]) ['a'..]) xs where+ go :: (Name, Type) -> Pat go (newvar,VarT v) = if v==varname then ConP conname [VarP newvar] else VarP newvar@@ -296,8 +297,6 @@ go (newvar,AppT ListT (AppT (ConT _) (VarT v))) = VarP newvar go (newvar,ConT c) = VarP newvar go (newvar,_) = VarP newvar-- go qqq = error $ "qqq="++show qqq typeL2expL :: [Type] -> [Exp] typeL2expL xs = map fst $ zip (map (\a -> VarE $ mkName [a]) ['a'..]) xs
subhask.cabal view
@@ -1,5 +1,5 @@ name: subhask-version: 0.1.0.1+version: 0.1.1.0 synopsis: Type safe interface for programming in subcategories of Hask homepage: http://github.com/mikeizbicki/subhask license: BSD3@@ -38,8 +38,9 @@ SubHask.Algebra.Metric SubHask.Algebra.Ord SubHask.Algebra.Parallel--- SubHask.Algebra.Trans.Kernel+ SubHask.Algebra.Ring SubHask.Algebra.Vector+ SubHask.Algebra.Vector.FFI SubHask.Category SubHask.Category.Finite@@ -47,10 +48,8 @@ SubHask.Category.Polynomial SubHask.Category.Slice SubHask.Category.Trans.Bijective--- SubHask.Category.Trans.Continuous SubHask.Category.Trans.Constrained SubHask.Category.Trans.Derivative--- SubHask.Category.Trans.Linear SubHask.Category.Trans.Monotonic SubHask.Compatibility.Base@@ -96,6 +95,7 @@ MultiWayIf, AutoDeriveTypeable,+ DeriveGeneric, RebindableSyntax -- OverloadedLists @@ -138,26 +138,26 @@ -- math erf == 2.0.0.0, gamma == 0.9.0.2,- vector == 0.10.12.3, hmatrix == 0.16.1.5, -- compatibility control flow mtl == 2.2.1,- MonadRandom == 0.1.13,- pipes == 4.1.3,+ MonadRandom == 0.4, -- compatibility data structures bytestring == 0.10.6.0, bloomfilter == 2.0.1.0,- cassava == 0.4.2.3,+ cassava == 0.4.3.1, containers == 0.5.6.2,- hyperloglog == 0.3.1,+ vector == 0.10.12.3,+ array == 0.5.1.0,+ hyperloglog == 0.3.4, -- required for hyperloglog compatibility- semigroups == 0.16.2,- bytes == 0.15,- approximate == 0.2.1.1,- lens == 4.9.1+ semigroups == 0.16.2.2,+ bytes == 0.15.0.1,+ approximate == 0.2.2.1,+ lens == 4.12.3 default-language: Haskell2010@@ -165,6 +165,7 @@ -------------------------------------------------------------------------------- Test-Suite TestSuite-Unoptimized+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: TestSuite.hs@@ -179,9 +180,10 @@ -- FIXME: -- The test below takes a long time to compile.--- The slow builds are cosing travis tests to fail.+-- The slow builds are causing travis tests to fail. -- -- Test-Suite TestSuite-Optimized+-- default-language: Haskell2010 -- type: exitcode-stdio-1.0 -- hs-source-dirs: test -- main-is: TestSuite.hs@@ -198,18 +200,21 @@ -------------------- Test-Suite Example0001+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: example0001-polynomials.lhs build-depends: subhask, base Test-Suite Example0002+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: example0002-monad-instances-for-set.lhs build-depends: subhask, base Test-Suite Example0003+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: example0003-linear-algebra.lhs@@ -218,6 +223,7 @@ -------------------------------------------------------------------------------- benchmark Vector+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: Vector.hs
test/TestSuite.hs view
@@ -63,17 +63,21 @@ , testGroup "objects" [ $( mkSpecializedClassTests [t| Labeled' Int Int |] [ ''Action,''Ord,''Metric ] ) ]+ , testGroup "arrays"+ [ $( mkSpecializedClassTests [t| BArray Char |] [ ''Foldable,''MinBound,''IxContainer ] )+ , $( mkSpecializedClassTests [t| UArray Char |] [ ''Foldable,''MinBound,''IxContainer ] )+ , $( mkSpecializedClassTests [t| UArray (UVector "dyn" Float) |] [ ''Foldable,''IxContainer ] )+ , $( mkSpecializedClassTests [t| UArray (Labeled' (UVector "dyn" Float) Int) |] [ ''Foldable,''IxContainer ] )+ ] , testGroup "containers" [ $( mkSpecializedClassTests [t| [] Char |] [ ''Foldable,''MinBound,''Partitionable ] )- , $( mkSpecializedClassTests [t| BArray Char |] [ ''Foldable,''MinBound ] ) --''Foldable,''MinBound,''Partitionable ] )- , $( mkSpecializedClassTests [t| UArray Char |] [ ''Foldable,''MinBound ] ) --''Foldable,''MinBound,''Partitionable ] ) , $( mkSpecializedClassTests [t| Set Char |] [ ''Foldable,''MinBound ] ) , $( mkSpecializedClassTests [t| Seq Char |] [ ''Foldable,''MinBound,''Partitionable ] ) , $( mkSpecializedClassTests [t| Map Int Int |] [ ''MinBound, ''IxConstructible ] ) , $( mkSpecializedClassTests [t| Map' Int Int |] [ ''MinBound, ''IxContainer ] ) , $( mkSpecializedClassTests [t| IntMap Int |] [ ''MinBound, ''IxContainer ] ) , $( mkSpecializedClassTests [t| IntMap' Int |] [ ''MinBound, ''IxContainer ] )- , $( mkSpecializedClassTests [t| ByteString Lazy Char |] [ ''Foldable,''MinBound,''Partitionable ] )+ , $( mkSpecializedClassTests [t| ByteString Char |] [ ''Foldable,''MinBound,''Partitionable ] ) , testGroup "transformers" [ $( mkSpecializedClassTests [t| Lexical [Char] |] [''Ord,''MinBound] ) , $( mkSpecializedClassTests [t| ComponentWise [Char] |] [''Lattice,''MinBound] )