diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Mike Izbicki + +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 Mike Izbicki 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,404 @@ +# SubHask ![https://travis-ci.org/mikeizbicki/subhask.svg](https://travis-ci.org/mikeizbicki/subhask.svg) + +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*. +The main idea is to use a type safe interface for programming in arbitrary subcategories of [Hask](https://wiki.haskell.org/Hask). +For example, the category [Vect](http://ncatlab.org/nlab/show/Vect) of linear functions is a subcategory of Hask, and SubHask exploits this fact to give a nice interface for linear algebra. +To achieve this goal, almost every class hierarchy is redefined to be more general. + + + + + + + + + +SubHask is a work in progress. +This README is intended to be a "quick start guide" to get you familiar with the current status and major differences from standard Haskell. + +### Table of contents: + +* [Installing](#installing) +* [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) +* [New class hierarchies](#new-class-hierarchies) + * [The category hierarchy](#category-hierarchy) + * [The functor hierarchy](#functor-hierarchy) + * [The container hierarchy](#container-hierarchy) + * [The comparison hierarchy](#comparison-hierarchy) + * [The numeric hierarchy](#numeric-hierarchy) +* [Automated testing](#automated-testing) +* [Limitations](#limitations) + +## Installing + +SubHask depends on: + +1. GHC >= 7.10. +You can download the latest version of GHC [here](https://www.haskell.org/ghc/download). + +1. llvm >= 3.5, llvm < 3.6. +To install on Linux or Mac, run the following commands: + + ``` + $ wget http://llvm.org/releases/3.5.2/llvm-3.5.2.src.tar.xz + $ tar -xf llvm-3.5.2.src.tar.xz + $ cd llvm-3.5.2 + $ mkdir build + $ cmake .. + $ make -j5 + $ sudo make install + ``` + +1. Any version of BLAS and LAPACK. +How to install these packages varies for different operating systems. +For Debian/Ubuntu systems, you can install them using: + + ``` + $ sudo apt-get install libblas-dev liblapack-dev + ``` + +SubHask also has strict dependency requirements on other Haskell packages. +Therefore, I recommend installing in a sandbox. +The following steps will create a project called `subhask-test`. + +``` +$ mkdir subhask-test +$ cd subhask-test +$ cabal update +$ cabal sandbox init +$ cabal install subhask -j5 +``` + +The cabal install command takes about an hour to run on my laptop. +Then you can start ghci by running: + +``` +$ cabal repl +``` + +## Examples + +See the [examples](/examples) folder for the literate haskell files. + +## New Class Hierarchies + +### Category Hierarchy + +The modified category hierarchy closely follows the presentation in the [Rosetta Stone paper](http://math.ucr.edu/home/baez/rosetta.pdf). + +The image below shows the category hierarchy: + +

+ +Important points: + +1. Intuitively, `Concrete` categories are functions that have been annotated with special properties. + More formally, a `Concrete` category is one that is a subtype of `(->)`. + Subtyping is not a builtin feature of the Haskell language, but we simulate subtyping using the class `<:`. + See the documentation in [SubHask.SubType](/src/SubHask/SubType.hs) for more details. + +1. SubHask contains implementations of both categories and what I call "category transformers." +A category transformer creates a type corresponding to a subcategory in the original category. +For example, we can use the category transformer `MonT :: (* -> * -> *) -> * -> * -> *` to construct the category `MonT (->) :: * -> * -> *`, which corresponds to the category of monotonic functions. +See the [SubHask.Category.Trans.Monotonic](/src/SubHask/Category/Trans/Monotonic.hs) module for details. + + The categories can be found in the `SubHask.Category.*` modules, + and transformers can be found in`SubHask.Category.Trans.*` modules. + The design of these transformers roughly follows that of the [mtl library](https://hackage.haskell.org/package/mtl) to allow for composition of transformers. + +1. I have removed the `Arrow` hierarchy in favor of a more principled approach. +Some of `Arrow`'s functionality has also been removed since I've never found a use for it, +but it will probably be added at a future point as SubHask matures. + +### 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: + +``` +class Category cat => Functor cat f where + fmap :: cat a b -> cat (f a) (f b) +``` + +The image below shows the functor hierarchy: + +

+ +The dashed lines above mean that the `Functor`, `Applicative`, and `Monad` instances can depend on a category. + +Important points: + +1. This modified functor hierarchy gives us a lot of power. +For example, we can finally make `Set` an instance of `Monad`! +Actually, `Set` is an instance of `Monad` in two separate categories: +the category of functions with an `Ord` constraint (i.e. `OrdHask`) +and the category of monotonic functions (i.e. `MonT (->)` mentioned above). +Semantically, both have the same meaning, but the monotonic `fmap` runs faster. + +1. We've introduced a new class `Then` that does not depend on the `Category`. +This class is a hack to make monads play nice with do notation; +it's only member function is the `(>>)` operator. +There's probably something deep going on here that I'm just not aware of. + +1. Notice that the `Applicative` class is not a super class of `Monad`. +While it's true that every `Monad` in `Hask` is also an `Applicative`, +this does not appear to be true for arbitrary categories. +At least it's definitely not true given the current definition of the `Category` class I've defined. +I'm not sure if that's a limitation of my design or something more fundamental. + +1. The functor hierarchy is much smaller than the functor hierarchy available with base. +I haven't included Prelude classes like `Alternative`, and I haven't included all of the classes Edward Kmett is famous for (see e.g. [category-extras](http://hackage.haskell.org/package/category-extras)). +All of these class can in principle be extended to the more generic setting of SubHask, I just haven't gotten around to it yet. + + [Lens](http://hackage.haskell.org/package/lens) is the most famous package that uses the extended funtor hierarchy. + As-is, the current version of lens is fully compatible with SubHask; + however, the [container hierarchy](#container-hierarchy) below obviates the need for most of the fancy lenses. + Eventually, I'd like to implement lenses in arbitrary categories. + For example, you could use a monotonic lens to guantee updates to a data structure are monotonic. + I haven't done very much work on this yet though. + + Another interesting category theoretic Kmett library is [hask](https://hackage.haskell.org/package/hask). + Everything in that library can be translated to SubHask, but that's not something I've done yet. + +### Comparison Hierarchy + +SubHask's comparison hierarchy is significantly more complicated than Prelude's. +It is directly inspired by [order theory](https://en.wikipedia.org/wiki/Order_theory) and [non-classical logic](https://en.wikipedia.org/wiki/Non-classical_logic). + +The hierarchy is shown in the following image: + +

+ +Important points: + +1. A type in SubHask can be compared using non-classical logics. + Consider the type of equality comparison: + ``` + (==) :: 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`. + + For most types, `Logic a` will be `Bool`, and everything will behave as you would expect. + But this more general type lets us define equality on types for which classical equality is either uncomputable, undefined, or not what we actually want. + + Consider the case of functions. + Classical equality over functions is uncomputable. + But in SubHask, we define: + ``` + type instance Logic (a -> b) = Logic b + + 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'] + "cdeq" + ``` + +* 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. + +### Container Hierarchy + +SubHask's container hierarchy is inspired by the [mono-traversable](http://hackage.haskell.org/package/mono-traversable) and [classy-prelude](https://hackage.haskell.org/package/classy-prelude) packages. +These packages use type families to make the standard type classes applicable to more data types. +For example, they can make `ByteString` an instance of `Foldable`, whereas the Prelude classes cannot. +This makes code *look* more generic, but unfortunately these packages' classes come with no laws. +In contrast, SubHask provides a clear and useful set of laws for each type class. + +The container laws are closely related to the axioms of set theory. +The main two differences are that SubHask's laws handle the case of non-commutative containers but don't bother with infinitely sized containers. +See the [automated-testing](#automated-testing) section below for more details on class laws. + +The container hierarchy is shown in the image below: + +

+ +Important points about containers: + +* The container hierarchy is general enough to support very weird containers. +Containers like [HyperLogLog](/src/SubHask/Compatibility/HyperLogLog.hs)s and [BloomFilter](/src/SubHask/Compatibility/BloomFilter.hs)s fit nicely in the hierarchy and don't need to implement their own non-standard interface. +This makes generic programming much easier. + +* SubHask makes a clear distinction between vectors and arrays. +A vector in SubHask is not a generic container (like it is in the C++ STL or Haskell's [vector](https://hackage.haskell.org/package/vector) package). +That's what arrays are for. +Vectors are elements of a vector space and subject to an entirely different set of laws (discussed in the [numeric hierarchy](#numeric-hierarchy) section below). +The array types can be found in the [SubHask.Algebra.Array](/src/SubHask/Algebra/Array.hs) module, and internally use the vector package for its nice fusion abilities. + + One nice result of the vector/array distinction is that it becomes easy to make unboxed arrays of unboxed vectors. + Unboxing the vectors within the array is crucial for high performance numeric operations, but it is not supported by standard Haskell. + +* Most Haskell data structures have two versions: a strict version and lazy version. +Standard Haskell packages use a separate module for each version. +The classic example is the [containers](https://hackage.haskell.org/package/containers) library exporting a lazy `Map` type in `Data.Map` and a strict `Map` in `Data.Map.Strict`. +Using these types requires qualified imports and makes code less generic. + + In SubHask, you can access the containers package by importing `SubHask.Compatibilty.Containers`. + This module exports `Map` as a lazy map and `Map'` as a strict map. + In general, the prime symbol on a type signifies that it is a strict variant of the unprimed type. + In practice, I've found this makes code much easier to read. + +* There's actually two separate container hierarchies. +Indexed containers (classes are prefixed with `Ix`) and non-indexed containers (classes have no prefix). +An example of an indexed container would be `Map` and a non-indexed container would be `Set`. +Some types, like arrays and lists are both indexed and non-indexed. + +* The classes in the functor hierarchy don't relate to the classes in the container hierarchy. +This is a code smell that's caused by some of the limitations in Haskell's type system. +See the [limitations](#limitations) section below for details. + + +* There is very little established mathematics about non-commutative containers. +Therefore this hierarchy is not yet as well principled as the other hierarchies. +It has the least stable interface. + +### Numeric Hierarchy + +SubHask is directly inspired by a lot of good existing work on improving Haskell's numeric support. +For example: + +* The [hmatrix](http://hackage.haskell.org/package/hmatrix) package provides fast matrix operations via [LAPACK](https://en.wikipedia.org/wiki/LAPACK) and [BLAS](https://en.wikipedia.org/wiki/Basic_Linear_Algebra_Subprograms). +One of hmatrix's design goals is to maintain compatibility with the standard Prelude, and this makes hmatrix's class hierarchy confusing to work with. +Because SubHask does not maintain Prelude compatibility, we can have an interface that aligns more closely with the math. + + Internally, SubHask's `Matrix` type is currently implemented via hmatrix. + In the future, I hope to make SubHask faster by supporting multiple backends like: + + * [accelerate](http://hackage.haskell.org/package/accelerate), for GPU based linear algebra + * [bed-and-breakfast](http://hackage.haskell.org/package/bed-and-breakfast), a native haskell implementation that would allow matrices of the `Rational` and `Integer` types + * [eigen](http://hackage.haskell.org/package/eigen), bindings to the C++ Eigen library supporting dense and sparse formats + * [hblas](https://hackage.haskell.org/package/hblas), which supports more dense matrix formats + + There's nothing difficult about adding these bindings. + It's just time consuming, which is why I haven't done it yet. + +* The [algebra](https://hackage.haskell.org/package/algebra) and [numeric-prelude](https://hackage.haskell.org/package/numeric-prelude) packages provide substantial rewrites of the `Num` class hierarchy. +These packages are excellent, but they have the following limitations: + + * They *only* redefine the `Num` hierarchy. + But the `Num` hierarchy is closely related to each of the other hierarchies. + I've found that redefining the other hierarchies greatly simplified numeric programming. + + * They don't have built-in linear algebra support, whereas SubHask does. + + * They don't take advantage of GHC's more recent type system improvements. + SubHask is able to simplify some of the interfaces + There are still a few warts in SubHask's interface, however, caused by [limitations](#limitations) in GHC's type system. + + * They don't provide an automated test suite, whereas SubHask does. + See the [automated testing](#automated-testing) section below for details on how SubHask handles this. + +* Finally, many numeric packages try to extend the existing Prelude without breaking compatibility. + + * [linear](http://hackage.haskell.org/package/linear) provides a vector hierarchy that exists on top of `Num`. + It's widely used on projects that require low dimensional matrices, + but performance is lacking for higher dimensional applications. + + * [monoid-subclasses](https://hackage.haskell.org/package/monoid-subclasses) provides (as the name suggests) subclasses of monoid. + Between the modified numeric and container hierarchies, SubHask supports everything monoid-subclasses does with a simpler interface. + +You can see it in the image below: + +

+ +Important points: + +* There are two main branches of the numeric hierarchy. +Along the bottom branch is the ring hierarchy. +Along the top branch is the branch for linear algebra. + + Morally, every instance of a class in the ring hierarchy is also an instance of the equivalent class in the linear algebra hierarchy. + For example, every field can be considered as a one-dimensional vector. + I would like to formalize this connection, but it's [current impossible](#limitations). + +* Non-exact implementations using floating point are allowed. +Currently, these implementations break the laws of the classes, but only slightly. +I intend to generalize the laws so that non-exact implementations are law abiding. + +## Automated testing + +There are currently over 1000 quickcheck properties being checked in the test suite. +But I didn't write any of these tests by hand. +Whenever I implement a new data type, template haskell functions add appropriate tests to the test suite automatically. +I literally don't have to think at all about writing tests and I still get the full benefits. +Here's how it works. + +Each class in the new hierarchies above comes with a set of laws they must obey. +Those laws are documented using [quickcheck](https://hackage.haskell.org/package/QuickCheck) properties. +These properties fully describe the intended behavior of the class, +and any instance that passes the quickcheck tests is a valid instance of the class. + +For example, the `Eq` class is intended to capture the notion of [equivalence classes](https://en.wikipedia.org/wiki/Equivalence_class) from algebra. +The class definition is: +``` +class Eq_ a where + (==) :: a -> a -> Logic a + (/=) :: a -> a -> Logic a +``` +and the quickcheck properties are: +``` +law_Eq_reflexive :: Eq a => a -> Logic a +law_Eq_reflexive a = a==a + +law_Eq_symmetric :: Eq a => a -> a -> Logic a +law_Eq_symmetric a1 a2 = (a1==a2) == (a2==a1) + +law_Eq_transitive :: Eq a => a -> a -> a -> Logic a +law_Eq_transitive a1 a2 a3 = (a1==a2&&a2==a3) ==> (a1==a3) + +defn_Eq_noteq :: (Complemented (Logic a), Eq a) => a -> a -> Logic a +defn_Eq_noteq a1 a2 = (a1/=a2) == (not $ a1==a2) +``` +The three properties prefixed with `law` capture the laws of the equivalence classes and the property prefixed with `defn` shows how the operators `(==)` and `(/=)` must relate to each other. + +You can use these laws to automatically test any data types you implement. +All you have to do is call the `mkSpecializedClassTests` template haskell function on the type you want to test. +This function constructs the test cases and adds them to the test suite. +See the [/tests/TestSuite.hs](https://github.com/mikeizbicki/subhask/blob/docs/test/TestSuite.hs) for how to use the function. +The module [SubHask.TemplateHaskell.Test](https://github.com/mikeizbicki/subhask/blob/master/src/SubHask/TemplateHaskell/Test.hs) contains the actual implementation. + +The existing interface is pretty convenient, but I think it should be automated even more. +There's a minor limitation in template haskell that currently prevents full automation (see [#9699](https://ghc.haskell.org/trac/ghc/ticket/9699)). + +## Limitations + +SubHask is far from production ready. +There are roughly three causes of SubHask's limitations: + +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)). + + * 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)). + + * A few of the invariants that are supposed to be maintained in SubHask's hierarchies can't be mechanically enforced because GHC doesn't allow cycles in the class hierarchy (see [#10592](https://ghc.haskell.org/trac/ghc/ticket/10592)). + +1. Some of the abstractions aren't quite right yet and will change in the future. +I expect that as I write more programs that depend on SubHask, these abstractions will flesh themselves out a bit. + +1. There's a lot of grunt work that I just haven't had time for. +For example, the current implementation of the derivative category transformer in [SubHask.Category.Trans.Derivative](src/SubHask/Category/Trans/Derivative.hs) only supports forward mode automatic differentiation. +Adding backwards mode support doesn't require any new ideas, just a couple hours of work. +There are currently 118 `FIXME` comments in the source documenting similar limitations. +A great, beginner friendly way to contribute to SubHask would be to find one of these limitations that interests you and fix it :) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Vector.hs b/bench/Vector.hs new file mode 100644 --- /dev/null +++ b/bench/Vector.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds,KindSignatures #-} + +import qualified Prelude as P +import Control.Monad.Random +import Criterion.Main +import Criterion.Types +import System.IO + +import SubHask +import SubHask.Algebra.Vector +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 + 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 + s2 = unsafeToModule (xs1+xs3) `asTypeOf` s1 + + d1 = unsafeToModule (xs1+xs2) :: SVector "dynamic" Float + d2 = unsafeToModule (xs1+xs3) `asTypeOf` d1 + + u1 = unsafeToModule (xs1+xs2) :: UVector "dynamic" Float + u2 = unsafeToModule (xs1+xs3) `asTypeOf` u1 + + let ub14 = distance s1 s2 * 1/4 + ub34 = distance s1 s2 * 3/4 + + deepseq s1 $ deepseq s2 $ return () + + ----------------------------------- + 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" + } + ) +-- [ bgroup "+" +-- [ bench "static" $ nf (s1+) s2 +-- , bench "dynamic" $ nf (d1+) d2 +-- , bench "unboxed" $ nf (u1+) u2 +-- ] + [ bgroup "distance" + [ bench "static" $ nf (distance s1) s2 + , bench "dynamic" $ nf (distance d1) d2 + , bench "unboxed" $ nf (distance u1) u2 + ] + , bgroup "distanceUB - bound (1/4)" + [ bench "static" $ nf (distanceUB s1 s2) ub14 + , bench "dynamic" $ nf (distanceUB d1 d2) ub14 + , bench "unboxed" $ nf (distanceUB u1 u2) ub14 + ] + , bgroup "distanceUB - bound (3/4)" + [ bench "static" $ nf (distanceUB s1 s2) ub34 + , bench "dynamic" $ nf (distanceUB d1 d2) ub34 + , bench "unboxed" $ nf (distanceUB u1 u2) ub34 + ] + , bgroup "distanceUB - bound infinity" + [ bench "static" $ nf (distanceUB s1 s2) infinity + , bench "dynamic" $ nf (distanceUB d1 d2) infinity + , bench "unboxed" $ nf (distanceUB u1 u2) infinity + ] +-- [ bgroup "size" +-- [ bench "static" $ nf size s1 +-- , bench "dynamic" $ nf size d2 +-- ] + ] +-- , bench "-" $ nf ((-) s1) s2 +-- , bench ".*." $ nf ((.*.) s1) s2 +-- , bench "./." $ nf ((./.) s1) s2 +-- , bench "negate" $ nf negate s2 +-- , bench ".*" $ nf (.*5) s2 +-- , bench "./" $ nf (./5) s2 +-- [ bench "distance" $ nf (distance s1) s2 +-- , bench "distance_Vector4_Float" $ nf (distance_Vector4_Float s1) s2 + diff --git a/cbits/Lebesgue.c b/cbits/Lebesgue.c new file mode 100644 --- /dev/null +++ b/cbits/Lebesgue.c @@ -0,0 +1,288 @@ +#include +#include +#include + +float distance_l2_float(float *p1, float *p2, int len) +{ + float ret=0; + int i=0; + for (i=0; i dist2) return NAN; + } + return sqrt(ret); +} + +double distance_l2_double(double *p1, double *p2, int len) +{ + double ret=0; + int i=0; + for (i=0; i dist2) return NAN; + } + return sqrt(ret); +} + +/******************************************************************************/ +/* __m128 */ + +float distance_l2_m128(__m128 *p1, __m128 *p2, int len) +{ + /*printf("distance_l2_m128; p1=%d; p2=%d; len=%d\n", ((unsigned int)p1%16), ((unsigned int)p2%16), len);*/ + + float ret=0; + __m128 sum={0,0,0,0}; + float fsum[4]; + + int i=0; + for (i=0; i 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]; + + return sqrt(ret); +} + +float isFartherThan_l2_m128(__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 dist2/4) { + _mm_store_ps(fsum,sum); + if (fsum[0]+fsum[1]+fsum[2]+fsum[3] > dist2) { + return NAN; + } + } + } + } + + _mm_store_ps(fsum,sum); + ret = fsum[0] + fsum[1] + fsum[2] + fsum[3]; + + for (i*=4; i dist2/4) { + if (sum[0]+sum[1]+sum[2]+sum[3] > dist2) { + return NAN; + } + } + } + + ret = sum[0] + sum[1] + sum[2] + sum[3]; + + for (i*=4; i dist2) { + return NAN; + } + + return sqrt(ret); +} + +float isFartherThan_l2_m128_nocheck(__m128 *p1, __m128 *p2, int len, float dist) +{ + float ret=0; + float dist2=dist*dist; + __m128 sum={0,0,0,0}; + + int i=0; + for (i=0; i dist2) { + return NAN; + } + } + } + + ret = sum[0] + sum[1]; + + for (i*=2; i {-# LANGUAGE NoImplicitPrelude #-} +> {-# LANGUAGE RebindableSyntax #-} +> import SubHask +> import SubHask.Category.Polynomial +> import System.IO + +We'll do everything within the `main` function so we can print some output as we go. + +> main = do + +To start off, we'll just create an ordinary function and print it's output. +The `Ring` class below corresponds very closely with the Prelude's `Num` class. + +> let f :: Ring x => x -> x +> f x = x*x*x + x + 3 +> +> let a = 3 :: Integer +> +> putStrLn $ "f a = " + show (f a) + +Now, we'll create a polynomial from our ordinary function. + +> let g :: Polynomial Integer +> g = provePolynomial f +> +> putStrLn "" +> putStrLn $ "g $ a = " + show ( g $ a ) + +The function `provePolynomial` above gives us a safe way to convert an arrow in Hask into an arrow in the category of polynomials. +The implementation uses a trick similar to automatic differentiation. +In general, every `Concrete` category has at least one similar function. +Finally, in order to apply our polynomial to a value, we must first convert it back into an arrow in Hask. +The function application operator `$` performs this task for us. + +Polynomials support operations that other functions in Hask do not support. +For example, we can show the value of a polynomial: + +> putStrLn "" +> putStrLn $ "g = " + show g +> putStrLn $ "g*g+g = " + show (g*g + g) + +Polynomials also support decidable equality: + +> putStrLn "" +> putStrLn $ "g==g = " + show (g==g) +> putStrLn $ "g==g*g+g = " + show (g==g*g+g) + +Finally, we can create polynomials of polynomials: + +> let h :: Polynomial (Polynomial Integer) +> h = provePolynomial f +> +> putStrLn "" +> putStrLn $ " h = " + show h +> putStrLn $ " h $ g = " + show ( h $ g ) +> putStrLn $ "(h $ g) $ a = " + show (( h $ g ) $ a) + +**For advanced readers:** +You may have noticed that function application on polynomials is equivalent to the join operation on monads. +That's because polynomials form a monad on Hask. +Sadly, we can't make `Polynomial` an instance of the new `Monad` class due to some limitatiions in GHC's type system. +This isn't too big of a loss though because I don't know of a useful application for this particular monad. +The monad described above is different than what category theorists call polynomial monads (see: http://ncatlab.org/nlab/show/polynomial+functor). + diff --git a/examples/example0002-monad-instances-for-set.lhs b/examples/example0002-monad-instances-for-set.lhs new file mode 100644 --- /dev/null +++ b/examples/example0002-monad-instances-for-set.lhs @@ -0,0 +1,115 @@ +In this example, we will use two different monad instances on sets. +In standard haskell, this is impossible because sets require an `Ord` constraint; +but in subhask we can make monads that require constraints. +The key is that set is not a monad over Hask. +It is a monad over the subcategories `OrdHask` and `Mon`. +`OrdHask` contains only those objects in Hask that have `Ord` constraints. +`Mon` is the subcategory on `OrdHask` whose arrows are monotonic functions. + +Now for the preliminaries: + +> {-# LANGUAGE NoImplicitPrelude #-} +> {-# LANGUAGE RebindableSyntax #-} +> {-# LANGUAGE OverloadedLists #-} +> {-# LANGUAGE TypeOperators #-} +> {-# LANGUAGE FlexibleContexts #-} +> {-# LANGUAGE GADTs #-} +> +> import SubHask +> import SubHask.Category.Trans.Constrained +> import SubHask.Category.Trans.Monotonic +> import SubHask.Compatibility.Containers +> import System.IO + +We'll do everything within the `main` function so we can print some output as we go. + +> 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. + +> let xs = [1..5] :: LexSet Int +> +> let f x = x+x -- monotonic +> g x = if x`mod`2 == 0 then x else -x -- not monotonic +> +> let fxs = fmap (proveOrdHask f) $ xs +> 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." + +Now let's see the `Functor Mon LexSet` instance in action. +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`. +Therefore we must use the `unsafeProveMon` function, as follows: + +> let fxs' = fmap (unsafeProveMon f) $ xs +> gxs' = fmap (unsafeProveMon g) $ xs +> +> putStrLn "" +> putStrLn $ "fxs' = " + show fxs' +> putStrLn $ "gxs' = " + show gxs' + +Notice that we were able to use the `Functor Mon` instance on the non-monotonic function `g`. +But since the `g` function is not in fact monotonic, the mapping did not work correctly. +Notice that equality checking is now broken: + +> putStrLn "" +> putStrLn $ "fxs == fxs' = " + show (fxs == fxs') +> putStrLn $ "gxs == gxs' = " + show (gxs == gxs') + +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. + +> let oddneg :: Int `OrdHask` (LexSet Int) +> oddneg = proveConstrained f +> where +> f i = if i `mod` 2 == 0 +> then [i] +> else [-i] +> +> let times3 :: (Ord a, Ring a) => a `OrdHask` (LexSet a) +> times3 = proveConstrained f +> where +> f a = [a,2*a,3*a] +> +> let times3mon :: (Ord a, Ring a) => a `Mon` (LexSet a) +> times3mon = unsafeProveMon (times3 $) +> +> putStrLn "" +> putStrLn $ "xs >>= oddneg = " + show (xs >>= oddneg) +> putStrLn $ "xs >>= times3 = " + show (xs >>= times3) +> putStrLn $ "xs >>= times3mon = " + show (xs >>= times3mon) + +One of the main advantages of monads is do notation. +Unfortunately, that's only partially supported at the moment. +Consider the do block: +``` +do + x <- xs + times3 x +``` +which gets desugared as: +``` +xs >>= (\x -> times3 x) +``` +The above code doesn't type check because the lambda expression is an arrow in Hask, +but we need an arrow in OrdHask. +This problem can be fixed by modifying the syntactic sugar of the do block to prefix its lambdas with a proof statement. +But for now, you have to do the desugaring manually. diff --git a/examples/example0003-linear-algebra.lhs b/examples/example0003-linear-algebra.lhs new file mode 100644 --- /dev/null +++ b/examples/example0003-linear-algebra.lhs @@ -0,0 +1,208 @@ +This example introduces subhask's basic linear algebra system. +It starts with the differences between arrays and vectors, +then shows example manipulations on a few vector spaces, +and concludes with links to real world code. + +But first the preliminaries: + +> {-# LANGUAGE NoImplicitPrelude #-} +> {-# LANGUAGE RebindableSyntax #-} +> {-# LANGUAGE OverloadedLists #-} +> {-# LANGUAGE TypeOperators #-} +> {-# LANGUAGE FlexibleContexts #-} +> {-# LANGUAGE GADTs #-} +> {-# LANGUAGE DataKinds #-} +> +> import SubHask +> import SubHask.Algebra.Array +> import SubHask.Algebra.Vector +> import System.IO + +We'll do everything within the `main` function so we can print some output as we go. + +> main = do + +Arrays vs. Vectors +======================================= + +Vectors are the heart of linear algebra. +But before we talk about vectors, we need to talk about containers. +In particular, arrays and vectors are different in subhask. +Arrays are generic containers suitable for storing both numeric and non-numeric values. +Vectors are elements of a vector space and come with a completely different set of laws. + +There are three different types of arrays, each represented differently in memory. +The `BArray` is a boxed array, `UArray` is an unboxed array, and `SArray` is a storable array. + +Because arrays are instances of `Constructable` and `Monoid`, they can be built using the `fromList` function. +With the `OverloadedLists` extension, this gives us the following syntax: + +> let arr = [1..5] :: UArray Int +> +> putStrLn $ "arr = " + show arr + +Like arrays, vectors come in three forms (`BVector`, `UVector` and `SVector`). +We construct vectors using the `unsafeToModule` function. +(Vectors are a special type of module.) + +> let vec = unsafeToModule [1..5] :: SVector 5 Double +> +> putStrLn $ "vec = " + show vec + +If the dimension of the vector is not known at compile time, it does not need to be specified in the type signature. +Instead, you can provide a string that represents the size of the vector. + +> let vec' = unsafeToModule [1..5] :: SVector "datapoint" Double +> +> putStrLn $ "vec' = " + show vec + +The laws of the `Constructible` class, ensure that the `Monoid` instance concatenates two containers together. +Vectors are not `Constructible` because their `Monoid` instance is not concatenation. +Instead, is is componentwise addition on each of the elements. +Compare the following: + +> putStrLn "" +> putStrLn $ "arr + arr = " + (show $ arr+arr) +> putStrLn $ "vec + vec = " + (show $ vec+vec) +> putStrLn $ "vec' + vec' = " + (show $ vec'+vec') + +One commonality between vectors and arrays is that they are both indexed containers (i.e. instances of `IxContainer`). +This lets us look up a value at a specific instance using the `(!)` operator: + +> putStrLn "" +> putStrLn $ "arr!0 = " + show (arr!0) +> putStrLn $ "vec!0 = " + show (vec!0) +> putStrLn $ "vec'!0 = " + show (vec'!0) + +Unboxed arrays in subhask are more powerful than the unboxed vectors used in standard haskell. +For example, we can make an unboxed array of unboxed vectors like so: + +> let arr1 = fromList $ map unsafeToModule [[1,2],[2,3],[1,3]] :: UArray (UVector "a" Double) +> arr2 = fromList $ map unsafeToModule [[1,2,2],[3,1,3]] :: UArray (UVector "b" Double) +> +> putStrLn "" +> putStrLn $ "arr1!0 + arr1!1 = " + show (arr1!0 + arr1!1) +> putStrLn $ "arr2!0 + arr2!1 = " + show (arr2!0 + arr2!1) + +Notice how we did not have to know the sizes of the `UVector`s above at compile time in order to unbox them within the `UArray`. +Nonetheless, because we have annotated the sizes with different strings, the following code will not type check: + +``` + putStrLn $ "arr1!0 + arr2!0 = " + show (arr1!0 + arr2!0) +``` + +And this is exactly what we want! +It doesn't make sense to add a vector of dimension 2 to a vector of dimension 3, so the types prevent it. + +I've found this distinction between vectors and arrays greatly simplifies the syntax when using linear algebra. + +Linear Algebra +======================================= + +Let's create two vectors and show all the vector operations you might want to perform on them: + +> let u = unsafeToModule [1,1,1] :: SVector 3 Double +> v = unsafeToModule [0,1,2] :: SVector 3 Double +> +> putStrLn "" +> putStrLn $ "add: " + show (u+v) +> putStrLn $ "sub: " + show (u-v) +> putStrLn $ "scalar mul: " + show (5*.u) +> putStrLn $ "component mul: " + show (u.*.v) + +Because `SVector` is not just a vector space but also a hilbert space (i.e. instance of `Hilbert`), +we get the following operations as well: + +> putStrLn "" +> putStrLn $ "norm: " + show (size u) +> putStrLn $ "distance: " + show (distance u v) +> putStrLn $ "inner product: " + show (u<>v) +> putStrLn $ "outer product: " + show (u>)` (also called `Vect`) is the subcategory of `Hask` corresponding to linear functions. + +The main advantage of this interpretation is that matrix multiplication is the same thing as function composition. + +> let matrix1 = u> SVector 3 Double +> +> putStrLn "" +> putStrLn $ "matrix1*matrix1 = " + show (matrix1*matrix1) +> putStrLn $ "matrix1.matrix1 = " + show (matrix1.matrix1) + +Square matrices (as shown above) are instances of the `Ring` type class. +But non-square matrices cannot be made instances of `Ring`. +The reason is that the type signature for multiplication +``` +(*) :: Ring r => r -> r -> r +``` +requires that all input and output arguments have the same type. +This simple type signature is needed to support good error messages and type inference. +But function composition from the category class allows the arguments to differ: +``` +(.) :: Category cat => cat b c -> cat a b -> cat a c +``` +What's more, each of the `a`, `b`, and `c` type variables above corresponds to a dimension of matrix. +So the type system will ensure that your matrix multiplications actually make sense! + +Here's an example: + +> let a = unsafeMkSMatrix 2 3 [1..6] :: SVector "a" Double +> SVector 3 Double +> b = unsafeMkSMatrix 3 2 [1..6] :: SVector 3 Double +> SVector "a" Double +> c = unsafeMkSMatrix 3 3 [1..9] :: SVector 3 Double +> SVector 3 Double +> +> putStrLn "" +> putStrLn $ "b.a = " + show (b.a) +> putStrLn $ "b.c.c.a = " + show (b.c.c.a) + +Linear functions form a subcategory of Hask, +and function application corresponds to right multiplying by a vector: + +> putStrLn "" +> putStrLn $ "c $ u = " + show (c $ u) + +Linear functions form what's known as a dagger catgory (i.e. `(+>)` is an instance of `Dagger`). +Dagger categories capture the idea of transposing a function and the ability to left multiply a vector. + +> putStrLn "" +> putStrLn $ "trans c = " + show (trans c) +> putStrLn $ "(trans c) $ u = " + show ((trans c) $ u) + +Finally, there are many vector spaces besides the three `Vector` types. +For example, the linear functions above are finite dimensional vector spaces, +and ordinary haskell functions are actually infinite dimensional vector space! +Here they are in action: + +> let f x = x.*.x -- :: SVector 5 Double +> g x = x+x -- :: SVector 5 Double +> +> let h = f.*.g -- :: SVector 5 Double -> SVector 5 Double +> +> putStrLn "" +> putStrLn $ "h u = " + show (h u) + +Going further +======================================= + +There's a lot of material about linear algebra this tutorial didn't cover. +You can see some real world machine learning examples in the the HLearn library. +A good place to start is the univariate optimization code: +https://github.com/mikeizbicki/HLearn/blob/master/src/HLearn/Optimization/Univariate.hs + +Issues +======================================= + +There's a number of warts still in the interface that I'm not pleased with. + +* All of the array and vector types are currently missing many instances that they should have, but that I just haven't had time to implement. +I'd greatly appreciate any pull requests :) + +* I'd like a good operator for function application on the left. +I think a mirror image dollar sign would work well, but I haven't found a unicode code point for that. + +* Currently, you cannot make a multiparameter linear function (e.g. `a +> b +>`). +These multiparameter functions correspond to higher order tensors. +The reason for this limitation is type system issues I haven't figured out. + +There are many more FIXME annotations documented in the code. diff --git a/src/SubHask.hs b/src/SubHask.hs new file mode 100644 --- /dev/null +++ b/src/SubHask.hs @@ -0,0 +1,17 @@ +-- | This module reexports the modules that every program using SubHask will need. +-- You should import it instead of Prelude. +module SubHask + ( module SubHask.Algebra + , module SubHask.Category + , module SubHask.Compatibility.Base + , module SubHask.Internal.Prelude + , module SubHask.Monad + , module SubHask.SubType + ) where + +import SubHask.Algebra +import SubHask.Category +import SubHask.Compatibility.Base +import SubHask.Internal.Prelude +import SubHask.Monad +import SubHask.SubType diff --git a/src/SubHask/Algebra.hs b/src/SubHask/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra.hs @@ -0,0 +1,3071 @@ +{-# LANGUAGE CPP,MagicHash,UnboxedTuples #-} + +-- | This module defines the algebraic type-classes used in subhask. +-- The class hierarchies are significantly more general than those in the standard Prelude. +module SubHask.Algebra + ( + -- * Comparisons + Logic + , ValidLogic + , ClassicalLogic + , Eq_ (..) + , Eq + , ValidEq + , law_Eq_reflexive + , law_Eq_symmetric + , law_Eq_transitive + , POrd_ (..) + , POrd + , law_POrd_commutative + , law_POrd_associative + , theorem_POrd_idempotent + , Lattice_ (..) + , Lattice + , isChain + , isAntichain + , POrdering (..) + , law_Lattice_commutative + , law_Lattice_associative + , theorem_Lattice_idempotent + , law_Lattice_infabsorption + , law_Lattice_supabsorption + , law_Lattice_reflexivity + , law_Lattice_antisymmetry + , law_Lattice_transitivity + , defn_Lattice_greaterthan + , MinBound_ (..) + , MinBound + , law_MinBound_inf + , Bounded (..) + , law_Bounded_sup + , supremum + , supremum_ + , infimum + , infimum_ + , Complemented (..) + , law_Complemented_not + , Heyting (..) + , modusPonens + , law_Heyting_maxbound + , law_Heyting_infleft + , law_Heyting_infright + , law_Heyting_distributive + , Boolean (..) + , law_Boolean_infcomplement + , law_Boolean_supcomplement + , law_Boolean_infdistributivity + , law_Boolean_supdistributivity + +-- , defn_Latticelessthaninf +-- , defn_Latticelessthansup + , Graded (..) + , law_Graded_pred + , law_Graded_fromEnum + , Ord_ (..) + , law_Ord_totality + , law_Ord_min + , law_Ord_max + , Ord + , Ordering (..) + , min + , max + , maximum + , maximum_ + , minimum + , minimum_ + , argmin + , argmax +-- , argminimum_ +-- , argmaximum_ + , Enum (..) + , law_Enum_succ + , law_Enum_toEnum + + -- ** Boolean helpers + , (||) + , (&&) + , true + , false + , and + , or + + -- * Set-like + , Elem + , SetElem + , Container (..) + , law_Container_preservation + + , Constructible (..) + , law_Constructible_singleton + , defn_Constructible_cons + , defn_Constructible_snoc + , defn_Constructible_fromList + , defn_Constructible_fromListN + , theorem_Constructible_cons + , fromString + , fromList + , fromListN + , insert + , empty + , isEmpty + + , Foldable (..) + , law_Foldable_sum + , theorem_Foldable_tofrom + , defn_Foldable_foldr + , defn_Foldable_foldr' + , defn_Foldable_foldl + , defn_Foldable_foldl' + , defn_Foldable_foldr1 + , defn_Foldable_foldr1' + , defn_Foldable_foldl1 + , defn_Foldable_foldl1' + + , foldtree1 + , length + , reduce + , concat + , headMaybe + , tailMaybe + , lastMaybe + , initMaybe + + -- *** indexed containers + , Index + , SetIndex + + , IxContainer (..) + , law_IxContainer_preservation + , defn_IxContainer_bang + , defn_IxContainer_findWithDefault + , defn_IxContainer_hasIndex + , (!?) + + , Sliceable (..) + + , IxConstructible (..) + , law_IxConstructible_lookup + , defn_IxConstructible_consAt + , defn_IxConstructible_snocAt + , defn_IxConstructible_fromIxList + , insertAt + + -- * Maybe + , CanError (..) + , Maybe' (..) + , Labeled' (..) + + -- * Number-like + -- ** Classes with one operator + , Semigroup (..) + , law_Semigroup_associativity + , defn_Semigroup_plusequal + , Actor + , Action (..) + , law_Action_compatibility + , defn_Action_dotplusequal + , (+.) + , Cancellative (..) + , law_Cancellative_rightminus1 + , law_Cancellative_rightminus2 + , defn_Cancellative_plusequal + , Monoid (..) + , isZero + , notZero + , law_Monoid_leftid + , law_Monoid_rightid + , defn_Monoid_isZero + , Abelian (..) + , law_Abelian_commutative + , Group (..) + , law_Group_leftinverse + , law_Group_rightinverse + , defn_Group_negateminus + + -- ** Classes with two operators + , Rg(..) + , law_Rg_multiplicativeAssociativity + , law_Rg_multiplicativeCommutivity + , law_Rg_annihilation + , law_Rg_distributivityLeft + , theorem_Rg_distributivityRight + , defn_Rg_timesequal + , Rig(..) + , isOne + , notOne + , law_Rig_multiplicativeId + , Rng + , defn_Ring_fromInteger + , Ring(..) + , indicator + , Integral(..) + , law_Integral_divMod + , law_Integral_quotRem + , law_Integral_toFromInverse + , fromIntegral + , Field(..) + , OrdField(..) + , RationalField(..) + , convertRationalField + , toFloat + , toDouble + , BoundedField(..) + , infinity + , negInfinity + , ExpRing (..) + , (^) + , ExpField (..) + , Real (..) + , QuotientField(..) + + -- ** Sizes + , Normed (..) + , abs + , Metric (..) + , isFartherThan + , lb2distanceUB + , law_Metric_nonnegativity + , law_Metric_indiscernables + , law_Metric_symmetry + , law_Metric_triangle + + -- ** Linear algebra + , Scalar + , IsScalar + , HasScalar + , type (><) + , Cone (..) + , Module (..) + , law_Module_multiplication + , law_Module_addition + , law_Module_action + , law_Module_unital + , defn_Module_dotstarequal + , (*.) + , FreeModule (..) + , law_FreeModule_commutative + , law_FreeModule_associative + , law_FreeModule_id + , defn_FreeModule_dotstardotequal + , FiniteModule (..) + , VectorSpace (..) + , Banach (..) + , Hilbert (..) + , innerProductDistance + , innerProductNorm + , TensorAlgebra (..) + + -- * Helper functions + , simpleMutableDefn + , module SubHask.Mutable + ) + where + +import qualified Prelude as P +import qualified Data.Number.Erf as P +import qualified Math.Gamma as P +import qualified Data.List as L + +import Prelude (Ordering (..)) +import Control.Monad hiding (liftM) +import Control.Monad.ST +import Data.Ratio +import Data.Typeable +import Test.QuickCheck (Arbitrary (..), frequency) + +import Control.Concurrent +import Control.Parallel +import Control.Parallel.Strategies +import System.IO.Unsafe -- used in the parallel function + +import GHC.Prim +import GHC.Types +import GHC.Magic + +import SubHask.Internal.Prelude +import SubHask.Category +import SubHask.Mutable +import SubHask.SubType + + +------------------------------------------------------------------------------- +-- Helper functions + +-- | Creates a quickcheck property for a simple mutable operator defined using "immutable2mutable" +simpleMutableDefn :: (Eq_ a, IsMutable a) + => (Mutable (ST s) a -> b -> ST s ()) -- ^ mutable function + -> (a -> b -> a) -- ^ create a mutable function using "immutable2mutable" + -> (a -> b -> Logic a) -- ^ the output property +simpleMutableDefn mf f a b = unsafeRunMutableProperty $ do + ma1 <- thaw a + ma2 <- thaw a + mf ma1 b + immutable2mutable f ma2 b + a1 <- freeze ma1 + a2 <- freeze ma2 + return $ a1==a2 + +------------------------------------------------------------------------------- +-- relational classes + +-- | Every type has an associated logic. +-- Most types use classical logic, which corresponds to the Bool type. +-- But types can use any logical system they want. +-- Functions, for example, use an infinite logic. +-- You probably want your logic to be an instance of "Boolean", but this is not required. +-- +-- See wikipedia's articles on , +-- and for more details. +type family Logic a :: * +type instance Logic Bool = Bool +type instance Logic Char = Bool +type instance Logic Int = Bool +type instance Logic Integer = Bool +type instance Logic Rational = Bool +type instance Logic Float = Bool +type instance Logic Double = Bool +type instance Logic (a->b) = a -> Logic b +type instance Logic () = () + +-- FIXME: +-- This type is only needed to due an apparent ghc bug. +-- See [#10592](https://ghc.haskell.org/trac/ghc/ticket/10592). +-- But there seems to be a workaround now. +type ValidLogic a = Complemented (Logic a) + +-- | Classical logic is implemented using the Prelude's Bool type. +type ClassicalLogic a = Logic a ~ Bool + +-- | Defines equivalence classes over the type. +-- The values need not have identical representations in the machine to be equal. +-- +-- See +-- and for more details. +class Eq_ a where + + infix 4 == + (==) :: a -> a -> Logic a + + -- | In order to have the "not equals to" relation, your logic must have a notion of "not", and therefore must be "Boolean". + {-# INLINE (/=) #-} + infix 4 /= + (/=) :: ValidLogic a => a -> a -> Logic a + (/=) = not (==) + +law_Eq_reflexive :: Eq a => a -> Logic a +law_Eq_reflexive a = a==a + +law_Eq_symmetric :: Eq a => a -> a -> Logic a +law_Eq_symmetric a1 a2 = (a1==a2)==(a2==a1) + +law_Eq_transitive :: Eq a => a -> a -> a -> Logic a +law_Eq_transitive a1 a2 a3 = (a1==a2&&a2==a3) ==> (a1==a3) + +defn_Eq_noteq :: (Complemented (Logic a), Eq a) => a -> a -> Logic a +defn_Eq_noteq a1 a2 = (a1/=a2) == (not $ a1==a2) + +instance Eq_ () where + {-# INLINE (==) #-} + () == () = () + + {-# INLINE (/=) #-} + () /= () = () + +instance Eq_ Bool where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} +instance Eq_ Char where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} +instance Eq_ Int where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} +instance Eq_ Integer where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} +instance Eq_ Rational where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} +instance Eq_ Float where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} +instance Eq_ Double where (==) = (P.==); (/=) = (P./=); {-# INLINE (==) #-}; {-# INLINE (/=) #-} + +instance Eq_ b => Eq_ (a -> b) where + {-# INLINE (==) #-} + (f==g) a = f a == g a + +type Eq a = (Eq_ a, Logic a~Bool) +type ValidEq a = (Eq_ a, ValidLogic a) + +-- class (Eq_ a, Logic a ~ Bool) => Eq a +-- instance (Eq_ a, Logic a ~ Bool) => Eq a +-- +-- class (Eq_ a, ValidLogic a) => ValidEq a +-- instance (Eq_ a, ValidLogic a) => ValidEq a + +-------------------- + +-- | This is more commonly known as a "meet" semilattice +class Eq_ b => POrd_ b where + inf :: b -> b -> b + + {-# INLINE (<=) #-} + infix 4 <= + (<=) :: b -> b -> Logic b + b1 <= b2 = inf b1 b2 == b1 + + {-# INLINE (<) #-} + infix 4 < + (<) :: Complemented (Logic b) => b -> b -> Logic b + b1 < b2 = inf b1 b2 == b1 && b1 /= b2 + +type POrd a = (Eq a, POrd_ a) +-- class (Eq b, POrd_ b) => POrd b +-- instance (Eq b, POrd_ b) => POrd b + +law_POrd_commutative :: (Eq b, POrd_ b) => b -> b -> Bool +law_POrd_commutative b1 b2 = inf b1 b2 == inf b2 b1 + +law_POrd_associative :: (Eq b, POrd_ b) => b -> b -> b -> Bool +law_POrd_associative b1 b2 b3 = inf (inf b1 b2) b3 == inf b1 (inf b2 b3) + +theorem_POrd_idempotent :: (Eq b, POrd_ b) => b -> Bool +theorem_POrd_idempotent b = inf b b == b + +#define mkPOrd_(x) \ +instance POrd_ x where \ + inf = (P.min) ;\ + (<=) = (P.<=) ;\ + (<) = (P.<) ;\ + {-# INLINE inf #-} ;\ + {-# INLINE (<=) #-} ;\ + {-# INLINE (<) #-} + +mkPOrd_(Bool) +mkPOrd_(Char) +mkPOrd_(Int) +mkPOrd_(Integer) +mkPOrd_(Float) +mkPOrd_(Double) +mkPOrd_(Rational) + +instance POrd_ () where + {-# INLINE inf #-} + inf () () = () + +instance POrd_ b => POrd_ (a -> b) where + {-# INLINE inf #-} + inf f g = \x -> inf (f x) (g x) + + {-# INLINE (<) #-} + (f<=g) a = f a <= g a + +------------------- + +-- | Most Lattice literature only considers 'Bounded' lattices, but here we have both upper and lower bounded lattices. +-- +-- prop> minBound <= b || not (minBound > b) +-- +class POrd_ b => MinBound_ b where + minBound :: b + +type MinBound a = (Eq a, MinBound_ a) +-- class (Eq b, MinBound_ b) => MinBound b +-- instance (Eq b, MinBound_ b) => MinBound b + +law_MinBound_inf :: (Eq b, MinBound_ b) => b -> Bool +law_MinBound_inf b = inf b minBound == minBound + +-- | "false" is an upper bound because `a && false = false` for all a. +{-# INLINE false #-} +false :: MinBound_ b => b +false = minBound + +instance MinBound_ () where minBound = () ; {-# INLINE minBound #-} +instance MinBound_ Bool where minBound = False ; {-# INLINE minBound #-} +instance MinBound_ Char where minBound = P.minBound ; {-# INLINE minBound #-} +instance MinBound_ Int where minBound = P.minBound ; {-# INLINE minBound #-} +instance MinBound_ Float where minBound = -1/0 ; {-# INLINE minBound #-} +instance MinBound_ Double where minBound = -1/0 ; {-# INLINE minBound #-} +-- FIXME: should be a primop for this + +instance MinBound_ b => MinBound_ (a -> b) where minBound = \x -> minBound ; {-# INLINE minBound #-} + +------------------- + +-- | Represents all the possible ordering relations in a classical logic (i.e. Logic a ~ Bool) +data POrdering + = PLT + | PGT + | PEQ + | PNA + deriving (Read,Show) + +type instance Logic POrdering = Bool + +instance Arbitrary POrdering where + arbitrary = frequency + [ (1, P.return PLT) + , (1, P.return PGT) + , (1, P.return PEQ) + , (1, P.return PNA) + ] + +instance Eq_ POrdering where + {-# INLINE (==) #-} + PLT == PLT = True + PGT == PGT = True + PEQ == PEQ = True + PNA == PNA = True + _ == _ = False + +-- | FIXME: there are many semigroups over POrdering; +-- how should we represent the others? newtypes? +instance Semigroup POrdering where + {-# INLINE (+) #-} + PEQ + x = x + PLT + _ = PLT + PGT + _ = PGT + PNA + _ = PNA + +type instance Logic Ordering = Bool + +instance Eq_ Ordering where + {-# INLINE (==) #-} + EQ == EQ = True + LT == LT = True + GT == GT = True + _ == _ = False + +instance Semigroup Ordering where + {-# INLINE (+) #-} + EQ + x = x + LT + _ = LT + GT + _ = GT + +instance Monoid POrdering where + {-# INLINE zero #-} + zero = PEQ + +instance Monoid Ordering where + {-# INLINE zero #-} + zero = EQ + + +-- | +-- +-- +-- See for more details. +class POrd_ b => Lattice_ b where + sup :: b -> b -> b + + {-# INLINE (>=) #-} + infix 4 >= + (>=) :: b -> b -> Logic b + b1 >= b2 = sup b1 b2 == b1 + + {-# INLINE (>) #-} + infix 4 > + (>) :: Boolean (Logic b) => b -> b -> Logic b + b1 > b2 = sup b1 b2 == b1 && b1 /= b2 + + -- | This function does not make sense on non-classical logics + -- + -- FIXME: there are probably related functions for all these other logics; + -- is there a nice way to represent them all? + {-# INLINABLE pcompare #-} + pcompare :: Logic b ~ Bool => b -> b -> POrdering + pcompare a b = if a==b + then PEQ + else if a < b + then PLT + else if a > b + then PGT + else PNA + +type Lattice a = (Eq a, Lattice_ a) +-- class (Eq b, Lattice_ b) => Lattice b +-- instance (Eq b, Lattice_ b) => Lattice b + +law_Lattice_commutative :: (Eq b, Lattice_ b) => b -> b -> Bool +law_Lattice_commutative b1 b2 = sup b1 b2 == sup b2 b1 + +law_Lattice_associative :: (Eq b, Lattice_ b) => b -> b -> b -> Bool +law_Lattice_associative b1 b2 b3 = sup (sup b1 b2) b3 == sup b1 (sup b2 b3) + +theorem_Lattice_idempotent :: (Eq b, Lattice_ b) => b -> Bool +theorem_Lattice_idempotent b = sup b b == b + +law_Lattice_infabsorption :: (Eq b, Lattice b) => b -> b -> Bool +law_Lattice_infabsorption b1 b2 = inf b1 (sup b1 b2) == b1 + +law_Lattice_supabsorption :: (Eq b, Lattice b) => b -> b -> Bool +law_Lattice_supabsorption b1 b2 = sup b1 (inf b1 b2) == b1 + +law_Lattice_reflexivity :: Lattice a => a -> Logic a +law_Lattice_reflexivity a = a<=a + +law_Lattice_antisymmetry :: Lattice a => a -> a -> Logic a +law_Lattice_antisymmetry a1 a2 + | a1 <= a2 && a2 <= a1 = a1 == a2 + | otherwise = true + +law_Lattice_transitivity :: Lattice a => a -> a -> a -> Logic a +law_Lattice_transitivity a1 a2 a3 + | a1 <= a2 && a2 <= a3 = a1 <= a3 + | a1 <= a3 && a3 <= a2 = a1 <= a2 + | a2 <= a1 && a1 <= a3 = a2 <= a3 + | a2 <= a3 && a3 <= a1 = a2 <= a1 + | a3 <= a2 && a2 <= a1 = a3 <= a1 + | a3 <= a1 && a1 <= a2 = a3 <= a2 + | otherwise = true + +defn_Lattice_greaterthan :: Lattice a => a -> a -> Logic a +defn_Lattice_greaterthan a1 a2 + | a1 < a2 = a2 >= a1 + | a1 > a2 = a2 <= a1 + | otherwise = true + +#define mkLattice_(x)\ +instance Lattice_ x where \ + sup = (P.max) ;\ + (>=) = (P.>=) ;\ + (>) = (P.>) ;\ + {-# INLINE sup #-} ;\ + {-# INLINE (>=) #-} ;\ + {-# INLINE (>) #-} + +mkLattice_(Bool) +mkLattice_(Char) +mkLattice_(Int) +mkLattice_(Integer) +mkLattice_(Float) +mkLattice_(Double) +mkLattice_(Rational) + +instance Lattice_ () where + {-# INLINE sup #-} + sup () () = () + +instance Lattice_ b => Lattice_ (a -> b) where + {-# INLINE sup #-} + sup f g = \x -> sup (f x) (g x) + + {-# INLINE (>=) #-} + (f>=g) a = f a >= g a + +{-# INLINE (&&) #-} +infixr 3 && +(&&) :: Lattice_ b => b -> b -> b +(&&) = inf + +{-# INLINE (||) #-} +infixr 2 || +(||) :: Lattice_ b => b -> b -> b +(||) = sup + +-- | A chain is a collection of elements all of which can be compared +{-# INLINABLE isChain #-} +isChain :: Lattice a => [a] -> Logic a +isChain [] = true +isChain (x:xs) = all (/=PNA) (map (pcompare x) xs) && isChain xs + +-- | An antichain is a collection of elements none of which can be compared +-- +-- See for more details. +-- +-- See also the article on . +{-# INLINABLE isAntichain #-} +isAntichain :: Lattice a => [a] -> Logic a +isAntichain [] = true +isAntichain (x:xs) = all (==PNA) (map (pcompare x) xs) && isAntichain xs + +------------------- + +-- | In a WellFounded type, every element (except the 'maxBound" if it exists) has a successor element +-- +-- See for more info. +class (Graded b, Ord_ b) => Enum b where + succ :: b -> b + + toEnum :: Int -> b + +law_Enum_succ :: Enum b => b -> b -> Bool +law_Enum_succ b1 b2 = fromEnum (succ b1) == fromEnum b1+1 + || fromEnum (succ b1) == fromEnum b1 + +law_Enum_toEnum :: (Lattice b, Enum b) => b -> Bool +law_Enum_toEnum b = toEnum (fromEnum b) == b + +instance Enum Bool where + {-# INLINE succ #-} + succ True = True + succ False = True + + {-# INLINE toEnum #-} + toEnum 1 = True + toEnum 0 = False + +instance Enum Int where + {-# INLINE succ #-} + succ i = if i == maxBound + then i + else i+1 + + {-# INLINE toEnum #-} + toEnum = id + +instance Enum Char where + {-# INLINE succ #-} + succ = P.succ + + {-# INLINE toEnum #-} + toEnum i = if i < 0 + then P.toEnum 0 + else P.toEnum i + +instance Enum Integer where + {-# INLINE succ #-} + succ = P.succ + + {-# INLINE toEnum #-} + toEnum = P.toEnum + +-- | An element of a graded poset has a unique predecessor. +-- +-- See for more details. +class Lattice b => Graded b where + -- | the predecessor in the ordering + pred :: b -> b + + -- | Algebrists typically call this function the "rank" of the element in the poset; + -- however we use the name from the standard prelude instead + fromEnum :: b -> Int + +law_Graded_pred :: Graded b => b -> b -> Bool +law_Graded_pred b1 b2 = fromEnum (pred b1) == fromEnum b1-1 + || fromEnum (pred b1) == fromEnum b1 + +law_Graded_fromEnum :: (Lattice b, Graded b) => b -> b -> Bool +law_Graded_fromEnum b1 b2 + | b1 < b2 = fromEnum b1 < fromEnum b2 + | b1 > b2 = fromEnum b1 > fromEnum b2 + | b1 == b2 = fromEnum b1 == fromEnum b2 + | otherwise = True + +instance Graded Bool where + {-# INLINE pred #-} + pred True = False + pred False = False + + {-# INLINE fromEnum #-} + fromEnum True = 1 + fromEnum False = 0 + +instance Graded Int where + {-# INLINE pred #-} + pred i = if i == minBound + then i + else i-1 + + {-# INLINE fromEnum #-} + fromEnum = id + +instance Graded Char where + {-# INLINE pred #-} + pred c = if c=='\NUL' + then '\NUL' + else P.pred c + + {-# INLINE fromEnum #-} + fromEnum = P.fromEnum + +instance Graded Integer where + {-# INLINE pred #-} + pred = P.pred + + {-# INLINE fromEnum #-} + fromEnum = P.fromEnum + +{-# INLINE (<.) #-} +(<.) :: (Lattice b, Graded b) => b -> b -> Bool +b1 <. b2 = b1 == pred b2 + +{-# INLINE (>.) #-} +(>.) :: (Lattice b, Enum b) => b -> b -> Bool +b1 >. b2 = b1 == succ b2 + +--------------------------------------- + +-- | This is the class of total orderings. +-- +-- See https://en.wikipedia.org/wiki/Total_order +class Lattice_ a => Ord_ a where + compare :: (Logic a~Bool, Ord_ a) => a -> a -> Ordering + compare a1 a2 = case pcompare a1 a2 of + PLT -> LT + PGT -> GT + PEQ -> EQ + PNA -> error "PNA given by pcompare on a totally ordered type" + +law_Ord_totality :: Ord a => a -> a -> Bool +law_Ord_totality a1 a2 = a1 <= a2 || a2 <= a1 + +law_Ord_min :: Ord a => a -> a -> Bool +law_Ord_min a1 a2 = min a1 a2 == a1 + || min a1 a2 == a2 + +law_Ord_max :: Ord a => a -> a -> Bool +law_Ord_max a1 a2 = max a1 a2 == a1 + || max a1 a2 == a2 + +{-# INLINE min #-} +min :: Ord_ a => a -> a -> a +min = inf + +{-# INLINE max #-} +max :: Ord_ a => a -> a -> a +max = sup + +type Ord a = (Eq a, Ord_ a) + +instance Ord_ () +instance Ord_ Char where compare = P.compare ; {-# INLINE compare #-} +instance Ord_ Int where compare = P.compare ; {-# INLINE compare #-} +instance Ord_ Integer where compare = P.compare ; {-# INLINE compare #-} +instance Ord_ Float where compare = P.compare ; {-# INLINE compare #-} +instance Ord_ Double where compare = P.compare ; {-# INLINE compare #-} +instance Ord_ Rational where compare = P.compare ; {-# INLINE compare #-} +instance Ord_ Bool where compare = P.compare ; {-# INLINE compare #-} + +------------------- + +-- | A Bounded lattice is a lattice with both a minimum and maximum element +-- +class (Lattice_ b, MinBound_ b) => Bounded b where + maxBound :: b + +law_Bounded_sup :: (Eq b, Bounded b) => b -> Bool +law_Bounded_sup b = sup b maxBound == maxBound + +-- | "true" is an lower bound because `a && true = true` for all a. +{-# INLINE true #-} +true :: Bounded b => b +true = maxBound + +instance Bounded () where maxBound = () ; {-# INLINE maxBound #-} +instance Bounded Bool where maxBound = True ; {-# INLINE maxBound #-} +instance Bounded Char where maxBound = P.maxBound ; {-# INLINE maxBound #-} +instance Bounded Int where maxBound = P.maxBound ; {-# INLINE maxBound #-} +instance Bounded Float where maxBound = 1/0 ; {-# INLINE maxBound #-} +instance Bounded Double where maxBound = 1/0 ; {-# INLINE maxBound #-} +-- FIXME: should be a primop for infinity + +instance Bounded b => Bounded (a -> b) where + {-# INLINE maxBound #-} + maxBound = \x -> maxBound + +-------------------- + +class Bounded b => Complemented b where + not :: b -> b + +law_Complemented_not :: (ValidLogic b, Complemented b) => b -> Logic b +law_Complemented_not b = not (true `asTypeOf` b) == false + && not (false `asTypeOf` b) == true + +instance Complemented () where + {-# INLINE not #-} + not () = () + +instance Complemented Bool where + {-# INLINE not #-} + not = P.not + +instance Complemented b => Complemented (a -> b) where + {-# INLINE not #-} + not f = \x -> not $ f x + +-- | Heyting algebras are lattices that support implication, but not necessarily the law of excluded middle. +-- +-- FIXME: +-- Is every Heyting algebra a cancellative Abelian semigroup? +-- If so, should we make that explicit in the class hierarchy? +-- +-- ==== Laws +-- There is a single, simple law that Heyting algebras must satisfy: +-- +-- prop> a ==> b = c ===> a && c < b +-- +-- ==== Theorems +-- From the laws, we automatically get the properties of: +-- +-- distributivity +-- +-- See for more details. +class Bounded b => Heyting b where + -- | FIXME: think carefully about infix + infixl 3 ==> + (==>) :: b -> b -> b + +law_Heyting_maxbound :: (Eq b, Heyting b) => b -> Bool +law_Heyting_maxbound b = (b ==> b) == maxBound + +law_Heyting_infleft :: (Eq b, Heyting b) => b -> b -> Bool +law_Heyting_infleft b1 b2 = (b1 && (b1 ==> b2)) == (b1 && b2) + +law_Heyting_infright :: (Eq b, Heyting b) => b -> b -> Bool +law_Heyting_infright b1 b2 = (b2 && (b1 ==> b2)) == b2 + +law_Heyting_distributive :: (Eq b, Heyting b) => b -> b -> b -> Bool +law_Heyting_distributive b1 b2 b3 = (b1 ==> (b2 && b3)) == ((b1 ==> b2) && (b1 ==> b3)) + +-- | FIXME: add the axioms for intuitionist logic, which are theorems based on these laws +-- + +-- | Modus ponens gives us a default definition for "==>" in a "Boolean" algebra. +-- This formula is guaranteed to not work in a "Heyting" algebra that is not "Boolean". +-- +-- See for more details. +modusPonens :: Boolean b => b -> b -> b +modusPonens b1 b2 = not b1 || b2 + +instance Heyting () where + {-# INLINE (==>) #-} + () ==> () = () + +instance Heyting Bool where + {-# INLINE (==>) #-} + (==>) = modusPonens + +instance Heyting b => Heyting (a -> b) where + {-# INLINE (==>) #-} + (f==>g) a = f a ==> g a + +-- | Generalizes Boolean variables. +-- +-- See for more details. +class (Complemented b, Heyting b) => Boolean b where + +law_Boolean_infcomplement :: (Eq b, Boolean b) => b -> Bool +law_Boolean_infcomplement b = (b || not b) == true + +law_Boolean_supcomplement :: (Eq b, Boolean b) => b -> Bool +law_Boolean_supcomplement b = (b && not b) == false + +law_Boolean_infdistributivity :: (Eq b, Boolean b) => b -> b -> b -> Bool +law_Boolean_infdistributivity b1 b2 b3 = (b1 || (b2 && b3)) == ((b1 || b2) && (b1 || b3)) + +law_Boolean_supdistributivity :: (Eq b, Boolean b) => b -> b -> b -> Bool +law_Boolean_supdistributivity b1 b2 b3 = (b1 && (b2 || b3)) == ((b1 && b2) || (b1 && b3)) + +instance Boolean () +instance Boolean Bool +instance Boolean b => Boolean (a -> b) + +------------------------------------------------------------------------------- +-- numeric classes + +class IsMutable g => Semigroup g where + {-# MINIMAL (+) | (+=) #-} + + {-# INLINE (+) #-} + infixl 6 + + (+) :: g -> g -> g + (+) = mutable2immutable (+=) + + {-# INLINE (+=) #-} + infixr 5 += + (+=) :: (PrimBase m) => Mutable m g -> g -> m () + (+=) = immutable2mutable (+) + +law_Semigroup_associativity :: (Eq g, Semigroup g ) => g -> g -> g -> Logic g +law_Semigroup_associativity g1 g2 g3 = g1 + (g2 + g3) == (g1 + g2) + g3 + +defn_Semigroup_plusequal :: (Eq_ g, Semigroup g, IsMutable g) => g -> g -> Logic g +defn_Semigroup_plusequal = simpleMutableDefn (+=) (+) + +-- | Measures the degree to which a Semigroup obeys the associative law. +-- +-- FIXME: Less-than-perfect associativity should be formalized in the class laws somehow. +associator :: (Semigroup g, Metric g) => g -> g -> g -> Scalar g +associator g1 g2 g3 = distance ((g1+g2)+g3) (g1+(g2+g3)) + +-- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. +-- May fail to terminate for some values in some semigroups. +cycle :: Semigroup m => m -> m +cycle xs = xs' where xs' = xs + xs' + +instance Semigroup Int where (+) = (P.+) ; {-# INLINE (+) #-} +instance Semigroup Integer where (+) = (P.+) ; {-# INLINE (+) #-} +instance Semigroup Float where (+) = (P.+) ; {-# INLINE (+) #-} +instance Semigroup Double where (+) = (P.+) ; {-# INLINE (+) #-} +instance Semigroup Rational where (+) = (P.+) ; {-# INLINE (+) #-} + +instance Semigroup () where + {-# INLINE (+) #-} + ()+() = () + +instance Semigroup b => Semigroup (a -> b) where + {-# INLINE (+) #-} + f+g = \a -> f a + g a + +--------------------------------------- + +-- | This type class is only used by the "Action" class. +-- It represents the semigroup that acts on our type. +type family Actor s + +-- | Semigroup actions let us apply a semigroup to a set. +-- The theory of Modules is essentially the theory of Ring actions. +-- (See for more detail. +-- +-- FIXME: These types could probably use a more expressive name. +-- +-- FIXME: We would like every Semigroup to act on itself, but this results in a class cycle. +class (IsMutable s, Semigroup (Actor s)) => Action s where + {-# MINIMAL (.+) | (.+=) #-} + + {-# INLINE (.+) #-} + infixl 6 .+ + (.+) :: s -> Actor s -> s + (.+) = mutable2immutable (.+=) + + {-# INLINE (.+=) #-} + infixr 5 .+= + (.+=) :: (PrimBase m) => Mutable m s -> Actor s -> m () + (.+=) = immutable2mutable (.+) + +law_Action_compatibility :: (Eq_ s, Action s) => Actor s -> Actor s -> s -> Logic s +law_Action_compatibility a1 a2 s = (a1+a2) +. s == a1 +. a2 +. s + +defn_Action_dotplusequal :: (Eq_ s, Action s, Logic (Actor s)~Logic s) => s -> Actor s -> Logic s +defn_Action_dotplusequal = simpleMutableDefn (.+=) (.+) + +-- | > s .+ a = a +. s +{-# INLINE (+.) #-} +infixr 6 +. +(+.) :: Action s => Actor s -> s -> s +a +. s = s .+ a + +type instance Actor Int = Int +type instance Actor Integer = Integer +type instance Actor Float = Float +type instance Actor Double = Double +type instance Actor Rational = Rational +type instance Actor () = () +type instance Actor (a->b) = a->Actor b + +instance Action Int where (.+) = (+) ; {-# INLINE (.+) #-} +instance Action Integer where (.+) = (+) ; {-# INLINE (.+) #-} +instance Action Float where (.+) = (+) ; {-# INLINE (.+) #-} +instance Action Double where (.+) = (+) ; {-# INLINE (.+) #-} +instance Action Rational where (.+) = (+) ; {-# INLINE (.+) #-} +instance Action () where (.+) = (+) ; {-# INLINE (.+) #-} + +instance Action b => Action (a->b) where + {-# INLINE (.+) #-} + f.+g = \x -> f x.+g x + +--------------------------------------- + +class Semigroup g => Monoid g where + zero :: g + +-- | FIXME: this should be in the Monoid class, but putting it there requires a lot of changes to Eq +isZero :: (Monoid g, ValidEq g) => g -> Logic g +isZero = (==zero) + +-- | FIXME: this should be in the Monoid class, but putting it there requires a lot of changes to Eq +notZero :: (Monoid g, ValidEq g) => g -> Logic g +notZero = (/=zero) + +law_Monoid_leftid :: (Monoid g, Eq g) => g -> Bool +law_Monoid_leftid g = zero + g == g + +law_Monoid_rightid :: (Monoid g, Eq g) => g -> Bool +law_Monoid_rightid g = g + zero == g + +defn_Monoid_isZero :: (Monoid g, Eq g) => g -> Bool +defn_Monoid_isZero g = (isZero $ zero `asTypeOf` g) + && (g /= zero ==> not isZero g) + +--------- + +instance Monoid Int where zero = 0 ; {-# INLINE zero #-} +instance Monoid Integer where zero = 0 ; {-# INLINE zero #-} +instance Monoid Float where zero = 0 ; {-# INLINE zero #-} +instance Monoid Double where zero = 0 ; {-# INLINE zero #-} +instance Monoid Rational where zero = 0 ; {-# INLINE zero #-} + +instance Monoid () where + {-# INLINE zero #-} + zero = () + +instance Monoid b => Monoid (a -> b) where + {-# INLINE zero #-} + zero = \a -> zero + +--------------------------------------- + +-- | In a cancellative semigroup, +-- +-- 1) +-- +-- > a + b = a + c ==> b = c +-- so +-- > (a + b) - b = a + (b - b) = a +-- +-- 2) +-- +-- > b + a = c + a ==> b = c +-- so +-- > -b + (b + a) = (-b + b) + a = a +-- +-- This allows us to define "subtraction" in the semigroup. +-- If the semigroup is embeddable in a group, subtraction can be thought of as performing the group subtraction and projecting the result back into the domain of the cancellative semigroup. +-- It is an open problem to fully characterize which cancellative semigroups can be embedded into groups. +-- +-- See for more details. +class Semigroup g => Cancellative g where + {-# MINIMAL (-) | (-=) #-} + + {-# INLINE (-) #-} + infixl 6 - + (-) :: g -> g -> g + (-) = mutable2immutable (-=) + + {-# INLINE (-=) #-} + infixr 5 -= + (-=) :: (PrimBase m) => Mutable m g -> g -> m () + (-=) = immutable2mutable (-) + + +law_Cancellative_rightminus1 :: (Eq g, Cancellative g) => g -> g -> Bool +law_Cancellative_rightminus1 g1 g2 = (g1 + g2) - g2 == g1 + +law_Cancellative_rightminus2 :: (Eq g, Cancellative g) => g -> g -> Bool +law_Cancellative_rightminus2 g1 g2 = g1 + (g2 - g2) == g1 + +defn_Cancellative_plusequal :: (Eq_ g, Cancellative g) => g -> g -> Logic g +defn_Cancellative_plusequal = simpleMutableDefn (-=) (-) + +instance Cancellative Int where (-) = (P.-) ; {-# INLINE (-) #-} +instance Cancellative Integer where (-) = (P.-) ; {-# INLINE (-) #-} +instance Cancellative Float where (-) = (P.-) ; {-# INLINE (-) #-} +instance Cancellative Double where (-) = (P.-) ; {-# INLINE (-) #-} +instance Cancellative Rational where (-) = (P.-) ; {-# INLINE (-) #-} + +instance Cancellative () where + {-# INLINE (-) #-} + ()-() = () + +instance Cancellative b => Cancellative (a -> b) where + {-# INLINE (-) #-} + f-g = \a -> f a - g a + +--------------------------------------- + +class (Cancellative g, Monoid g) => Group g where + {-# INLINE negate #-} + negate :: g -> g + negate g = zero - g + +defn_Group_negateminus :: (Eq g, Group g) => g -> g -> Bool +defn_Group_negateminus g1 g2 = g1 + negate g2 == g1 - g2 + +law_Group_leftinverse :: (Eq g, Group g) => g -> Bool +law_Group_leftinverse g = negate g + g == zero + +law_Group_rightinverse :: (Eq g, Group g) => g -> Bool +law_Group_rightinverse g = g + negate g == zero + +instance Group Int where negate = P.negate ; {-# INLINE negate #-} +instance Group Integer where negate = P.negate ; {-# INLINE negate #-} +instance Group Float where negate = P.negate ; {-# INLINE negate #-} +instance Group Double where negate = P.negate ; {-# INLINE negate #-} +instance Group Rational where negate = P.negate ; {-# INLINE negate #-} + +instance Group () where + {-# INLINE negate #-} + negate () = () + +instance Group b => Group (a -> b) where + {-# INLINE negate #-} + negate f = negate . f + +--------------------------------------- + +class Semigroup m => Abelian m + +law_Abelian_commutative :: (Abelian g, Eq g) => g -> g -> Bool +law_Abelian_commutative g1 g2 = g1 + g2 == g2 + g1 + +instance Abelian Int +instance Abelian Integer +instance Abelian Float +instance Abelian Double +instance Abelian Rational + +instance Abelian () + +instance Abelian b => Abelian (a -> b) + +--------------------------------------- + +-- | A Rg is a Ring without multiplicative identity or negative numbers. +-- (Hence the removal of the i and n from the name.) +-- +-- There is no standard terminology for this structure. +-- They might also be called \"semirings without identity\", \"pre-semirings\", or \"hemirings\". +-- See for a discussion on naming. +-- +class (Abelian r, Monoid r) => Rg r where + {-# MINIMAL (*) | (*=) #-} + + {-# INLINE (*) #-} + infixl 7 * + (*) :: r -> r -> r + (*) = mutable2immutable (*=) + + {-# INLINE (*=) #-} + infixr 5 *= + (*=) :: (PrimBase m) => Mutable m r -> r -> m () + (*=) = immutable2mutable (*) + +law_Rg_multiplicativeAssociativity :: (Eq r, Rg r) => r -> r -> r -> Bool +law_Rg_multiplicativeAssociativity r1 r2 r3 = (r1 * r2) * r3 == r1 * (r2 * r3) + +law_Rg_multiplicativeCommutivity :: (Eq r, Rg r) => r -> r -> Bool +law_Rg_multiplicativeCommutivity r1 r2 = r1*r2 == r2*r1 + +law_Rg_annihilation :: (Eq r, Rg r) => r -> Bool +law_Rg_annihilation r = r * zero == zero + +law_Rg_distributivityLeft :: (Eq r, Rg r) => r -> r -> r -> Bool +law_Rg_distributivityLeft r1 r2 r3 = r1*(r2+r3) == r1*r2+r1*r3 + +theorem_Rg_distributivityRight :: (Eq r, Rg r) => r -> r -> r -> Bool +theorem_Rg_distributivityRight r1 r2 r3 = (r2+r3)*r1 == r2*r1+r3*r1 + +defn_Rg_timesequal :: (Eq_ g, Rg g) => g -> g -> Logic g +defn_Rg_timesequal = simpleMutableDefn (*=) (*) + +instance Rg Int where (*) = (P.*) ; {-# INLINE (*) #-} +instance Rg Integer where (*) = (P.*) ; {-# INLINE (*) #-} +instance Rg Float where (*) = (P.*) ; {-# INLINE (*) #-} +instance Rg Double where (*) = (P.*) ; {-# INLINE (*) #-} +instance Rg Rational where (*) = (P.*) ; {-# INLINE (*) #-} + +instance Rg b => Rg (a -> b) where + {-# INLINE (*) #-} + f*g = \a -> f a * g a + +--------------------------------------- + +-- | A Rig is a Rg with multiplicative identity. +-- They are also known as semirings. +-- +-- See +-- and +-- for more details. +class (Monoid r, Rg r) => Rig r where + -- | the multiplicative identity + one :: r + +-- | FIXME: this should be in the Rig class, but putting it there requires a lot of changes to Eq +isOne :: (Rig g, ValidEq g) => g -> Logic g +isOne = (==one) + +-- | FIXME: this should be in the Rig class, but putting it there requires a lot of changes to Eq +notOne :: (Rig g, ValidEq g) => g -> Logic g +notOne = (/=one) + +law_Rig_multiplicativeId :: (Eq r, Rig r) => r -> Bool +law_Rig_multiplicativeId r = r * one == r && one * r == r + +instance Rig Int where one = 1 ; {-# INLINE one #-} +instance Rig Integer where one = 1 ; {-# INLINE one #-} +instance Rig Float where one = 1 ; {-# INLINE one #-} +instance Rig Double where one = 1 ; {-# INLINE one #-} +instance Rig Rational where one = 1 ; {-# INLINE one #-} + +instance Rig b => Rig (a -> b) where + {-# INLINE one #-} + one = \a -> one + +--------------------------------------- + +-- | A "Ring" without identity. +type Rng r = (Rg r, Group r) + +-- | +-- +-- It is not part of the standard definition of rings that they have a "fromInteger" function. +-- It follows from the definition, however, that we can construct such a function. +-- The "slowFromInteger" function is this standard construction. +-- +-- See +-- and +-- for more details. +-- +-- FIXME: +-- We can construct a "Module" from any ring by taking (*)=(.*.). +-- Thus, "Module" should be a superclass of "Ring". +-- Currently, however, this creates a class cycle, so we can't do it. +-- A number of type signatures are therefore more complicated than they need to be. +class (Rng r, Rig r) => Ring r where + fromInteger :: Integer -> r + fromInteger = slowFromInteger + +defn_Ring_fromInteger :: (Eq r, Ring r) => r -> Integer -> Bool +defn_Ring_fromInteger r i = fromInteger i `asTypeOf` r + == slowFromInteger i + +-- | Here we construct an element of the Ring based on the additive and multiplicative identities. +-- This function takes O(n) time, where n is the size of the Integer. +-- Most types should be able to compute this value significantly faster. +-- +-- FIXME: replace this with peasant multiplication. +slowFromInteger :: forall r. (Rng r, Rig r) => Integer -> r +slowFromInteger i = if i>0 + then foldl' (+) zero $ P.map (const (one::r)) [1.. i] + else negate $ foldl' (+) zero $ P.map (const (one::r)) [1.. negate i] + +instance Ring Int where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-} +instance Ring Integer where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-} +instance Ring Float where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-} +instance Ring Double where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-} +instance Ring Rational where fromInteger = P.fromInteger ; {-# INLINE fromInteger #-} + +instance Ring b => Ring (a -> b) where + {-# INLINE fromInteger #-} + fromInteger i = \a -> fromInteger i + +{-# INLINABLE indicator #-} +indicator :: Ring r => Bool -> r +indicator True = 1 +indicator False = 0 + +--------------------------------------- + +-- | 'Integral' numbers can be formed from a wide class of things that behave +-- like integers, but intuitively look nothing like integers. +-- +-- FIXME: All Fields are integral domains; should we make it a subclass? This wouuld have the (minor?) problem of making the Integral class have to be an approximate embedding. +-- FIXME: Not all integral domains are homomorphic to the integers (e.g. a field) +-- +-- See wikipedia on , +-- , +-- and the . +class Ring a => Integral a where + toInteger :: a -> Integer + + infixl 7 `quot`, `rem` + + -- | truncates towards zero + {-# INLINE quot #-} + quot :: a -> a -> a + quot a1 a2 = fst (quotRem a1 a2) + + {-# INLINE rem #-} + rem :: a -> a -> a + rem a1 a2 = snd (quotRem a1 a2) + + quotRem :: a -> a -> (a,a) + + + infixl 7 `div`, `mod` + + -- | truncates towards negative infinity + {-# INLINE div #-} + div :: a -> a -> a + div a1 a2 = fst (divMod a1 a2) + + {-# INLINE mod #-} + mod :: a -> a -> a + mod a1 a2 = snd (divMod a1 a2) + + divMod :: a -> a -> (a,a) + + +law_Integral_divMod :: (Eq a, Integral a) => a -> a -> Bool +law_Integral_divMod a1 a2 = if a2 /= 0 + then a2 * (a1 `div` a2) + (a1 `mod` a2) == a1 + else True + +law_Integral_quotRem :: (Eq a, Integral a) => a -> a -> Bool +law_Integral_quotRem a1 a2 = if a2 /= 0 + then a2 * (a1 `quot` a2) + (a1 `rem` a2) == a1 + else True + +law_Integral_toFromInverse :: (Eq a, Integral a) => a -> Bool +law_Integral_toFromInverse a = fromInteger (toInteger a) == a + +{-# INLINE[1] fromIntegral #-} +fromIntegral :: (Integral a, Ring b) => a -> b +fromIntegral = fromInteger . toInteger + +-- FIXME: +-- need more RULES; need tests +{-# RULES +"subhask/fromIntegral/Int->Int" fromIntegral = id :: Int -> Int + #-} + +instance Integral Int where + {-# INLINE div #-} + {-# INLINE mod #-} + {-# INLINE divMod #-} + {-# INLINE quot #-} + {-# INLINE rem #-} + {-# INLINE quotRem #-} + {-# INLINE toInteger #-} + div = P.div + mod = P.mod + divMod = P.divMod + quot = P.quot + rem = P.rem + quotRem = P.quotRem + toInteger = P.toInteger + +instance Integral Integer where + {-# INLINE div #-} + {-# INLINE mod #-} + {-# INLINE divMod #-} + {-# INLINE quot #-} + {-# INLINE rem #-} + {-# INLINE quotRem #-} + {-# INLINE toInteger #-} + div = P.div + mod = P.mod + divMod = P.divMod + quot = P.quot + rem = P.rem + quotRem = P.quotRem + toInteger = P.toInteger + +instance Integral b => Integral (a -> b) where + {-# INLINE div #-} + {-# INLINE mod #-} + {-# INLINE divMod #-} + {-# INLINE quot #-} + {-# INLINE rem #-} + {-# INLINE quotRem #-} + {-# INLINE toInteger #-} + quot f1 f2 = \a -> quot (f1 a) (f2 a) + rem f1 f2 = \a -> rem (f1 a) (f2 a) + quotRem f1 f2 = (quot f1 f2, rem f1 f2) + + div f1 f2 = \a -> div (f1 a) (f2 a) + mod f1 f2 = \a -> mod (f1 a) (f2 a) + divMod f1 f2 = (div f1 f2, mod f1 f2) + + -- FIXME + toInteger = error "toInteger shouldn't be in the integral class b/c of bad function instance" + +--------------------------------------- + +-- | Fields are Rings with a multiplicative inverse. +-- +-- See +-- and +-- for more details. +class Ring r => Field r where + {-# INLINE reciprocal #-} + reciprocal :: r -> r + reciprocal r = one/r + + {-# INLINE (/) #-} + infixl 7 / + (/) :: r -> r -> r + n/d = n * reciprocal d + +-- infixr 5 /= +-- (/=) :: (PrimBase m) => Mutable m g -> g -> m () +-- (/=) = immutable2mutable (/) + + {-# INLINE fromRational #-} + fromRational :: Rational -> r + fromRational r = fromInteger (numerator r) / fromInteger (denominator r) + +#define mkField(x) \ +instance Field x where \ + (/) = (P./) ;\ + fromRational=P.fromRational ;\ + {-# INLINE fromRational #-} ;\ + {-# INLINE (/) #-} + +mkField(Float) +mkField(Double) +mkField(Rational) + +instance Field b => Field (a -> b) where + {-# INLINE fromRational #-} + reciprocal f = reciprocal . f + +---------------------------------------- + +-- | Ordered fields are generalizations of the rational numbers that maintain most of the nice properties. +-- In particular, all finite fields and the complex numbers are NOT ordered fields. +-- +-- See for more details. +class (Field r, Ord r, Normed r, IsScalar r) => OrdField r + +instance OrdField Float +instance OrdField Double +instance OrdField Rational + +--------------------------------------- + +-- | The prototypical example of a bounded field is the extended real numbers. +-- Other examples are the extended hyperreal numbers and the extended rationals. +-- Each of these fields has been extensively studied, but I don't know of any studies of this particular abstraction of these fields. +-- +-- See for more details. +class (OrdField r, Bounded r) => BoundedField r where + {-# INLINE nan #-} + nan :: r + nan = 0/0 + + isNaN :: r -> Bool + +{-# INLINE infinity #-} +infinity :: BoundedField r => r +infinity = maxBound + +{-# INLINE negInfinity #-} +negInfinity :: BoundedField r => r +negInfinity = minBound + +instance BoundedField Float where isNaN = P.isNaN ; {-# INLINE isNaN #-} +instance BoundedField Double where isNaN = P.isNaN ; {-# INLINE isNaN #-} + +---------------------------------------- + +-- | A Rational field is a field with only a single dimension. +-- +-- FIXME: this isn't part of standard math; why is it here? +class Field r => RationalField r where + toRational :: r -> Rational + +instance RationalField Float where toRational=P.toRational ; {-# INLINE toRational #-} +instance RationalField Double where toRational=P.toRational ; {-# INLINE toRational #-} +instance RationalField Rational where toRational=P.toRational ; {-# INLINE toRational #-} + +{-# INLINE convertRationalField #-} +convertRationalField :: (RationalField a, RationalField b) => a -> b +convertRationalField = fromRational . toRational + +-- | +-- +-- FIXME: +-- These functions don't work for Int's, but they should +toFloat :: RationalField a => a -> Float +toFloat = convertRationalField + +toDouble :: RationalField a => a -> Double +toDouble = convertRationalField + +--------------------------------------- + +-- | A 'QuotientField' is a field with an 'IntegralDomain' as a subring. +-- There may be many such subrings (for example, every field has itself as an integral domain subring). +-- This is especially true in Haskell because we have different data types that represent essentially the same ring (e.g. "Int" and "Integer"). +-- Therefore this is a multiparameter type class. +-- The 'r' parameter represents the quotient field, and the 's' parameter represents the subring. +-- The main purpose of this class is to provide functions that map elements in 'r' to elements in 's' in various ways. +-- +-- FIXME: Need examples. Is there a better representation? +-- +-- See for more details. +-- +class (Ring r, Integral s) => QuotientField r s where + truncate :: r -> s + round :: r -> s + ceiling :: r -> s + floor :: r -> s + + (^^) :: r -> s -> r + +#define mkQuotientField(r,s) \ +instance QuotientField r s where \ + truncate = P.truncate; \ + round = P.round; \ + ceiling = P.ceiling; \ + floor = P.floor; \ + (^^) = (P.^^); \ + {-# INLINE truncate #-} ;\ + {-# INLINE round #-} ;\ + {-# INLINE ceiling #-} ;\ + {-# INLINE floor #-} ;\ + {-# INLINE (^^) #-} ;\ + +mkQuotientField(Float,Int) +mkQuotientField(Float,Integer) +mkQuotientField(Double,Int) +mkQuotientField(Double,Integer) +mkQuotientField(Rational,Int) +mkQuotientField(Rational,Integer) + +-- mkQuotientField(Integer,Integer) +-- mkQuotientField(Int,Int) + +instance QuotientField b1 b2 => QuotientField (a -> b1) (a -> b2) where + truncate f = \a -> truncate $ f a + round f = \a -> round $ f a + ceiling f = \a -> ceiling $ f a + floor f = \a -> floor $ f a + (^^) f1 f2 = \a -> (^^) (f1 a) (f2 a) + +--------------------------------------- + +-- | Rings augmented with the ability to take exponents. +-- +-- Not all rings have this ability. +-- Consider the ring of rational numbers (represented by "Rational" in Haskell). +-- Raising any rational to an integral power results in another rational. +-- But raising to a fractional power results in an irrational number. +-- For example, the square root of 2. +-- +-- See for more detail. +-- +-- FIXME: +-- This class hierarchy doesn't give a nice way exponentiate the integers. +-- We need to add instances for all the quotient groups. +class Ring r => ExpRing r where + (**) :: r -> r -> r + infixl 8 ** + + logBase :: r -> r -> r + +-- | An alternate form of "(**)" that some people find more convenient. +(^) :: ExpRing r => r -> r -> r +(^) = (**) + +instance ExpRing Float where + {-# INLINE (**) #-} + (**) = (P.**) + + {-# INLINE logBase #-} + logBase = P.logBase + +instance ExpRing Double where + {-# INLINE (**) #-} + (**) = (P.**) + + {-# INLINE logBase #-} + logBase = P.logBase + +--------------------------------------- + +-- | Fields augmented with exponents and logarithms. +-- +-- Technically, there are fields for which only a subset of the functions below are meaningful. +-- But these fields don't have any practical computational uses that I'm aware of. +-- So I've combined them all into a single class for simplicity. +-- +-- See for more detail. +class (ExpRing r, Field r) => ExpField r where + sqrt :: r -> r + sqrt r = r**(1/2) + + exp :: r -> r + log :: r -> r + +instance ExpField Float where + sqrt = P.sqrt + log = P.log + exp = P.exp + +instance ExpField Double where + sqrt = P.sqrt + log = P.log + exp = P.exp + +--------------------------------------- + +-- | This is a catch-all class for things the real numbers can do but don't exist in other classes. +-- +-- FIXME: +-- Factor this out into a more appropriate class hierarchy. +-- For example, some (all?) trig functions need to move to a separate class in order to support trig in finite fields (see ). +-- +-- FIXME: +-- This class is misleading/incorrect for complex numbers. +-- +-- FIXME: +-- There's a lot more functions that need adding. +class ExpField r => Real r where + gamma :: r -> r + lnGamma :: r -> r + erf :: r -> r + pi :: r + sin :: r -> r + cos :: r -> r + tan :: r -> r + asin :: r -> r + acos :: r -> r + atan :: r -> r + sinh :: r -> r + cosh :: r -> r + tanh :: r -> r + asinh :: r -> r + acosh :: r -> r + atanh :: r -> r + +instance Real Float where + gamma = P.gamma + lnGamma = P.lnGamma + erf = P.erf + + pi = P.pi + + sin = P.sin + cos = P.cos + tan = P.tan + asin = P.asin + acos = P.acos + atan = P.atan + sinh = P.sinh + cosh = P.cosh + tanh = P.tanh + asinh = P.asinh + acosh = P.acosh + atanh = P.atanh + +instance Real Double where + gamma = P.gamma + lnGamma = P.lnGamma + erf = P.erf + + pi = P.pi + + sin = P.sin + cos = P.cos + tan = P.tan + asin = P.asin + acos = P.acos + atan = P.atan + sinh = P.sinh + cosh = P.cosh + tanh = P.tanh + asinh = P.asinh + acosh = P.acosh + atanh = P.atanh + +--------------------------------------- + +type family Scalar m + +infixr 8 >< +type family (><) (a::k1) (b::k2) :: * +type instance Int >< Int = Int +type instance Integer >< Integer = Integer +type instance Float >< Float = Float +type instance Double >< Double = Double +type instance Rational >< Rational = Rational + +-- type instance (a,b) >< Scalar b = (a,b) +-- type instance (a,b,c) >< Scalar b = (a,b,c) + +type instance (a -> b) >< c = a -> (b>< (a -> b) = a -> (c> b) = Scalar b + +--------------------------------------- + +-- | FIXME: What constraint should be here? Semigroup? +-- +-- See +class + ( Ord_ (Scalar g) + , Scalar (Scalar g) ~ Scalar g + , Ring (Scalar g) + ) => Normed g where + size :: g -> Scalar g + + sizeSquared :: g -> Scalar g + sizeSquared g = s*s + where + s = size g + +abs :: IsScalar g => g -> g +abs = size + +instance Normed Int where size = P.abs +instance Normed Integer where size = P.abs +instance Normed Float where size = P.abs +instance Normed Double where size = P.abs +instance Normed Rational where size = P.abs + +--------------------------------------- + +-- | A Cone is an \"almost linear\" subspace of a module. +-- Examples include the cone of positive real numbers and the cone of positive semidefinite matrices. +-- +-- See +-- and for more details. +class (Cancellative m, HasScalar m, Rig (Scalar m)) => Cone m where + infixl 7 *.. + (*..) :: Scalar m -> m -> m + + infixl 7 ..*.. + (..*..) :: m -> m -> m + +--------------------------------------- + +class + ( Abelian v + , Group v + , HasScalar v + , v ~ (v> Module v + where + + {-# MINIMAL (.*) | (.*=) #-} + + -- | Scalar multiplication. + {-# INLINE (.*) #-} + infixl 7 .* + (.*) :: v -> Scalar v -> v + (.*) = mutable2immutable (.*=) + + {-# INLINE (.*=) #-} + infixr 5 .*= + (.*=) :: (PrimBase m) => Mutable m v -> Scalar v -> m () + (.*=) = immutable2mutable (.*) + +law_Module_multiplication :: (Eq_ m, Module m) => m -> m -> Scalar m -> Logic m +law_Module_multiplication m1 m2 s = s *. (m1 + m2) == s*.m1 + s*.m2 + +law_Module_addition :: (Eq_ m, Module m) => m -> Scalar m -> Scalar m -> Logic m +law_Module_addition m s1 s2 = (s1+s2)*.m == s1*.m + s2*.m + +law_Module_action :: (Eq_ m, Module m) => m -> Scalar m -> Scalar m -> Logic m +law_Module_action m s1 s2 = s1*.(s2*.m) == (s1*s2)*.m + +law_Module_unital :: (Eq_ m, Module m) => m -> Logic m +law_Module_unital m = 1 *. m == m + +defn_Module_dotstarequal :: (Eq_ m, Module m) => m -> Scalar m -> Logic m +defn_Module_dotstarequal = simpleMutableDefn (.*=) (.*) + + +{-# INLINE (*.) #-} +infixl 7 *. +(*.) :: Module v => Scalar v -> v -> v +r *. v = v .* r + +instance Module Int where (.*) = (*) +instance Module Integer where (.*) = (*) +instance Module Float where (.*) = (*) +instance Module Double where (.*) = (*) +instance Module Rational where (.*) = (*) + +instance + ( Module b + ) => Module (a -> b) + where + f .* b = \a -> f a .* b + +--------------------------------------- + +-- | Free modules have a basis. +-- This means it makes sense to perform operations elementwise on the basis coefficients. +-- +-- See for more detail. +class Module v => FreeModule v where + + {-# MINIMAL ones, ((.*.) | (.*.=)) #-} + + -- | Multiplication of the components pointwise. + -- For matrices, this is commonly called Hadamard multiplication. + -- + -- See for more detail. + -- + -- FIXME: This is only valid for modules with a basis. + {-# INLINE (.*.) #-} + infixl 7 .*. + (.*.) :: v -> v -> v + (.*.) = mutable2immutable (.*.=) + + {-# INLINE (.*.=) #-} + infixr 5 .*.= + (.*.=) :: (PrimBase m) => Mutable m v -> v -> m () + (.*.=) = immutable2mutable (.*.) + + -- | The identity for Hadamard multiplication. + -- Intuitively, this object has the value "one" in every column. + ones :: v + +law_FreeModule_commutative :: (Eq_ m, FreeModule m) => m -> m -> Logic m +law_FreeModule_commutative m1 m2 = m1.*.m2 == m2.*.m1 + +law_FreeModule_associative :: (Eq_ m, FreeModule m) => m -> m -> m -> Logic m +law_FreeModule_associative m1 m2 m3 = m1.*.(m2.*.m3) == (m1.*.m2).*.m3 + +law_FreeModule_id :: (Eq_ m, FreeModule m) => m -> Logic m +law_FreeModule_id m = m == m.*.ones + +defn_FreeModule_dotstardotequal :: (Eq_ m, FreeModule m) => m -> m -> Logic m +defn_FreeModule_dotstardotequal = simpleMutableDefn (.*.=) (.*.) + +instance FreeModule Int where (.*.) = (*); ones = one +instance FreeModule Integer where (.*.) = (*); ones = one +instance FreeModule Float where (.*.) = (*); ones = one +instance FreeModule Double where (.*.) = (*); ones = one +instance FreeModule Rational where (.*.) = (*); ones = one + +instance + ( FreeModule b + ) => FreeModule (a -> b) + where + g .*. f = \a -> g a .*. f a + ones = \a -> ones + +--------------------------------------- + +-- | If our "FreeModule" has a finite basis, then we can: +-- +-- * index into the modules basis coefficients +-- +-- * provide a dense construction method that's a bit more convenient than "fromIxList". +class + ( FreeModule v + , IxContainer v + , Elem v~Scalar v + , Index v~Int + , v ~ SetElem v (Elem v) + ) => FiniteModule v + where + -- | Returns the dimension of the object. + -- For some objects, this may be known statically, and so the parameter will not be "seq"ed. + -- But for others, this may not be known statically, and so the parameter will be "seq"ed. + dim :: v -> Int + + unsafeToModule :: [Scalar v] -> v + +type instance Elem Int = Int +type instance Elem Integer = Integer +type instance Elem Float = Float +type instance Elem Double = Double +type instance Elem Rational = Rational + +type instance SetElem Int a = Int +type instance SetElem Integer a = Integer +type instance SetElem Float a = Float +type instance SetElem Double a = Double +type instance SetElem Rational a = Rational + +type instance Index Int = Int +type instance Index Integer = Int +type instance Index Float = Int +type instance Index Double = Int +type instance Index Rational = Int + +type instance SetIndex Int a = Int +type instance SetIndex Integer a = Int +type instance SetIndex Float a = Int +type instance SetIndex Double a = Int +type instance SetIndex Rational a = Int + +instance FiniteModule Int where dim _ = 1; unsafeToModule [x] = x +instance FiniteModule Integer where dim _ = 1; unsafeToModule [x] = x +instance FiniteModule Float where dim _ = 1; unsafeToModule [x] = x +instance FiniteModule Double where dim _ = 1; unsafeToModule [x] = x +instance FiniteModule Rational where dim _ = 1; unsafeToModule [x] = x + +--------------------------------------- + +class (FreeModule v, Field (Scalar v)) => VectorSpace v where + + {-# MINIMAL (./.) | (./.=) #-} + + {-# INLINE (./) #-} + infixl 7 ./ + (./) :: v -> Scalar v -> v + v ./ r = v .* reciprocal r + + {-# INLINE (./.) #-} + infixl 7 ./. + (./.) :: v -> v -> v + (./.) = mutable2immutable (./.=) + + {-# INLINE (./=) #-} + infixr 5 ./= + (./=) :: (PrimBase m) => Mutable m v -> Scalar v -> m () + (./=) = immutable2mutable (./) + + {-# INLINE (./.=) #-} + infixr 5 ./.= + (./.=) :: (PrimBase m) => Mutable m v -> v -> m () + (./.=) = immutable2mutable (./.) + + +instance VectorSpace Float where (./) = (/); (./.) = (/) +instance VectorSpace Double where (./) = (/); (./.) = (/) +instance VectorSpace Rational where (./) = (/); (./.) = (/) + +instance VectorSpace b => VectorSpace (a -> b) where g ./. f = \a -> g a ./. f a + +--------------------------------------- + +-- | A Reisz space is a vector space obeying nice partial ordering laws. +-- +-- See for more details. +class (VectorSpace v, Lattice_ v) => Reisz v where + -- + -- | An element of a reisz space can always be split into positive and negative components. + reiszSplit :: v -> (v,v) + +--------------------------------------- + +-- | A Banach space is a Vector Space equipped with a compatible Norm and Metric. +-- +-- See for more details. +class (VectorSpace v, Normed v, Metric v) => Banach v where + {-# INLINE normalize #-} + normalize :: v -> v + normalize v = v ./ size v + +law_Banach_distance :: Banach v => v -> v -> Logic (Scalar v) +law_Banach_distance v1 v2 = size (v1 - v2) == distance v1 v2 + +law_Banach_size :: Banach v => v -> Logic (Scalar v) +law_Banach_size v + = isZero v + || size (normalize v) == 1 + +instance Banach Float +instance Banach Double +instance Banach Rational + +--------------------------------------- + +-- | Hilbert spaces are a natural generalization of Euclidean space that allows for infinite dimension. +-- +-- See for more details. +-- +-- FIXME: +-- The result of a dot product must always be an ordered field. +-- This is true even when the Hilbert space is over a non-ordered field like the complex numbers. +-- But the "OrdField" constraint currently prevents us from doing scalar multiplication on Complex Hilbert spaces. +-- See and for some technical details. +class ( Banach v , TensorAlgebra v , Real (Scalar v), OrdField (Scalar v) ) => Hilbert v where + infix 8 <> + (<>) :: v -> v -> Scalar v + +instance Hilbert Float where (<>) = (*) +instance Hilbert Double where (<>) = (*) + +{-# INLINE squaredInnerProductNorm #-} +squaredInnerProductNorm :: Hilbert v => v -> Scalar v +squaredInnerProductNorm v = v<>v + +{-# INLINE innerProductNorm #-} +innerProductNorm :: Hilbert v => v -> Scalar v +innerProductNorm = undefined -- sqrt . squaredInnerProductNorm + +{-# INLINE innerProductDistance #-} +innerProductDistance :: Hilbert v => v -> v -> Scalar v +innerProductDistance v1 v2 = undefined --innerProductNorm $ v1-v2 + +--------------------------------------- + +-- | Tensor algebras generalize the outer product of vectors to construct a matrix. +-- +-- See for details. +-- +-- FIXME: +-- This needs to be replaced by the Tensor product in the Monoidal category Vect +class + ( VectorSpace v + , VectorSpace (v> TensorAlgebra v + where + + -- | Take the tensor product of two vectors + (><) :: v -> v -> (v> (v> v + + -- | "right multiplication" of a square matrix + mXv :: (v> v -> v + +instance TensorAlgebra Float where (><) = (*); vXm = (*); mXv = (*) +instance TensorAlgebra Double where (><) = (*); vXm = (*); mXv = (*) +instance TensorAlgebra Rational where (><) = (*); vXm = (*); mXv = (*) + +--------------------------------------- + +{- +-- | Bregman divergences generalize the squared Euclidean distance and the KL-divergence. +-- They are closely related to exponential family distributions. +-- +-- Mark Reid has a . +-- +-- FIXME: +-- The definition of divergence requires taking the derivative. +-- How should this relate to categories? +class + ( Hilbert v + ) => Bregman v + where + + divergence :: v -> v -> Scalar v + divergence v1 v2 = f v1 - f v2 - (derivative f v2 <> v1 - v2) + where + f = bregmanFunction + + bregmanFunction :: v -> Scalar v + +law_Bregman_nonnegativity :: v -> v -> Logic v +law_Bregman_nonnegativity v1 v2 = divergence v1 v2 > 0 + +law_Bregman_triangle :: +-} + +--------------------------------------- + +-- | Metric spaces give us the most intuitive notion of distance between objects. +-- +-- FIXME: There are many other notions of distance and we should make a whole hierarchy. +class + ( HasScalar v + , Eq_ v + , Boolean (Logic v) + , Logic (Scalar v) ~ Logic v + ) => Metric v + where + + distance :: v -> v -> Scalar v + + -- | If the distance between two datapoints is less than or equal to the upper bound, + -- then this function will return the distance. + -- Otherwise, it will return some number greater than the upper bound. + {-# INLINE distanceUB #-} + distanceUB :: v -> v -> Scalar v -> Scalar v + distanceUB v1 v2 _ = {-# SCC distanceUB #-} distance v1 v2 + +-- | Calling this function will be faster on some 'Metric's than manually checking if distance is greater than the bound. +{-# INLINE isFartherThan #-} +isFartherThan :: Metric v => v -> v -> Scalar v -> Logic v +isFartherThan s1 s2 b = {-# SCC isFartherThan #-} distanceUB s1 s2 b > b + +-- | This function constructs an efficient default implementation for 'distanceUB' given a function that lower bounds the distance metric. +{-# INLINE lb2distanceUB #-} +lb2distanceUB :: + ( Metric a + , ClassicalLogic a + ) => (a -> a -> Scalar a) + -> (a -> a -> Scalar a -> Scalar a) +lb2distanceUB lb p q b = if lbpq > b + then lbpq + else distance p q + where + lbpq = lb p q +law_Metric_nonnegativity :: Metric v => v -> v -> Logic v +law_Metric_nonnegativity v1 v2 = distance v1 v2 >= 0 + +law_Metric_indiscernables :: (Eq v, Metric v) => v -> v -> Logic v +law_Metric_indiscernables v1 v2 = if v1 == v2 + then distance v1 v2 == 0 + else distance v1 v2 > 0 + +law_Metric_symmetry :: Metric v => v -> v -> Logic v +law_Metric_symmetry v1 v2 = distance v1 v2 == distance v2 v1 + +law_Metric_triangle :: Metric v => v -> v -> v -> Logic v +law_Metric_triangle m1 m2 m3 + = distance m1 m2 <= distance m1 m3 + distance m2 m3 + && distance m1 m3 <= distance m1 m2 + distance m2 m3 + && distance m2 m3 <= distance m1 m3 + distance m2 m1 + +instance Metric Int where distance x1 x2 = abs $ x1 - x2 +instance Metric Integer where distance x1 x2 = abs $ x1 - x2 +instance Metric Float where distance x1 x2 = abs $ x1 - x2 +instance Metric Double where distance x1 x2 = abs $ x1 - x2 +instance Metric Rational where distance x1 x2 = abs $ x1 - x2 + +--------- + +class CanError a where + errorVal :: a + isError :: a -> Bool + + isJust :: a -> Bool + isJust = not isError + +instance CanError (Maybe a) where + {-# INLINE isError #-} + isError Nothing = True + isError _ = False + + {-# INLINE errorVal #-} + errorVal = Nothing + +instance CanError (Maybe' a) where + {-# INLINE isError #-} + isError Nothing' = True + isError _ = False + + {-# INLINE errorVal #-} + errorVal = Nothing' + +instance CanError [a] where + {-# INLINE isError #-} + isError [] = True + isError _ = False + + {-# INLINE errorVal #-} + errorVal = [] + +instance CanError Float where + {-# INLINE isError #-} + {-# INLINE errorVal #-} + isError = isNaN + errorVal = 0/0 + +instance CanError Double where + {-# INLINE isError #-} + {-# INLINE errorVal #-} + isError = isNaN + errorVal = 0/0 + +------------------------------------------------------------------------------- +-- set-like + +type Item s = Elem s + +type family Elem s +type family SetElem s t + +type ValidSetElem s = SetElem s (Elem s) ~ s + +-- | Two sets are disjoint if their infimum is the empty set. +-- This function generalizes the notion of disjointness for any lower bounded lattice. +-- FIXME: add other notions of disjoint +infDisjoint :: (Constructible s, MinBound s, Monoid s) => s -> s -> Logic s +infDisjoint s1 s2 = isEmpty $ inf s1 s2 + +sizeDisjoint :: (Normed s, Constructible s) => s -> s -> Logic (Scalar s) +sizeDisjoint s1 s2 = size s1 + size s2 == size (s1+s2) + +-- | 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. +-- +-- See for more details. +class Semigroup s => Constructible s where + + {-# MINIMAL singleton | cons | fromList1 #-} + + -- | creates the smallest value containing the given element + singleton :: Elem s -> s + singleton x = fromList1N 1 x [] + + -- | inserts an element on the left + cons :: Elem s -> s -> s + cons x xs = singleton x + xs + + -- | inserts an element on the right; + -- in a non-abelian 'Constructible', this may not insert the element; + -- this occurs, for example, in the Map type. + snoc :: s -> Elem s -> s + snoc xs x = xs + singleton x + + -- | Construct the type from a list. + -- Since lists may be empty (but not all 'Constructible's can be empty) we explicitly pass in an Elem s. + fromList1 :: Elem s -> [Elem s] -> s + fromList1 x xs = foldl' snoc (singleton x) xs + + -- | Like "fromList1" but passes in the size of the list for more efficient construction. + fromList1N :: Int -> Elem s -> [Elem s] -> s + fromList1N _ = fromList1 + +defn_Constructible_fromList :: (Eq_ s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s +defn_Constructible_fromList s e es = fromList1 e es `asTypeOf` s == foldl' snoc (singleton e) es + +defn_Constructible_fromListN :: (Eq_ s, Constructible s) => s -> Elem s -> [Elem s] -> Logic s +defn_Constructible_fromListN s e es = (fromList1 e es `asTypeOf` s)==fromList1N (size es+1) e es + +defn_Constructible_cons :: (Eq_ s, Constructible s) => s -> Elem s -> Logic s +defn_Constructible_cons s e = cons e s == singleton e + s + +defn_Constructible_snoc :: (Eq_ s, Constructible s) => s -> Elem s -> Logic s +defn_Constructible_snoc s e = snoc s e == s + singleton e + +-- | A more suggestive name for inserting an element into a container that does not remember location +insert :: Constructible s => Elem s -> s -> s +insert = cons + +-- | A slightly more suggestive name for a container's monoid identity +empty :: (Monoid s, Constructible s) => s +empty = zero + +-- | A slightly more suggestive name for checking if a container is empty +isEmpty :: (ValidEq s, Monoid s, Constructible s) => s -> Logic s +isEmpty = isZero + +-- | This function needed for the OverloadedStrings language extension +fromString :: (Monoid s, Constructible s, Elem s ~ Char) => String -> s +fromString = fromList + +-- | FIXME: if -XOverloadedLists is enabled, this causes an infinite loop for some reason +fromList :: (Monoid s, Constructible s) => [Elem s] -> s +fromList [] = zero +fromList (x:xs) = fromList1 x xs + +fromListN :: (Monoid s, Constructible s) => Int -> [Elem s] -> s +fromListN 0 [] = zero +fromListN i (x:xs) = fromList1N i x xs + +-- | 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 + elem :: Elem s -> s -> Logic s + + notElem :: Elem s -> s -> Logic s + notElem = not elem + +law_Container_preservation :: (Heyting (Logic s), Container s) => s -> s -> Elem s -> Logic s +law_Container_preservation s1 s2 e = (e `elem` s1 || e `elem` s2) ==> (e `elem` (s1+s2)) + +law_Constructible_singleton :: Container s => s -> Elem s -> Logic s +law_Constructible_singleton s e = elem e $ singleton e `asTypeOf` s + +theorem_Constructible_cons :: Container s => s -> Elem s -> Logic s +theorem_Constructible_cons s e = elem e (cons e s) + + +-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'. +newtype DualSG a = DualSG { getDualSG :: a } + deriving (Read,Show) + +instance Semigroup a => Semigroup (DualSG a) where + (DualSG x)+(DualSG y) = DualSG (x+y) + +instance Monoid a => Monoid (DualSG a) where + zero = DualSG zero + +-- | The monoid of endomorphisms under composition. +newtype Endo a = Endo { appEndo :: a -> a } + +instance Semigroup (Endo a) where + (Endo f)+(Endo g) = Endo (f.g) + +instance Monoid (Endo a) where + zero = Endo id + +-- | Provides inverse operations for "Constructible". +-- +-- FIXME: +-- should this class be broken up into smaller pieces? +class (Constructible s, Monoid s, Normed s, Scalar s~Int) => Foldable s where + + {-# MINIMAL foldMap | foldr #-} + + -- | Convert the container into a list. + toList :: Foldable s => s -> [Elem s] + toList s = foldr (:) [] s + + -- | Remove an element from the left of the container. + uncons :: s -> Maybe (Elem s,s) + uncons s = case toList s of + [] -> Nothing + (x:xs) -> Just (x,fromList xs) + + -- | Remove an element from the right of the container. + unsnoc :: s -> Maybe (s,Elem s) + unsnoc s = case unsnoc (toList s) of + Nothing -> Nothing + Just (xs,x) -> Just (fromList xs,x) + + -- | Add all the elements of the container together. + {-# INLINABLE sum #-} + sum :: Monoid (Elem s) => s -> Elem s + sum xs = foldl' (+) zero $ toList xs + + -- | the default summation uses kahan summation +-- sum :: (Abelian (Elem s), Group (Elem s)) => s -> Elem s +-- sum = snd . foldl' go (zero,zero) +-- where +-- go (c,t) i = ((t'-t)-y,t') +-- where +-- y = i-c +-- t' = t+y + + -- the definitions below are copied from Data.Foldable + + foldMap :: Monoid a => (Elem s -> a) -> s -> a + foldMap f = foldr ((+) . f) zero + + foldr :: (Elem s -> a -> a) -> a -> s -> a + foldr f z t = appEndo (foldMap (Endo . f) t) z + + foldr' :: (Elem s -> a -> a) -> a -> s -> a + foldr' f z0 xs = foldl f' id xs z0 + where f' k x z = k $! f x z + + foldl :: (a -> Elem s -> a) -> a -> s -> a + foldl f z t = appEndo (getDualSG (foldMap (DualSG . Endo . flip f) t)) z + + foldl' :: (a -> Elem s -> a) -> a -> s -> a + foldl' f z0 xs = foldr f' id xs z0 + where f' x k z = k $! f z x + + -- the following definitions are simpler (IMO) than those in Data.Foldable + + foldr1 :: (Elem s -> Elem s -> Elem s) -> s -> Elem s + foldr1 f s = foldr1 f (toList s) + + foldr1' :: (Elem s -> Elem s -> Elem s) -> s -> Elem s + foldr1' f s = foldr1' f (toList s) + + foldl1 :: (Elem s -> Elem s -> Elem s) -> s -> Elem s + foldl1 f s = foldl1 f (toList s) + + foldl1' :: (Elem s -> Elem s -> Elem s) -> s -> Elem s + foldl1' f s = foldl1' f (toList s) + +defn_Foldable_foldr :: + ( Eq_ a + , a~Elem s + , Logic a ~ Logic (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) +defn_Foldable_foldr f a s = foldr f a s == foldr f a (toList s) + +defn_Foldable_foldr' :: + ( Eq_ a + , a~Elem s + , Logic a ~ Logic (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) +defn_Foldable_foldr' f a s = foldr' f a s == foldr' f a (toList s) + +defn_Foldable_foldl :: + ( Eq_ a + , a~Elem s + , Logic a ~ Logic (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) +defn_Foldable_foldl f a s = foldl f a s == foldl f a (toList s) + +defn_Foldable_foldl' :: + ( Eq_ a + , a~Elem s + , Logic a ~ Logic (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> Elem s -> s -> Logic (Elem s) +defn_Foldable_foldl' f a s = foldl' f a s == foldl' f a (toList s) + +defn_Foldable_foldr1 :: + ( Eq_ (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) +defn_Foldable_foldr1 f s = (length s > 0) ==> (foldr1 f s == foldr1 f (toList s)) + +defn_Foldable_foldr1' :: + ( Eq_ (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) +defn_Foldable_foldr1' f s = (length s > 0) ==> (foldr1' f s == foldr1' f (toList s)) + +defn_Foldable_foldl1 :: + ( Eq_ (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) +defn_Foldable_foldl1 f s = (length s > 0) ==> (foldl1 f s == foldl1 f (toList s)) + +defn_Foldable_foldl1' :: + ( Eq_ (Elem s) + , Logic (Scalar s) ~ Logic (Elem s) + , Boolean (Logic (Elem s)) + , Foldable s + ) => (Elem s -> Elem s -> Elem s) -> s -> Logic (Elem s) +defn_Foldable_foldl1' f s = (length s > 0) ==> (foldl1' f s == foldl1' f (toList s)) + +-- | +-- +-- Note: +-- The inverse \"theorem\" of @(toList . fromList) xs == xs@ is actually not true. +-- See the "Set" type for a counter example. +theorem_Foldable_tofrom :: (Eq_ s, Foldable s) => s -> Logic s +theorem_Foldable_tofrom s = fromList (toList s) == s + +-- | +-- FIXME: +-- This law can't be automatically included in the current test system because it breaks parametricity by requiring @Monoid (Elem s)@ +law_Foldable_sum :: + ( Logic (Scalar s)~Logic s + , Logic (Elem s)~Logic s + , Heyting (Logic s) + , Monoid (Elem s) + , Eq_ (Elem s) + , Foldable s + ) => s -> s -> Logic s +law_Foldable_sum s1 s2 = sizeDisjoint s1 s2 ==> (sum (s1+s2) == sum s1 + sum s2) + +-- | This fold is not in any of the standard libraries. +foldtree1 :: Monoid a => [a] -> a +foldtree1 as = case go as of + [] -> zero + [a] -> a + as -> foldtree1 as + where + go [] = [] + go [a] = [a] + go (a1:a2:as) = (a1+a2):go as + +{-# INLINE[1] convertUnfoldable #-} +convertUnfoldable :: (Monoid t, Foldable s, Constructible t, Elem s ~ Elem t) => s -> t +convertUnfoldable = fromList . toList + +{-# INLINE reduce #-} +reduce :: (Monoid (Elem s), Foldable s) => s -> Elem s +reduce s = foldl' (+) zero s + +-- | For anything foldable, the norm must be compatible with the folding structure. +{-# INLINE length #-} +length :: Normed s => s -> Scalar s +length = size + +{-# INLINE and #-} +and :: (Foldable bs, Elem bs~b, Boolean b) => bs -> b +and = foldl' inf true + +{-# INLINE or #-} +or :: (Foldable bs, Elem bs~b, Boolean b) => bs -> b +or = foldl' sup false + +{-# INLINE argmin #-} +argmin :: Ord b => a -> a -> (a -> b) -> a +argmin a1 a2 f = if f a1 < f a2 then a1 else a2 + +{-# INLINE argmax #-} +argmax :: Ord b => a -> a -> (a -> b) -> a +argmax a1 a2 f = if f a1 > f a2 then a1 else a2 + +-- {-# INLINE argminimum_ #-} +-- argminimum_ :: Ord_ b => a -> [a] -> (a -> b) -> a +-- argminimum_ a as f = fstHask $ foldl' go (a,f a) as +-- where +-- go (a1,fa1) a2 = if fa1 < fa2 +-- then (a1,fa1) +-- else (a2,fa2) +-- where fa2 = f a2 +-- +-- {-# INLINE argmaximum_ #-} +-- argmaximum_ :: Ord_ b => a -> [a] -> (a -> b) -> a +-- argmaximum_ a as f = fstHask $ foldl' go (a,f a) as +-- where +-- go (a1,fa1) a2 = if fa1 > fa2 +-- then (a1,fa1) +-- else (a2,fa2) +-- where fa2 = f a2 + +{-# INLINE maximum #-} +maximum :: (ValidLogic b, Bounded b) => [b] -> b +maximum = supremum + +{-# INLINE maximum_ #-} +maximum_ :: (ValidLogic b, Ord_ b) => b -> [b] -> b +maximum_ = supremum_ + +{-# INLINE minimum #-} +minimum :: (ValidLogic b, Bounded b) => [b] -> b +minimum = infimum + +{-# INLINE minimum_ #-} +minimum_ :: (ValidLogic b, Ord_ b) => b -> [b] -> b +minimum_ = infimum_ + +{-# INLINE supremum #-} +supremum :: (Foldable bs, Elem bs~b, Bounded b) => bs -> b +supremum = supremum_ minBound + +{-# INLINE supremum_ #-} +supremum_ :: (Foldable bs, Elem bs~b, Lattice_ b) => b -> bs -> b +supremum_ = foldl' sup + +{-# INLINE infimum #-} +infimum :: (Foldable bs, Elem bs~b, Bounded b) => bs -> b +infimum = infimum_ maxBound + +{-# INLINE infimum_ #-} +infimum_ :: (Foldable bs, Elem bs~b, POrd_ b) => b -> bs -> b +infimum_ = foldl' inf + +{-# INLINE concat #-} +concat :: (Monoid (Elem s), Foldable s) => s -> Elem s +concat = foldl' (+) zero + +{-# INLINE headMaybe #-} +headMaybe :: Foldable s => s -> Maybe (Elem s) +headMaybe = P.fmap fst . uncons + +{-# INLINE tailMaybe #-} +tailMaybe :: Foldable s => s -> Maybe s +tailMaybe = P.fmap snd . uncons + +{-# INLINE lastMaybe #-} +lastMaybe :: Foldable s => s -> Maybe (Elem s) +lastMaybe = P.fmap snd . unsnoc + +{-# INLINE initMaybe #-} +initMaybe :: Foldable s => s -> Maybe s +initMaybe = P.fmap fst . unsnoc + +-- | +-- +-- FIXME: +-- This is a correct definition of topologies, but is it useful? +-- How can this relate to continuous functions? +class (Boolean (Logic s), Boolean s, Container s) => Topology s where + open :: s -> Logic s + + closed :: s -> Logic s + closed s = open $ not s + + clopen :: s -> Logic s + clopen = open && closed + +---------------------------------------- + +type family Index s +type family SetIndex s a + +type ValidSetIndex s = SetIndex s (Index s) ~ s + +-- | An indexed constructible container associates an 'Index' with each 'Elem'. +-- This class generalizes the map abstract data type. +-- +-- There are two differences in the indexed hierarchy of containers from the standard hierarchy. +-- 1. 'IxConstructible' requires a 'Monoid' constraint whereas 'Constructible' requires a 'Semigroup' constraint because there are no valid 'IxConstructible's (that I know of at least) that are not also 'Monoid's. +-- 2. Many regular containers are indexed containers, but not the other way around. +-- So the class hierarchy is in a different order. +-- +class (ValidLogic s, Monoid s, ValidSetElem s{-, ValidSetIndex s-}) => IxContainer s where + lookup :: Index s -> s -> Maybe (Elem s) + + {-# INLINABLE (!) #-} + (!) :: s -> Index s -> Elem s + (!) s i = case lookup i s of + Just x -> x + Nothing -> error "used (!) on an invalid index" + + {-# INLINABLE findWithDefault #-} + findWithDefault :: Elem s -> Index s -> s -> Elem s + findWithDefault def i s = case s !? i of + Nothing -> def + Just e -> e + + {-# INLINABLE hasIndex #-} + hasIndex :: s -> Index s -> Logic s + hasIndex s i = case s !? i of + Nothing -> false + Just _ -> true + + -- | FIXME: should the functions below be moved to other classes? + type ValidElem s e :: Constraint + type ValidElem s e = () + + imap :: (ValidElem s (Elem s), ValidElem s b) => (Index s -> Elem s -> b) -> s -> SetElem s b + + toIxList :: s -> [(Index s, Elem s)] + + indices :: s -> [Index s] + indices = map fst . toIxList + + values :: s -> [Elem s] + values = map snd . toIxList + +law_IxContainer_preservation :: + ( Logic (Elem s)~Logic s + , ValidLogic s + , Eq_ (Elem s) + , IxContainer s + ) => s -> s -> Index s -> Logic s +law_IxContainer_preservation s1 s2 i = case s1 !? i of + Nothing -> case s2 !? i of + Nothing -> true + Just e -> (s1+s2) !? i == Just e + Just e -> (s1+s2) !? i == Just e + +defn_IxContainer_bang :: + ( Eq_ (Elem s) + , ValidLogic (Elem s) + , IxContainer s + ) => s -> Index s -> Logic (Elem s) +defn_IxContainer_bang s i = case s !? i of + Nothing -> true + Just e -> s!i == e + +defn_IxContainer_findWithDefault :: + ( Eq_ (Elem s) + , IxContainer s + ) => s -> Index s -> Elem s -> Logic (Elem s) +defn_IxContainer_findWithDefault s i e = case s !? i of + Nothing -> findWithDefault e i s == e + Just e' -> findWithDefault e i s == e' + +defn_IxContainer_hasIndex :: + ( Eq_ (Elem s) + , IxContainer s + ) => s -> Index s -> Logic s +defn_IxContainer_hasIndex s i = case s !? i of + Nothing -> not $ hasIndex s i + Just _ -> hasIndex s i + +-- FIXME: +-- It would be interesting to make the "Index" of scalars be (). +-- Is it worth it? +#define mkIxContainer(t) \ +type instance Index t = Int; \ +type instance Elem t = t; \ +instance IxContainer t where \ + lookup 0 x = Just x; \ + lookup _ _ = Nothing + +mkIxContainer(Int) +mkIxContainer(Integer) +mkIxContainer(Float) +mkIxContainer(Double) +mkIxContainer(Rational) + +-- | Sliceable containers generalize the notion of a substring to any IxContainer. +class (IxContainer s, Enum (Index s)) => Sliceable s where + slice :: Index s -> Int -> s -> s + +-- | Some containers that use indices are not typically constructed with those indices (e.g. Arrays). +class IxContainer s => IxConstructible s where + {-# MINIMAL singletonAt | consAt #-} + + -- | Construct a container with only the single (index,element) pair. + -- This function is equivalent to 'singleton' in the 'Constructible' class. + singletonAt :: Index s -> Elem s -> s + singletonAt i e = consAt i e zero + + -- | Insert an element, overwriting the previous value if the index already exists. + -- This function is equivalent to 'cons' in the 'Constructible' class. + {-# INLINABLE consAt #-} + consAt :: Index s -> Elem s -> s -> s + consAt i e s = singletonAt i e + s + + -- | Insert an element only if the index does not already exist. + -- If the index already exists, the container is unmodified. + -- This function is equivalent to 'snoc' in the 'Constructible' class. + {-# INLINABLE snocAt #-} + snocAt :: s -> Index s -> Elem s -> s + snocAt s i e = s + singletonAt i e + + -- | This function is the equivalent of 'fromList' in the 'Constructible' class. + -- We do not require all the variants of 'fromList' because of our 'Monoid' constraint. + {-# INLINABLE fromIxList #-} + fromIxList :: [(Index s, Elem s)] -> s + fromIxList xs = foldl' (\s (i,e) -> snocAt s i e) zero xs + +law_IxConstructible_lookup :: + ( ValidLogic (Elem s) + , Eq_ (Elem s) + , IxConstructible s + ) => s -> Index s -> Elem s -> Logic (Elem s) +law_IxConstructible_lookup s i e = case lookup i (consAt i e s) of + Just e' -> e'==e + Nothing -> false + +defn_IxConstructible_consAt :: (Eq_ s, IxConstructible s) => s -> Index s -> Elem s -> Logic s +defn_IxConstructible_consAt s i e = consAt i e s == singletonAt i e + s + +defn_IxConstructible_snocAt :: (Eq_ s, IxConstructible s) => s -> Index s -> Elem s -> Logic s +defn_IxConstructible_snocAt s i e = snocAt s i e == s + singletonAt i e + +defn_IxConstructible_fromIxList :: (Eq_ s, IxConstructible s) => s -> [(Index s, Elem s)] -> Logic s +defn_IxConstructible_fromIxList t es + = fromIxList es `asTypeOf` t == foldl' (\s (i,e) -> snocAt s i e) zero es + +insertAt :: IxConstructible s => Index s -> Elem s -> s -> s +insertAt = consAt + +-- | An infix operator equivalent to 'lookup' +{-# INLINABLE (!?) #-} +(!?) :: IxContainer s => s -> Index s -> Maybe (Elem s) +(!?) s i = lookup i s + +-------------------------------------------------------------------------------- + +type instance Scalar [a] = Int +type instance Logic [a] = Logic a +type instance Elem [a] = a +type instance SetElem [a] b = [b] +type instance Index [a] = Int + +instance ValidEq a => Eq_ [a] where + (x:xs)==(y:ys) = x==y && xs==ys + (x:xs)==[] = false + [] ==(y:ts) = false + [] ==[] = true + +instance Eq a => POrd_ [a] where + inf [] _ = [] + inf _ [] = [] + inf (x:xs) (y:ys) = if x==y + then x:inf xs ys + else [] + +instance Eq a => MinBound_ [a] where + minBound = [] + +instance Normed [a] where + size = P.length + +instance Semigroup [a] where + (+) = (P.++) + +instance Monoid [a] where + zero = [] + +instance ValidEq a => Container [a] where + elem _ [] = false + elem x (y:ys) = x==y || elem x ys + + notElem = not elem + +instance Constructible [a] where + singleton a = [a] + cons x xs = x:xs + fromList1 x xs = x:xs + fromList1N _ x xs = x:xs + +instance Foldable [a] where + toList = id + + uncons [] = Nothing + uncons (x:xs) = Just (x,xs) + + unsnoc [] = Nothing + unsnoc xs = Just (P.init xs,P.last xs) + + foldMap f s = concat $ map f s + + foldr = L.foldr + foldr' = L.foldr + foldr1 = L.foldr1 + foldr1' = L.foldr1 + + foldl = L.foldl + foldl' = L.foldl' + foldl1 = L.foldl1 + foldl1' = L.foldl1' + +instance ValidLogic a => IxContainer [a] where + lookup 0 (x:xs) = Just x + lookup i (x:xs) = lookup (i-1) xs + lookup _ [] = Nothing + + imap f xs = map (uncurry f) $ P.zip [0..] xs + + toIxList xs = P.zip [0..] xs + +---------------------------------------- + +type instance Scalar (Maybe a) = Scalar a +type instance Logic (Maybe a) = Logic a + +instance ValidEq a => Eq_ (Maybe a) where + Nothing == Nothing = true + Nothing == _ = false + _ == Nothing = false + (Just a1) == (Just a2) = a1==a2 + +instance Semigroup a => Semigroup (Maybe a) where + (Just a1) + (Just a2) = Just $ a1+a2 + Nothing + a2 = a2 + a1 + Nothing = a1 + +instance Semigroup a => Monoid (Maybe a) where + zero = Nothing + +---------- + +data Maybe' a = Nothing' | Just' { fromJust' :: !a } + +type instance Scalar (Maybe' a) = Scalar a +type instance Logic (Maybe' a) = Logic a + +instance NFData a => NFData (Maybe' a) where + rnf Nothing' = () + rnf (Just' a) = rnf a + +instance ValidEq a => Eq_ (Maybe' a) where + (Just' a1) == (Just' a2) = a1==a2 + Nothing' == Nothing' = true + _ == _ = false + +instance Semigroup a => Semigroup (Maybe' a) where + (Just' a1) + (Just' a2) = Just' $ a1+a2 + Nothing' + a2 = a2 + a1 + Nothing' = a1 + +instance Semigroup a => Monoid (Maybe' a) where + zero = Nothing' + +---------------------------------------- + +type instance Logic (a,b) = Logic a +type instance Logic (a,b,c) = Logic a + +instance (ValidEq a, ValidEq b, Logic a ~ Logic b) => Eq_ (a,b) where + (a1,b1)==(a2,b2) = a1==a2 && b1==b2 + +instance (ValidEq a, ValidEq b, ValidEq c, Logic a ~ Logic b, Logic b~Logic c) => Eq_ (a,b,c) where + (a1,b1,c1)==(a2,b2,c2) = a1==a2 && b1==b2 && c1==c2 + +instance (Semigroup a, Semigroup b) => Semigroup (a,b) where + (a1,b1)+(a2,b2) = (a1+a2,b1+b2) + +instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a,b,c) where + (a1,b1,c1)+(a2,b2,c2) = (a1+a2,b1+b2,c1+c2) + +instance (Monoid a, Monoid b) => Monoid (a,b) where + zero = (zero,zero) + +instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where + zero = (zero,zero,zero) + +instance (Cancellative a, Cancellative b) => Cancellative (a,b) where + (a1,b1)-(a2,b2) = (a1-a2,b1-b2) + +instance (Cancellative a, Cancellative b, Cancellative c) => Cancellative (a,b,c) where + (a1,b1,c1)-(a2,b2,c2) = (a1-a2,b1-b2,c1-c2) + +instance (Group a, Group b) => Group (a,b) where + negate (a,b) = (negate a,negate b) + +instance (Group a, Group b, Group c) => Group (a,b,c) where + negate (a,b,c) = (negate a,negate b,negate c) + +instance (Abelian a, Abelian b) => Abelian (a,b) + +instance (Abelian a, Abelian b, Abelian c) => Abelian (a,b,c) + +-- instance (Module a, Module b, Scalar a ~ Scalar b) => Module (a,b) where +-- (a,b) .* r = (r*.a, r*.b) +-- (a1,b1).*.(a2,b2) = (a1.*.a2,b1.*.b2) +-- +-- instance (Module a, Module b, Module c, Scalar a ~ Scalar b, Scalar c~Scalar b) => Module (a,b,c) where +-- (a,b,c) .* r = (r*.a, r*.b,r*.c) +-- (a1,b1,c1).*.(a2,b2,c2) = (a1.*.a2,b1.*.b2,c1.*.c2) +-- +-- instance (VectorSpace a,VectorSpace b, Scalar a ~ Scalar b) => VectorSpace (a,b) where +-- (a,b) ./ r = (a./r,b./r) +-- (a1,b1)./.(a2,b2) = (a1./.a2,b1./.b2) +-- +-- instance (VectorSpace a,VectorSpace b, VectorSpace c, Scalar a ~ Scalar b, Scalar c~Scalar b) => VectorSpace (a,b,c) where +-- (a,b,c) ./ r = (a./r,b./r,c./r) +-- (a1,b1,c1)./.(a2,b2,c2) = (a1./.a2,b1./.b2,c1./.c2) + +-------------------------------------------------------------------------------- + +data Labeled' x y = Labeled' { xLabeled' :: !x, yLabeled' :: !y } + deriving (Read,Show,Typeable) + +instance (NFData x, NFData y) => NFData (Labeled' x y) where + rnf (Labeled' x y) = deepseq x $ rnf y + +instance (Arbitrary x, Arbitrary y) => Arbitrary (Labeled' x y) where + arbitrary = do + x <- arbitrary + y <- arbitrary + return $ Labeled' 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 +type instance Elem (Labeled' x y) = Elem x + +----- + +instance Eq_ x => Eq_ (Labeled' x y) where + (Labeled' x1 y1) == (Labeled' x2 y2) = x1==x2 + +instance (ClassicalLogic x, Ord_ x) => POrd_ (Labeled' x y) where + inf (Labeled' x1 y1) (Labeled' x2 y2) = if x1 < x2 + then Labeled' x1 y1 + else Labeled' x2 y2 + (Labeled' x1 _)< (Labeled' x2 _) = x1< x2 + (Labeled' x1 _)<=(Labeled' x2 _) = x1<=x2 + +instance (ClassicalLogic x, Ord_ x) => Lattice_ (Labeled' x y) where + sup (Labeled' x1 y1) (Labeled' x2 y2) = if x1 >= x2 + then Labeled' x1 y1 + else Labeled' x2 y2 + (Labeled' x1 _)> (Labeled' x2 _) = x1> x2 + (Labeled' x1 _)>=(Labeled' x2 _) = x1>=x2 + +instance (ClassicalLogic x, Ord_ x) => Ord_ (Labeled' x y) where + +----- + +instance Semigroup x => Action (Labeled' x y) where + (Labeled' x y) .+ x' = Labeled' (x'+x) y + +----- + +instance Metric x => Metric (Labeled' x y) where + distance (Labeled' x1 y1) (Labeled' x2 y2) = distance x1 x2 + distanceUB (Labeled' x1 y1) (Labeled' x2 y2) = distanceUB x1 x2 + +instance Normed x => Normed (Labeled' x y) where + size (Labeled' x _) = size x + + +-------------------------------------------------------------------------------- + +mkMutable [t| POrdering |] +mkMutable [t| Ordering |] +mkMutable [t| forall a. Endo a |] +mkMutable [t| forall a. DualSG a |] +mkMutable [t| forall a. Maybe a |] +mkMutable [t| forall a. Maybe' a |] +mkMutable [t| forall a b. Labeled' a b |] + diff --git a/src/SubHask/Algebra/Array.hs b/src/SubHask/Algebra/Array.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Array.hs @@ -0,0 +1,699 @@ +{-# LANGUAGE CPP #-} +module SubHask.Algebra.Array + ( BArray (..) + , UArray + , Unboxable + ) + where + +import Control.Monad +import Control.Monad.Primitive +import Unsafe.Coerce +import Data.Primitive as Prim +import Data.Primitive.ByteArray +import qualified Data.Vector as V +import qualified Data.Vector as VM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM + +import qualified Prelude as P +import SubHask.Algebra +import SubHask.Algebra.Parallel +import SubHask.Algebra.Vector +import SubHask.Category +import SubHask.Internal.Prelude +import SubHask.Compatibility.Base + +------------------------------------------------------------------------------- +-- boxed arrays + +newtype BArray e = BArray (V.Vector e) + +type instance Index (BArray e) = Int +type instance Logic (BArray e) = Logic e +type instance Scalar (BArray e) = Int +type instance Elem (BArray e) = e +type instance SetElem (BArray e) e' = BArray e' + +---------------------------------------- +-- mutability + +mkMutable [t| forall e. BArray e |] + +---------------------------------------- +-- misc instances + +instance Arbitrary e => Arbitrary (BArray e) where + arbitrary = fmap fromList arbitrary + +instance NFData e => NFData (BArray e) where + rnf (BArray v) = rnf v + +instance Show e => Show (BArray e) where + show (BArray v) = "BArray " ++ show (VG.toList v) + +---------------------------------------- +-- algebra + +instance Semigroup (BArray e) where + (BArray v1)+(BArray v2) = fromList $ VG.toList v1 ++ VG.toList v2 + +instance Monoid (BArray e) where + zero = BArray VG.empty + +instance Normed (BArray e) where + size (BArray v) = VG.length v + +---------------------------------------- +-- comparison + +instance (ValidLogic e, Eq_ e) => Eq_ (BArray e) where + a1==a2 = toList a1==toList a2 + +instance (ClassicalLogic e, POrd_ e) => POrd_ (BArray e) where + inf a1 a2 = fromList $ inf (toList a1) (toList a2) + +instance (ClassicalLogic e, POrd_ e) => MinBound_ (BArray e) where + minBound = zero + +---------------------------------------- +-- container + +instance Constructible (BArray e) where + fromList1 x xs = BArray $ VG.fromList (x:xs) + +instance (ValidLogic e, Eq_ e) => Container (BArray e) where + elem e arr = elem e $ toList arr + +instance Foldable (BArray e) where + + {-# INLINE toList #-} + toList (BArray v) = VG.toList v + + {-# INLINE uncons #-} + uncons (BArray v) = if VG.null v + then Nothing + else Just (VG.head v, BArray $ VG.tail v) + + {-# INLINE unsnoc #-} + unsnoc (BArray v) = if VG.null v + then Nothing + else Just (BArray $ VG.init v, VG.last v) + + {-# INLINE foldMap #-} + foldMap f (BArray v) = VG.foldl' (\a e -> a + f e) zero v + + {-# INLINE foldr #-} + {-# INLINE foldr' #-} + {-# INLINE foldr1 #-} + {-# INLINE foldr1' #-} + {-# INLINE foldl #-} + {-# INLINE foldl' #-} + {-# INLINE foldl1 #-} + {-# INLINE foldl1' #-} + foldr f x (BArray v) = VG.foldr f x v + foldr' f x (BArray v) = {-# SCC foldr'_BArray #-} VG.foldr' f x v + foldr1 f (BArray v) = VG.foldr1 f v + foldr1' f (BArray v) = VG.foldr1' f v + foldl f x (BArray v) = VG.foldl f x v + foldl' f x (BArray v) = VG.foldl' f x v + foldl1 f (BArray v) = VG.foldl1 f v + foldl1' f (BArray v) = VG.foldl1' f v + +instance ValidLogic e => Sliceable (BArray e) where + slice i n (BArray v) = BArray $ VG.slice i n v + +instance ValidLogic e => IxContainer (BArray e) where + lookup i (BArray v) = v VG.!? i + (!) (BArray v) = VG.unsafeIndex v + indices (BArray v) = [0..VG.length v-1] + values (BArray v) = VG.toList v + imap f (BArray v) = BArray $ VG.imap f v + +instance ValidLogic e => Partitionable (BArray e) where + partition n arr = go 0 + where + go i = if i>=length arr + then [] + else (slice i len arr):(go $ i+lenmax) + where + len = if i+lenmax >= length arr + then (length arr)-i + else lenmax + + lenmax = length arr `quot` n + +------------------------------------------------------------------------------- +-- unboxed arrays + +newtype UArray e = UArray (VU.Vector e) + +type instance Index (UArray e) = Int +type instance Logic (UArray e) = Logic e +type instance Scalar (UArray e) = Int +type instance Elem (UArray e) = e +type instance SetElem (UArray e) e' = UArray e' + +---------------------------------------- +-- mutability + +mkMutable [t| forall e. UArray e |] + +---------------------------------------- +-- misc instances + +instance (Unboxable e, Arbitrary e) => Arbitrary (UArray e) where + arbitrary = fmap fromList arbitrary + +instance (Unbox e, NFData e) => NFData (UArray e) where + rnf (UArray v) = rnf v + +instance (Unbox e, Show e) => Show (UArray e) where + show (UArray v) = "UArray " ++ show (VG.toList v) + +---------------------------------------- +-- algebra + +instance Unboxable e => Semigroup (UArray e) where + (UArray v1)+(UArray v2) = fromList $ VG.toList v1 ++ VG.toList v2 + +instance Unbox e => Normed (UArray e) where + size (UArray v) = VG.length v + +---------------------------------------- +-- comparison + +instance (Unboxable e, Eq_ e) => Eq_ (UArray e) where + a1==a2 = toList a1==toList a2 + +instance (Unboxable e, POrd_ e) => POrd_ (UArray e) where + inf a1 a2 = fromList $ inf (toList a1) (toList a2) + +instance (Unboxable e, POrd_ e) => MinBound_ (UArray e) where + minBound = zero + +---------------------------------------- +-- container + +type Unboxable e = (Monoid (UArray e), Constructible (UArray e), ClassicalLogic 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 + +mkConstructible(Int) +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 + , Unbox r + , Prim r + , FreeModule r + , IsScalar r + ) => Constructible (UArray (UVector (s::Symbol) r)) + where + + {-# INLINABLE fromList1 #-} + fromList1 x xs = fromList1N (length $ x:xs) x xs + + {-# INLINABLE fromList1N #-} + fromList1N n x xs = unsafeInlineIO $ do + marr <- safeNewByteArray (n*size*rbytes) 16 + let mv = UArray_MUVector marr 0 n size + + 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=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) + + 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 + , 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 + +instance Unboxable e => Foldable (UArray e) where + + {-# INLINE toList #-} + toList (UArray v) = VG.toList v + + {-# INLINE uncons #-} + uncons (UArray v) = if VG.null v + then Nothing + else Just (VG.head v, UArray $ VG.tail v) + + {-# INLINE unsnoc #-} + unsnoc (UArray v) = if VG.null v + then Nothing + else Just (UArray $ VG.init v, VG.last v) + + {-# INLINE foldMap #-} + foldMap f (UArray v) = VG.foldl' (\a e -> a + f e) zero v + + {-# INLINE foldr #-} + {-# INLINE foldr' #-} + {-# INLINE foldr1 #-} + {-# INLINE foldr1' #-} + {-# INLINE foldl #-} + {-# INLINE foldl' #-} + {-# INLINE foldl1 #-} + {-# INLINE foldl1' #-} + foldr f x (UArray v) = VG.foldr f x v + foldr' f x (UArray v) = {-# SCC foldr'_UArray #-} VG.foldr' f x v + foldr1 f (UArray v) = VG.foldr1 f v + foldr1' f (UArray v) = VG.foldr1' f v + foldl f x (UArray v) = VG.foldl f x v + foldl' f x (UArray v) = VG.foldl' f x v + foldl1 f (UArray v) = VG.foldl1 f v + foldl1' f (UArray v) = VG.foldl1' f v + +instance Unboxable e => Sliceable (UArray e) where + slice i n (UArray v) = UArray $ VG.slice i n v + +instance Unboxable e => IxContainer (UArray e) where + 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 + where + go i = if i>=length arr + then [] + else (slice i len arr):(go $ i+lenmax) + where + len = if i+lenmax >= length arr + then (length arr)-i + else lenmax + + 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 + ( IsScalar elem + , ClassicalLogic elem + , Unbox elem + , Prim elem + ) => Unbox (UVector (n::Symbol) elem) + +--------------------------------------- + +data instance VU.Vector (UVector (n::Symbol) elem) = UArray_UVector + {-#UNPACK#-}!ByteArray + {-#UNPACK#-}!Int -- offset + {-#UNPACK#-}!Int -- length of container + {-#UNPACK#-}!Int -- length of element vectors + +instance + ( IsScalar elem + , Unbox elem + , Prim elem + ) => VG.Vector VU.Vector (UVector (n::Symbol) elem) + where + + {-# INLINABLE basicLength #-} + basicLength (UArray_UVector _ _ n _) = n + + {-# INLINABLE basicUnsafeSlice #-} + basicUnsafeSlice i len' (UArray_UVector arr off n size) = UArray_UVector arr (off+i*size) len' size + + {-# INLINABLE basicUnsafeFreeze #-} + basicUnsafeFreeze (UArray_MUVector marr off n size) = do + arr <- unsafeFreezeByteArray marr + return $ UArray_UVector arr off n size + + {-# INLINABLE basicUnsafeThaw #-} + basicUnsafeThaw (UArray_UVector arr off n size)= do + marr <- unsafeThawByteArray arr + return $ UArray_MUVector marr off n size + + {-# INLINABLE basicUnsafeIndexM #-} + basicUnsafeIndexM (UArray_UVector arr off n size) i = + return $ UVector_Dynamic arr (off+i*size) size + +-- {-# INLINABLE basicUnsafeCopy #-} +-- basicUnsafeCopy mv v = VG.basicUnsafeCopy (vecM mv) (vec v) + +--------------------------------------- + +data instance VUM.MVector s (UVector (n::Symbol) elem) = UArray_MUVector + {-#UNPACK#-}!(MutableByteArray s) + {-#UNPACK#-}!Int -- offset in number of elem + {-#UNPACK#-}!Int -- length of container + {-#UNPACK#-}!Int -- length of element vectors + +instance + ( ClassicalLogic elem + , IsScalar elem + , Unbox elem + , Prim elem + ) => VGM.MVector VUM.MVector (UVector (n::Symbol) elem) + where + + {-# INLINABLE basicLength #-} + basicLength (UArray_MUVector _ _ n _) = n + + {-# INLINABLE basicUnsafeSlice #-} + 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 lenM' = do +-- let elemsize=ptsize +-- marr <- newPinnedByteArray (lenM'*elemsize*Prim.sizeOf (undefined::elem)) +-- return $ UArray_MUVector marr 0 lenM' elemsize + + {-# INLINABLE basicUnsafeRead #-} + basicUnsafeRead mv@(UArray_MUVector marr off n size) i = do + let b=Prim.sizeOf (undefined::elem) + marr' <- safeNewByteArray (size*b) 16 + copyMutableByteArray marr' 0 marr ((off+i*size)*b) (size*b) + arr <- unsafeFreezeByteArray marr' + return $ UVector_Dynamic arr 0 size + + {-# INLINABLE basicUnsafeWrite #-} + basicUnsafeWrite mv@(UArray_MUVector marr1 off1 _ size) loc v@(UVector_Dynamic arr2 off2 _) = + copyByteArray marr1 ((off1+size*loc)*b) arr2 (off2*b) (size*b) + where + b=Prim.sizeOf (undefined::elem) + + {-# INLINABLE basicUnsafeCopy #-} + basicUnsafeCopy (UArray_MUVector marr1 off1 n1 size1) (UArray_MUVector marr2 off2 n2 size2) = + copyMutableByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) + where + b = size1*Prim.sizeOf (undefined::elem) + + {-# INLINABLE basicUnsafeMove #-} + basicUnsafeMove (UArray_MUVector marr1 off1 n1 size1) (UArray_MUVector marr2 off2 n2 size2) = + moveByteArray marr1 (off1*b) marr2 (off2*b) (n2*b) + where + b = size1*Prim.sizeOf (undefined::elem) + +---------------------------------------- +-- Labeled' + +instance + ( Unbox y + , Prim y + , ClassicalLogic a + , IsScalar a + , Unbox a + , Prim a + ) => Unbox (Labeled' (UVector (s::Symbol) a) y) + +--------------------------------------- + +data instance VUM.MVector s (Labeled' (UVector (n::Symbol) elem) y) = UArray_Labeled'_MUVector + {-#UNPACK#-}!(MutableByteArray s) + {-#UNPACK#-}!Int -- offset in number of elem + {-#UNPACK#-}!Int -- length of container + {-#UNPACK#-}!Int -- length of element vectors + +instance + ( ClassicalLogic elem + , IsScalar elem + , Unbox elem + , Prim elem + , Prim y + ) => VGM.MVector VUM.MVector (Labeled' (UVector (n::Symbol) elem) y) + where + + {-# INLINABLE basicLength #-} + basicLength (UArray_Labeled'_MUVector _ _ n _) = n + + {-# INLINABLE basicUnsafeSlice #-} + 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) + + {-# 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 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) + + {-# INLINABLE basicUnsafeRead #-} + basicUnsafeRead mv@(UArray_Labeled'_MUVector marr off n size) i = do + marr' <- safeNewByteArray (size*b) 16 + 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 + return $ Labeled' x y + where + b=Prim.sizeOf (undefined::elem) + ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) + + {-# INLINABLE basicUnsafeWrite #-} + basicUnsafeWrite + (UArray_Labeled'_MUVector marr1 off1 _ size) + i + (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 + where + b=Prim.sizeOf (undefined::elem) + ysize=4 --Prim.sizeOf (undefined::y) `quot` Prim.sizeOf (undefined::elem) + + {-# INLINABLE basicUnsafeCopy #-} + basicUnsafeCopy + (UArray_Labeled'_MUVector marr1 off1 n1 size1) + (UArray_Labeled'_MUVector marr2 off2 n2 size2) + = 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) + + {-# INLINABLE basicUnsafeMove #-} + basicUnsafeMove + (UArray_Labeled'_MUVector marr1 off1 n1 size1) + (UArray_Labeled'_MUVector marr2 off2 n2 size2) + = 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) + +---------------------------------------- + +data instance VU.Vector (Labeled' (UVector (n::Symbol) elem) y) = UArray_Labeled'_UVector + {-#UNPACK#-}!ByteArray + {-#UNPACK#-}!Int -- offset + {-#UNPACK#-}!Int -- length of container + {-#UNPACK#-}!Int -- length of element vectors + +instance + ( IsScalar elem + , Unbox elem + , Prim elem + , Prim y + ) => VG.Vector VU.Vector (Labeled' (UVector (n::Symbol) elem) y) + where + + {-# INLINABLE basicLength #-} + basicLength (UArray_Labeled'_UVector _ _ n _) = n + + {-# INLINABLE basicUnsafeSlice #-} + 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) + + {-# INLINABLE basicUnsafeFreeze #-} + basicUnsafeFreeze (UArray_Labeled'_MUVector marr off n size) = do + arr <- unsafeFreezeByteArray marr + return $ UArray_Labeled'_UVector arr off n size + + {-# INLINABLE basicUnsafeThaw #-} + basicUnsafeThaw (UArray_Labeled'_UVector arr off n size)= do + marr <- unsafeThawByteArray arr + return $ UArray_Labeled'_MUVector marr off n size + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (UArray_Labeled'_UVector arr off n size) i = + 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 + +------------------------------------------------------------------------------- +-- Labeled' + +{- +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)) + +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 (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 + basicUnsafeRead (UMV_Labeled' v) i = do + (!x,!y) <- VGM.basicUnsafeRead v i + return $ Labeled' x y + basicUnsafeWrite (UMV_Labeled' v) i (Labeled' x y) = VGM.basicUnsafeWrite v i (x,y) + basicUnsafeCopy (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicUnsafeCopy v1 v2 + basicUnsafeMove (UMV_Labeled' v1) (UMV_Labeled' v2) = VGM.basicUnsafeMove v1 v2 + basicSet (UMV_Labeled' v1) (Labeled' x y) = VGM.basicSet v1 (x,y) + +newtype instance VU.Vector (Labeled' x y) = UV_Labeled' (VU.Vector (x,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 #-} + {-# INLINE 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 + basicUnsafeSlice i len (UV_Labeled' v) = UV_Labeled' $ VG.basicUnsafeSlice i len v + basicUnsafeIndexM (UV_Labeled' v) i = do + (!x,!y) <- VG.basicUnsafeIndexM v i + return $ Labeled' x y + -} diff --git a/src/SubHask/Algebra/Container.hs b/src/SubHask/Algebra/Container.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Container.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE RebindableSyntax,QuasiQuotes #-} + +-- | This module contains the container algebras +module SubHask.Algebra.Container + where + +import Control.Monad +import GHC.Prim +import Control.Monad +import GHC.TypeLits +import qualified Prelude as P +import Prelude (tail,head,last) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import SubHask.Algebra +import SubHask.Algebra.Ord +import SubHask.Category +import SubHask.Compatibility.Base +import SubHask.SubType +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Deriving + +-------------------------------------------------------------------------------- +-- | A 'Box' is a generalization of an interval from the real numbers into an arbitrary lattice. +-- Boxes are closed in the sense that the end points of the boxes are also contained within the box. +-- +-- See for more details. +data Box v = Box + { smallest :: !v + , largest :: !v + } + deriving (Read,Show) + +mkMutable [t| forall v. Box v |] + +invar_Box_ordered :: (Lattice v, HasScalar v) => Box v -> Logic v +invar_Box_ordered b = largest b >= smallest b + +type instance Scalar (Box v) = Scalar v +type instance Logic (Box v) = Logic v +type instance Elem (Box v) = v +type instance SetElem (Box v) v' = Box v' + +-- misc classes + +instance (Lattice v, Arbitrary v) => Arbitrary (Box v) where + arbitrary = do + v1 <- arbitrary + v2 <- arbitrary + return $ Box (inf v1 v2) (sup v1 v2) + +-- comparison + +instance (Eq v, HasScalar v) => Eq_ (Box v) where + b1==b2 = smallest b1 == smallest b2 + && largest b1 == largest b2 + +-- FIXME: +-- the following instances are "almost" valid +-- POrd_, however, can't be correct without adding an empty element to the Box +-- should we do this? Would it hurt efficiency? +-- +-- instance (Lattice v, HasScalar v) => POrd_ (Box v) where +-- inf b1 b2 = Box +-- { smallest = sup (smallest b1) (smallest b2) +-- , largest = inf (largest b1) (largest b2) +-- } +-- +-- instance (Lattice v, HasScalar v) => Lattice_ (Box v) where +-- sup = (+) + +-- algebra + +instance (Lattice v, HasScalar v) => Semigroup (Box v) where + b1+b2 = Box + { smallest = inf (smallest b1) (smallest b2) + , largest = sup (largest b1) (largest b2) + } + +-- container + +instance (Lattice v, HasScalar v) => Constructible (Box v) where + singleton v = Box v v + +instance (Lattice v, HasScalar v) => Container (Box v) where + elem a (Box lo hi) = a >= lo && a <= hi + +------------------------------------------------------------------------------- + +-- | The Jaccard distance. +-- +-- See for more detail. +newtype Jaccard a = Jaccard a + +deriveHierarchy ''Jaccard + [ ''Ord + , ''Boolean + , ''Ring + , ''Foldable + ] + +instance + ( Lattice_ a + , Field (Scalar a) + , Normed a + , Logic (Scalar a) ~ Logic a + , Boolean (Logic a) + , HasScalar a + ) => Metric (Jaccard a) + where + distance (Jaccard xs) (Jaccard ys) = 1 - size (xs && ys) / size (xs || ys) + +---------------------------------------- + +-- | The Hamming distance. +-- +-- See for more detail. +newtype Hamming a = Hamming a + +deriveHierarchy ''Hamming + [ ''Ord + , ''Boolean + , ''Ring + , ''Foldable + ] + +instance + ( Foldable a + , Eq (Elem a) + , Eq a + , ClassicalLogic (Scalar a) + , HasScalar a + ) => Metric (Hamming a) + where + + {-# INLINE distance #-} + distance (Hamming xs) (Hamming ys) = + {-# SCC distance_Hamming #-} + go (toList xs) (toList ys) 0 + where + go [] [] i = i + go xs [] i = i + fromIntegral (size xs) + go [] ys i = i + fromIntegral (size ys) + go (x:xs) (y:ys) i = go xs ys $ i + if x==y + then 0 + else 1 + + {-# INLINE distanceUB #-} + distanceUB (Hamming xs) (Hamming ys) dist = + {-# SCC distanceUB_Hamming #-} + go (toList xs) (toList ys) 0 + where + go xs ys tot = if tot > dist + then tot + else go_ xs ys tot + where + go_ (x:xs) (y:ys) i = go xs ys $ i + if x==y + then 0 + else 1 + go_ [] [] i = i + go_ xs [] i = i + fromIntegral (size xs) + go_ [] ys i = i + fromIntegral (size ys) + +---------------------------------------- + +-- | The Levenshtein distance is a type of edit distance, but it is often referred to as THE edit distance. +-- +-- FIXME: The implementation could be made faster in a number of ways; +-- for example, the Hamming distance is a lower bound on the Levenshtein distance +-- +-- See for more detail. +newtype Levenshtein a = Levenshtein a + +deriveHierarchy ''Levenshtein + [ ''Ord + , ''Boolean + , ''Ring + , ''Foldable + ] + +instance + ( Foldable a + , Eq (Elem a) + , Eq a + , Show a + , HasScalar a + , ClassicalLogic (Scalar a) + , Bounded (Scalar a) + ) => Metric (Levenshtein a) + where + + {-# INLINE distance #-} + distance (Levenshtein xs) (Levenshtein ys) = + {-# SCC distance_Levenshtein #-} + fromIntegral $ dist (toList xs) (toList ys) + +-- | this function stolen from +-- https://www.haskell.org/haskellwiki/Edit_distance +dist :: Eq a => [a] -> [a] -> Int +dist a b + = last (if lab == 0 + then mainDiag + else if lab > 0 + then lowers P.!! (lab - 1) + else{- < 0 -} uppers P.!! (-1 - lab)) + where + mainDiag = oneDiag a b (head uppers) (-1 : head lowers) + uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals + lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals + eachDiag a [] diags = [] + eachDiag a (bch:bs) (lastDiag:diags) = oneDiag a bs nextDiag lastDiag : eachDiag a bs diags + where + nextDiag = head (tail diags) + oneDiag a b diagAbove diagBelow = thisdiag + where + doDiag [] b nw n w = [] + doDiag a [] nw n w = [] + doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w)) + where + me = if ach == bch then nw else 1 + min3 (head w) nw (head n) + firstelt = 1 + head diagBelow + thisdiag = firstelt : doDiag a b firstelt diagAbove (tail diagBelow) + lab = size a - size b + min3 x y z = if x < y then x else min y z + +---------------------------------------- + +-- | Compensated sums are more accurate for floating point math +-- +-- FIXME: There are many different types of compensated sums, they should be implemented too. +-- +-- FIXME: Is this the best representation for compensated sums? +-- The advantage is that we can make any algorithm work in a compensated or uncompensated manner by just changing the types. +-- This is closely related to the measure theory containers work. +-- +-- See, e.g. for more detail. +newtype Uncompensated s = Uncompensated s + +deriveHierarchy ''Uncompensated + [ ''Ord + , ''Boolean + , ''Normed + , ''Monoid + , ''Constructible + ] + +instance Foldable s => Foldable (Uncompensated s) where + uncons (Uncompensated s) = case uncons s of + Nothing -> Nothing + Just (x,xs) -> Just (x, Uncompensated xs) + + unsnoc (Uncompensated s) = case unsnoc s of + Nothing -> Nothing + Just (xs,x) -> Just (Uncompensated xs,x) + + foldMap f (Uncompensated s) = foldMap f s + foldr f a (Uncompensated s) = foldr f a s + foldr' f a (Uncompensated s) = foldr' f a s + foldr1 f (Uncompensated s) = foldr1 f s + foldr1' f (Uncompensated s) = foldr1' f s + foldl f a (Uncompensated s) = foldl f a s + foldl' f a (Uncompensated s) = foldl' f a s + foldl1 f (Uncompensated s) = foldl1 f s + foldl1' f (Uncompensated s) = foldl1' f s + + sum = foldl' (+) zero + + +---------------------------------------- + +-- | Lexical ordering of foldable types. +-- +-- NOTE: The default ordering for containers is the partial ordering by inclusion. +-- In most cases this makes more sense intuitively. +-- But this is NOT the ordering in the Prelude, because the Prelude does not have partial orders. +-- Therefore, in the prelude, @@"abc" < "def"@@, but for us, "abc" and "def" are incomparable "PNA". +-- The Lexical newtype gives us the total ordering provided by the Prelude. +-- +-- FIXME: there are more container orderings that probably deserve implementation +newtype Lexical a = Lexical { unLexical :: a } + +deriveHierarchy ''Lexical [ ''Eq_, ''Foldable, ''Constructible, ''Monoid ] +-- deriveHierarchy ''Lexical [ ''Eq_, ''Monoid ] + +instance + (Logic a~Bool + , Ord (Elem a) + , Foldable a + , Eq_ a + ) => POrd_ (Lexical a) + where + inf a1 a2 = if a1y + then False + else go xs ys + go [] [] = False + go [] _ = True + go _ [] = False + +instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => MinBound_ (Lexical a) where + minBound = Lexical zero + +instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => Lattice_ (Lexical a) where + sup a1 a2 = if a1>a2 then a1 else a2 + + (Lexical a1)>(Lexical a2) = go (toList a1) (toList a2) + where + go (x:xs) (y:ys) = if x>y + then True + else if x Ord_ (Lexical a) where + +--------------------------------------- + +newtype ComponentWise a = ComponentWise { unComponentWise :: a } + +deriveHierarchy ''ComponentWise [ ''Eq_, ''Foldable, ''Monoid ] +-- deriveHierarchy ''ComponentWise [ ''Monoid ] + +class (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a +instance (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a + +-- instance (SimpleContainerLogic a, Eq_ (Elem a), Foldable a) => Eq_ (ComponentWise a) where +-- (ComponentWise a1)==(ComponentWise a2) = toList a1==toList a2 + +instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => POrd_ (ComponentWise a) where + inf (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2) + where + go (x:xs) (y:ys) = inf x y:go xs ys + go _ _ = [] + +instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => MinBound_ (ComponentWise a) where + minBound = ComponentWise zero + +instance (SimpleContainerLogic a, Eq_ a, Lattice_ (Elem a), Foldable a) => Lattice_ (ComponentWise a) where + sup (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2) + where + go (x:xs) (y:ys) = sup x y:go xs ys + go xs [] = xs + go [] ys = ys + diff --git a/src/SubHask/Algebra/Group.hs b/src/SubHask/Algebra/Group.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Group.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE RebindableSyntax,QuasiQuotes #-} + +-- | This module contains most of the math types not directly related to linear algebra +-- +-- FIXME: there is probably a better name for this +module SubHask.Algebra.Group + where + +import Control.Monad +import qualified Prelude as P + +import SubHask.Algebra +import SubHask.Category +import SubHask.Mutable +import SubHask.SubType +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Deriving + +------------------------------------------------------------------------------- +-- non-negative objects + +newtype NonNegative t = NonNegative { unNonNegative :: t } + +deriveHierarchy ''NonNegative [ ''Enum, ''Boolean, ''Rig, ''Metric ] + +instance (Ord t, Group t) => Cancellative (NonNegative t) where + (NonNegative t1)-(NonNegative t2) = if diff>zero + then NonNegative diff + else NonNegative zero + where + diff=t1-t2 + +------------------- + +{- +newtype a +> b = HomHask { unHomHask :: a -> b } +infixr +> + +unsafeHomHask2 :: (a -> b -> c) -> (a +> b +> c) +unsafeHomHask2 f = HomHask (\a -> HomHask $ \b -> f a b) + +instance Category (+>) where + type ValidCategory (+>) a = () + id = HomHask id + (HomHask a).(HomHask b) = HomHask $ a.b + +instance Sup (+>) (->) (->) +instance Sup (->) (+>) (->) +instance (+>) <: (->) where + embedType_ = Embed2 unHomHask + +instance Monoidal (+>) where + type Tensor (+>) = (,) + tensor = unsafeHomHask2 $ \a b -> (a,b) + +instance Braided (+>) where + braid = HomHask $ \(a,b) -> (b,a) + unbraid = braid + +instance Closed (+>) where + curry (HomHask f) = HomHask $ \ a -> HomHask $ \b -> f (a,b) + uncurry (HomHask f) = HomHask $ \ (a,b) -> unHomHask (f a) b + +mkSubtype [t|Int|] [t|Integer|] 'toInteger + +[subhask| +poop :: (Semigroup' g, Ring g) => g +> g +poop = (+:1) +|] + +class Semigroup' a where + (+:) :: a +> a +> a + +instance Semigroup' Int where (+:) = unsafeHomHask2 (+) + +instance Semigroup' [a] where (+:) = unsafeHomHask2 (+) + +f :: Integer +> Integer +f = HomHask $ \i -> i+1 + +n1 = NonNegative 5 :: NonNegative Int +n2 = NonNegative 3 :: NonNegative Int +i1 = 5 :: Int +i2 = 3 :: Int +j1 = 5 :: Integer +j2 = 3 :: Integer +-} + +------------------------------------------------------------------------------- +-- integers modulo n + +-- | Maps members of an equivalence class into the "canonical" element. +class Quotient a (b::k) where + mkQuotient :: a -> a/b + +-- | The type of equivalence classes created by a mod b. +newtype (/) (a :: *) (b :: k) = Mod a + +-- mkDefaultMutable [t| forall a b. a/b |] + +-- newtype instance Mutable m (a/b) = Mutable_Mod (Mutable m a) + +instance (Quotient a b, Arbitrary a) => Arbitrary (a/b) where + arbitrary = liftM mkQuotient arbitrary + +deriveHierarchyFiltered ''(/) [ ''Eq_, ''P.Ord ] [''Arbitrary] + +instance (Semigroup a, Quotient a b) => Semigroup (a/b) where + (Mod z1) + (Mod z2) = mkQuotient $ z1 + z2 + +instance (Abelian a, Quotient a b) => Abelian (a/b) + +instance (Monoid a, Quotient a b) => Monoid (a/b) + where zero = Mod zero + +instance (Cancellative a, Quotient a b) => Cancellative (a/b) where + (Mod i1)-(Mod i2) = mkQuotient $ i1-i2 + +instance (Group a, Quotient a b) => Group (a/b) where + negate (Mod i) = mkQuotient $ negate i + +instance (Rg a, Quotient a b) => Rg (a/b) where + (Mod z1)*(Mod z2) = mkQuotient $ z1 * z2 + +instance (Rig a, Quotient a b) => Rig (a/b) where + one = Mod one + +instance (Ring a, Quotient a b) => Ring (a/b) where + fromInteger i = mkQuotient $ fromInteger i + +type instance ((a/b)> Module (a/b) where + (Mod a) .* r = mkQuotient $ a .* r + +-- | The type of integers modulo n +type Z (n::Nat) = Integer/n + +instance KnownNat n => Quotient Int n + where + mkQuotient i = Mod $ i `P.mod` (fromIntegral $ natVal (Proxy::Proxy n)) + +instance KnownNat n => Quotient Integer n + where + mkQuotient i = Mod $ i `P.mod` (natVal (Proxy::Proxy n)) + +-- | Extended Euclid's algorithm is used to calculate inverses in modular arithmetic +extendedEuclid :: (Eq t, Integral t) => t -> t -> (t,t,t,t,t,t) +extendedEuclid a b = go zero one one zero b a + where + go s1 s0 t1 t0 r1 r0 = if r1==zero + then (s1,s0,t1,t0,undefined,r0) + else go s1' s0' t1' t0' r1' r0' + where + q = r0 `div` r1 + (r0', r1') = (r1,r0-q*r1) + (s0', s1') = (s1,s0-q*s1) + (t0', t1') = (t1,t0-q*t1) + +------------------------------------------------------------------------------- +-- example: Galois field + +-- | @Galois p k@ is the type of integers modulo p^k, where p is prime. +-- All finite fields have this form. +-- +-- See wikipedia for more details. +-- +-- FIXME: Many arithmetic operations over Galois Fields can be implemented more efficiently than the standard operations. +-- See . +newtype Galois (p::Nat) (k::Nat) = Galois (Z (p^k)) + +type instance Galois p k >< Integer = Galois p k + +deriveHierarchy ''Galois [''Eq_,''Ring] + +instance KnownNat (p^k) => Module (Galois p k) where + z .* i = Galois (Mod i) * z + +instance (Prime p, KnownNat (p^k)) => Field (Galois p k) where + reciprocal (Galois (Mod i)) = Galois $ mkQuotient $ t + where + (_,_,_,t,_,_) = extendedEuclid n i + n = natVal (Proxy::Proxy (p^k)) + +------------------- + +class Prime (n::Nat) +instance Prime 1 +instance Prime 2 +instance Prime 3 +instance Prime 5 +instance Prime 7 +instance Prime 11 +instance Prime 13 +instance Prime 17 +instance Prime 19 +instance Prime 23 + +------------------------------------------------------------------------------- +-- the symmetric group + +-- | The symmetric group is one of the simplest and best studied finite groups. +-- It is efficiently implemented as a "BijectiveT SparseFunction (Z n) (Z n)". +-- See + +-- newtype Sym (n::Nat) = Sym (BijectiveT SparseFunction (Z n) (Z n)) +-- +-- instance KnownNat n => Monoid (Sym n) where +-- zero = Sym id +-- (Sym s1)+(Sym s2) = Sym $ s1.s2 +-- +-- instance KnownNat n => Group (Sym n) where +-- negate (Sym s) = Sym $ inverse s + +------------------------------------------------------------------------------- +-- | The GrothendieckGroup is a general way to construct groups from cancellative semigroups. +-- +-- FIXME: How should this be related to the Ratio type? +-- +-- See for more details. +data GrothendieckGroup g where + GrotheindieckGroup :: Cancellative g => g -> GrothendieckGroup g + +------------------------------------------------------------------------------- +-- the vedic square + +-- | The Vedic Square always forms a monoid, +-- and sometimes forms a group depending on the value of "n". +-- (The type system isn't powerful enough to encode these special cases.) +-- +-- See for more detail. +newtype VedicSquare (n::Nat) = VedicSquare (Z n) + +deriveHierarchy ''VedicSquare [''Eq_] + +instance KnownNat n => Semigroup (VedicSquare n) where + (VedicSquare v1)+(VedicSquare v2) = VedicSquare $ v1*v2 + +instance KnownNat n => Monoid (VedicSquare n) where + zero = VedicSquare one + +------------------------------------------------------------------------------ +-- Minkowski addition + +-- | TODO: implement +-- More details available at . + + + diff --git a/src/SubHask/Algebra/Logic.hs b/src/SubHask/Algebra/Logic.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Logic.hs @@ -0,0 +1,201 @@ +module SubHask.Algebra.Logic + where + +import Control.Monad +import qualified Prelude as P +import Test.QuickCheck.Gen (suchThat,oneof) + +import SubHask.Algebra +import SubHask.Category +import SubHask.Compatibility.Base +import SubHask.SubType +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Deriving + +class (Ord r, Ring r) => OrdRing_ r +instance (Ord r, Ring r) => OrdRing_ r + +-------------------------------------------------------------------------------- + +-- | The Goedel fuzzy logic is one of the simpler fuzzy logics. +-- In particular, it is an example of a Heyting algebra that is not also a Boolean algebra. +-- +-- See the +type Goedel = Goedel_ Rational + +newtype Goedel_ r = Goedel_ r + +deriveHierarchyFiltered ''Goedel_ [ ''Eq_ ] [ ''Arbitrary ] + +instance (OrdRing_ r, Arbitrary r) => Arbitrary (Goedel_ r) where + arbitrary = fmap Goedel_ $ arbitrary `suchThat` ((>=0) && (<=1)) + +instance OrdRing_ r => POrd_ (Goedel_ r) where +-- inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ max 0 (r1 + r2 - 1) + inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ min r1 r2 +-- inf (Goedel_ r1) (Goedel_ r2) = Goedel_ $ r1*r2 + +instance OrdRing_ r => Lattice_ (Goedel_ r) where +-- sup (Goedel_ r1) (Goedel_ r2) = Goedel_ $ min 1 (r1 + r2) + sup (Goedel_ r1) (Goedel_ r2) = Goedel_ $ max r1 r2 +-- sup l1 l2 = not $ inf (not l1) (not l2) + +instance OrdRing_ r => Ord_ (Goedel_ r) + +instance OrdRing_ r => MinBound_ (Goedel_ r) where + minBound = Goedel_ 0 + +instance OrdRing_ r => Bounded (Goedel_ r) where + maxBound = Goedel_ 1 + +instance OrdRing_ r => Heyting (Goedel_ r) where +-- (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ (1 - r1 + r2) + (Goedel_ r1)==>(Goedel_ r2) = if r1 <= r2 then Goedel_ 1 else Goedel_ r2 + +--------------------------------------- + +-- | H3 is the smallest Heyting algebra that is not also a boolean algebra. +-- In addition to true and false, there is a value to represent whether something's truth is unknown. +-- AFAIK it has no real applications. +-- +-- See +data H3 + = HTrue + | HFalse + | HUnknown + deriving (Read,Show) + +instance NFData H3 where + rnf HTrue = () + rnf HFalse = () + rnf HUnknown = () + +instance Arbitrary H3 where + arbitrary = oneof $ map return [HTrue, HFalse, HUnknown] + +type instance Logic H3 = Bool + +instance Eq_ H3 where + HTrue == HTrue = True + HFalse == HFalse = True + HUnknown == HUnknown = True + _ == _ = False + +instance POrd_ H3 where + inf HTrue HTrue = HTrue + inf HTrue HUnknown = HUnknown + inf HUnknown HTrue = HUnknown + inf HUnknown HUnknown = HUnknown + inf _ _ = HFalse + +instance Lattice_ H3 where + sup HFalse HFalse = HFalse + sup HFalse HUnknown = HUnknown + sup HUnknown HFalse = HUnknown + sup HUnknown HUnknown = HUnknown + sup _ _ = HTrue + +instance Ord_ H3 + +instance MinBound_ H3 where + minBound = HFalse + +instance Bounded H3 where + maxBound = HTrue + +instance Heyting H3 where + _ ==> HTrue = HTrue + HFalse ==> _ = HTrue + HTrue ==> HFalse = HFalse + HUnknown ==> HUnknown = HTrue + HUnknown ==> HFalse = HFalse + _ ==> _ = HUnknown + +--------------------------------------- + +-- | K3 stands for Kleene's 3-valued logic. +-- In addition to true and false, there is a value to represent whether something's truth is unknown. +-- K3 is an example of a logic that is neither Boolean nor Heyting. +-- +-- See . +-- +-- FIXME: We need a way to represent implication and negation for logics outside of the Lattice hierarchy. +data K3 + = KTrue + | KFalse + | KUnknown + deriving (Read,Show) + +instance NFData K3 where + rnf KTrue = () + rnf KFalse = () + rnf KUnknown = () + +instance Arbitrary K3 where + arbitrary = oneof $ map return [KTrue, KFalse, KUnknown] + +type instance Logic K3 = Bool + +instance Eq_ K3 where + KTrue == KTrue = True + KFalse == KFalse = True + KUnknown == KUnknown = True + _ == _ = False + +instance POrd_ K3 where + inf KTrue KTrue = KTrue + inf KTrue KUnknown = KUnknown + inf KUnknown KTrue = KUnknown + inf KUnknown KUnknown = KUnknown + inf _ _ = KFalse + +instance Lattice_ K3 where + sup KFalse KFalse = KFalse + sup KFalse KUnknown = KUnknown + sup KUnknown KFalse = KUnknown + sup KUnknown KUnknown = KUnknown + sup _ _ = KTrue + +instance Ord_ K3 + +instance MinBound_ K3 where + minBound = KFalse + +instance Bounded K3 where + maxBound = KTrue + +-------------------------------------------------------------------------------- +-- | A Boolean algebra is a special type of Ring. +-- Their applications (set-like operations) tend to be very different than Rings, so it makes sense for the class hierarchies to be completely unrelated. +-- The "Boolean2Ring" type, however, provides the correct transformation. + +newtype Boolean2Ring b = Boolean2Ring b + +deriveHierarchy ''Boolean2Ring [ ''Boolean ] + +mkBoolean2Ring :: Boolean b => b -> Boolean2Ring b +mkBoolean2Ring = Boolean2Ring + +instance (IsMutable b, Boolean b, ValidLogic b) => Semigroup (Boolean2Ring b) where + (Boolean2Ring b1)+(Boolean2Ring b2) = Boolean2Ring $ (b1 || b2) && not (b1 && b2) + +instance (IsMutable b, Boolean b, ValidLogic b) => Abelian (Boolean2Ring b) + +instance (IsMutable b, Boolean b, ValidLogic b) => Monoid (Boolean2Ring b) where + zero = Boolean2Ring $ false + +instance (IsMutable b, Boolean b, ValidLogic b) => Cancellative (Boolean2Ring b) where + (-)=(+) +-- b1-b2 = b1+negate b2 + +instance (IsMutable b, Boolean b, ValidLogic b) => Group (Boolean2Ring b) where + negate = id +-- negate (Boolean2Ring b) = Boolean2Ring $ not b + +instance (IsMutable b, Boolean b, ValidLogic b) => Rg (Boolean2Ring b) where + (Boolean2Ring b1)*(Boolean2Ring b2) = Boolean2Ring $ b1 && b2 + +instance (IsMutable b, Boolean b, ValidLogic b) => Rig (Boolean2Ring b) where + one = Boolean2Ring $ true + +instance (IsMutable b, Boolean b, ValidLogic b) => Ring (Boolean2Ring b) diff --git a/src/SubHask/Algebra/Metric.hs b/src/SubHask/Algebra/Metric.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Metric.hs @@ -0,0 +1,115 @@ +-- | This module defines the algebra over various types of balls in metric spaces +module SubHask.Algebra.Metric + where + +import SubHask.Category +import SubHask.Algebra +import SubHask.Algebra.Ord +-- import SubHask.Monad +-- import SubHask.Compatibility.Base +import SubHask.Internal.Prelude +import Control.Monad + +import Data.List (nubBy,permutations,sort) +import System.IO + +-------------------------------------------------------------------------------- + +-- | Useful for identifying tree metrics. +printTriDistances :: (Show (Scalar m), Metric m) => m -> m -> m -> IO () +printTriDistances m1 m2 m3 = do + putStrLn $ show (distance m1 m2) ++ " <= " + show (distance m2 m3 + distance m1 m3) + putStrLn $ show (distance m1 m3) ++ " <= " + show (distance m2 m3 + distance m1 m2) + putStrLn $ show (distance m2 m3) ++ " <= " + show (distance m1 m2 + distance m1 m3) + +-- | There are three distinct perfect matchings in every complete 4 node graph. +-- A metric is a tree metric iff two of these perfect matchings have the same weight. +-- This is called the 4 points condition. +-- printQuadDistances :: (Ord (Scalar m), Show (Scalar m), Metric m) => m -> m -> m -> m -> IO () +printQuadDistances m1 m2 m3 m4 = do + forM_ xs $ \(match,dist) -> do + putStrLn $ match ++ " = " ++ show dist + + where + xs = nubBy (\(x,_) (y,_) -> x==y) + $ sort + $ map mkMatching + $ 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:[]) + ] + , distance n1 n2 + distance n3 n4 + ) + +-------------------------------------------------------------------------------- + +-- | The closed balls in metric space. +-- Note that since we are not assuming any special structure, addition is rather inefficient. +-- +-- FIXME: +-- There are several valid ways to perform the addition; which should we use? +-- We could add Lattice instances in a similar way as we could with Box if we added an empty element; should we do this? + +data Ball v = Ball + { radius :: !(Scalar v) + , center :: !v + } + +mkMutable [t| forall b. Ball b |] + +invar_Ball_radius :: (HasScalar v) => Ball v -> Logic (Scalar v) +invar_Ball_radius b = radius b >= 0 + +type instance Scalar (Ball v) = Scalar v +type instance Logic (Ball v) = Logic v +type instance Elem (Ball v) = v +type instance SetElem (Ball v) v' = Ball v' + +-- misc classes + +deriving instance (Read v, Read (Scalar v)) => Read (Ball v) +deriving instance (Show v, Show (Scalar v)) => Show (Ball v) + +instance (Arbitrary v, Arbitrary (Scalar v), HasScalar v) => Arbitrary (Ball v) where + arbitrary = do + r <- arbitrary + c <- arbitrary + return $ Ball (abs r) c + +instance (NFData v, NFData (Scalar v)) => NFData (Ball v) where + rnf b = deepseq (center b) + $ rnf (radius b) + +-- comparison + +instance (Eq v, HasScalar v) => Eq_ (Ball v) where + b1 == b2 = radius b1 == radius b2 + && center b1 == center b2 + +-- algebra + +instance (Metric v, HasScalar v, ClassicalLogic v) => Semigroup (Ball v) where + b1+b2 = b1 { radius = radius b2 + radius b1 + distance (center b1) (center b2) } +-- b1+b2 = b1 { radius = radius b2 + max (radius b1) (distance (center b1) (center b2)) } + +-- b1+b2 = b1' { radius = max (radius b1') (radius b2' + distance (center b1') (center b2')) } +-- where +-- (b1',b2') = if radius b1 > radius b2 +-- then (b1,b2) +-- else (b2,b1) + +-- container + +instance (Metric v, HasScalar v, ClassicalLogic v) => Constructible (Ball v) where + singleton v = Ball 0 v + +instance (Metric v, HasScalar v, ClassicalLogic v) => Container (Ball v) where + elem v b = not $ isFartherThan v (center b) (radius b) + +-------------------------------------------------------------------------------- + +-- | FIXME: In a Banach space we can make Ball addition more efficient by moving the center to an optimal location. +newtype BanachBall v = BanachBall (Ball v) diff --git a/src/SubHask/Algebra/Ord.hs b/src/SubHask/Algebra/Ord.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Ord.hs @@ -0,0 +1,63 @@ +-- | This module contains any objects relating to order theory +module SubHask.Algebra.Ord + where + +-- import Control.Monad +import qualified Prelude as P + +import SubHask.Algebra +import SubHask.Category +import SubHask.Mutable +import SubHask.SubType +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 +------------- + +newtype WithPreludeOrd a = WithPreludeOrd { unWithPreludeOrd :: a } + deriving Storable + +instance Show a => Show (WithPreludeOrd a) where + show (WithPreludeOrd a) = show a + +-- | FIXME: for some reason, our deriving mechanism doesn't work on Show here; +-- It causes's Set's show to enter an infinite loop +deriveHierarchyFiltered ''WithPreludeOrd [ ''Eq_, ''Enum, ''Boolean, ''Ring, ''Metric ] [ ''Show ] + +instance Eq a => P.Eq (WithPreludeOrd a) where + {-# INLINE (==) #-} + a==b = a==b + +instance Ord a => P.Ord (WithPreludeOrd a) where + {-# INLINE (<=) #-} + a<=b = a<=b diff --git a/src/SubHask/Algebra/Parallel.hs b/src/SubHask/Algebra/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Parallel.hs @@ -0,0 +1,205 @@ +-- | Every monoid homomorphism from a Container can be parallelized. +-- And if you believe that @NC /= P@, then every parallel algorithm is induced by a monoid in this manner. +module SubHask.Algebra.Parallel + ( parallel + , disableMultithreading + , Partitionable (..) + , law_Partitionable_length + , law_Partitionable_monoid + + -- * parallel helpers + , parallelBlockedN + , parallelBlocked + , unsafeParallelInterleavedN + , unsafeParallelInterleaved + , parallelInterleaved + ) + where + +import SubHask.Algebra +import SubHask.Category +import SubHask.Internal.Prelude + +import Control.Monad + +import qualified Prelude as P +import Control.Concurrent +import Control.Parallel +import Control.Parallel.Strategies +import System.IO.Unsafe + +-------------------------------------------------------------------------------- + +-- | Converts any monoid homomorphism into an efficient parallelized function. +-- This is the only function you should have to care about. +-- It uses rewrite rules to select the most cache-efficient parallelization method for the particular data types called. +{-# INLINABLE parallel #-} +parallel :: + ( Partitionable domain + , Monoid range + , NFData range + ) => (domain -> range) -- ^ sequential monoid homomorphism + -> (domain -> range) -- ^ parallel monoid homomorphism +parallel = parallelBlocked + +parallelN :: + ( Partitionable domain + , Monoid range + , NFData range + ) => Int -- ^ number of parallel threads + -> (domain -> range) -- ^ sequential monoid homomorphism + -> (domain -> range) -- ^ parallel monoid homomorphism +parallelN=parallelBlockedN + +-- | Let's you specify the exact number of threads to parallelize over. +{-# INLINE [2] parallelBlockedN #-} +parallelBlockedN :: + ( Partitionable domain + , Monoid range + , NFData range + ) => Int -- ^ number of parallel threads + -> (domain -> range) -- ^ sequential monoid homomorphism + -> (domain -> range) -- ^ parallel monoid homomorphism +parallelBlockedN n f = parfoldtree1 . parMap rdeepseq f . partition n + +-- The function automatically detects the number of available processors and parallelizes the function accordingly. +{-# INLINE [2] parallelBlocked #-} +parallelBlocked :: + ( Partitionable domain + , Monoid range + , NFData range + ) => (domain -> range) -- ^ sequential monoid homomorphism + -> (domain -> range) -- ^ parallel monoid homomorphism +parallelBlocked = if dopar + then parallelBlockedN numproc + else id + where + numproc = unsafePerformIO getNumCapabilities + dopar = numproc > 1 + +-- | Let's you specify the exact number of threads to parallelize over. +-- This function is unsafe because if our @range@ is not "Abelian", this function changes the results. +{-# INLINE [2] unsafeParallelInterleavedN #-} +unsafeParallelInterleavedN :: + ( Partitionable domain + , Monoid range + , NFData range + ) => Int -- ^ number of parallel threads + -> (domain -> range) -- ^ sequential monoid homomorphism + -> (domain -> range) -- ^ parallel monoid homomorphism +unsafeParallelInterleavedN n f = parfoldtree1 . parMap rdeepseq f . partitionInterleaved n + +-- | This function automatically detects the number of available processors and parallelizes the function accordingly. +-- This function is unsafe because if our @range@ is not "Abelian", this function changes the results. +{-# INLINE [2] unsafeParallelInterleaved #-} +unsafeParallelInterleaved :: + ( Partitionable domain + , Monoid range + , NFData range + ) => (domain -> range) -- ^ sequential monoid homomorphism + -> (domain -> range) -- ^ parallel monoid homomorphism +unsafeParallelInterleaved = if dopar + then unsafeParallelInterleavedN numproc + else id + where + numproc = unsafePerformIO getNumCapabilities + dopar = numproc > 1 + +-- | This function automatically detects the number of available processors and parallelizes the function accordingly. +-- This function is safe (i.e. it won't affect the output) because it requires the "Abelian" constraint. +{-# INLINE [2] parallelInterleaved #-} +parallelInterleaved :: + ( Partitionable domain + , Abelian range + , Monoid range + , NFData range + ) => (domain -> range) -- ^ sequential monoid homomorphism + -> (domain -> range) -- ^ parallel monoid homomorphism +parallelInterleaved = unsafeParallelInterleaved + +-- | This forces a function to be run with only a single thread. +-- That is, the function is executed as if @-N1@ was passed into the program rather than whatever value was actually used. +-- Subsequent functions are not affected. +-- +-- Why is this useful? +-- The GHC runtime system can make non-threaded code run really slow when many threads are enabled. +-- For example, I have found instances of sequential code taking twice as long when the @-N16@ flag is passed to the run time system. +-- By wrapping those function calls in "disableMultithreading", we restore the original performance. +{-# INLINABLE disableMultithreading #-} +disableMultithreading :: IO a -> IO a +disableMultithreading a = do + n <- getNumCapabilities + setNumCapabilities 1 + a' <- a + setNumCapabilities n + return a' + +-------------------------------------------------------------------------------- + +-- | A Partitionable container can be split up into an arbitrary number of subcontainers of roughly equal size. +class (Monoid t, Foldable t, Constructible t) => Partitionable t where + + -- | The Int must be >0 + {-# INLINABLE partition #-} + partition :: Int -> t -> [t] + partition i t = map (\(x:xs) -> fromList1 x xs) $ partitionBlocked_list i $ toList t + + {-# INLINABLE partitionInterleaved #-} + partitionInterleaved :: Int -> t -> [t] + partitionInterleaved i t = map (\(x:xs) -> fromList1 x xs) $ partitionInterleaved_list i $ toList t + +law_Partitionable_length :: (ClassicalLogic t, Partitionable t) => Int -> t -> Bool +law_Partitionable_length n t + | n > 0 = length (partition n t) <= n + | otherwise = True + +law_Partitionable_monoid :: (ClassicalLogic t, Eq_ t, Partitionable t) => Int -> t -> Bool +law_Partitionable_monoid n t + | n > 0 = sum (partition n t) == t + | otherwise = True + +-- | Like foldtree1, but parallel +{-# INLINABLE parfoldtree1 #-} +parfoldtree1 :: Monoid a => [a] -> a +parfoldtree1 as = case go as of + [] -> zero + [a] -> a + as -> parfoldtree1 as + where + go [] = [] + go [a] = [a] + go (a1:a2:as) = par a12 $ a12:go as + where + a12=a1+a2 + +instance Partitionable [a] where + {-# INLINABLE partition #-} + partition = partitionBlocked_list + + {-# INLINABLE partitionInterleaved #-} + partitionInterleaved = partitionInterleaved_list + +{-# INLINABLE partitionBlocked_list #-} +partitionBlocked_list :: Int -> [a] -> [[a]] +partitionBlocked_list n xs = go xs + where + go [] = [] + go xs = a:go b + where + (a,b) = P.splitAt len xs + + size = length xs + len = size `div` n + + if size `rem` n == 0 then 0 else 1 + +-- | This is an alternative definition for list partitioning. +-- It should be faster on large lists because it only requires one traversal. +-- But it also breaks parallelism for non-commutative operations. +{-# INLINABLE partitionInterleaved_list #-} +partitionInterleaved_list :: Int -> [a] -> [[a]] +partitionInterleaved_list n xs = [map snd $ P.filter (\(i,x)->i `mod` n==j) ixs | j<-[0..n-1]] + where + ixs = addIndex 0 xs + addIndex i [] = [] + addIndex i (x:xs) = (i,x):(addIndex (i+1) xs) + diff --git a/src/SubHask/Algebra/Vector.hs b/src/SubHask/Algebra/Vector.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Algebra/Vector.hs @@ -0,0 +1,1812 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | Dense vectors and linear algebra operations. +-- +-- NOTE: +-- This module is a prototype for what a more fully featured linear algebra module might look like. +-- There are a number of efficiency related features that are missing. +-- In particular, matrices will get copied more often than they need to, and only the most naive dense matrix format is currently supported. +-- These limitations are due to using "hmatrix" as a backend (all operations should be at least as fast as in hmatrix). +-- Future iterations will use something like "hblas" to get finer lever control. +-- +-- +-- FIXME: +-- Shouldn't expose the constructors, but they're needed for the "SubHask.Algebra.Array" types. +-- +-- FIXME: +-- We shouldn't need to call out to the FFI in order to get SIMD instructions. +module SubHask.Algebra.Vector + ( SVector (..) + , UVector (..) + , Unbox + , type (+>) + , 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 + ) + where + +import qualified Prelude as P + +import Control.Monad.Primitive +import Control.Monad +import Data.Primitive hiding (sizeOf) +import Debug.Trace +import qualified Data.Primitive as Prim +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Marshal.Utils +import Test.QuickCheck.Gen (frequency) + +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import qualified Data.Vector.Storable as VS +import qualified Data.Packed.Matrix as HM +import qualified Numeric.LinearAlgebra as HM + +import qualified Prelude as P +import SubHask.Algebra +import SubHask.Category +import SubHask.Compatibility.Base +import SubHask.Internal.Prelude +import SubHask.SubType + +import Data.Csv (FromRecord,FromField,parseRecord) + +import System.IO.Unsafe +import Unsafe.Coerce + + +-------------------------------------------------------------------------------- +-- rewrite rules for faster static parameters +-- +-- FIXME: Find a better home for this. +-- +-- FIXME: Expand to many more naturals. + +{-# INLINE[2] nat2int #-} +nat2int :: KnownNat n => Proxy n -> Int +nat2int = fromIntegral . natVal + +{-# INLINE[1] nat200 #-} +nat200 :: Proxy 200 -> Int +nat200 _ = 200 + +{-# RULES + +"subhask/nat2int_200" nat2int = nat200 + + #-} + +-------------------------------------------------------------------------------- + +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. +data family UVector (n::k) r + +type instance Scalar (UVector n r) = Scalar r +type instance Logic (UVector n r) = Logic r +type instance UVector n r >< a = UVector n (r> Show (UVector (n::Symbol) r) where + show (UVector_Dynamic arr off n) = if isZero n + then "zero" + else show $ go (n-1) [] + where + go (-1) xs = xs + go i xs = go (i-1) (x:xs) + where + x = indexByteArray arr (off+i) :: r + +instance (Arbitrary r, Prim r, FreeModule r, IsScalar r) => Arbitrary (UVector (n::Symbol) r) where + arbitrary = frequency + [ (1,return zero) + , (9,fmap unsafeToModule $ replicateM 27 arbitrary) + ] + +instance (NFData r, Prim r) => NFData (UVector (n::Symbol) r) where + rnf (UVector_Dynamic arr off n) = seq arr () + +instance (FromField r, Prim r, IsScalar r, FreeModule r) => FromRecord (UVector (n::Symbol) r) where + parseRecord r = do + rs :: [r] <- parseRecord r + return $ unsafeToModule rs + +--------------------------------------- +-- mutable + +newtype instance Mutable m (UVector (n::Symbol) r) + = Mutable_UVector (PrimRef m (UVector (n::Symbol) r)) + +instance Prim r => IsMutable (UVector (n::Symbol) r) where + freeze mv = copy mv >>= unsafeFreeze + thaw v = unsafeThaw v >>= copy + + unsafeFreeze (Mutable_UVector ref) = readPrimRef ref + unsafeThaw v = do + ref <- newPrimRef v + return $ Mutable_UVector ref + + copy (Mutable_UVector ref) = do + (UVector_Dynamic arr1 off1 n) <- readPrimRef ref + let b = (extendDimensions n)*Prim.sizeOf (undefined::r) + if n==0 + then do + ref <- newPrimRef $ UVector_Dynamic arr1 off1 n + return $ Mutable_UVector ref + else unsafePrimToPrim $ do + marr2 <- safeNewByteArray b 16 + copyByteArray marr2 0 arr1 off1 b + arr2 <- unsafeFreezeByteArray marr2 + ref2 <- newPrimRef (UVector_Dynamic arr2 0 n) + return $ Mutable_UVector ref2 + + write (Mutable_UVector ref) (UVector_Dynamic arr2 off2 n2) = do + (UVector_Dynamic arr1 off1 n1) <- readPrimRef ref + unsafePrimToPrim $ if + -- both ptrs null: do nothing + | n1==0 && n2==0 -> return () + + -- only arr1 null: allocate memory then copy arr2 over + | n1==0 -> do + marr1' <- safeNewByteArray b 16 + copyByteArray marr1' 0 arr2 off2 b + arr1' <- unsafeFreezeByteArray marr1' + unsafePrimToPrim $ writePrimRef ref (UVector_Dynamic arr1' 0 n2) + + -- only arr2 null: make arr1 null + | n2==0 -> do + writePrimRef ref (UVector_Dynamic arr2 0 n1) + + -- both ptrs valid: perform a normal copy + | otherwise -> do + marr1 <- unsafeThawByteArray arr1 + copyByteArray marr1 off1 arr2 off2 b + + where b = (extendDimensions n2)*Prim.sizeOf (undefined::r) + +---------------------------------------- +-- algebra + +extendDimensions :: Int -> Int +extendDimensions i = i+i`rem`4 + +safeNewByteArray :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m)) +safeNewByteArray b 16 = do + let n=extendDimensions $ b`rem`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) + return marr + +{-# INLINE binopDynUV #-} +binopDynUV :: forall a b n m. + ( Prim a + , Monoid a + ) => (a -> a -> a) -> UVector (n::Symbol) a -> UVector (n::Symbol) a -> UVector (n::Symbol) a +binopDynUV f v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) = if + | isZero n1 && isZero n2 -> v1 + | isZero n1 -> monopDynUV (f zero) v2 + | isZero n2 -> monopDynUV (\a -> f a zero) v1 + | otherwise -> unsafeInlineIO $ do + let b = (extendDimensions n1)*Prim.sizeOf (undefined::a) + marr3 <- safeNewByteArray b 16 + go marr3 (n1-1) + arr3 <- unsafeFreezeByteArray marr3 + return $ UVector_Dynamic arr3 0 n1 + + where + go _ (-1) = return () + go marr3 i = do + let v1 = indexByteArray arr1 (off1+i) + v2 = indexByteArray arr2 (off2+i) + writeByteArray marr3 i (f v1 v2) + go marr3 (i-1) + +{-# INLINE monopDynUV #-} +monopDynUV :: forall a b n m. + ( Prim a + ) => (a -> a) -> UVector (n::Symbol) a -> UVector (n::Symbol) a +monopDynUV f v@(UVector_Dynamic arr1 off1 n) = if n==0 + then v + else unsafeInlineIO $ do + let b = n*Prim.sizeOf (undefined::a) + marr2 <- safeNewByteArray b 16 + go marr2 (n-1) + arr2 <- unsafeFreezeByteArray marr2 + return $ UVector_Dynamic arr2 0 n + + where + go _ (-1) = return () + go marr2 i = do + let v1 = indexByteArray arr1 (off1+i) + writeByteArray marr2 i (f v1) + go marr2 (i-1) + +{- +{-# INLINE binopDynUVM #-} +binopDynUVM :: forall a b n m. + ( PrimBase m + , Prim a + , Prim b + , Monoid a + , Monoid b + ) => (a -> b -> a) -> Mutable m (UVector (n::Symbol) a) -> UVector n b -> m () +binopDynUVM f (Mutable_UVector ref) (UVector_Dynamic arr2 off2 n2) = do + (UVector_Dynamic arr1 off1 n1) <- readPrimRef ref + + let runop arr1 arr2 n = unsafePrimToPrim $ + withForeignPtr arr1 $ \p1 -> + withForeignPtr arr2 $ \p2 -> + go (plusPtr p1 off1) (plusPtr p2 off2) (n-1) + + unsafePrimToPrim $ if + -- both vectors are zero: do nothing + | isNull arr1 && isNull arr2 -> return () + + -- only left vector is zero: allocate space and overwrite old vector + -- FIXME: this algorithm requires two passes over the left vector + | isNull arr1 -> do + arr1' <- zerofp n2 + unsafePrimToPrim $ writePrimRef ref (UVector_Dynamic arr1' 0 n2) + runop arr1' arr2 n2 + + -- only right vector is zero: use a temporary zero vector to run like normal + -- FIXME: this algorithm requires an unneeded memory allocation and memory pass + | isNull arr2 -> do + arr2' <- zerofp n1 + runop arr1 arr2' n1 + + -- both vectors nonzero: run like normal + | otherwise -> runop arr1 arr2 n1 + + where + go _ _ (-1) = return () + go p1 p2 i = do + v1 <- peekElemOff p1 i + v2 <- peekElemOff p2 i + pokeElemOff p1 i (f v1 v2) + go p1 p2 (i-1) + +{-# INLINE monopDynM #-} +monopDynM :: forall a b n m. + ( PrimMonad m + , Prim a + ) => (a -> a) -> Mutable m (UVector (n::Symbol) a) -> m () +monopDynM f (Mutable_UVector ref) = do + (UVector_Dynamic arr1 off1 n) <- readPrimRef ref + if isNull arr1 + then return () + else unsafePrimToPrim $ + withForeignPtr arr1 $ \p1 -> + go (plusPtr p1 off1) (n-1) + + where + go _ (-1) = return () + go p1 i = do + v1 <- peekElemOff p1 i + pokeElemOff p1 i (f v1) + go p1 (i-1) + +------------------- + +-} +instance (Monoid r, Prim r) => Semigroup (UVector (n::Symbol) r) where + {-# INLINE (+) #-} ; (+) = binopDynUV (+) +-- {-# INLINE (+=) #-} ; (+=) = binopDynUVM (+) + +instance (Monoid r, Cancellative r, Prim r) => Cancellative (UVector (n::Symbol) r) where + {-# INLINE (-) #-} ; (-) = binopDynUV (-) +-- {-# INLINE (-=) #-} ; (-=) = binopDynUVM (-) + +instance (Monoid r, Prim r) => Monoid (UVector (n::Symbol) r) where + {-# INLINE zero #-} + zero = unsafeInlineIO $ do + marr <- safeNewByteArray 0 16 + arr <- unsafeFreezeByteArray marr + return $ UVector_Dynamic arr 0 0 + +instance (Group r, Prim r) => Group (UVector (n::Symbol) r) where + {-# INLINE negate #-} + negate v = monopDynUV negate v + +instance (Monoid r, Abelian r, Prim r) => Abelian (UVector (n::Symbol) r) + +instance (Module r, Prim r) => Module (UVector (n::Symbol) r) where + {-# INLINE (.*) #-} ; (.*) v r = monopDynUV (.*r) v +-- {-# INLINE (.*=) #-} ; (.*=) v r = monopDynM (.*r) v + +instance (FreeModule r, Prim r) => FreeModule (UVector (n::Symbol) r) where + {-# INLINE (.*.) #-} ; (.*.) = binopDynUV (.*.) +-- {-# INLINE (.*.=) #-} ; (.*.=) = binopDynUVM (.*.) + +instance (VectorSpace r, Prim r) => VectorSpace (UVector (n::Symbol) r) where + {-# INLINE (./) #-} ; (./) v r = monopDynUV (./r) v +-- {-# INLINE (./=) #-} ; (./=) v r = monopDynM (./r) v + + {-# INLINE (./.) #-} ; (./.) = binopDynUV (./.) +-- {-# INLINE (./.=) #-} ; (./.=) = binopDynUVM (./.) + +---------------------------------------- +-- container + +instance (Monoid r, ValidLogic r, Prim r, IsScalar r) => IxContainer (UVector (n::Symbol) r) where + + {-# INLINE (!) #-} + (!) (UVector_Dynamic arr off n) i = indexByteArray arr (off+i) + + {-# INLINABLE toIxList #-} + toIxList (UVector_Dynamic arr off n) = P.zip [0..] $ go (n-1) [] + where + go (-1) xs = xs + go i xs = go (i-1) (indexByteArray arr (off+i) : xs) + +-- imap f v = unsafeToModule $ imap f $ values v + + +instance (FreeModule r, ValidLogic r, Prim r, IsScalar r) => FiniteModule (UVector (n::Symbol) r) where + + {-# INLINE dim #-} + dim (UVector_Dynamic _ _ n) = n + + {-# INLINABLE unsafeToModule #-} + unsafeToModule xs = unsafeInlineIO $ do + marr <- safeNewByteArray (n*Prim.sizeOf (undefined::r)) 16 + go marr (P.reverse xs) (n-1) + arr <- unsafeFreezeByteArray marr + return $ UVector_Dynamic arr 0 n + + where + n = length xs + + go marr [] (-1) = return () + go marr (x:xs) i = do + writeByteArray marr i x + go marr xs (i-1) + +---------------------------------------- +-- comparison + +isConst :: (Prim r, Eq_ r, ValidLogic r) => UVector (n::Symbol) r -> r -> Logic r +isConst (UVector_Dynamic arr1 off1 n1) c = go (off1+n1-1) + where + go (-1) = true + go i = indexByteArray arr1 i==c && go (i-1) + +instance (Eq r, Monoid r, Prim r) => Eq_ (UVector (n::Symbol) r) where + {-# INLINE (==) #-} + v1@(UVector_Dynamic arr1 off1 n1)==v2@(UVector_Dynamic arr2 off2 n2) = if + | isZero n1 && isZero n2 -> true + | isZero n1 -> isConst v2 zero + | isZero n2 -> isConst v1 zero + | otherwise -> go (n1-1) + where + go (-1) = true + go i = v1==v2 && go (i-1) + where + v1 = indexByteArray arr1 (off1+i) :: r + v2 = indexByteArray arr2 (off2+i) :: r + +{- + + +{-# INLINE innerp #-} +-- innerp :: UVector 200 Float -> UVector 200 Float -> Float +innerp v1 v2 = go 0 (n-1) + + where + n = 200 +-- n = nat2int (Proxy::Proxy n) + + go !tot !i = if i<4 + then goEach tot i + else + go (tot+(v1!(i ) * v2!(i )) + +(v1!(i-1) * v2!(i-1)) + +(v1!(i-2) * v2!(i-2)) + +(v1!(i-3) * v2!(i-3)) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) +-} + +---------------------------------------- +-- distances + +instance + ( Prim r + , ExpField r + , Normed r + , Ord_ r + , Logic r~Bool + , IsScalar r + , VectorSpace r + ) => Metric (UVector (n::Symbol) r) + where + + {-# INLINE[2] distance #-} + distance v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) + = {-# SCC distance_UVector #-} if + | isZero n1 -> size v2 + | isZero n2 -> size v1 + | otherwise -> sqrt $ go 0 (n1-1) + where + go !tot !i = if i<4 + then goEach tot i + else go (tot+(v1!(i ) - v2!(i )) .*. (v1!(i ) - v2!(i )) + +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1)) + +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2)) + +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3)) + ) + (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot + (v1!i-v2!i).*.(v1!i-v2!i)) (i-1) + + {-# INLINE[2] distanceUB #-} + distanceUB v1@(UVector_Dynamic arr1 off1 n1) v2@(UVector_Dynamic arr2 off2 n2) ub + = {-# SCC distanceUB_UVector #-} if + | isZero n1 -> size v2 + | isZero n2 -> size v1 + | otherwise -> sqrt $ go 0 (n1-1) + where + ub2=ub*ub + + go !tot !i = if tot>ub2 + then tot + else if i<4 + then goEach tot i + else go (tot+(v1!(i ) - v2!(i )) .*. (v1!(i ) - v2!(i )) + +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1)) + +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2)) + +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3)) + ) + (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot + (v1!i-v2!i).*.(v1!i-v2!i)) (i-1) + + +instance (VectorSpace r, Prim r, IsScalar r, ExpField r) => Normed (UVector (n::Symbol) r) where + {-# INLINE size #-} + size v@(UVector_Dynamic arr off n) = if isZero n + then 0 + else sqrt $ go 0 (off+n-1) + where + go !tot !i = if i<4 + then goEach tot i + else go (tot+v!(i ).*.v!(i ) + +v!(i-1).*.v!(i-1) + +v!(i-2).*.v!(i-2) + +v!(i-3).*.v!(i-3) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+v!i*v!i) (i-1) + +-------------------------------------------------------------------------------- +-- helper functions for memory management + +-- | does the foreign pointer equal null? +isNull :: ForeignPtr a -> Bool +isNull fp = unsafeInlineIO $ withForeignPtr fp $ \p -> (return $ p P.== nullPtr) + +-- | allocates a ForeignPtr that is filled with n "zero"s +zerofp :: forall n r. (Storable r, Monoid r) => Int -> IO (ForeignPtr r) +zerofp n = do + fp <- mallocForeignPtrBytes b + withForeignPtr fp $ \p -> go p (n-1) + return fp + where + b = n*sizeOf (undefined::r) + + go _ (-1) = return () + go p i = do + pokeElemOff p i zero + go p (i-1) + +-------------------------------------------------------------------------------- + +-- | The type of dynamic or statically sized vectors implemented using the FFI. +data family SVector (n::k) r + +type instance Scalar (SVector n r) = Scalar r +type instance Logic (SVector n r) = Logic r + +-- type instance SVector m a >< b = VectorOuterProduct (SVector m a) b +-- type family VectorOuterProduct a b where +-- -- VectorOuterProduct (SVector m a) (SVector n a) = SVector m a +-- -- VectorOuterProduct (SVector m a) (SVector n a) = Matrix a m n +-- VectorOuterProduct (SVector m a) a = SVector m a -- (a>< a = SVector n (r>< b = Tensor_SVector (SVector m a) b +type family Tensor_SVector a b where + Tensor_SVector (SVector n r1) (SVector m r2) = SVector n r1 +> SVector m r2 + Tensor_SVector (SVector n r1) r1 = SVector n r1 -- (r1> Show (SVector (n::Symbol) r) where + show (SVector_Dynamic fp off n) = if isNull fp + then "zero" + else show $ unsafeInlineIO $ go (n-1) [] + where + go (-1) xs = return $ xs + go i xs = withForeignPtr fp $ \p -> do + x <- peekElemOff p (off+i) + go (i-1) (x:xs) + +instance (Arbitrary r, ValidSVector n r, FreeModule r, IsScalar r) => Arbitrary (SVector (n::Symbol) r) where + arbitrary = frequency + [ (1,return zero) + , (9,fmap unsafeToModule $ replicateM 27 arbitrary) + ] + +instance (NFData r, ValidSVector n r) => NFData (SVector (n::Symbol) r) where + rnf (SVector_Dynamic fp off n) = seq fp () + +instance (FromField r, ValidSVector n r, IsScalar r, FreeModule r) => FromRecord (SVector (n::Symbol) r) where + parseRecord r = do + rs :: [r] <- parseRecord r + return $ unsafeToModule rs + +--------------------------------------- +-- mutable + +newtype instance Mutable m (SVector (n::Symbol) r) = Mutable_SVector (PrimRef m (SVector (n::Symbol) r)) + +instance (ValidSVector n r) => IsMutable (SVector (n::Symbol) r) where + freeze mv = copy mv >>= unsafeFreeze + thaw v = unsafeThaw v >>= copy + + unsafeFreeze (Mutable_SVector ref) = readPrimRef ref + unsafeThaw v = do + ref <- newPrimRef v + return $ Mutable_SVector ref + + copy (Mutable_SVector ref) = do + (SVector_Dynamic fp1 off1 n) <- readPrimRef ref + let b = n*sizeOf (undefined::r) + fp2 <- if isNull fp1 + then return fp1 + else unsafePrimToPrim $ do + fp2 <- mallocForeignPtrBytes b + withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> copyBytes p2 (plusPtr p1 off1) b + return fp2 + ref2 <- newPrimRef (SVector_Dynamic fp2 0 n) + return $ Mutable_SVector ref2 + + write (Mutable_SVector ref) (SVector_Dynamic fp2 off2 n2) = do + (SVector_Dynamic fp1 off1 n1) <- readPrimRef ref + unsafePrimToPrim $ if + -- both ptrs null: do nothing + | isNull fp1 && isNull fp2 -> return () + + -- only fp1 null: allocate memory then copy fp2 over + | isNull fp1 && not isNull fp2 -> do + fp1' <- mallocForeignPtrBytes b + unsafePrimToPrim $ writePrimRef ref (SVector_Dynamic fp1' 0 n2) + withForeignPtr fp1' $ \p1 -> withForeignPtr fp2 $ \p2 -> + copyBytes p1 p2 b + + -- only fp2 null: make fp1 null + | not isNull fp1 && isNull fp2 -> unsafePrimToPrim $ writePrimRef ref (SVector_Dynamic fp2 0 n1) + + -- both ptrs valid: perform a normal copy + | otherwise -> + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + copyBytes p1 p2 b + where b = n2*sizeOf (undefined::r) + +---------------------------------------- +-- algebra + +{-# INLINE binopDyn #-} +binopDyn :: forall a b n m. + ( Storable a + , Monoid a + ) => (a -> a -> a) -> SVector (n::Symbol) a -> SVector (n::Symbol) a -> SVector (n::Symbol) a +binopDyn f v1@(SVector_Dynamic fp1 off1 n1) v2@(SVector_Dynamic fp2 off2 n2) = if + | isNull fp1 && isNull fp2 -> v1 + | isNull fp1 -> monopDyn (f zero) v2 + | isNull fp2 -> monopDyn (\a -> f a zero) v1 + | otherwise -> unsafeInlineIO $ do + let b = n1*sizeOf (undefined::a) + fp3 <- mallocForeignPtrBytes b + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + withForeignPtr fp3 $ \p3 -> + go (plusPtr p1 off1) (plusPtr p2 off2) p3 (n1-1) + return $ SVector_Dynamic fp3 0 n1 + + where + go _ _ _ (-1) = return () + go p1 p2 p3 i = do + v1 <- peekElemOff p1 i + v2 <- peekElemOff p2 i + pokeElemOff p3 i (f v1 v2) + go p1 p2 p3 (i-1) + +{-# INLINE monopDyn #-} +monopDyn :: forall a b n m. + ( Storable a + ) => (a -> a) -> SVector (n::Symbol) a -> SVector (n::Symbol) a +monopDyn f v@(SVector_Dynamic fp1 off1 n) = if isNull fp1 + then v + else unsafeInlineIO $ do + let b = n*sizeOf (undefined::a) + fp2 <- mallocForeignPtrBytes b + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + go (plusPtr p1 off1) p2 (n-1) + return $ SVector_Dynamic fp2 0 n + + where + go _ _ (-1) = return () + go p1 p2 i = do + v1 <- peekElemOff p1 i + pokeElemOff p2 i (f v1) + go p1 p2 (i-1) + +{-# INLINE binopDynM #-} +binopDynM :: forall a b n m. + ( PrimBase m + , Storable a + , Storable b + , Monoid a + , Monoid b + ) => (a -> b -> a) -> Mutable m (SVector (n::Symbol) a) -> SVector n b -> m () +binopDynM f (Mutable_SVector ref) (SVector_Dynamic fp2 off2 n2) = do + (SVector_Dynamic fp1 off1 n1) <- readPrimRef ref + + let runop fp1 fp2 n = unsafePrimToPrim $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + go (plusPtr p1 off1) (plusPtr p2 off2) (n-1) + + unsafePrimToPrim $ if + -- both vectors are zero: do nothing + | isNull fp1 && isNull fp2 -> return () + + -- only left vector is zero: allocate space and overwrite old vector + -- FIXME: this algorithm requires two passes over the left vector + | isNull fp1 -> do + fp1' <- zerofp n2 + unsafePrimToPrim $ writePrimRef ref (SVector_Dynamic fp1' 0 n2) + runop fp1' fp2 n2 + + -- only right vector is zero: use a temporary zero vector to run like normal + -- FIXME: this algorithm requires an unneeded memory allocation and memory pass + | isNull fp2 -> do + fp2' <- zerofp n1 + runop fp1 fp2' n1 + + -- both vectors nonzero: run like normal + | otherwise -> runop fp1 fp2 n1 + + where + go _ _ (-1) = return () + go p1 p2 i = do + v1 <- peekElemOff p1 i + v2 <- peekElemOff p2 i + pokeElemOff p1 i (f v1 v2) + go p1 p2 (i-1) + +{-# INLINE monopDynM #-} +monopDynM :: forall a b n m. + ( PrimMonad m + , Storable a + ) => (a -> a) -> Mutable m (SVector (n::Symbol) a) -> m () +monopDynM f (Mutable_SVector ref) = do + (SVector_Dynamic fp1 off1 n) <- readPrimRef ref + if isNull fp1 + then return () + else unsafePrimToPrim $ + withForeignPtr fp1 $ \p1 -> + go (plusPtr p1 off1) (n-1) + + where + go _ (-1) = return () + go p1 i = do + v1 <- peekElemOff p1 i + pokeElemOff p1 i (f v1) + go p1 (i-1) + +------------------- + +instance (Monoid r, ValidSVector n r) => Semigroup (SVector (n::Symbol) r) where + {-# INLINE (+) #-} ; (+) = binopDyn (+) + {-# INLINE (+=) #-} ; (+=) = binopDynM (+) + +instance (Monoid r, Cancellative r, ValidSVector n r) => Cancellative (SVector (n::Symbol) r) where + {-# INLINE (-) #-} ; (-) = binopDyn (-) + {-# INLINE (-=) #-} ; (-=) = binopDynM (-) + +instance (Monoid r, ValidSVector n r) => Monoid (SVector (n::Symbol) r) where + {-# INLINE zero #-} + zero = SVector_Dynamic (unsafeInlineIO $ newForeignPtr_ nullPtr) 0 0 + +instance (Group r, ValidSVector n r) => Group (SVector (n::Symbol) r) where + {-# INLINE negate #-} + negate v = unsafeInlineIO $ do + mv <- thaw v + monopDynM negate mv + unsafeFreeze mv + +instance (Monoid r, Abelian r, ValidSVector n r) => Abelian (SVector (n::Symbol) r) + +instance (Module r, ValidSVector n r, IsScalar r) => Module (SVector (n::Symbol) r) where + {-# INLINE (.*) #-} ; (.*) v r = monopDyn (.*r) v + {-# INLINE (.*=) #-} ; (.*=) v r = monopDynM (.*r) v + +instance (FreeModule r, ValidSVector n r, IsScalar r) => FreeModule (SVector (n::Symbol) r) where + {-# INLINE (.*.) #-} ; (.*.) = binopDyn (.*.) + {-# INLINE (.*.=) #-} ; (.*.=) = binopDynM (.*.) + +instance (VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpace (SVector (n::Symbol) r) where + {-# INLINE (./) #-} ; (./) v r = monopDyn (./r) v + {-# INLINE (./=) #-} ; (./=) v r = monopDynM (./r) v + + {-# INLINE (./.) #-} ; (./.) = binopDyn (./.) + {-# INLINE (./.=) #-} ; (./.=) = binopDynM (./.) + +---------------------------------------- +-- container + +instance + ( Monoid r + , ValidLogic r + , ValidSVector n r + , IsScalar r + , FreeModule r + ) => IxContainer (SVector (n::Symbol) r) + where + + {-# INLINE (!) #-} + (!) (SVector_Dynamic fp off n) i = unsafeInlineIO $ withForeignPtr fp $ \p -> peekElemOff p (off+i) + + {-# INLINABLE toIxList #-} + toIxList v = P.zip [0..] $ go (dim v-1) [] + where + go (-1) xs = xs + go i xs = go (i-1) (v!i : xs) + + {-# INLINABLE imap #-} + imap f v = unsafeToModule $ imap f $ values v + + type ValidElem (SVector n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidSVector n e) + +instance (FreeModule r, ValidLogic r, ValidSVector n r, IsScalar r) => FiniteModule (SVector (n::Symbol) r) where + + {-# INLINE dim #-} + dim (SVector_Dynamic _ _ n) = n + + {-# INLINABLE unsafeToModule #-} + unsafeToModule xs = unsafeInlineIO $ do + fp <- mallocForeignPtrArray n + withForeignPtr fp $ \p -> go p (P.reverse xs) (n-1) + return $ SVector_Dynamic fp 0 n + + where + n = length xs + + go p [] (-1) = return () + go p (x:xs) i = do + pokeElemOff p i x + go p xs (i-1) + +---------------------------------------- +-- comparison + +instance (Eq r, Monoid r, ValidSVector n r) => Eq_ (SVector (n::Symbol) r) where + {-# INLINE (==) #-} + (SVector_Dynamic fp1 off1 n1)==(SVector_Dynamic fp2 off2 n2) = unsafeInlineIO $ if + | isNull fp1 && isNull fp2 -> return true + | isNull fp1 -> withForeignPtr fp2 $ \p -> checkZero (plusPtr p off2) (n2-1) + | isNull fp2 -> withForeignPtr fp1 $ \p -> checkZero (plusPtr p off1) (n1-1) + | otherwise -> + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + outer (plusPtr p1 off1) (plusPtr p2 off2) (n1-1) + where + checkZero :: Ptr r -> Int -> IO Bool + checkZero p (-1) = return true + checkZero p i = do + x <- peekElemOff p i + if isZero x + then checkZero p (-1) + else return false + + outer :: Ptr r -> Ptr r -> Int -> IO Bool + outer p1 p2 = go + where + go (-1) = return true + go i = do + v1 <- peekElemOff p1 i + v2 <- peekElemOff p2 i + next <- go (i-1) + return $ v1==v2 && next + +---------------------------------------- +-- distances + +instance + ( ValidSVector n r + , ExpField r + , Normed r + , Ord_ r + , Logic r~Bool + , IsScalar r + , VectorSpace r + ) => Metric (SVector (n::Symbol) r) + where + + {-# INLINE[2] distance #-} + distance v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) = {-# SCC distance_SVector #-} if + | isNull fp1 -> size v2 + | isNull fp2 -> size v1 + | otherwise -> sqrt $ go 0 (n-1) + where + go !tot !i = if i<4 + then goEach tot i + else go (tot+(v1!(i ) - v2!(i )) .*. (v1!(i ) - v2!(i )) + +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1)) + +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2)) + +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3)) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) + + {-# INLINE[2] distanceUB #-} + distanceUB v1@(SVector_Dynamic fp1 _ n) v2@(SVector_Dynamic fp2 _ _) ub = {-# SCC distanceUB_SVector #-}if + | isNull fp1 -> size v2 + | isNull fp2 -> size v1 + | otherwise -> sqrt $ go 0 (n-1) + where + ub2=ub*ub + + go !tot !i = if tot>ub2 + then tot + else if i<4 + then goEach tot i + else go (tot+(v1!(i ) - v2!(i )) .*. (v1!(i ) - v2!(i )) + +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1)) + +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2)) + +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3)) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) + +instance (VectorSpace r, ValidSVector n r, IsScalar r, ExpField r) => Normed (SVector (n::Symbol) r) where + {-# INLINE size #-} + size v@(SVector_Dynamic fp _ n) = if isNull fp + then 0 + else sqrt $ go 0 (n-1) + where + go !tot !i = if i<4 + then goEach tot i + else go (tot+v!(i ).*.v!(i ) + +v!(i-1).*.v!(i-1) + +v!(i-2).*.v!(i-2) + +v!(i-3).*.v!(i-3) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+v!i*v!i) (i-1) + +instance + ( VectorSpace r + , ValidSVector n r + , IsScalar r + , ExpField r + , Real r + ) => Banach (SVector (n::Symbol) r) + +instance + ( VectorSpace r + , ValidSVector n r + , IsScalar r + , ExpField r + , Real r + , OrdField r + , MatrixField r + ) => Hilbert (SVector (n::Symbol) r) + where + + {-# INLINE (<>) #-} + v1@(SVector_Dynamic fp1 _ _)<>v2@(SVector_Dynamic fp2 _ n) = if isNull fp1 || isNull fp2 + then 0 + else go 0 (n-1) + where + go !tot !i = if i<4 + then goEach tot i + else + go (tot+(v1!(i ) * v2!(i )) + +(v1!(i-1) * v2!(i-1)) + +(v1!(i-2) * v2!(i-2)) + +(v1!(i-3) * v2!(i-3)) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+(v1!i * v2!i)) (i-1) + + +-------------------------------------------------------------------------------- + +newtype instance SVector (n::Nat) r = SVector_Nat (ForeignPtr r) + +instance (Show r, ValidSVector n r, KnownNat n) => Show (SVector n r) where + show v = show (vec2list v) + where + n = nat2int (Proxy::Proxy n) + + vec2list (SVector_Nat fp) = unsafeInlineIO $ go (n-1) [] + where + go (-1) xs = return $ xs + go i xs = withForeignPtr fp $ \p -> do + x <- peekElemOff p i + go (i-1) (x:xs) + +instance + ( KnownNat n + , Arbitrary r + , ValidSVector n r + , FreeModule r + , IsScalar r + ) => Arbitrary (SVector (n::Nat) r) + where + arbitrary = do + xs <- replicateM n arbitrary + return $ unsafeToModule xs + where + n = nat2int (Proxy::Proxy n) + +instance (NFData r, ValidSVector n r) => NFData (SVector (n::Nat) r) where + rnf (SVector_Nat fp) = seq fp () + +static2dynamic :: forall n m r. KnownNat n => SVector (n::Nat) r -> SVector (m::Symbol) r +static2dynamic (SVector_Nat fp) = SVector_Dynamic fp 0 $ nat2int (Proxy::Proxy n) + +-------------------- + +newtype instance Mutable m (SVector (n::Nat) r) = Mutable_SVector_Nat (ForeignPtr r) + +instance (KnownNat n, ValidSVector n r) => IsMutable (SVector (n::Nat) r) where + freeze mv = copy mv >>= unsafeFreeze + thaw v = unsafeThaw v >>= copy + + unsafeFreeze (Mutable_SVector_Nat fp) = return $ SVector_Nat fp + unsafeThaw (SVector_Nat fp) = return $ Mutable_SVector_Nat fp + + copy (Mutable_SVector_Nat fp1) = unsafePrimToPrim $ do + fp2 <- mallocForeignPtrBytes b + withForeignPtr fp1 $ \p1 -> withForeignPtr fp2 $ \p2 -> copyBytes p2 p1 b + return (Mutable_SVector_Nat fp2) + + where + n = nat2int (Proxy::Proxy n) + b = n*sizeOf (undefined::r) + + write (Mutable_SVector_Nat fp1) (SVector_Nat fp2) = unsafePrimToPrim $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + copyBytes p1 p2 b + + where + n = nat2int (Proxy::Proxy n) + b = n*sizeOf (undefined::r) + +---------------------------------------- +-- algebra + +{-# INLINE binopStatic #-} +binopStatic :: forall a b n m. + ( Storable a + , KnownNat n + ) => (a -> a -> a) -> SVector n a -> SVector n a -> SVector n a +binopStatic f v1@(SVector_Nat fp1) v2@(SVector_Nat fp2) = unsafeInlineIO $ do + fp3 <- mallocForeignPtrBytes b + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + withForeignPtr fp3 $ \p3 -> + go p1 p2 p3 (n-1) + return $ SVector_Nat fp3 + + where + n = nat2int (Proxy::Proxy n) + b = n*sizeOf (undefined::a) + + go _ _ _ (-1) = return () + go p1 p2 p3 i = do + x0 <- peekElemOff p1 i +-- x1 <- peekElemOff p1 (i-1) +-- x2 <- peekElemOff p1 (i-2) +-- x3 <- peekElemOff p1 (i-3) + + y0 <- peekElemOff p2 i +-- y1 <- peekElemOff p2 (i-1) +-- y2 <- peekElemOff p2 (i-2) +-- y3 <- peekElemOff p2 (i-3) + + pokeElemOff p3 i (f x0 y0) +-- pokeElemOff p3 (i-1) (f x1 y1) +-- pokeElemOff p3 (i-2) (f x2 y2) +-- pokeElemOff p3 (i-3) (f x3 y3) + + go p1 p2 p3 (i-1) +-- go p1 p2 p3 (i-4) + +{-# INLINE monopStatic #-} +monopStatic :: forall a b n m. + ( Storable a + , KnownNat n + ) => (a -> a) -> SVector n a -> SVector n a +monopStatic f v@(SVector_Nat fp1) = unsafeInlineIO $ do + fp2 <- mallocForeignPtrBytes b + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + go p1 p2 (n-1) + return $ SVector_Nat fp2 + + where + n = nat2int (Proxy::Proxy n) + b = n*sizeOf (undefined::a) + + go _ _ (-1) = return () + go p1 p2 i = do + v1 <- peekElemOff p1 i + pokeElemOff p2 i (f v1) + go p1 p2 (i-1) + +{-# INLINE binopStaticM #-} +binopStaticM :: forall a b n m. + ( PrimMonad m + , Storable a + , Storable b + , KnownNat n + ) => (a -> b -> a) -> Mutable m (SVector n a) -> SVector n b -> m () +binopStaticM f (Mutable_SVector_Nat fp1) (SVector_Nat fp2) = unsafePrimToPrim $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + go p1 p2 (n-1) + + where + n = nat2int (Proxy::Proxy n) + + go _ _ (-1) = return () + go p1 p2 i = do + v1 <- peekElemOff p1 i + v2 <- peekElemOff p2 i + pokeElemOff p1 i (f v1 v2) + go p1 p2 (i-1) + +{-# INLINE monopStaticM #-} +monopStaticM :: forall a b n m. + ( PrimMonad m + , Storable a + , KnownNat n + ) => (a -> a) -> Mutable m (SVector n a) -> m () +monopStaticM f (Mutable_SVector_Nat fp1) = unsafePrimToPrim $ + withForeignPtr fp1 $ \p1 -> + go p1 (n-1) + + where + n = nat2int (Proxy::Proxy n) + + go _ (-1) = return () + go p1 i = do + v1 <- peekElemOff p1 i + pokeElemOff p1 i (f v1) + go p1 (i-1) + +------------------- + +instance (KnownNat n, Semigroup r, ValidSVector n r) => Semigroup (SVector (n::Nat) r) where + {-# INLINE (+) #-} ; (+) = binopStatic (+) + {-# INLINE (+=) #-} ; (+=) = binopStaticM (+) + +instance (KnownNat n, Cancellative r, ValidSVector n r) => Cancellative (SVector (n::Nat) r) where + {-# INLINE (-) #-} ; (-) = binopStatic (-) + {-# INLINE (-=) #-} ; (-=) = binopStaticM (-) + +instance (KnownNat n, Monoid r, ValidSVector n r) => Monoid (SVector (n::Nat) r) where + {-# INLINE zero #-} + zero = unsafeInlineIO $ do + mv <- fmap (\fp -> Mutable_SVector_Nat fp) $ mallocForeignPtrArray n + monopStaticM (const zero) mv + unsafeFreeze mv + where + n = nat2int (Proxy::Proxy n) + +instance (KnownNat n, Group r, ValidSVector n r) => Group (SVector (n::Nat) r) where + {-# INLINE negate #-} + negate v = unsafeInlineIO $ do + mv <- thaw v + monopStaticM negate mv + unsafeFreeze mv + +instance (KnownNat n, Abelian r, ValidSVector n r) => Abelian (SVector (n::Nat) r) + +instance (KnownNat n, Module r, ValidSVector n r, IsScalar r) => Module (SVector (n::Nat) r) where + {-# INLINE (.*) #-} ; (.*) v r = monopStatic (.*r) v + {-# INLINE (.*=) #-} ; (.*=) v r = monopStaticM (.*r) v + +instance (KnownNat n, FreeModule r, ValidSVector n r, IsScalar r) => FreeModule (SVector (n::Nat) r) where + {-# INLINE (.*.) #-} ; (.*.) = binopStatic (.*.) + {-# INLINE (.*.=) #-} ; (.*.=) = binopStaticM (.*.) + +instance (KnownNat n, VectorSpace r, ValidSVector n r, IsScalar r) => VectorSpace (SVector (n::Nat) r) where + {-# INLINE (./) #-} ; (./) v r = monopStatic (./r) v + {-# INLINE (./=) #-} ; (./=) v r = monopStaticM (./r) v + + {-# INLINE (./.) #-} ; (./.) = binopStatic (./.) + {-# INLINE (./.=) #-} ; (./.=) = binopStaticM (./.) + +---------------------------------------- +-- "container" + +instance + ( KnownNat n + , Monoid r + , ValidLogic r + , ValidSVector n r + , IsScalar r + , FreeModule r + ) => IxContainer (SVector (n::Nat) r) + where + + {-# INLINE (!) #-} + (!) (SVector_Nat fp) i = unsafeInlineIO $ withForeignPtr fp $ \p -> peekElemOff p i + + {-# INLINABLE toIxList #-} + toIxList v = P.zip [0..] $ go (dim v-1) [] + where + go (-1) xs = xs + go i xs = go (i-1) (v!i : xs) + + {-# INLINABLE imap #-} + imap f v = unsafeToModule $ imap f $ values v + + type ValidElem (SVector n r) e = (ClassicalLogic e, IsScalar e, FiniteModule e, ValidSVector n e) + +instance + ( KnownNat n + , FreeModule r + , ValidLogic r + , ValidSVector n r + , IsScalar r + ) => FiniteModule (SVector (n::Nat) r) + where + + {-# INLINE dim #-} + dim v = nat2int (Proxy::Proxy n) + + {-# INLINABLE unsafeToModule #-} + unsafeToModule xs = if n /= length xs + then error "unsafeToModule size mismatch" + else unsafeInlineIO $ do + fp <- mallocForeignPtrArray n + withForeignPtr fp $ \p -> go p (P.reverse xs) (n-1) + return $ SVector_Nat fp + + where + n = nat2int (Proxy::Proxy n) + + go p [] (-1) = return () + go p (x:xs) i = do + pokeElemOff p i x + go p xs (i-1) + + +---------------------------------------- +-- comparison + +instance (KnownNat n, Eq_ r, ValidLogic r, ValidSVector n r) => Eq_ (SVector (n::Nat) r) where + {-# INLINE (==) #-} + (SVector_Nat fp1)==(SVector_Nat fp2) = unsafeInlineIO $ + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> + outer p1 p2 (n-1) + where + n = nat2int (Proxy::Proxy n) + + outer p1 p2 = go + where + go (-1) = return true + go i = do + v1 <- peekElemOff p1 i + v2 <- peekElemOff p2 i + next <- go (i-1) + return $ v1==v2 && next + +---------------------------------------- +-- distances + +instance + ( KnownNat n + , ValidSVector n r + , ExpField r + , Normed r + , Ord_ r + , Logic r~Bool + , IsScalar r + , VectorSpace r + , ValidSVector "dyn" r + ) => Metric (SVector (n::Nat) r) + where + + -- For some reason, using the dynamic vector is a little faster than a straight implementation + {-# INLINE[2] distance #-} + distance v1 v2 = distance (static2dynamic v1) (static2dynamic v2 :: SVector "dyn" r) +-- distance v1 v2 = sqrt $ go 0 (n-1) +-- where +-- n = nat2int (Proxy::Proxy n) +-- +-- go !tot !i = if i<4 +-- then goEach tot i +-- else go (tot+(v1!(i ) - v2!(i )) .*. (v1!(i ) - v2!(i )) +-- +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1)) +-- +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2)) +-- +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3)) +-- ) (i-4) +-- +-- goEach !tot !i = if i<0 +-- then tot +-- else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) + + {-# INLINE[2] distanceUB #-} + distanceUB v1 v2 ub = {-# SCC distanceUB_SVector #-} sqrt $ go 0 (n-1) + where + n = nat2int (Proxy::Proxy n) + ub2 = ub*ub + + go !tot !i = if tot>ub2 + then tot + else if i<4 + then goEach tot i + else go (tot+(v1!(i ) - v2!(i )) .*. (v1!(i ) - v2!(i )) + +(v1!(i-1) - v2!(i-1)) .*. (v1!(i-1) - v2!(i-1)) + +(v1!(i-2) - v2!(i-2)) .*. (v1!(i-2) - v2!(i-2)) + +(v1!(i-3) - v2!(i-3)) .*. (v1!(i-3) - v2!(i-3)) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+(v1!i - v2!i) * (v1!i - v2!i)) (i-1) + +instance + ( KnownNat n + , VectorSpace r + , ValidSVector n r + , IsScalar r + , ExpField r + ) => Normed (SVector (n::Nat) r) + where + {-# INLINE size #-} + size v = sqrt $ go 0 (n-1) + where + n = nat2int (Proxy::Proxy n) + + go !tot !i = if i<4 + then goEach tot i + else go (tot+v!(i ) .*. v!(i ) + +v!(i-1) .*. v!(i-1) + +v!(i-2) .*. v!(i-2) + +v!(i-3) .*. v!(i-3) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+v!i*v!i) (i-1) + +instance + ( KnownNat n + , VectorSpace r + , ValidSVector n r + , IsScalar r + , ExpField r + , Real r + , ValidSVector n r + , ValidSVector "dyn" r + ) => Banach (SVector (n::Nat) r) + +instance + ( KnownNat n + , VectorSpace r + , ValidSVector n r + , IsScalar r + , ExpField r + , Real r + , OrdField r + , MatrixField r + , ValidSVector n r + , ValidSVector "dyn" r + ) => Hilbert (SVector (n::Nat) r) + where + + {-# INLINE (<>) #-} + v1<>v2 = go 0 (n-1) + where + n = nat2int (Proxy::Proxy n) + + go !tot !i = if i<4 + then goEach tot i + else + go (tot+(v1!(i ) * v2!(i )) + +(v1!(i-1) * v2!(i-1)) + +(v1!(i-2) * v2!(i-2)) + +(v1!(i-3) * v2!(i-3)) + ) (i-4) + + goEach !tot !i = if i<0 + then tot + else goEach (tot+(v1!i * v2!i)) (i-1) + +-------------------------------------------------------------------------------- + +type MatrixField r = + ( IsScalar r + , VectorSpace r + , Field r + , HM.Field r + , HM.Container HM.Vector r + , HM.Product r + ) + +{- +data Matrix r (m::k1) (n::k2) where + Zero :: Matrix r m n + Id :: {-#UNPACK#-}!r -> Matrix r m m + Diag :: {-#UNPACK#-}!(SVector m r) -> Matrix r m m + Mat :: {-#UNPACK#-}!(HM.Matrix r) -> Matrix r m n + +type instance Scalar (Matrix r m n) = Scalar r +type instance (Matrix r m n)> Int -> Int -> [r] -> Matrix r m n +mkMatrix m n rs = Mat $ (m HM.>< n) rs + +-------------------------------------------------------------------------------- +-- class instances + +deriving instance + ( MatrixField r + , Show (SVector n r) + , Show r + ) => Show (Matrix r m n) + +---------------------------------------- +-- misc + +instance (Storable r, NFData r) => NFData (Matrix r m n) where + rnf (Id r) = () + rnf (Mat m) = rnf m + +---------------------------------------- +-- category + +instance MatrixField r => Category (Matrix r) where + type ValidCategory (Matrix r) a = () + + id = Id 1 + + (Id r1).(Id r2) = Id (r1*r2) + (Id r ).(Mat m ) = Mat $ HM.scale r m + (Mat m ).(Id r ) = Mat $ HM.scale r m + (Mat m1).(Mat m2) = Mat $ m2 HM.<> m1 + +instance MatrixField r => Matrix r (m::Symbol) (n::Symbol) <: (SVector m r -> SVector n r) where + embedType_ = Embed0 $ embedType go + where + go :: Matrix r m n -> SVector m r -> SVector n r + go (Id r) (SVector_Dynamic fp off n) = (SVector_Dynamic fp off n).*r + go (Mat m) (SVector_Dynamic fp off n) = SVector_Dynamic fp' off' n' + where + (fp',off',n') = VS.unsafeToForeignPtr $ m HM.<> VS.unsafeFromForeignPtr fp off n + +type family ToHask (cat :: ka -> kb -> *) (a :: ka) (b :: kb) :: * where + ToHask (Matrix r) a b = SVector r a -> SVector r b + +infixr 0 $$$ +-- ($$$) :: (Matrix r a b <: (SVector a r -> SVector b r)) => Matrix r a b -> SVector a r -> SVector b r +($$$) :: (Matrix r a b <: ToHask (Matrix r) a b) => Matrix r a b -> ToHask (Matrix r) a b +($$$) = embedType + +instance MatrixField r => Dagger (Matrix r) where + dagger (Id r) = Id r + dagger (Mat m) = Mat $ HM.trans m + +---------------------------------------- +-- size + +instance MatrixField r => Normed (Matrix r m n) where + size (Id r) = r + size (Mat m) = HM.det m + +---------------------------------------- +-- algebra + +instance MatrixField r => Semigroup (Matrix r m n) where + (Id r1)+(Id r2) = Id (r1+r2) + (Id r )+(Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.add` m + (Mat m )+(Id r ) = Mat $ m `HM.add` HM.scale r (HM.ident (HM.rows m)) + (Mat m1)+(Mat m2) = Mat $ m1 `HM.add` m2 + +instance MatrixField r => Monoid (Matrix r m n) where + zero = Zero + +instance MatrixField r => Cancellative (Matrix r m n) where + (Id r1)-(Id r2) = Id (r1-r2) + (Id r )-(Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.sub` m + (Mat m )-(Id r ) = Mat $ m `HM.sub` HM.scale r (HM.ident (HM.rows m)) + (Mat m1)-(Mat m2) = Mat $ m1 `HM.sub` m2 + +instance MatrixField r => Group (Matrix r m n) where + negate (Id r) = Id $ negate r + negate (Mat m) = Mat $ HM.scale (-1) m + +instance MatrixField r => Abelian (Matrix r m n) + +------------------- +-- modules + +instance MatrixField r => Module (Matrix r m n) where + (Id r1) .* r2 = Id $ r1*r2 + (Mat m) .* r2 = Mat $ HM.scale r2 m + +instance MatrixField r => FreeModule (Matrix r m n) where + (Id r1) .*. (Id r2) = Id $ r1*r2 + (Id r ) .*. (Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.mul` m + (Mat m ) .*. (Id r ) = Mat $ m `HM.mul` HM.scale r (HM.ident (HM.rows m)) + (Mat m1) .*. (Mat m2) = Mat $ m1 `HM.mul` m2 + +instance MatrixField r => VectorSpace (Matrix r m n) where + (Id r1) ./. (Id r2) = Id $ r1/r2 + (Id r ) ./. (Mat m ) = Mat $ HM.scale r (HM.ident (HM.rows m)) `HM.divide` m + (Mat m ) ./. (Id r ) = Mat $ m `HM.divide` HM.scale r (HM.ident (HM.rows m)) + (Mat m1) ./. (Mat m2) = Mat $ m1 `HM.divide` m2 + +------------------- +-- rings +-- +-- NOTE: matrices are only a ring when their dimensions are equal + +instance MatrixField r => Rg (Matrix r m m) where + (*) = (>>>) + +instance MatrixField r => Rig (Matrix r m m) where + one = id + +instance MatrixField r => Ring (Matrix r m m) where + fromInteger i = Id $ fromInteger i + +instance MatrixField r => Field (Matrix r m m) where + fromRational r = Id $ fromRational r + + reciprocal (Id r ) = Id $ reciprocal r + reciprocal (Mat m) = Mat $ HM.inv m + +---------------------------------------- + +instance + ( FiniteModule (SVector n r) + , VectorSpace (SVector n r) + , MatrixField r + ) => TensorAlgebra (SVector n r) + where + v1> VS.Vector (Scalar a) + fromVector :: VS.Vector (Scalar a) -> a + +instance ToFromVector Double where + toVector x = VS.fromList [x] + fromVector v = VS.head v + +instance MatrixField r => ToFromVector (SVector (n::Symbol) r) where + toVector (SVector_Dynamic fp off n) = VS.unsafeFromForeignPtr fp off n + fromVector v = SVector_Dynamic fp off n + where + (fp,off,n) = VS.unsafeToForeignPtr v + +instance (KnownNat n, MatrixField r) => ToFromVector (SVector (n::Nat) r) where + toVector (SVector_Nat fp) = VS.unsafeFromForeignPtr fp 0 n + where + n = nat2int (Proxy::Proxy n) + fromVector v = SVector_Nat fp + where + (fp,off,n) = VS.unsafeToForeignPtr v + +--------- + +apMat_ :: + ( Scalar a~Scalar b + , MatrixField (Scalar a) + , ToFromVector a + , ToFromVector b + ) => HM.Matrix (Scalar a) -> a -> b +apMat_ m a = fromVector $ m HM.<> toVector a + +--------------------------------------- + +data a +> b where + Zero :: + ( Module a + , Module b + ) => a +> b + + Id_ :: + ( VectorSpace b + ) => {-#UNPACK#-}!(Scalar b) -> b +> b + + Mat_ :: + ( MatrixField (Scalar b) + , Scalar a~Scalar b + , VectorSpace a + , VectorSpace b + , ToFromVector a + , ToFromVector b + ) => {-#UNPACK#-}!(HM.Matrix (Scalar b)) -> a +> b + +type instance Scalar (a +> b) = Scalar b +type instance Logic (a +> b) = Bool + +type instance (a +> b) >< c = Tensor_Linear (a +> b) c +type family Tensor_Linear a b where +-- Tensor_SVector (SVector n r1) (SVector m r2) = SVector n r1 +> SVector m r2 +-- Tensor_Linear (a +> b) (c +> d) = (a +> b) +> (c +> d) + Tensor_Linear (a +> b) c = a +> b + +mkMutable [t| forall a b. a +> b |] + +-- | A slightly more convenient type for linear functions between "SVector"s +type SMatrix r m n = SVector m r +> SVector n r + +-- | Construct an "SMatrix" +unsafeMkSMatrix :: + ( VectorSpace (SVector m r) + , VectorSpace (SVector n r) + , ToFromVector (SVector m r) + , ToFromVector (SVector n r) + , MatrixField r + ) => Int -> Int -> [r] -> SMatrix r m n +unsafeMkSMatrix m n rs = Mat_ $ (m HM.>< n) rs + +-------------------------------------------------------------------------------- +-- instances + +deriving instance ( MatrixField (Scalar b), Show (Scalar b) ) => Show (a +> b) + +---------------------------------------- +-- category + +instance Category (+>) where + type ValidCategory (+>) a = MatrixField a + + id = Id_ 1 + + Zero . Zero = Zero + Zero . (Id_ _ ) = Zero + Zero . (Mat_ _ ) = Zero + + (Id_ r ) . Zero = Zero + (Id_ r1) . (Id_ r2) = Id_ (r1*r2) + (Id_ r ) . (Mat_ m ) = Mat_ $ HM.scale r m + + (Mat_ m1) . Zero = Zero + (Mat_ m ) . (Id_ r ) = Mat_ $ HM.scale r m + (Mat_ m1) . (Mat_ m2) = Mat_ $ m2 HM.<> m1 + +instance Sup (+>) (->) (->) +instance Sup (->) (+>) (->) + +instance (+>) <: (->) where + embedType_ = Embed2 (embedType2 go) + where + go :: a +> b -> a -> b + go Zero = zero + go (Id_ r) = (r*.) + go (Mat_ m) = apMat_ m + +instance Dagger (+>) where + trans Zero = Zero + trans (Id_ r) = Id_ r + trans (Mat_ m) = Mat_ $ HM.trans m + +instance Groupoid (+>) where + inverse (Id_ r) = Id_ $ reciprocal r + inverse (Mat_ m) = Mat_ $ HM.inv m + +---------------------------------------- +-- size + +-- FIXME: what's the norm of a tensor? +instance MatrixField r => Normed (SVector m r +> SVector n r) where + size (Id_ r) = r + size (Mat_ m) = HM.det m + +---------------------------------------- +-- algebra + +instance Semigroup (a +> b) where + Zero + a = a + a + Zero = a + (Id_ r1) + (Id_ r2) = Id_ (r1+r2) + (Id_ r ) + (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.add` m + (Mat_ m ) + (Id_ r ) = Mat_ $ m `HM.add` HM.scale r (HM.ident (HM.rows m)) + (Mat_ m1) + (Mat_ m2) = Mat_ $ m1 `HM.add` m2 + +instance (VectorSpace a, VectorSpace b) => Monoid (a +> b) where + zero = Zero + +instance (VectorSpace a, VectorSpace b) => Cancellative (a +> b) where + a - Zero = a + Zero - a = negate a + (Id_ r1) - (Id_ r2) = Id_ (r1-r2) + (Id_ r ) - (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.sub` m + (Mat_ m ) - (Id_ r ) = Mat_ $ m `HM.sub` HM.scale r (HM.ident (HM.rows m)) + (Mat_ m1) - (Mat_ m2) = Mat_ $ m1 `HM.sub` m2 + +instance (VectorSpace a, VectorSpace b) => Group (a +> b) where + negate Zero = Zero + negate (Id_ r) = Id_ $ negate r + negate (Mat_ m) = Mat_ $ HM.scale (-1) m + +instance Abelian (a +> b) + +------------------- +-- modules + +instance (VectorSpace a, VectorSpace b) => Module (a +> b) where + Zero .* _ = Zero + (Id_ r1) .* r2 = Id_ $ r1*r2 + (Mat_ m) .* r2 = Mat_ $ HM.scale r2 m + +instance (VectorSpace a, VectorSpace b) => FreeModule (a +> b) where + Zero .*. _ = Zero + _ .*. Zero = Zero + (Id_ r1) .*. (Id_ r2) = Id_ $ r1*r2 + (Id_ r ) .*. (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.mul` m + (Mat_ m ) .*. (Id_ r ) = Mat_ $ m `HM.mul` HM.scale r (HM.ident (HM.rows m)) + (Mat_ m1) .*. (Mat_ m2) = Mat_ $ m1 `HM.mul` m2 + +instance (VectorSpace a, VectorSpace b) => VectorSpace (a +> b) where + Zero ./. _ = Zero + (Id_ r1) ./. (Id_ r2) = Id_ $ r1/r2 + (Id_ r ) ./. (Mat_ m ) = Mat_ $ HM.scale r (HM.ident (HM.rows m)) `HM.divide` m + (Mat_ m ) ./. (Id_ r ) = Mat_ $ m `HM.divide` HM.scale r (HM.ident (HM.rows m)) + (Mat_ m1) ./. (Mat_ m2) = Mat_ $ m1 `HM.divide` m2 + +------------------- +-- rings +-- +-- NOTE: matrices are only a ring when their dimensions are equal + +instance VectorSpace a => Rg (a +> a) where + (*) = (>>>) + +instance VectorSpace a => Rig (a +> a) where + one = Id_ one + +instance VectorSpace a => Ring (a +> a) where + fromInteger i = Id_ $ fromInteger i + +instance VectorSpace a => Field (a +> a) where + fromRational r = Id_ $ fromRational r + + reciprocal (Id_ r ) = Id_ $ reciprocal r + reciprocal (Mat_ m) = Mat_ $ HM.inv m + +instance + ( FiniteModule (SVector n r) + , VectorSpace (SVector n r) + , MatrixField r + , ToFromVector (SVector n r) + ) => TensorAlgebra (SVector n r) + where + v1> k -> *@, +-- and define an instance of the "Category" class. +-- Because our version of "Category" uses the ConstraintKinds extension, +-- we can encode many more categories than the standard "Data.Category" class. +-- +-- There are many subclasses of "Category" for categories with extra features. +-- Most of this module is spent defining these categories +-- and instantiating appropriate instances for "Hask". +-- +-- Unfortunately, many of the terms used in category theory are non-standard. +-- In this module, we try to follow the names used out in John Baez and Mike Stay's +-- . +-- This is a fairly accessible introduction to category theory for Haskeller's ready +-- to move beyond \"monads are monoids in the category of endofunctors.\" +-- +-- FIXME: +-- Writing laws for any classes in this file requires at least the "Eq" class from "SubHask.Algebra". +-- Hence, the laws are not explicitly stated anywhere. +-- +-- +-- **Method 2** +-- +-- For any subcategory of "Hask", we can define a type "ProofOf subcat". +-- Then any function of type @ProofOf subcat a -> ProofOf subcat b@ is an arrow within @subcat@. +-- This is essentially a generalization of automatic differentiation to any category. +-- +-- TODO: +-- This needs a much better explanation and examples. +-- +-- **Comparison** +-- Method 1 is the primary way to represent a category. +-- It's main advantage is that we have complete control over the representation in memory. +-- With method 2, everything must be wrapped within function calls. +-- Besides this layer of indirection, we also increase the chance for accidental space leaks. +-- +-- Usually, it is easier to work with functions using method 1, +-- but it is easier to construct functions using method 2. +-- +-- FIXME: +-- Currently, each category comes with its own mechanism for converting between the two representations. +-- We need something more generic. +module SubHask.Category + ( + Category (..) + , (<<<) + , (>>>) + + -- * Hask + , Hask + , ($) + , ($!) + , embedHask + , embedHask2 + , withCategory + , embed2 + , fst + , snd + + -- * Special types of categories + , Concrete (..) + , Monoidal (..) +-- , (><) + , Braided (..) + , Symmetric (..) + , Cartesian (..) + , const + , const2 +-- , duplicate + , Closed (..) + + , Groupoid (..) + , Compact (..) + , Dagger (..) + + -- * Proofs + , Provable(..) + , ProofOf_ + , ProofOf + ) where + +import GHC.Prim +import SubHask.Internal.Prelude +import SubHask.SubType +import qualified Prelude as P + +-- required for compilation because these are defined properly in the Algebra.hs file +import GHC.Exts (fromListN,fromString) + +------------------------------------------------------------------------------- + +-- | This 'Category' class modifies the one in the Haskell standard to include the 'ValidCategory' type constraint. +-- This constraint let's us make instances of arbitrary subcategories of Hask. +-- +-- Subcategories are defined using the subtyping mechanism "(<:)". +-- Intuitively, arrows and objects in a subcategory satisfy additional properties that elements of the larger category do not necessarily satisfy. +-- Elements of a subcategory can always be embeded in the larger category. +-- Going in the other direction, however, requires a proof. +-- These proofs can (usually) not be verified by the type system and are therefore labeled unsafe. +-- +-- More details available at +-- and . + +class Category (cat :: k -> k -> *) where + + type ValidCategory cat (a::k) :: Constraint + id :: ValidCategory cat a => cat a a + + infixr 9 . + (.) :: cat b c -> cat a b -> cat a c + +-- | An alternative form of function composition taken from "Control.Arrow" +(>>>) :: Category cat => cat a b -> cat b c -> cat a c +a >>> b = b.a + +-- | An alternative form of function composition taken from "Control.Arrow" +(<<<) :: Category cat => cat b c -> cat a b -> cat a c +a <<< b = a.b + +-- | The category with Haskell types as objects, and functions as arrows. +-- +-- More details available at the . +type Hask = (->) + +instance Category (->) where + type ValidCategory (->) (a :: *) = () + id = P.id + + {-# NOINLINE (.) #-} + (.) = (P..) + +-- | The category with categories as objects and functors as arrows. +-- +-- More details available at +-- and . +-- +-- --- +-- +-- TODO: can this be extended to functor categories? +-- http://ncatlab.org/nlab/show/functor+category + +type Cat cat1 cat2 = forall a b. CatT (->) a b cat1 cat2 + +data CatT + ( cat :: * -> * -> *) + ( a :: k ) + ( b :: k ) + ( cat1 :: k -> k -> * ) + ( cat2 :: k -> k -> * ) + = CatT (cat1 a b `cat` cat2 a b) + +instance Category cat => Category (CatT cat a b) where + type ValidCategory (CatT cat a b) cat1 = + ( ValidCategory cat1 a + , ValidCategory cat1 b + , ValidCategory cat (cat1 a b) + ) + + id = CatT id + (CatT f).(CatT g) = CatT $ f.g + +-- NOTE: We would rather have the definition of CatT not depend on the a and b +-- variables, as in the code below. Unfortunately, GHC 7.8's type checker isn't +-- strong enough to handle forall inside of a type class. +-- +-- data CatT +-- ( cat :: * -> * -> *) +-- ( cat1 :: * -> * -> * ) +-- ( cat2 :: * -> * -> * ) +-- = forall a b. +-- ( ValidCategory cat1 a +-- , ValidCategory cat2 a +-- , ValidCategory cat1 b +-- , ValidCategory cat2 b +-- ) => CatT (cat1 a b `cat` cat2 a b) +-- +-- instance Category cat => Category (CatT cat) where +-- type ValidCategory (CatT cat) cat1 = forall a b. +-- ( ValidCategory cat1 a +-- , ValidCategory cat1 b +-- , ValidCategory cat (cat1 a b) +-- ) +-- +-- id = CatT id +-- (CatT f).(CatT g) = CatT $ f.g + +--------------------------------------- + +-- | Technicaly, a concrete category is any category equiped with a faithful +-- functor to the category of sets. This is just a little too platonic to +-- be represented in Haskell, but 'Hask' makes a pretty good approximation. +-- So we call any 'SubCategory' of 'Hask' 'Concrete'. Importantly, not +-- all categories are concrete. See the 'SubHask.Category.Slice.Slice' +-- category for an example. +-- +-- More details available at +-- and . +type Concrete cat = cat <: (->) + +-- | We generalize the Prelude's definition of "$" so that it applies to any +-- subcategory of 'Hask' (that is, any 'Concrete' 'Category'. This lets us +-- easily use these subcategories as functions. For example, given a polynomial +-- function +-- +-- > f :: Polynomial Double +-- +-- we can evaluate the polynomial at the number 5 by +-- +-- > f $ 5 +-- +-- NOTE: +-- Base's implementation of '$' has special compiler support that let's it work with the RankNTypes extension. +-- This version does not. +-- See for more detail. + +infixr 0 $ +($) :: Concrete subcat => subcat a b -> a -> b +($) = embedType2 + +-- | A strict version of '$' +infixr 0 $! +($!) :: Concrete subcat => subcat a b -> a -> b +f $! x = let !vx = x in f $ vx + +-- | Embeds a unary function into 'Hask' +embedHask :: Concrete subcat => subcat a b -> a -> b +embedHask = embedType2 + +-- | Embeds a binary function into 'Hask' +embedHask2 :: Concrete subcat => subcat a (subcat b c) -> a -> b -> c +embedHask2 f = \a b -> (f $ a) $ b + +-- | This is a special form of the 'embed' function which can make specifying the +-- category we are embedding into easier. +withCategory :: Concrete subcat => proxy subcat -> subcat a b -> a -> b +withCategory _ f = embedType2 f + +-- | FIXME: This would be a useful function to have, but I'm not sure how to implement it yet! +embed2 :: (subcat <: cat) => subcat a (subcat a b) -> cat a (cat a b) +embed2 f = undefined + +------------------------------------------------------------------------------- + +-- | The intuition behind a monoidal category is similar to the intuition +-- behind the 'SubHask.Algebra.Monoid' algebraic structure. Unfortunately, +-- there are a number of rather awkward laws to work out the technical details. +-- The associator and unitor functions are provided to demonstrate the +-- required isomorphisms. +-- +-- More details available at +class + ( Category cat + , ValidCategory cat (TUnit cat) + ) => Monoidal cat + where + + type Tensor cat :: k -> k -> k + tensor :: + ( ValidCategory cat a + , ValidCategory cat b + ) => cat a (cat b (Tensor cat a b)) + + type TUnit cat :: k + tunit :: proxy cat -> TUnit cat + +instance Monoidal (->) where + type Tensor (->) = (,) + tensor = \a b -> (a,b) + + type TUnit (->) = (() :: *) + tunit _ = () + +-- | This is a convenient and (hopefully) suggestive shortcut for constructing +-- tensor products in 'Concrete' categories. +infixl 7 >< +(><) :: forall cat a b. + ( Monoidal cat + , Concrete cat + , ValidCategory cat a + , ValidCategory cat b + ) => a -> b -> Proxy cat -> Tensor cat a b +(><) a b _ = embedHask2 (tensor::cat a (cat b (Tensor cat a b))) a b + +-- | Braided categories let us switch the order of tensored objects. +-- +-- More details available at +-- and +class Monoidal cat => Braided cat where + braid :: cat (Tensor cat a b) (Tensor cat b a) + unbraid :: cat (Tensor cat a b) (Tensor cat b a) + +instance Braided (->) where + braid (a,b) = (b,a) + unbraid = braid + +-- | In a symmetric braided category, 'braid' and 'unbraid' are inverses of each other. +-- +-- More details available at +class Braided cat => Symmetric cat +instance Symmetric (->) + +-- | In a cartesian monoidal category, the monoid object acts in a particularly nice way where we can compose and decompose it. +-- Intuitively, we can delete information using the 'fst' and 'snd' arrows, as well as +-- duplicate information using the 'duplicate' arrow. +-- +-- More details available at +class Symmetric cat => Cartesian cat where + fst_ :: + ( ValidCategory cat a + , ValidCategory cat b + , ValidCategory cat (Tensor cat a b) + ) => cat (Tensor cat a b) a + + snd_ :: + ( ValidCategory cat a + , ValidCategory cat b + , ValidCategory cat (Tensor cat a b) + ) => cat (Tensor cat a b) b + + terminal :: + ( ValidCategory cat a + ) => a -> cat a (TUnit cat) + + initial :: + ( ValidCategory cat a + ) => a -> cat (TUnit cat) a + +-- | "fst" specialized to Hask to aid with type inference +-- FIXME: this will not be needed with injective types +fst :: (a,b) -> a +fst (a,b) = a + +-- | "snd" specialized to Hask to aid with type inference +-- FIXME: this will not be needed with injective types +snd :: (a,b) -> b +snd (a,b) = b + +-- | Creates an arrow that ignores its first parameter. +const :: + ( Cartesian cat + , ValidCategory cat a + , ValidCategory cat b + ) => a -> cat b a +const a = const2 a undefined + +-- | Based on the type signature, this looks like it should be the inverse of "embed" function. +-- But it's not. +-- This function completely ignores its second argument! +const2 :: + ( Cartesian cat + , ValidCategory cat a + , ValidCategory cat b + ) => a -> b -> cat b a +const2 a b = initial a . terminal b + +instance Cartesian ((->) :: * -> * -> *) where + fst_ (a,b) = a + snd_ (a,b) = b + terminal a _ = () + initial a _ = a + +-- | Closed monoidal categories allow currying, and closed braided categories allow flipping. +-- We combine them into a single "Closed" class to simplify notation. +-- +-- In general, closed categories need not be either "Monoidal" or "Braided". +-- All a closed category requires is that all arrows are also objects in the category. +-- For example, `a +> (b +> c)` is a vallid arrow in the category `(+>)`. +-- But I don't know of any uses for this general definition of a closed category. +-- And this restricted definition seems to have a lot of uses. +-- +-- More details available at +-- and +class Braided cat => Closed cat where + curry :: cat (Tensor cat a b) c -> cat a (cat b c) + uncurry :: cat a (cat b c) -> cat (Tensor cat a b) c + + -- | The default definition should be correct for any category, + -- but can be overridden with a more efficient implementation. + -- + -- FIXME: does this actually need to be in a class? + -- or should it be a stand-alone function like "const"? + flip :: cat a (cat b c) -> cat b (cat a c) + flip f = curry (uncurry f . braid) + +instance Closed (->) where + curry f = \a b -> f (a,b) + uncurry f = \(a,b) -> f a b + +-- | Groupoids are categories where every arrow can be reversed. +-- This generalizes bijective and inverse functions. +-- Notably, 'Hask' is NOT a Groupoid. +-- +-- More details available at +-- , and +-- . +class Category cat => Groupoid cat where + inverse :: cat a b -> cat b a + +-- | Compact categories are another generalization from linear algebra. +-- In a compact category, we can dualize any object in the same way that we +-- can generate a covector from a vector. +-- Notably, 'Hask' is NOT compact. +-- +-- More details available at +-- and . +class Symmetric cat => Compact cat where + type Dual cat x + unit :: cat x (Tensor cat x (Dual cat x)) + counit :: cat (Tensor cat (Dual cat x) x) x + +-- | A dagger (also called an involution) is an arrow that is its own inverse. +-- Daggers generalize the idea of a transpose from linear algebra. +-- Notably, 'Hask' is NOT a dagger category. +-- +-- More details avalable at +-- and +class Category cat => Dagger cat where + trans :: cat a b -> cat b a + +-------------------------------------------------------------------------------- + +-- | This data family can be used to provide proofs that an arrow in Hask (i.e. a function) can be embedded in some subcategory. +-- We're travelling in the opposite direction of the subtyping mechanism. +-- That's valid only in a small number of cases. +-- These proofs give a type safe way to capture some (but not all) of those cases. +data family ProofOf (cat :: k -> k -> *) a + +newtype instance ProofOf Hask a = ProofOf { unProofOfHask :: a } + +-- FIXME: which direction should the subtyping go? +instance Sup (ProofOf cat a) a (ProofOf cat a) +instance Sup a (ProofOf cat a) (ProofOf cat a) + +instance a <: ProofOf Hask a where + embedType_ = Embed0 ProofOf + +-- | A provable category gives us the opposite ability as a Concrete category. +-- Instead of embedding a function in the subcategory into Hask, +-- we can embed certain functions from Hask into the subcategory. +class Concrete cat => Provable cat where + + -- | If you want to apply a function inside of a proof, + -- you must use the "($$)" operator instead of the more commonly used "($)". + -- + -- FIXME: + -- This is rather inelegant. + -- Is there any way to avoid this? + infixr 0 $$ + ($$) :: cat a b -> ProofOf_ cat a -> ProofOf_ cat b + +type family ProofOf_ cat a where + ProofOf_ Hask a = a + ProofOf_ cat a = ProofOf cat a + diff --git a/src/SubHask/Category/Finite.hs b/src/SubHask/Category/Finite.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Category/Finite.hs @@ -0,0 +1,249 @@ +-- {-# LANGUAGE ScopedTypeVariables #-} + +{- | +Finite categories are categories with a finite number of arrows. +In our case, this corresponds to functions with finite domains (and hence, ranges). +These functions have a number of possible representations. +Which is best will depend on the given function. +One common property is that these functions support decidable equality. +-} +module SubHask.Category.Finite + ( + + -- * Function representations + -- ** Sparse permutations + SparseFunction + , proveSparseFunction + , list2sparseFunction + + -- ** Sparse monoids + , SparseFunctionMonoid + + -- ** Dense functions + , DenseFunction + , proveDenseFunction + + -- * Finite types + , FiniteType (..) + , ZIndex + ) + where + +import Control.Monad +import GHC.Prim +import GHC.TypeLits +import Data.Proxy +import qualified Data.Map as Map +import qualified Data.Vector.Unboxed as VU +import qualified Prelude as P + +import SubHask.Algebra +import SubHask.Algebra.Group +import SubHask.Category +import SubHask.Internal.Prelude +import SubHask.SubType +import SubHask.TemplateHaskell.Deriving + +------------------------------------------------------------------------------- + +-- | A type is finite if there is a bijection between it and the natural numbers. +-- The 'index'/'deZIndex' functions implement this bijection. +class KnownNat (Order a) => FiniteType a where + type Order a :: Nat + index :: a -> ZIndex a + deZIndex :: ZIndex a -> a + enumerate :: [a] + getOrder :: a -> Integer + +instance KnownNat n => FiniteType (Z n) where + type Order (Z n) = n + index i = ZIndex i + deZIndex (ZIndex i) = i + enumerate = [ mkQuotient i | i <- [0..n - 1] ] + where + n = natVal (Proxy :: Proxy n) + getOrder z = natVal (Proxy :: Proxy n) + +-- | The 'ZIndex' class is a newtype wrapper around the natural numbers 'Z'. +-- +-- FIXME: remove this layer; I don't think it helps +-- +newtype ZIndex a = ZIndex (Z (Order a)) + +deriveHierarchy ''ZIndex [ ''Eq_, ''P.Ord ] + +-- | Swap the phantom type between two indices. +swapZIndex :: Order a ~ Order b => ZIndex a -> ZIndex b +swapZIndex (ZIndex i) = ZIndex i + +------------------------------------------------------------------------------- + +-- | Represents finite functions as a map associating input/output pairs. +data SparseFunction a b where + SparseFunction :: + ( FiniteType a + , FiniteType b + , Order a ~ Order b + ) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunction a b + +instance Category SparseFunction where + type ValidCategory SparseFunction a = + ( FiniteType a + ) + + id = SparseFunction $ Map.empty + + (SparseFunction f1).(SparseFunction f2) = SparseFunction + (Map.map (\a -> find a f1) f2) + where + find k map = case Map.lookup k map of + Just v -> v + Nothing -> swapZIndex k + +-- instance Sup SparseFunction (->) (->) +-- instance Sup (->) SparseFunction (->) +-- instance SparseFunction <: (->) where +-- embedType_ = Embed2 $ map2function f +-- where +-- map2function map k = case Map.lookup (index k) map of +-- Just v -> deZIndex v +-- Nothing -> deZIndex $ swapZIndex $ index k + +-- | Generates a sparse representation of a 'Hask' function. +-- This proof will always succeed, although it may be computationally expensive if the 'Order' of a and b is large. +proveSparseFunction :: + ( ValidCategory SparseFunction a + , ValidCategory SparseFunction b + , Order a ~ Order b + ) => (a -> b) -> SparseFunction a b +proveSparseFunction f = SparseFunction + $ Map.fromList + $ P.map (\a -> (index a,index $ f a)) enumerate + +-- | Generate sparse functions on some subset of the domain. +list2sparseFunction :: + ( ValidCategory SparseFunction a + , ValidCategory SparseFunction b + , Order a ~ Order b + ) => [Z (Order a)] -> SparseFunction a b +list2sparseFunction xs = SparseFunction $ Map.fromList $ go xs + where + go (y:[]) = [(ZIndex y, ZIndex $ P.head xs)] + go (y1:y2:ys) = (ZIndex y1,ZIndex y2):go (y2:ys) + +------------------------------------------------------------------------------- + +data SparseFunctionMonoid a b where + SparseFunctionMonoid :: + ( FiniteType a + , FiniteType b + , Monoid a + , Monoid b + , Order a ~ Order b + ) => Map.Map (ZIndex a) (ZIndex b) -> SparseFunctionMonoid a b + +instance Category SparseFunctionMonoid where + type ValidCategory SparseFunctionMonoid a = + ( FiniteType a + , Monoid a + ) + + id :: forall a. ValidCategory SparseFunctionMonoid a => SparseFunctionMonoid a a + id = SparseFunctionMonoid $ Map.fromList $ P.zip xs xs + where + xs = P.map index (enumerate :: [a]) + + (SparseFunctionMonoid f1).(SparseFunctionMonoid f2) = SparseFunctionMonoid + (Map.map (\a -> find a f1) f2) + where + find k map = case Map.lookup k map of + Just v -> v + Nothing -> index zero + +-- instance Sup SparseFunctionMonoid (->) (->) +-- instance Sup (->) SparseFunctionMonoid (->) +-- instance (SparseFunctionMonoid <: (->)) where +-- embedType_ = Embed2 $ map2function f +-- where +-- map2function map k = case Map.lookup (index k) map of +-- Just v -> deZIndex v +-- Nothing -> zero + +--------------------------------------- + +{- +instance (FiniteType b, Semigroup b) => Semigroup (SparseFunctionMonoid a b) where + (SparseFunctionMonoid f1)+(SparseFunctionMonoid f2) = SparseFunctionMonoid $ Map.unionWith go f1 f2 + where + go b1 b2 = index $ deZIndex b1 + deZIndex b2 + +instance + ( FiniteType a + , FiniteType b + , Monoid a + , Monoid b + , Order a ~ Order b + ) => Monoid (SparseFunctionMonoid a b) where + zero = SparseFunctionMonoid $ Map.empty + +instance + ( FiniteType b + , Abelian b + ) => Abelian (SparseFunctionMonoid a b) + +instance (FiniteType b, Group b) => Group (SparseFunctionMonoid a b) where + negate (SparseFunctionMonoid f) = SparseFunctionMonoid $ Map.map (index.negate.deZIndex) f + +type instance Scalar (SparseFunctionMonoid a b) = Scalar b + +instance (FiniteType b, Module b) => Module (SparseFunctionMonoid a b) where + r *. (SparseFunctionMonoid f) = SparseFunctionMonoid $ Map.map (index.(r*.).deZIndex) f + +instance (FiniteType b, VectorSpace b) => VectorSpace (SparseFunctionMonoid a b) where + (SparseFunctionMonoid f) ./ r = SparseFunctionMonoid $ Map.map (index.(./r).deZIndex) f +-} + +------------------------------------------------------------------------------- + +-- | Represents finite functions as a hash table associating input/output value pairs. +data DenseFunction (a :: *) (b :: *) where + DenseFunction :: + ( FiniteType a + , FiniteType b + ) => VU.Vector Int -> DenseFunction a b + +instance Category DenseFunction where + type ValidCategory DenseFunction (a :: *) = + ( FiniteType a + ) + + id :: forall a. ValidCategory DenseFunction a => DenseFunction a a + id = DenseFunction $ VU.generate n id + where + n = fromIntegral $ natVal (Proxy :: Proxy (Order a)) + + (DenseFunction f).(DenseFunction g) = DenseFunction $ VU.map (f VU.!) g + +-- instance SubCategory DenseFunction (->) where +-- embed (DenseFunction f) = \x -> deZIndex $ int2index $ f VU.! (index2int $ index x) + +-- | Generates a dense representation of a 'Hask' function. +-- This proof will always succeed; however, if the 'Order' of the finite types +-- are very large, it may take a long time. +-- In that case, a `SparseFunction` is probably the better representation. +proveDenseFunction :: forall a b. + ( ValidCategory DenseFunction a + , ValidCategory DenseFunction b + ) => (a -> b) -> DenseFunction a b +proveDenseFunction f = DenseFunction $ VU.generate n (index2int . index . f . deZIndex . int2index) + where + n = fromIntegral $ natVal (Proxy :: Proxy (Order a)) + +--------------------------------------- +-- internal functions only + +int2index :: Int -> ZIndex a +int2index i = ZIndex $ Mod $ fromIntegral i + +index2int :: ZIndex a -> Int +index2int (ZIndex (Mod i)) = fromIntegral i diff --git a/src/SubHask/Category/Polynomial.hs b/src/SubHask/Category/Polynomial.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Category/Polynomial.hs @@ -0,0 +1,161 @@ +module SubHask.Category.Polynomial + where + +import Data.List (intersperse,filter,reverse) +import qualified Prelude as P + +import SubHask.Internal.Prelude +import SubHask.Category +import SubHask.Algebra +import SubHask.Monad +import SubHask.SubType + +------------------------------------------------------------------------------- + + +-- | The type of polynomials over an arbitrary ring. +-- +-- See for more detail. +type Polynomial a = Polynomial_ a a + +-- | +-- FIXME: +-- "Polynomial_" takes two type parameters in order to be compatible with the "Category" hierarchy of classes. +-- But currently, both types must match each other. +-- Can/Should we generalize this to allow polynomials between types? +-- +data Polynomial_ a b where + Polynomial_ :: (ValidLogic a, Ring a, a~b) => {-#UNPACK#-}![a] -> Polynomial_ a b + +mkMutable [t| forall a b. Polynomial_ a b |] + +instance (Eq r, Show r) => Show (Polynomial_ r r) where + show (Polynomial_ xs) = concat $ intersperse " + " $ filter (/=[]) $ reverse $ imap go xs + where + -- FIXME: + -- The code below results in prettier output but incurs an "Eq" constraint that confuses ghci + go :: Int -> r -> String + go 0 x = when (zero/=x) $ show x + go 1 x = when (zero/=x) $ when (one/=x) (show x) ++ "x" + go i x = when (zero/=x) $ when (one/=x) (show x) ++ "x^" ++ show i + + when :: Monoid a => Bool -> a -> a + when cond x = if cond then x else zero + + +------------------------------------------------------------------------------- + +newtype instance ProofOf Polynomial_ a = ProofOf { unProofOf :: Polynomial_ a a } + +mkMutable [t| forall a. ProofOf Polynomial_ a |] + +instance Ring a => Semigroup (ProofOf Polynomial_ a) where + (ProofOf p1)+(ProofOf p2) = ProofOf $ p1+p2 + +instance (ValidLogic a, Ring a) => Cancellative (ProofOf Polynomial_ a) where + (ProofOf p1)-(ProofOf p2) = ProofOf $ p1-p2 + +instance (ValidLogic a, Ring a) => Monoid (ProofOf Polynomial_ a) where + zero = ProofOf zero + +instance (Ring a, Abelian a) => Abelian (ProofOf Polynomial_ a) + +instance (ValidLogic a, Ring a) => Group (ProofOf Polynomial_ a) where + negate (ProofOf p) = ProofOf $ negate p + +instance (ValidLogic a, Ring a) => Rg (ProofOf Polynomial_ a) where + (ProofOf p1)*(ProofOf p2) = ProofOf $ p1*p2 + +instance (ValidLogic a, Ring a) => Rig (ProofOf Polynomial_ a) where + one = ProofOf one + +instance (ValidLogic a, Ring a) => Ring (ProofOf Polynomial_ a) where + fromInteger i = ProofOf $ fromInteger i + +provePolynomial :: (ValidLogic a, Ring a) => (ProofOf Polynomial_ a -> ProofOf Polynomial_ a) -> Polynomial_ a a +provePolynomial f = unProofOf $ f $ ProofOf $ Polynomial_ [0,1] +--------------------------------------- + +type instance Scalar (Polynomial_ a b) = Scalar b +type instance Logic (Polynomial_ a b) = Logic b + +instance Eq b => Eq_ (Polynomial_ a b) where + (Polynomial_ xs)==(Polynomial_ ys) = xs==ys + +instance Ring r => Semigroup (Polynomial_ r r) where + (Polynomial_ p1)+(Polynomial_ p2) = Polynomial_ $ sumList (+) p1 p2 + +instance (ValidLogic r, Ring r) => Monoid (Polynomial_ r r) where + zero = Polynomial_ [] + +instance (ValidLogic r, Ring r) => Cancellative (Polynomial_ r r) where + (Polynomial_ p1)-(Polynomial_ p2) = Polynomial_ $ sumList (-) p1 p2 + +instance (ValidLogic r, Ring r) => Group (Polynomial_ r r) where + negate (Polynomial_ p) = Polynomial_ $ P.map negate p + +instance (Ring r, Abelian r) => Abelian (Polynomial_ r r) + +instance (ValidLogic r, Ring r) => Rg (Polynomial_ r r) where + (Polynomial_ p1)*(Polynomial_ p2) = Polynomial_ $ P.foldl (sumList (+)) [] $ go p1 zero + where + go [] i = [] + go (x:xs) i = (P.replicate i zero ++ P.map (*x) p2):go xs (i+one) + +instance (ValidLogic r, Ring r) => Rig (Polynomial_ r r) where + one = Polynomial_ [one] + +instance (ValidLogic r, Ring r) => Ring (Polynomial_ r r) where + fromInteger i = Polynomial_ [fromInteger i] + +type instance Polynomial_ r r >< r = Polynomial_ r r + +instance IsScalar r => Module (Polynomial_ r r) where + (Polynomial_ xs) .* r = Polynomial_ $ P.map (*r) xs + +instance IsScalar r => FreeModule (Polynomial_ r r) where + (Polynomial_ xs) .*. (Polynomial_ ys) = Polynomial_ $ P.zipWith (*) xs ys + ones = Polynomial_ $ P.repeat one + +sumList f [] ys = ys +sumList f xs [] = xs +sumList f (x:xs) (y:ys) = f x y:sumList f xs ys + +--------------------------------------- + +instance Category Polynomial_ where + type ValidCategory Polynomial_ a = (ValidLogic a, Ring a) + id = Polynomial_ [zero, one] + (Polynomial_ xs) . p2@(Polynomial_ _) = Polynomial_ (map (\x -> Polynomial_ [x]) xs) $ p2 + +instance Sup Polynomial_ Hask Hask +instance Sup Hask Polynomial_ Hask + +instance Polynomial_ <: Hask where + embedType_ = Embed2 evalPolynomial_ + +pow :: Rig r => r -> Int -> r +pow r i = foldl' (*) one $ P.replicate i r + +evalPolynomial_ :: Polynomial_ a b -> a -> b +evalPolynomial_ (Polynomial_ xs) r = sum $ imap go xs + where + go i x = x*pow r i + +------------------------------------------------------------------------------- + +-- FIXME: +-- Polynomial_s should use the derivative interface from the Derivative module +-- +-- class Category cat => Smooth cat where +-- derivative :: ValidCategory cat a b => cat a b Linear.+> cat a b +-- +-- instance Smooth Polynomial_ where +-- derivative = unsafeProveLinear go +-- where +-- go (Polynomial_ xs) = Polynomial_ $ P.tail $ P.zipWith (*) (inflist zero one) xs +-- inflist xs x = xs : inflist (xs+x) x +-- +-- data MonoidT c a b = MonoidT (c a) + + diff --git a/src/SubHask/Category/Product.hs b/src/SubHask/Category/Product.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Category/Product.hs @@ -0,0 +1,20 @@ +module SubHask.Category.Product + where + +import GHC.Prim +import qualified Prelude as P + +import SubHask.Category +import SubHask.Internal.Prelude +import GHC.Exts + +------------------------------------------------------------------------------- + +data (><) cat1 cat2 a b = Product (cat1 a b, cat2 a b) + +instance (Category cat1, Category cat2) => Category (cat1 >< cat2) where + type ValidCategory (cat1> Category (Comma cat1 cat2 cat3) + where + + type ValidCategory (Comma cat1 cat2 cat3) a = + ( ValidCategory cat1 a + , ValidCategory cat2 a + ) + + id = Comma id id + (Comma f1 g1).(Comma f2 g2) = Comma (f1.f2) (g1.g2) + +-- runComma :: ValidCategory (Comma cat1 cat2 cat3) a b => +-- (Comma cat1 cat2 cat3) a b -> cat3 a b -> cat3 a b + +------------------------------------------------------------------------------- + +data (cat / (obj :: *)) (a :: *) (b :: *) = Slice (cat a b) + +instance Category cat => Category (cat/obj) where + type ValidCategory (cat/obj) (a :: *) = + ( ValidCategory cat a + , Category cat + ) + + id = Slice id + (Slice f).(Slice g) = Slice $ f.g + +runSlice :: + ( ValidCategory (cat/obj) a + , ValidCategory (cat/obj) b + ) => (cat/obj) a b -> (cat b obj) -> (cat a obj) +runSlice (Slice cat1) cat2 = cat2.cat1 + diff --git a/src/SubHask/Category/Trans/Bijective.hs b/src/SubHask/Category/Trans/Bijective.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Category/Trans/Bijective.hs @@ -0,0 +1,123 @@ +-- | Provides transformer categories for injective, surjective, and bijective +-- functions. +-- +-- TODO: Add @Epic@, @Monic@, and @Iso@ categories. +module SubHask.Category.Trans.Bijective + ( Injective + , InjectiveT + , unsafeProveInjective + , Surjective + , SurjectiveT + , unsafeProveSurjective + , Bijective + , BijectiveT + , proveBijective + , unsafeProveBijective + ) + where + +import SubHask.Category +import SubHask.Algebra +import SubHask.SubType +import SubHask.Internal.Prelude + + +-- newtype instance ProofOf InjectiveT a = ProofOf { unProofOf :: a } +-- +-- instance Semigroup a => Semigroup (ProofOf InjectiveT a) where +-- (ProofOf a1)+(ProofOf a2) = ProofOf (a1+a2) +-- +-- proveInjective :: (ProofOf InjectiveT a -> ProofOf InjectiveT b) -> InjectiveT (->) a b +-- proveInjective f = InjectiveT $ \a -> unProofOf $ f $ ProofOf a + +------------------------------------------------------------------------------- + +-- | Injective (one-to-one) functions map every input to a unique output. See +-- for more detail. +class Concrete cat => Injective cat + +newtype InjectiveT cat a b = InjectiveT { unInjectiveT :: cat a b } + +instance Concrete cat => Injective (InjectiveT cat) + +instance Category cat => Category (InjectiveT cat) where + type ValidCategory (InjectiveT cat) a = (ValidCategory cat a) + id = InjectiveT id + (InjectiveT f).(InjectiveT g) = InjectiveT (f.g) + +instance Sup a b c => Sup (InjectiveT a) b c +instance Sup b a c => Sup a (InjectiveT b) c +instance (subcat <: cat) => InjectiveT subcat <: cat where + embedType_ = Embed2 (\ (InjectiveT f) -> embedType2 f) + +unsafeProveInjective :: Concrete cat => cat a b -> InjectiveT cat a b +unsafeProveInjective = InjectiveT + +------------------- + +-- | Surjective (onto) functions can take on every value in the range. See +-- for more detail. +class Concrete cat => Surjective cat + +newtype SurjectiveT cat a b = SurjectiveT { unSurjectiveT :: cat a b } + +instance Concrete cat => Surjective (SurjectiveT cat) + +instance Category cat => Category (SurjectiveT cat) where + type ValidCategory (SurjectiveT cat) a = (ValidCategory cat a) + id = SurjectiveT id + (SurjectiveT f).(SurjectiveT g) = SurjectiveT (f.g) + +instance Sup a b c => Sup (SurjectiveT a) b c +instance Sup b a c => Sup a (SurjectiveT b) c +instance (subcat <: cat) => SurjectiveT subcat <: cat where + embedType_ = Embed2 (\ (SurjectiveT f) -> embedType2 f) + +unsafeProveSurjective :: Concrete cat => cat a b -> SurjectiveT cat a b +unsafeProveSurjective = SurjectiveT + +------------------- + +-- | Bijective functions are both injective and surjective. See +-- for more detail. +class (Injective cat, Surjective cat) => Bijective cat + +newtype BijectiveT cat a b = BijectiveT { unBijectiveT :: cat a b } + +instance Concrete cat => Surjective (BijectiveT cat) +instance Concrete cat => Injective (BijectiveT cat) +instance Concrete cat => Bijective (BijectiveT cat) + +instance Category cat => Category (BijectiveT cat) where + type ValidCategory (BijectiveT cat) a = (ValidCategory cat a) + id = BijectiveT id + (BijectiveT f).(BijectiveT g) = BijectiveT (f.g) + +instance Sup a b c => Sup (BijectiveT a) b c +instance Sup b a c => Sup a (BijectiveT b) c +instance (subcat <: cat) => BijectiveT subcat <: cat where + embedType_ = Embed2 (\ (BijectiveT f) -> embedType2 f) + +proveBijective :: (Injective cat, Surjective cat) => cat a b -> BijectiveT cat a b +proveBijective = BijectiveT + +unsafeProveBijective :: Concrete cat => cat a b -> BijectiveT cat a b +unsafeProveBijective = BijectiveT + +{- +data BijectiveT cat a b = BijectiveT (cat a b) (cat b a) + +instance SubCategory cat subcat => SubCategory cat (BijectiveT subcat) where + embed (BijectiveT f fi) = embed f + +instance Category cat => Groupoid (BijectiveT cat) where + inverse (BijectiveT f fi) = BijectiveT fi f + +instance Category cat => Category (BijectiveT cat) where + type ValidCategory (BijectiveT cat) a b = (ValidCategory cat a b, ValidCategory cat b a) + id = BijectiveT id id + (BijectiveT f fi).(BijectiveT g gi) = BijectiveT (f.g) (gi.fi) + +unsafeProveBijective :: cat a b -> cat b a -> BijectiveT cat a b +unsafeProveBijective f fi = BijectiveT f fi +-} diff --git a/src/SubHask/Category/Trans/Constrained.hs b/src/SubHask/Category/Trans/Constrained.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Category/Trans/Constrained.hs @@ -0,0 +1,90 @@ +module SubHask.Category.Trans.Constrained + ( ConstrainedT(..) + , proveConstrained + + -- ** Common type synonyms + , EqHask + , proveEqHask + + , OrdHask + , proveOrdHask + ) + where + +import GHC.Prim +import qualified Prelude as P + +import SubHask.Algebra +import SubHask.Category +import SubHask.SubType +import SubHask.Internal.Prelude + +------------------------------------------------------------------------------- + +type EqHask = ConstrainedT '[Eq_ ] Hask +type OrdHask = ConstrainedT '[Ord_] Hask + +type family AppConstraints (f :: [* -> Constraint]) (a :: *) :: Constraint +type instance AppConstraints '[] a = (ClassicalLogic a) +type instance AppConstraints (x ': xs) a = (x a, AppConstraints xs a) + +--------- + +data ConstrainedT (xs :: [* -> Constraint]) cat (a :: *) (b :: *) where + ConstrainedT :: + ( AppConstraints xs a + , AppConstraints xs b + , ValidCategory cat a + , ValidCategory cat b + ) => cat a b -> ConstrainedT xs cat a b + +proveConstrained :: + ( ValidCategory (ConstrainedT xs cat) a + , ValidCategory (ConstrainedT xs cat) b + ) => cat a b -> ConstrainedT xs cat a b +proveConstrained = ConstrainedT + +proveEqHask :: (Eq a, Eq b) => (a -> b) -> (a `EqHask` b) +proveEqHask = proveConstrained + +proveOrdHask :: (Ord a, Ord b) => (a -> b) -> (a `OrdHask` b) +proveOrdHask = proveConstrained + +--------- + +instance Category cat => Category (ConstrainedT xs cat) where + + type ValidCategory (ConstrainedT xs cat) (a :: *) = + ( AppConstraints xs a + , ValidCategory cat a + ) + + id = ConstrainedT id + + (ConstrainedT f).(ConstrainedT g) = ConstrainedT (f.g) + +instance Sup a b c => Sup (ConstrainedT xs a) b c +instance Sup b a c => Sup a (ConstrainedT xs b) c +instance (subcat <: cat) => ConstrainedT xs subcat <: cat where + embedType_ = Embed2 (\ (ConstrainedT f) -> embedType2 f) + +instance (AppConstraints xs (TUnit cat), Monoidal cat) => Monoidal (ConstrainedT xs cat) where + type Tensor (ConstrainedT xs cat) = Tensor cat + tensor = error "FIXME: need to add a Hask Functor instance for this to work" + + type TUnit (ConstrainedT xs cat) = TUnit cat + tunit _ = tunit (Proxy::Proxy cat) + +-- instance (AppConstraints xs (TUnit cat), Braided cat) => Braided (ConstrainedT xs cat) where +-- braid = braid (Proxy :: Proxy cat) +-- unbraid = unbraid (Proxy :: Proxy cat) + +-- instance (AppConstraints xs (TUnit cat), Symmetric cat) => Symmetric (ConstrainedT xs cat) + +-- instance (AppConstraints xs (TUnit cat), Cartesian cat) => Cartesian (ConstrainedT xs cat) where +-- fst = ConstrainedT fst +-- snd = ConstrainedT snd +-- +-- terminal a = ConstrainedT $ terminal a +-- initial a = ConstrainedT $ initial a + diff --git a/src/SubHask/Category/Trans/Derivative.hs b/src/SubHask/Category/Trans/Derivative.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Category/Trans/Derivative.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE IncoherentInstances #-} + +-- | This module provides a category transformer for automatic differentiation. +-- +-- There are many alternative notions of a generalized derivative. +-- Perhaps the most common is the differential Ring. +-- In Haskell, this might be defined as: +-- +-- > class Field r => Differential r where +-- > derivative :: r -> r +-- > +-- > type Diff cat = forall a b. (Category cat, Differential cat a b) +-- +-- But this runs into problems with the lack of polymorphic constraints in GHC. +-- See, for example . +-- +-- References: +-- +-- * +module SubHask.Category.Trans.Derivative + where + +import SubHask.Algebra +import SubHask.Algebra.Vector +import SubHask.Category +import SubHask.SubType +import SubHask.Internal.Prelude + +import qualified Prelude as P + +-------------------------------------------------------------------------------- + +-- | This is essentially just a translation of the "Numeric.AD.Forward.Forward" type +-- for use with the SubHask numeric hierarchy. +-- +-- FIXME: +-- +-- Add reverse mode auto-differentiation for vectors. +-- Apply the "ProofOf" framework from Monotonic +data Forward a = Forward + { val :: !a + , val' :: a + } + deriving (Typeable,Show) + +mkMutable [t| forall a. Forward a |] + +instance Semigroup a => Semigroup (Forward a) where + (Forward a1 a1')+(Forward a2 a2') = Forward (a1+a2) (a1'+a2') + +instance Cancellative a => Cancellative (Forward a) where + (Forward a1 a1')-(Forward a2 a2') = Forward (a1-a2) (a1'-a2') + +instance Monoid a => Monoid (Forward a) where + zero = Forward zero zero + +instance Group a => Group (Forward a) where + negate (Forward a b) = Forward (negate a) (negate b) + +instance Abelian a => Abelian (Forward a) + +instance Rg a => Rg (Forward a) where + (Forward a1 a1')*(Forward a2 a2') = Forward (a1*a2) (a1*a2'+a2*a1') + +instance Rig a => Rig (Forward a) where + one = Forward one zero + +instance Ring a => Ring (Forward a) where + fromInteger x = Forward (fromInteger x) zero + +instance Field a => Field (Forward a) where + reciprocal (Forward a a') = Forward (reciprocal a) (-a'/(a*a)) + (Forward a1 a1')/(Forward a2 a2') = Forward (a1/a2) ((a1'*a2+a1*a2')/(a2'*a2')) + fromRational r = Forward (fromRational r) 0 + +--------- + +proveC1 :: (a ~ (a> (Forward a -> Forward a) -> C1 (a -> a) +proveC1 f = Diffn (\a -> val $ f $ Forward a one) $ Diff0 $ \a -> val' $ f $ Forward a one + +proveC2 :: (a ~ (a> (Forward (Forward a) -> Forward (Forward a)) -> C2 (a -> a) +proveC2 f + = Diffn (\a -> val $ val $ f $ Forward (Forward a one) one) + $ Diffn (\a -> val' $ val $ f $ Forward (Forward a one) one) + $ Diff0 (\a -> val' $ val' $ f $ Forward (Forward a one) one) + +-------------------------------------------------------------------------------- + +class C (cat :: * -> * -> *) where + type D cat :: * -> * -> * + derivative :: cat a b -> D cat a (a >< b) + +data Diff (n::Nat) a b where + Diff0 :: (a -> b) -> Diff 0 a b + Diffn :: (a -> b) -> Diff (n-1) a (a >< b) -> Diff n a b + +--------- + +instance Sup (->) (Diff n) (->) +instance Sup (Diff n) (->) (->) + +instance Diff 0 <: (->) where + embedType_ = Embed2 unDiff0 + where + unDiff0 :: Diff 0 a b -> a -> b + unDiff0 (Diff0 f) = f + +instance Diff n <: (->) where + embedType_ = Embed2 unDiffn + where + unDiffn :: Diff n a b -> a -> b + unDiffn (Diffn f f') = f +-- +-- FIXME: these subtyping instance should be made more generic +-- the problem is that type families aren't currently powerful enough +-- +instance Sup (Diff 0) (Diff 1) (Diff 0) +instance Sup (Diff 1) (Diff 0) (Diff 0) +instance Diff 1 <: Diff 0 where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diff0 f + +instance Sup (Diff 0) (Diff 2) (Diff 0) +instance Sup (Diff 2) (Diff 0) (Diff 0) +instance Diff 2 <: Diff 0 where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diff0 f + +instance Sup (Diff 1) (Diff 2) (Diff 1) +instance Sup (Diff 2) (Diff 1) (Diff 1) +instance Diff 2 <: Diff 1 where embedType_ = Embed2 m2n where m2n (Diffn f f') = Diffn f (embedType2 f') + +--------- + +instance (1 <= n) => C (Diff n) where + type D (Diff n) = Diff (n-1) + derivative (Diffn f f') = f' + +unsafeProveC0 :: (a -> b) -> Diff 0 a b +unsafeProveC0 f = Diff0 f + +unsafeProveC1 + :: (a -> b) -- ^ f(x) + -> (a -> a> C1 (a -> b) +unsafeProveC1 f f' = Diffn f $ unsafeProveC0 f' + +unsafeProveC2 + :: (a -> b) -- ^ f(x) + -> (a -> a> (a -> a> C2 (a -> b) +unsafeProveC2 f f' f'' = Diffn f $ unsafeProveC1 f' f'' + +type C0 a = C0_ a +type family C0_ (f :: *) :: * where + C0_ (a -> b) = Diff 0 a b + +type C1 a = C1_ a +type family C1_ (f :: *) :: * where + C1_ (a -> b) = Diff 1 a b + +type C2 a = C2_ a +type family C2_ (f :: *) :: * where + C2_ (a -> b) = Diff 2 a b + +--------------------------------------- +-- algebra + +mkMutable [t| forall n a b. Diff n a b |] + +instance Semigroup b => Semigroup (Diff 0 a b) where + (Diff0 f1 )+(Diff0 f2 ) = Diff0 (f1+f2) + +instance (Semigroup b, Semigroup (a> Semigroup (Diff 1 a b) where + (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2') + +instance (Semigroup b, Semigroup (a> Semigroup (Diff 2 a b) where + (Diffn f1 f1')+(Diffn f2 f2') = Diffn (f1+f2) (f1'+f2') + +instance Monoid b => Monoid (Diff 0 a b) where + zero = Diff0 zero + +instance (Monoid b, Monoid (a> Monoid (Diff 1 a b) where + zero = Diffn zero zero + +instance (Monoid b, Monoid (a> Monoid (Diff 2 a b) where + zero = Diffn zero zero + +-------------------------------------------------------------------------------- +-- test + +-- v = unsafeToModule [1,2,3,4,5] :: SVector 5 Double +-- +-- sphere :: Hilbert v => C0 (v -> Scalar v) +-- sphere = unsafeProveC0 f +-- where +-- f v = v<>v diff --git a/src/SubHask/Category/Trans/Monotonic.hs b/src/SubHask/Category/Trans/Monotonic.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Category/Trans/Monotonic.hs @@ -0,0 +1,196 @@ +module SubHask.Category.Trans.Monotonic +-- ( Mon (..) +-- , unsafeProveMon +-- +-- -- * The MonT transformer +-- , MonT (..) +-- , unsafeProveMonT +-- +-- ) + where + +import GHC.Prim +import Data.Proxy +import qualified Prelude as P + +import SubHask.Internal.Prelude +import SubHask.Category +import SubHask.Algebra +import SubHask.SubType +import SubHask.Category.Trans.Constrained + +------------------------------------------------------------------------------- + +data IncreasingT cat (a :: *) (b :: *) where + IncreasingT :: (Ord_ a, Ord_ b) => cat a b -> IncreasingT cat a b + +mkMutable [t| forall cat a b. IncreasingT cat a b |] + +instance Category cat => Category (IncreasingT cat) where + type ValidCategory (IncreasingT cat) a = (ValidCategory cat a, Ord_ a) + id = IncreasingT id + (IncreasingT f).(IncreasingT g) = IncreasingT $ f.g + +instance Sup a b c => Sup (IncreasingT a) b c +instance Sup b a c => Sup a (IncreasingT b) c +instance (subcat <: cat) => IncreasingT subcat <: cat where + embedType_ = Embed2 (\ (IncreasingT f) -> embedType2 f) + +------------------- + +instance Semigroup (cat a b) => Semigroup (IncreasingT cat a b) where + (IncreasingT f)+(IncreasingT g) = IncreasingT $ f+g + +-- instance (Ord_ a, Ord_ b, Monoid (cat a b)) => Monoid (IncreasingT cat a b) where +-- zero = IncreasingT zero +-- +instance Abelian (cat a b) => Abelian (IncreasingT cat a b) where + +instance Provable (IncreasingT Hask) where + f $$ a = ProofOf $ (f $ unProofOf a) + + +------------------- + +newtype instance ProofOf (IncreasingT cat) a = ProofOf { unProofOf :: ProofOf_ cat a } + +mkMutable [t| forall a cat. ProofOf (IncreasingT cat) a |] + +instance Semigroup (ProofOf_ cat a) => Semigroup (ProofOf (IncreasingT cat) a) where + (ProofOf a1)+(ProofOf a2) = ProofOf (a1+a2) + +-- instance Monoid (ProofOf cat a) => Monoid (ProofOf (IncreasingT cat) a) where +-- zero = ProofOf zero + +instance Abelian (ProofOf_ cat a) => Abelian (ProofOf (IncreasingT cat) a) + +------------------- + +type Increasing a = Increasing_ a +type family Increasing_ a where + Increasing_ ( (cat :: * -> * -> *) a b) = IncreasingT cat a b + +proveIncreasing :: + ( Ord_ a + , Ord_ b + ) => (ProofOf (IncreasingT Hask) a -> ProofOf (IncreasingT Hask) b) -> Increasing (a -> b) +proveIncreasing f = unsafeProveIncreasing $ \a -> unProofOf $ f $ ProofOf a + +instance (Ord_ a, Ord_ b) => Hask (ProofOf (IncreasingT Hask) a) (ProofOf (IncreasingT Hask) b) <: (IncreasingT Hask) a b where + embedType_ = Embed0 proveIncreasing + +unsafeProveIncreasing :: + ( Ord_ a + , Ord_ b + ) => (a -> b) -> Increasing (a -> b) +unsafeProveIncreasing = IncreasingT + +------------------------------------------------------------------------------- + +-- | A convenient specialization of "MonT" and "Hask" +type Mon = MonT Hask + +-- type family ValidMon a :: Constraint where +-- ValidMon a = Ord_ a +-- ValidMon (MonT (->) b c) = (ValidMon b, ValidMon c) +-- ValidMon a = Ord a +type ValidMon a = Ord a + +data MonT cat (a :: *) (b :: *) where + MonT :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b + +unsafeProveMonT :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b +unsafeProveMonT = MonT + +unsafeProveMon :: (ValidMon a, ValidMon b) => cat a b -> MonT cat a b +unsafeProveMon = MonT + +------------------- + +instance Category cat => Category (MonT cat) where + type ValidCategory (MonT cat) a = (ValidCategory cat a, ValidMon a) + id = MonT id + (MonT f).(MonT g) = MonT $ f.g + +instance Sup a b c => Sup (MonT a) b c +instance Sup b a c => Sup a (MonT b) c +instance (subcat <: cat) => MonT subcat <: cat where + embedType_ = Embed2 (\ (MonT f) -> embedType2 f) + +-- instance (ValidMon (TUnit cat), Monoidal cat) => Monoidal (MonT cat) where +-- type Tensor (MonT cat) = Tensor cat +-- tensor = error "FIXME: need to add a Hask Functor instance for this to work" +-- +-- type TUnit (MonT cat) = TUnit cat +-- tunit _ = tunit (Proxy::Proxy cat) + +-- instance (ValidMon (TUnit cat), Braided cat) => Braided (MonT cat) where +-- braid _ = braid (Proxy :: Proxy cat) +-- unbraid _ = unbraid (Proxy :: Proxy cat) +-- +-- instance (ValidMon (TUnit cat), Symmetric cat) => Symmetric (MonT cat) +-- +-- instance (ValidMon (TUnit cat), Cartesian cat) => Cartesian (MonT cat) where +-- fst = MonT fst +-- snd = MonT snd +-- +-- terminal a = MonT $ terminal a +-- initial a = MonT $ initial a + +------------------------------------------------------------------------------- + +{- +type Mon = MonT Hask + +newtype MonT cat a b = MonT (ConstrainedT '[P.Ord] cat a b) + +unsafeProveMon :: + ( Ord b + , Ord a + , ValidCategory cat a + , ValidCategory cat b + ) => cat a b -> MonT (cat) a b +unsafeProveMon f = MonT $ proveConstrained f + +------------------- + +instance Category cat => Category (MonT cat) where + type ValidCategory (MonT cat) a = ValidCategory (ConstrainedT '[P.Ord] cat) a + id = MonT id + (MonT f) . (MonT g) = MonT (f.g) + +instance SubCategory subcat cat => SubCategory (MonT subcat) cat where + embed (MonT f) = embed f + +instance (Ord (TUnit cat), Monoidal cat) => Monoidal (MonT cat) where + type Tensor (MonT cat) = Tensor cat + tensor = error "FIXME: need to add a Hask Functor instance for this to work" + + type TUnit (MonT cat) = TUnit cat + tunit _ = tunit (Proxy::Proxy cat) + +instance (Ord (TUnit cat), Braided cat) => Braided (MonT cat) where + braid _ = braid (Proxy :: Proxy cat) + unbraid _ = unbraid (Proxy :: Proxy cat) + +instance (Ord (TUnit cat), Symmetric cat) => Symmetric (MonT cat) + +instance (Ord (TUnit cat), Cartesian cat) => Cartesian (MonT cat) where + fst = MonT $ ConstrainedT fst + snd = MonT $ ConstrainedT snd + + terminal a = MonT $ ConstrainedT $ terminal a + initial a = MonT $ ConstrainedT $ initial a + + +------------------- + +mon :: Int -> [Int] +mon i = [i,i+1,i+2] + +nomon :: Int -> [Int] +nomon i = if i `mod` 2 == 0 + then mon i + else mon (i*2) + +-} diff --git a/src/SubHask/Compatibility/Base.hs b/src/SubHask/Compatibility/Base.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Compatibility/Base.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE NoRebindableSyntax #-} + +-- | This file contains a LOT of instance declarations for making Base code compatible with SubHask type classes. +-- There's very little code in here though. +-- Most instances are generated using the functions in "SubHask.TemplateHaskell.Base". +module SubHask.Compatibility.Base + () + where + +import Data.Typeable +import qualified Prelude as Base +import qualified Control.Applicative as Base +import qualified Control.Monad as Base +import Language.Haskell.TH + +import Control.Arrow +import Control.Monad.Identity (Identity(..)) +import Control.Monad.Reader (Reader,ReaderT) +import Control.Monad.State.Strict (State,StateT) +import Control.Monad.Trans +import Control.Monad.ST (ST) +import GHC.Conc.Sync +import GHC.GHCi +import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadPrec + +import Control.Monad.Random + +import SubHask.Algebra +import SubHask.Category +import SubHask.Monad +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Base +import SubHask.TemplateHaskell.Deriving + + +-------------------------------------------------------------------------------- +-- bug fixes + +-- required for GHCI to work because NoIO does not have a Base.Functor instance +instance Functor Hask NoIO where fmap = Base.liftM + +-- these definitions are required for the corresponding types to be in scope in the TH code below; +-- pretty sure this is a GHC bug +dummy1 = undefined :: Identity a +dummy2 = undefined :: StateT s m a +dummy3 = undefined :: ReaderT s m a + +-------------------------------------------------------------------------------- +-- derive instances + +-- forAllInScope ''Base.Eq mkPreludeEq +forAllInScope ''Base.Functor mkPreludeFunctor +-- forAllInScope ''Base.Applicative mkPreludeApplicative +forAllInScope ''Base.Monad mkPreludeMonad + +-------------------------------------------------------------------------------- + +-- FIXME: +-- Similar instances are not valid for all monads. +-- For example, [] instance for Semigroup would be incompatible with the below definitions. +-- These instances are useful enough, however, that maybe we should have a template haskell generating function. +-- Possibly also a new type class that is a proof of compatibility. + +mkMutable [t| forall a. IO a |] + +instance Semigroup a => Semigroup (IO a) where + (+) = liftM2 (+) + +instance Monoid a => Monoid (IO a) where + zero = return zero + +-------------------------------------------------------------------------------- + +type instance Logic TypeRep = Bool + +instance Eq_ TypeRep where + (==) = (Base.==) + +instance POrd_ TypeRep where + inf x y = case Base.compare x y of + LT -> x + _ -> y +instance Lattice_ TypeRep where + sup x y = case Base.compare x y of + GT -> x + _ -> y +instance Ord_ TypeRep where compare = Base.compare + +--------- + +mkMutable [t| forall a b. Either a b |] + +instance (Semigroup b) => Semigroup (Either a b) where + (Left a) + _ = Left a + _ + (Left a) = Left a + (Right b1)+(Right b2) = Right $ b1+b2 + +instance (Monoid b) => Monoid (Either a b) where + zero = Right zero + +--------- + +instance Base.Functor Maybe' where + fmap = fmap + +instance Base.Applicative Maybe' + +instance Base.Monad Maybe' where + return = Just' + Nothing' >>= f = Nothing' + (Just' a) >>= f = f a + +instance Functor Hask Maybe' where + fmap f Nothing' = Nothing' + fmap f (Just' a) = Just' $ f a + +instance Then Maybe' where + Nothing' >> _ = Nothing' + _ >> a = a + +instance Monad Hask Maybe' where + return_ = Just' + join Nothing' = Nothing' + join (Just' Nothing') = Nothing' + join (Just' (Just' a)) = Just' a diff --git a/src/SubHask/Compatibility/BloomFilter.hs b/src/SubHask/Compatibility/BloomFilter.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Compatibility/BloomFilter.hs @@ -0,0 +1,45 @@ +module SubHask.Compatibility.BloomFilter + ( BloomFilter + ) + where + +import SubHask.Algebra +import SubHask.Category +import SubHask.Internal.Prelude + +import qualified Data.BloomFilter as BF + +-------------------------------------------------------------------------------- + +newtype BloomFilter (n::Nat) a = BloomFilter (BF.Bloom a) + +mkMutable [t| forall n a. BloomFilter n a |] + +type instance Scalar (BloomFilter n a) = Int +type instance Logic (BloomFilter n a) = Bool + +type instance Elem (BloomFilter n a) = a +type instance SetElem (BloomFilter n a) b = BloomFilter n b + +hash = undefined + +instance KnownNat n => Semigroup (BloomFilter n a) + -- FIXME: need access to the underlying representation of BF.Bloom to implement + +instance KnownNat n => Monoid (BloomFilter n a) where + zero = BloomFilter (BF.empty hash n) + where + n = fromInteger $ natVal (Proxy::Proxy n) + +instance KnownNat n => Constructible (BloomFilter n a) + -- FIXME: need a good way to handle the hash generically + +instance KnownNat n => Container (BloomFilter n a) where + elem a (BloomFilter b) = BF.elem a b + +instance KnownNat n => Normed (BloomFilter n a) where + size (BloomFilter b) = BF.length b + -- formula for number of elements in a bloom filter + -- http://stackoverflow.com/questions/6099562/combining-bloom-filters + -- c = log(z / N) / ((h * log(1 - 1 / N)) + diff --git a/src/SubHask/Compatibility/ByteString.hs b/src/SubHask/Compatibility/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Compatibility/ByteString.hs @@ -0,0 +1,118 @@ +module SubHask.Compatibility.ByteString + where + +import SubHask +import SubHask.Algebra.Parallel +import SubHask.TemplateHaskell.Deriving + +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Prelude as P + +-------------------------------------------------------------------------------- + +-- | The type of lazy byte strings. +-- +-- FIXME: +-- Add strict byte strings as type "ByteString'" +data family ByteString elem + +mkMutable [t| forall a. ByteString a |] + +type instance Scalar (ByteString b) = Int +type instance Logic (ByteString b) = Bool +type instance Elem (ByteString b) = b +type instance SetElem (ByteString b) c = ByteString c + +---------------------------------------- + +newtype instance ByteString Char = BSLC { unBSLC :: BS.ByteString } + deriving (NFData,Read,Show) + +instance Arbitrary (ByteString Char) where + arbitrary = fmap fromList arbitrary + +instance Eq_ (ByteString Char) where + (BSLC b1)==(BSLC b2) = b1 P.== b2 + +instance POrd_ (ByteString Char) where + inf (BSLC b1) (BSLC b2) = fromList $ map fst $ P.takeWhile (\(a,b) -> a==b) $ BS.zip b1 b2 + (BSLC b1) < (BSLC b2) = BS.isPrefixOf b1 b2 + +instance MinBound_ (ByteString Char) where + minBound = zero + +instance Semigroup (ByteString Char) where + (BSLC b1)+(BSLC b2) = BSLC $ BS.append b1 b2 + +instance Monoid (ByteString Char) where + zero = BSLC BS.empty + +instance Container (ByteString Char) where + elem x (BSLC xs) = BS.elem x xs + notElem x (BSLC xs) = BS.notElem x xs + +instance Constructible (ByteString Char) where + fromList1 x xs = BSLC $ BS.pack (x:xs) + singleton = BSLC . BS.singleton + +instance Normed (ByteString Char) where + size (BSLC xs) = fromIntegral $ P.toInteger $ BS.length xs + +instance Foldable (ByteString Char) where + uncons (BSLC xs) = case BS.uncons xs of + Nothing -> Nothing + Just (x,xs) -> Just (x,BSLC xs) + + toList (BSLC xs) = BS.unpack xs + + foldr f a (BSLC xs) = BS.foldr f a xs +-- foldr' f a (BSLC xs) = BS.foldr' f a xs + foldr1 f (BSLC xs) = BS.foldr1 f xs +-- foldr1' f (BSLC xs) = BS.foldr1' f xs + + foldl f a (BSLC xs) = BS.foldl f a xs + foldl' f a (BSLC xs) = BS.foldl' f a xs + foldl1 f (BSLC xs) = BS.foldl1 f xs + foldl1' f (BSLC xs) = BS.foldl1' f xs + +instance Partitionable (ByteString Char) where + partition n (BSLC xs) = go xs + where + go xs = if BS.null xs + then [] + else BSLC a:go b + where + (a,b) = BS.splitAt len xs + + n' = P.fromIntegral $ toInteger n + size = BS.length xs + len = size `P.div` n' + P.+ if size `P.rem` n' P.== (P.fromInteger 0) then P.fromInteger 0 else P.fromInteger 1 + +-------------------------------------------------------------------------------- + +-- | +-- +-- FIXME: +-- Make generic method "readFile" probably using cereal/binary +readFileByteString :: FilePath -> IO (ByteString Char) +readFileByteString = fmap BSLC . BS.readFile + +-------------------------------------------------------------------------------- + +-- | FIXME: +-- Make this generic by moving some of the BS functions into the Foldable/Unfoldable type classes. +-- Then move this into Algebra.Containers +newtype PartitionOnNewline a = PartitionOnNewline a + +deriveHierarchy ''PartitionOnNewline [''Monoid,''Boolean,''Foldable] + +instance (a~ByteString Char, Partitionable a) => Partitionable (PartitionOnNewline a) where + partition n (PartitionOnNewline xs) = map PartitionOnNewline $ go $ partition n xs + where + go [] = [] + go [x] = [x] + go (x1:x2:xs) = (x1+BSLC a):go (BSLC b:xs) + where + (a,b) = BS.break (=='\n') $ unBSLC x2 + diff --git a/src/SubHask/Compatibility/Cassava.hs b/src/SubHask/Compatibility/Cassava.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Compatibility/Cassava.hs @@ -0,0 +1,53 @@ +module SubHask.Compatibility.Cassava + ( decode_ + , decode + + -- * Types + , FromRecord + , ToRecord + , FromField + , ToField + , HasHeader (..) + ) + where + +import SubHask +import SubHask.Algebra.Array +import SubHask.Algebra.Parallel +import SubHask.Compatibility.ByteString + +import qualified Prelude as P +import qualified Data.Csv as C +import Data.Csv (FromRecord, ToRecord, FromField, ToField, HasHeader) + +-------------------------------------------------------------------------------- +-- instances + +instance FromField a => FromRecord (BArray a) where + parseRecord = P.fmap fromList . C.parseRecord + +instance (Constructible (UArray a), Monoid (UArray a), FromField a) => FromRecord (UArray a) where + parseRecord = P.fmap fromList . C.parseRecord + +-------------------------------------------------------------------------------- +-- replacement functions + +-- | This is a monoid homomorphism, which means it can be parallelized +decode_ :: + ( FromRecord a + ) => HasHeader + -> PartitionOnNewline (ByteString Char) + -> Either String (BArray a) +decode_ h (PartitionOnNewline (BSLC bs)) = case C.decode h bs of + Right r -> Right $ BArray r + Left s -> Left s + +-- | Like the "decode" function in Data.Csv, but works in parallel +decode :: + ( NFData a + , FromRecord a + , ValidEq a + ) => HasHeader + -> ByteString Char + -> Either String (BArray a) +decode h = parallel (decode_ h) . PartitionOnNewline diff --git a/src/SubHask/Compatibility/Containers.hs b/src/SubHask/Compatibility/Containers.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Compatibility/Containers.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE RebindableSyntax #-} +-- | Bindings to make the popular containers library compatible with subhask +module SubHask.Compatibility.Containers + where + +import qualified Data.Foldable as F +import qualified Data.Map as M +import qualified Data.IntMap as IM +import qualified Data.Map.Strict as MS +import qualified Data.IntMap.Strict as IMS +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import qualified Prelude as P + +import SubHask.Algebra +import SubHask.Algebra.Container +import SubHask.Algebra.Ord +import SubHask.Algebra.Parallel +import SubHask.Category +import SubHask.Category.Trans.Constrained +import SubHask.Category.Trans.Monotonic +import SubHask.Compatibility.Base +import SubHask.Internal.Prelude +import SubHask.Monad +import SubHask.TemplateHaskell.Deriving + +------------------------------------------------------------------------------- +-- | This is a thin wrapper around Data.Sequence + +newtype Seq a = Seq (Seq.Seq a) + deriving (Read,Show,NFData) + +mkMutable [t| forall a. Seq a |] + +type instance Scalar (Seq a) = Int +type instance Logic (Seq a) = Bool +type instance Elem (Seq a) = a +type instance SetElem (Seq a) b = Seq b + +instance (Eq a, Arbitrary a) => Arbitrary (Seq a) where + arbitrary = P.fmap fromList arbitrary + +instance Normed (Seq a) where + {-# INLINE size #-} + size (Seq s) = Seq.length s + +instance Eq a => Eq_ (Seq a) where + {-# INLINE (==) #-} + (Seq a1)==(Seq a2) = F.toList a1==F.toList a2 + +instance POrd a => POrd_ (Seq a) where + {-# INLINE inf #-} + inf a1 a2 = fromList $ inf (toList a1) (toList a2) + +instance POrd a => MinBound_ (Seq a) where + {-# INLINE minBound #-} + minBound = empty + +instance Semigroup (Seq a) where + {-# INLINE (+) #-} + (Seq a1)+(Seq a2) = Seq $ a1 Seq.>< a2 + +instance Monoid (Seq a) where + {-# INLINE zero #-} + zero = Seq $ Seq.empty + +instance Eq a => Container (Seq a) where + {-# INLINE elem #-} + elem e (Seq a) = elem e $ F.toList a + + {-# INLINE notElem #-} + notElem = not elem + +instance Constructible (Seq a) where + {-# INLINE cons #-} + {-# INLINE snoc #-} + {-# INLINE singleton #-} + {-# INLINE fromList1 #-} + cons e (Seq a) = Seq $ e Seq.<| a + snoc (Seq a) e = Seq $ a Seq.|> e + singleton e = Seq $ Seq.singleton e + + fromList1 x xs = Seq $ Seq.fromList (x:xs) + +instance ValidEq a => Foldable (Seq a) where + + {-# INLINE toList #-} + toList (Seq a) = F.toList a + + {-# INLINE uncons #-} + uncons (Seq a) = if Seq.null a + then Nothing + else Just (Seq.index a 0, Seq $ Seq.drop 1 a) + + {-# INLINE unsnoc #-} + unsnoc (Seq e) = if Seq.null e + then Nothing + else Just (Seq $ Seq.take (Seq.length e-1) e, Seq.index e 0) + +-- foldMap f (Seq a) = F.foldMap f a + + {-# INLINE foldr #-} + {-# INLINE foldr' #-} + {-# INLINE foldr1 #-} + foldr f e (Seq a) = F.foldr f e a + foldr' f e (Seq a) = F.foldr' f e a + foldr1 f (Seq a) = F.foldr1 f a +-- foldr1' f (Seq a) = F.foldr1' f a + + {-# INLINE foldl #-} + {-# INLINE foldl' #-} + {-# INLINE foldl1 #-} + foldl f e (Seq a) = F.foldl f e a + foldl' f e (Seq a) = F.foldl' f e a + foldl1 f (Seq a) = F.foldl1 f a +-- foldl1' f (Seq a) = F.foldl1' f a + +instance (ValidEq a) => Partitionable (Seq a) where + {-# INLINABLE partition #-} + partition n (Seq xs) = go xs + where + go :: Seq.Seq a -> [Seq a] + go xs = if Seq.null xs + then [] + else Seq a:go b + where + (a,b) = Seq.splitAt len xs + + size = Seq.length xs + len = size `div` n + + if size `rem` n == 0 then 0 else 1 + + {-# INLINABLE partitionInterleaved #-} + partitionInterleaved n xs = foldl' go (P.replicate n empty) xs + where + go (r:rs) x = rs+[r`snoc`x] + +------------------------------------------------------------------------------- +-- | This is a thin wrapper around Data.Map + +newtype Map i e = Map (M.Map (WithPreludeOrd i) (WithPreludeOrd e)) + deriving (Show,NFData) + +mkMutable [t| forall i e. Map i e |] + +type instance Scalar (Map i e) = Int +type instance Logic (Map i e) = Bool +type instance Index (Map i e) = i +type instance SetIndex (Map i e) i' = Map i' e +type instance Elem (Map i e) = e +type instance SetElem (Map i e) e' = Map i e' + +-- misc classes + +instance (Eq e, Ord i, Semigroup e, Arbitrary i, Arbitrary e) => Arbitrary (Map i e) where + arbitrary = P.fmap fromIxList arbitrary + +-- comparisons + +instance (Eq i, Eq e) => Eq_ (Map i e) where + {-# INLINE (==) #-} + (Map m1)==(Map m2) = m1 P.== m2 + +instance (Ord i, Eq e) => POrd_ (Map i e) where + {-# INLINE inf #-} + inf (Map m1) (Map m2) = Map $ M.differenceWith go (M.intersection m1 m2) m2 + where + go v1 v2 = if v1==v2 then Just v1 else Nothing + +instance (Ord i, POrd e) => MinBound_ (Map i e) where + {-# INLINE minBound #-} + minBound = zero + +-- algebra + +instance Ord i => Semigroup (Map i e) where + {-# INLINE (+) #-} + (Map m1)+(Map m2) = Map $ M.union m1 m2 + +instance Ord i => Monoid (Map i e) where + {-# INLINE zero #-} + zero = Map $ M.empty + +instance Normed (Map i e) where + {-# INLINE size #-} + size (Map m) = M.size m + +-- indexed containers + +instance (Ord i, Eq e) => IxContainer (Map i e) where + {-# INLINE lookup #-} + {-# INLINE hasIndex #-} + lookup i (Map m) = P.fmap unWithPreludeOrd $ M.lookup (WithPreludeOrd i) m + hasIndex (Map m) i = M.member (WithPreludeOrd i) m + + {-# INLINE toIxList #-} + {-# INLINE indices #-} + {-# INLINE values #-} + {-# INLINE imap #-} + toIxList (Map m) = map (\(WithPreludeOrd i,WithPreludeOrd e)->(i,e)) $ M.assocs m + indices (Map m) = map unWithPreludeOrd $ M.keys m + values (Map m) = map unWithPreludeOrd $ M.elems m + imap f (Map m) = Map $ M.mapWithKey (\(WithPreludeOrd i) (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + +instance (Ord i, Eq e) => IxConstructible (Map i e) where + {-# INLINE singletonAt #-} + singletonAt i e = Map $ M.singleton (WithPreludeOrd i) (WithPreludeOrd e) + + {-# INLINE consAt #-} + consAt i e (Map m) = Map $ M.insert (WithPreludeOrd i) (WithPreludeOrd e) m + +---------------------------------------- +-- | This is a thin wrapper around Data.Map.Strict + +newtype Map' i e = Map' (MS.Map (WithPreludeOrd i) (WithPreludeOrd e)) + deriving (Show,NFData) + +mkMutable [t| forall i e. Map' i e |] + +type instance Scalar (Map' i e) = Int +type instance Logic (Map' i e) = Bool +type instance Index (Map' i e) = i +type instance SetIndex (Map' i e) i' = Map' i' e +type instance Elem (Map' i e) = e +type instance SetElem (Map' i e) e' = Map' i e' + +-- misc classes + +instance (Eq e, Ord i, Semigroup e, Arbitrary i, Arbitrary e) => Arbitrary (Map' i e) where + arbitrary = P.fmap fromIxList arbitrary + +-- comparisons + +instance (Eq i, Eq e) => Eq_ (Map' i e) where + {-# INLINE (==) #-} + (Map' m1)==(Map' m2) = m1 P.== m2 + +instance (Ord i, Eq e) => POrd_ (Map' i e) where + {-# INLINE inf #-} + inf (Map' m1) (Map' m2) = Map' $ MS.differenceWith go (MS.intersection m1 m2) m2 + where + go v1 v2 = if v1==v2 then Just v1 else Nothing + +instance (Ord i, POrd e) => MinBound_ (Map' i e) where + {-# INLINE minBound #-} + minBound = zero + +-- algebra + +instance Ord i => Semigroup (Map' i e) where + {-# INLINE (+) #-} + (Map' m1)+(Map' m2) = Map' $ MS.union m1 m2 + +instance Ord i => Monoid (Map' i e) where + {-# INLINE zero #-} + zero = Map' $ MS.empty + +instance Normed (Map' i e) where + {-# INLINE size #-} + size (Map' m) = MS.size m + +-- indexed containers + +instance (Ord i, Eq e) => IxContainer (Map' i e) where + {-# INLINE lookup #-} + {-# INLINE hasIndex #-} + lookup i (Map' m) = P.fmap unWithPreludeOrd $ MS.lookup (WithPreludeOrd i) m + hasIndex (Map' m) i = MS.member (WithPreludeOrd i) m + + {-# INLINE toIxList #-} + {-# INLINE indices #-} + {-# INLINE values #-} + {-# INLINE imap #-} + toIxList (Map' m) = map (\(WithPreludeOrd i,WithPreludeOrd e)->(i,e)) $ MS.assocs m + indices (Map' m) = map unWithPreludeOrd $ MS.keys m + values (Map' m) = map unWithPreludeOrd $ MS.elems m + imap f (Map' m) = Map' $ MS.mapWithKey (\(WithPreludeOrd i) (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + +instance (Ord i, Eq e) => IxConstructible (Map' i e) where + {-# INLINE singletonAt #-} + singletonAt i e = Map' $ MS.singleton (WithPreludeOrd i) (WithPreludeOrd e) + + {-# INLINE consAt #-} + consAt i e (Map' m) = Map' $ MS.insert (WithPreludeOrd i) (WithPreludeOrd e) m + +------------------------------------------------------------------------------- +-- | This is a thin wrapper around Data.IntMap + +newtype IntMap e = IntMap (IM.IntMap (WithPreludeOrd e)) + deriving (Read,Show,NFData) + +mkMutable [t| forall a. IntMap a |] + +type instance Scalar (IntMap e) = Int +type instance Logic (IntMap e) = Bool +type instance Index (IntMap e) = IM.Key +type instance Elem (IntMap e) = e +type instance SetElem (IntMap e) e' = IntMap e' + +-- misc classes + +instance (Eq e, Semigroup e, Arbitrary e) => Arbitrary (IntMap e) where + {-# INLINABLE arbitrary #-} + arbitrary = P.fmap fromIxList arbitrary + +-- comparisons + +instance (Eq e) => Eq_ (IntMap e) where + {-# INLINE (==) #-} + (IntMap m1)==(IntMap m2) = m1 P.== m2 + +instance (Eq e) => POrd_ (IntMap e) where + {-# INLINE inf #-} + inf (IntMap m1) (IntMap m2) = IntMap $ IM.differenceWith go (IM.intersection m1 m2) m2 + where + go v1 v2 = if v1==v2 then Just v1 else Nothing + +instance (POrd e) => MinBound_ (IntMap e) where + {-# INLINE minBound #-} + minBound = zero + +-- algebra + +instance Semigroup (IntMap e) where + {-# INLINE (+) #-} + (IntMap m1)+(IntMap m2) = IntMap $ IM.union m1 m2 + +instance Monoid (IntMap e) where + {-# INLINE zero #-} + zero = IntMap $ IM.empty + +instance Normed (IntMap e) where + {-# INLINE size #-} + size (IntMap m) = IM.size m + +-- indexed container + +instance (Eq e) => IxConstructible (IntMap e) where + {-# INLINE singletonAt #-} + {-# INLINE consAt #-} + singletonAt i e = IntMap $ IM.singleton i (WithPreludeOrd e) + consAt i e (IntMap m) = IntMap $ IM.insert i (WithPreludeOrd e) m + +instance (Eq e) => IxContainer (IntMap e) where + {-# INLINE lookup #-} + {-# INLINE hasIndex #-} + lookup i (IntMap m) = P.fmap unWithPreludeOrd $ IM.lookup i m + hasIndex (IntMap m) i = IM.member i m + + {-# INLINE toIxList #-} + {-# INLINE indices #-} + {-# INLINE values #-} + {-# INLINE imap #-} + toIxList (IntMap m) = map (\(i,WithPreludeOrd e)->(i,e)) $ IM.assocs m + indices (IntMap m) = IM.keys m + values (IntMap m) = map unWithPreludeOrd $ IM.elems m + imap f (IntMap m) = IntMap $ IM.mapWithKey (\i (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + +---------------------------------------- +-- | This is a thin wrapper around Data.IntMap.Strict + +newtype IntMap' e = IntMap' (IMS.IntMap (WithPreludeOrd e)) + deriving (Read,Show,NFData) + +mkMutable [t| forall a. IntMap' a |] + +type instance Scalar (IntMap' e) = Int +type instance Logic (IntMap' e) = Bool +type instance Index (IntMap' e) = IMS.Key +type instance Elem (IntMap' e) = e +type instance SetElem (IntMap' e) e' = IntMap' e' + +-- misc classes + +instance (Eq e, Semigroup e, Arbitrary e) => Arbitrary (IntMap' e) where + {-# INLINABLE arbitrary #-} + arbitrary = P.fmap fromIxList arbitrary + +-- comparisons + +instance (Eq e) => Eq_ (IntMap' e) where + {-# INLINE (==) #-} + (IntMap' m1)==(IntMap' m2) = m1 P.== m2 + +instance (Eq e) => POrd_ (IntMap' e) where + {-# INLINE inf #-} + inf (IntMap' m1) (IntMap' m2) = IntMap' $ IMS.differenceWith go (IMS.intersection m1 m2) m2 + where + go v1 v2 = if v1==v2 then Just v1 else Nothing + +instance (POrd e) => MinBound_ (IntMap' e) where + {-# INLINE minBound #-} + minBound = zero + +-- algebra + +instance Semigroup (IntMap' e) where + {-# INLINE (+) #-} + (IntMap' m1)+(IntMap' m2) = IntMap' $ IMS.union m1 m2 + +instance Monoid (IntMap' e) where + {-# INLINE zero #-} + zero = IntMap' $ IMS.empty + +instance Normed (IntMap' e) where + {-# INLINE size #-} + size (IntMap' m) = IMS.size m + +-- container + +instance (Eq e) => IxConstructible (IntMap' e) where + {-# INLINABLE singletonAt #-} + {-# INLINABLE consAt #-} + singletonAt i e = IntMap' $ IMS.singleton i (WithPreludeOrd e) + consAt i e (IntMap' m) = IntMap' $ IMS.insert i (WithPreludeOrd e) m + +instance (Eq e) => IxContainer (IntMap' e) where + {-# INLINE lookup #-} + {-# INLINE hasIndex #-} + lookup i (IntMap' m) = P.fmap unWithPreludeOrd $ IMS.lookup i m + hasIndex (IntMap' m) i = IMS.member i m + + {-# INLINE toIxList #-} + {-# INLINE indices #-} + {-# INLINE values #-} + {-# INLINE imap #-} + toIxList (IntMap' m) = map (\(i,WithPreludeOrd e)->(i,e)) $ IMS.assocs m + indices (IntMap' m) = IMS.keys m + values (IntMap' m) = map unWithPreludeOrd $ IMS.elems m + imap f (IntMap' m) = IntMap' $ IMS.mapWithKey (\i (WithPreludeOrd e) -> WithPreludeOrd $ f i e) m + +------------------------------------------------------------------------------- +-- | This is a thin wrapper around the container's set type + +newtype Set a = Set (Set.Set (WithPreludeOrd a)) + deriving (Show,NFData) + +mkMutable [t| forall a. Set a |] + +instance (Ord a, Arbitrary a) => Arbitrary (Set a) where + {-# INLINABLE arbitrary #-} + arbitrary = P.fmap fromList arbitrary + +type instance Scalar (Set a) = Int +type instance Logic (Set a) = Logic a +type instance Elem (Set a) = a +type instance SetElem (Set a) b = Set b + +instance Normed (Set a) where + {-# INLINE size #-} + size (Set s) = Set.size s + +instance Eq a => Eq_ (Set a) where + {-# INLINE (==) #-} + (Set s1)==(Set s2) = s1'==s2' + where + s1' = removeWithPreludeOrd $ Set.toList s1 + s2' = removeWithPreludeOrd $ Set.toList s2 + removeWithPreludeOrd [] = [] + removeWithPreludeOrd (WithPreludeOrd x:xs) = x:removeWithPreludeOrd xs + +instance Ord a => POrd_ (Set a) where + {-# INLINE inf #-} + inf (Set s1) (Set s2) = Set $ Set.intersection s1 s2 + +instance Ord a => MinBound_ (Set a) where + {-# INLINE minBound #-} + minBound = Set $ Set.empty + +instance Ord a => Lattice_ (Set a) where + {-# INLINE sup #-} + sup (Set s1) (Set s2) = Set $ Set.union s1 s2 + +instance Ord a => Semigroup (Set a) where + {-# INLINE (+) #-} + (Set s1)+(Set s2) = Set $ Set.union s1 s2 + +instance Ord a => Monoid (Set a) where + {-# INLINE zero #-} + zero = Set $ Set.empty + +instance Ord a => Abelian (Set a) + +instance Ord a => Container (Set a) where + {-# INLINE elem #-} + {-# INLINE notElem #-} + elem a (Set s) = Set.member (WithPreludeOrd a) s + notElem a (Set s) = not $ Set.member (WithPreludeOrd a) s + +instance Ord a => Constructible (Set a) where + {-# INLINE singleton #-} + singleton a = Set $ Set.singleton (WithPreludeOrd a) + + {-# INLINE fromList1 #-} + fromList1 a as = Set $ Set.fromList $ map WithPreludeOrd (a:as) + +instance Ord a => Foldable (Set a) where + {-# INLINE foldl #-} + {-# INLINE foldl' #-} + {-# INLINE foldr #-} + {-# INLINE foldr' #-} + foldl f a (Set s) = Set.foldl (\a (WithPreludeOrd e) -> f a e) a s + foldl' f a (Set s) = Set.foldl' (\a (WithPreludeOrd e) -> f a e) a s + foldr f a (Set s) = Set.foldr (\(WithPreludeOrd e) a -> f e a) a s + foldr' f a (Set s) = Set.foldr' (\(WithPreludeOrd e) a -> f e a) a s + +------------------- + +-- | +-- +-- FIXME: implement this in terms of @Lexical@ and @Set@ +-- +-- FIXME: add the @Constrained@ Monad +data LexSet a where + LexSet :: Ord a => Set a -> LexSet a + +mkMutable [t| forall a. LexSet a |] + +type instance Scalar (LexSet a) = Int +type instance Logic (LexSet a) = Bool +type instance Elem (LexSet a) = a +type instance SetElem (LexSet a) b = LexSet b + +instance Show a => Show (LexSet a) where + show (LexSet s) = "LexSet "++show (toList s) + +instance Eq_ (LexSet a) where + (LexSet a1)==(LexSet a2) = Lexical a1==Lexical a2 + +instance POrd_ (LexSet a) where + inf (LexSet a1) (LexSet a2) = LexSet $ unLexical $ inf (Lexical a1) (Lexical a2) + (LexSet a1) < (LexSet a2) = Lexical a1 < Lexical a2 + (LexSet a1) <= (LexSet a2) = Lexical a1 <= Lexical a2 + +instance Lattice_ (LexSet a) where + sup (LexSet a1) (LexSet a2) = LexSet $ unLexical $ sup (Lexical a1) (Lexical a2) + (LexSet a1) > (LexSet a2) = Lexical a1 > Lexical a2 + (LexSet a1) >= (LexSet a2) = Lexical a1 >= Lexical a2 + +instance Ord_ (LexSet a) + +instance Semigroup (LexSet a) where + (LexSet a1)+(LexSet a2) = LexSet $ a1+a2 + +instance Ord a => Monoid (LexSet a) where + zero = LexSet zero + +instance (Ord a ) => Container (LexSet a) where + elem x (LexSet s) = elem x s + +instance (Ord a ) => Constructible (LexSet a) where + fromList1 a as = LexSet $ fromList1 a as + +instance (Ord a ) => Normed (LexSet a) where + size (LexSet s) = size s + +instance (Ord a ) => MinBound_ (LexSet a) where + minBound = zero + +instance (Ord a ) => Foldable (LexSet a) where + foldl f a (LexSet s) = foldl f a s + foldl' f a (LexSet s) = foldl' f a s + foldl1 f (LexSet s) = foldl1 f s + foldl1' f (LexSet s) = foldl1' f s + foldr f a (LexSet s) = foldr f a s + foldr' f a (LexSet s) = foldr' f a s + foldr1 f (LexSet s) = foldr1 f s + foldr1' f (LexSet s) = foldr1' f s + +liftPreludeOrd :: (a -> b) -> WithPreludeOrd a -> WithPreludeOrd b +liftPreludeOrd f (WithPreludeOrd a) = WithPreludeOrd $ f a + +instance Functor OrdHask LexSet where + fmap (ConstrainedT f) = proveConstrained go + where + go (LexSet (Set s)) = LexSet $ Set $ Set.map (liftPreludeOrd f) s + +instance Monad OrdHask LexSet where + return_ = proveConstrained singleton + join = proveConstrained $ \(LexSet s) -> foldl1' (+) s + +instance Functor Mon LexSet where + fmap (MonT f) = unsafeProveMon go + where + go (LexSet (Set s)) = LexSet $ Set $ Set.mapMonotonic (liftPreludeOrd f) s + +-- | FIXME: is there a more efficient implementation? +instance Monad Mon LexSet where + return_ = unsafeProveMon singleton + join = unsafeProveMon $ \(LexSet s) -> foldl1' (+) s + +instance Then LexSet where + (LexSet a)>>(LexSet b) = LexSet b + + diff --git a/src/SubHask/Compatibility/HyperLogLog.hs b/src/SubHask/Compatibility/HyperLogLog.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Compatibility/HyperLogLog.hs @@ -0,0 +1,46 @@ +module SubHask.Compatibility.HyperLogLog + where + +import SubHask.Algebra +import SubHask.Category +import SubHask.Internal.Prelude + +import qualified Data.HyperLogLog as H +import qualified Data.Semigroup as S +import qualified Prelude as P + +-- FIXME: move the below imports to separate compatibility layers +import qualified Data.Bytes.Serial as S +import qualified Data.Approximate as A +import qualified Control.Lens as L + +type instance Scalar Int64 = Int64 + +-------------------------------------------------------------------------------- + +newtype HyperLogLog p a = H (H.HyperLogLog p) + +mkMutable [t| forall p a. HyperLogLog p a |] + +type instance Scalar (HyperLogLog p a) = Integer -- FIXME: make Int64 +type instance Logic (HyperLogLog p a) = Bool +type instance Elem (HyperLogLog p a) = a + +instance Semigroup (HyperLogLog p a) where + (H h1)+(H h2) = H $ h1 S.<> h2 + +instance Abelian (HyperLogLog p a) + +instance + ( H.ReifiesConfig p + ) => Normed (HyperLogLog p a) + where + size (H h) = P.fromIntegral $ L.view A.estimate (H.size h) + +instance + ( H.ReifiesConfig p + , S.Serial a + ) => Constructible (HyperLogLog p a) + where + cons a (H h) = H $ H.insert a h + diff --git a/src/SubHask/Internal/Prelude.hs b/src/SubHask/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Internal/Prelude.hs @@ -0,0 +1,89 @@ +module SubHask.Internal.Prelude + ( + -- * classes + Show (..) + , Read (..) + , read + + , Storable (..) + + -- * data types + , String + , FilePath + , Char + , Int + , Int8 + , Int16 + , Int32 + , Int64 + , Integer + , Float + , Double + , Rational + , Bool (..) + + , IO + , ST + , Maybe (..) + , Either (..) + + -- * Prelude functions + , build + , (++) + + , Prelude.all + , map + + , asTypeOf + , undefined + , otherwise + , error + , seq + + -- * subhask functions + , assert + , ifThenElse + + -- * Modules + , module Data.Proxy + , module Data.Typeable + , module GHC.TypeLits + , module Control.DeepSeq + + -- * Non-base types + , Arbitrary (..) + , Constraint + ) + where + +import Control.DeepSeq +import Control.Monad.ST +import Data.Foldable +import Data.List (foldl, foldl', foldr, foldl1, foldl1', foldr1, map, (++), intersectBy, unionBy ) +import Data.Maybe +import Data.Typeable +import Data.Proxy +import Data.Traversable +import GHC.TypeLits +import GHC.Exts +import GHC.Int +import Prelude +import Test.QuickCheck.Arbitrary +import Foreign.Storable + +{-# INLINE ifThenElse #-} +-- ifThenElse a b c = if a then b else c +ifThenElse a b c = case a of + True -> b + False -> c + +-- | +-- +-- FIXME: +-- Move to a better spot +-- Add rewrite rules to remove with optimization -O +assert :: String -> Bool -> a -> a +assert str b = if b + then id + else error $ "ASSERT FAILED: "++str + diff --git a/src/SubHask/Monad.hs b/src/SubHask/Monad.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Monad.hs @@ -0,0 +1,275 @@ +-- | This module contains the Monad hierarchy of classes. +module SubHask.Monad + where + +import qualified Prelude as P +import Prelude (replicate, zipWith, unzip) + +import SubHask.Algebra +import SubHask.Category +import SubHask.Internal.Prelude + +-------------------------------------------------------------------------------- + +class Category cat => Functor cat f where + fmap :: cat a b -> cat (f a) (f b) + +-- | +-- +-- FIXME: Not all monads can be made instances of Applicative in certain subcategories of hask. +-- For example, the "OrdHask" instance of "Set" requires an Ord constraint and a classical logic. +-- This means that we can't support @Set (a -> b)@, which means no applicative instance. +-- +-- There are reasonable solutions to this problem for Set (by storing functions differently), but are there other instances where Applicative is not a monad? +class Functor cat f => Applicative cat f where + pure :: cat a (f a) + (<*>) :: f (cat a b) -> cat (f a) (f b) + +-- | This class is a hack. +-- We can't include the @(>>)@ operator in the @Monad@ class because it doesn't depend on the underlying category. +class Then m where + infixl 1 >> + (>>) :: m a -> m b -> m b + +-- | A default implementation +haskThen :: Monad Hask m => m a -> m b -> m b +haskThen xs ys = xs >>= \_ -> ys + +-- | This is the only current alternative to the @Then@ class for supporting @(>>)@. +-- The problems with this implementation are: +-- 1. All those ValidCategory constraints are ugly! +-- 2. We've changed the signature of @(>>)@ in a way that's incompatible with do notation. +mkThen :: forall proxy cat m a b. + ( Monad cat m + , Cartesian cat + , Concrete cat + , ValidCategory cat a + , ValidCategory cat (m b) + ) => proxy cat -> m a -> m b -> m b +mkThen _ xs ys = xs >>= (const ys :: cat a (m b)) + +return :: Monad Hask m => a -> m a +return = return_ + +-- | +-- +-- FIXME: right now, we're including any possibly relevant operator in this class; +-- the main reason is that I don't know if there will be more efficient implementations for these in different categories +-- +-- FIXME: think about do notation again +class (Then m, Functor cat m) => Monad cat m where + return_ :: ValidCategory cat a => cat a (m a) + + -- | join ought to have a default implementation of: + -- + -- > join = (>>= id) + -- + -- but "id" requires a "ValidCategory" constraint, so we can't use this default implementation. + join :: cat (m (m a)) (m a) + + -- | In Hask, most people think of monads in terms of the @>>=@ operator; + -- for our purposes, the reverse operator is more fundamental because it does not require the @Concrete@ constraint + infixr 1 =<< + (=<<) :: cat a (m b) -> cat (m a) (m b) + (=<<) f = join . fmap f + + -- | The bind operator is used in desguaring do notation; + -- unlike all the other operators, we're explicitly applying values to the arrows passed in; + -- that's why we need the "Concrete" constraint + infixl 1 >>= + (>>=) :: Concrete cat => m a -> cat a (m b) -> m b + (>>=) a f = join . fmap f $ a + + -- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped + infixr 1 <=< + (<=<) :: cat b (m c) -> cat a (m b) -> cat a (m c) + f<==> + (>=>) :: cat a (m b) -> cat b (m c) -> cat a (m c) + (>=>) = flip (<=<) + +fail = error + +-------------------------------------------------------------------------------- + +-- | Every Monad has a unique Kleisli category +-- +-- FIXME: should this be a GADT? +newtype Kleisli cat f a b = Kleisli (cat a (f b)) + +instance Monad cat f => Category (Kleisli cat f) where + type ValidCategory (Kleisli cat f) a = ValidCategory cat a + id = Kleisli return_ + (Kleisli f).(Kleisli g) = Kleisli (f<= [m a] -> m [a] +{-# INLINE sequence #-} +sequence ms = foldr k (return []) ms + where + k m m' = do { x <- m; xs <- m'; return (x:xs) } + +-- | Evaluate each action in the sequence from left to right, +-- and ignore the results. +sequence_ :: Monad Hask m => [m a] -> m () +{-# INLINE sequence_ #-} +sequence_ ms = foldr (>>) (return ()) ms + +-- | @'mapM' f@ is equivalent to @'sequence' . 'map' f@. +mapM :: Monad Hask m => (a -> m b) -> [a] -> m [b] +{-# INLINE mapM #-} +mapM f as = sequence (map f as) + +-- | @'mapM_' f@ is equivalent to @'sequence_' . 'map' f@. +mapM_ :: Monad Hask m => (a -> m b) -> [a] -> m () +{-# INLINE mapM_ #-} +mapM_ f as = sequence_ (map f as) + +-- | This generalizes the list-based 'filter' function. +filterM :: (Monad Hask m) => (a -> m Bool) -> [a] -> m [a] +filterM _ [] = return [] +filterM p (x:xs) = do + flg <- p x + ys <- filterM p xs + return (if flg then x:ys else ys) + +-- | 'forM' is 'mapM' with its arguments flipped +forM :: Monad Hask m => [a] -> (a -> m b) -> m [b] +{-# INLINE forM #-} +forM = flip mapM + + +-- | 'forM_' is 'mapM_' with its arguments flipped +forM_ :: Monad Hask m => [a] -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | @'forever' act@ repeats the action infinitely. +forever :: (Monad Hask m) => m a -> m b +{-# INLINE forever #-} +forever a = let a' = a >> a' in a' +-- Use explicit sharing here, as it is prevents a space leak regardless of +-- optimizations. + +-- | @'void' value@ discards or ignores the result of evaluation, such as the return value of an 'IO' action. +void :: Functor Hask f => f a -> f () +void = fmap (const ()) + +-- ----------------------------------------------------------------------------- +-- Other monad functions + +-- | The 'mapAndUnzipM' function maps its first argument over a list, returning +-- the result as a pair of lists. This function is mainly used with complicated +-- data structures or a state-transforming monad. +mapAndUnzipM :: (Monad Hask m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) +mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip + +-- | The 'zipWithM' function generalizes 'zipWith' to arbitrary monads. +zipWithM :: (Monad Hask m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +zipWithM f xs ys = sequence (zipWith f xs ys) + +-- | 'zipWithM_' is the extension of 'zipWithM' which ignores the final result. +zipWithM_ :: (Monad Hask m) => (a -> b -> m c) -> [a] -> [b] -> m () +zipWithM_ f xs ys = sequence_ (zipWith f xs ys) + +{- | The 'foldM' function is analogous to 'foldl', except that its result is +encapsulated in a monad. Note that 'foldM' works from left-to-right over +the list arguments. This could be an issue where @('>>')@ and the `folded +function' are not commutative. + + +> foldM f a1 [x1, x2, ..., xm] + +== + +> do +> a2 <- f a1 x1 +> a3 <- f a2 x2 +> ... +> f am xm + +If right-to-left evaluation is required, the input list should be reversed. +-} + +foldM :: (Monad Hask m) => (a -> b -> m a) -> a -> [b] -> m a +foldM _ a [] = return a +foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs + +-- | Like 'foldM', but discards the result. +foldM_ :: (Monad Hask m) => (a -> b -> m a) -> a -> [b] -> m () +foldM_ f a xs = foldM f a xs >> return () + +-- | @'replicateM' n act@ performs the action @n@ times, +-- gathering the results. +replicateM :: (Monad Hask m) => Int -> m a -> m [a] +replicateM n x = sequence (replicate n x) + +-- | Like 'replicateM', but discards the result. +replicateM_ :: (Monad Hask m) => Int -> m a -> m () +replicateM_ n x = sequence_ (replicate n x) + +{- | Conditional execution of monadic expressions. For example, + +> when debug (putStr "Debugging\n") + +will output the string @Debugging\\n@ if the Boolean value @debug@ is 'True', +and otherwise do nothing. +-} + +when :: (Monad Hask m) => Bool -> m () -> m () +when p s = if p then s else return () + +-- | The reverse of 'when'. + +unless :: (Monad Hask m) => Bool -> m () -> m () +unless p s = if p then return () else s + +-- | Promote a function to a monad. +liftM :: (Monad Hask m) => (a1 -> r) -> m a1 -> m r +liftM f m1 = do { x1 <- m1; return (f x1) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right. For example, +-- +-- > liftM2 (+) [0,1] [0,2] = [0,2,1,3] +-- > liftM2 (+) (Just 1) Nothing = Nothing +-- +liftM2 :: (Monad Hask m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r +liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM3 :: (Monad Hask m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r +liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM4 :: (Monad Hask m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r +liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } + +-- | Promote a function to a monad, scanning the monadic arguments from +-- left to right (cf. 'liftM2'). +liftM5 :: (Monad Hask m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r +liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } + +{- | In many situations, the 'liftM' operations can be replaced by uses of +'ap', which promotes function application. + +> return f `ap` x1 `ap` ... `ap` xn + +is equivalent to + +> liftMn f x1 x2 ... xn + +-} + +ap :: (Monad Hask m) => m (a -> b) -> m a -> m b +ap = liftM2 id + + diff --git a/src/SubHask/Mutable.hs b/src/SubHask/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/Mutable.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE NoAutoDeriveTypeable #-} +-- | In the SubHask library, every type has both a mutable and immutable version. +-- Normally we work with the immutable version; +-- however, certain algorithms require the mutable version for efficiency. +-- This module defines the interface to the mutable types. +module SubHask.Mutable + ( Mutable + , IsMutable (..) + , immutable2mutable + , mutable2immutable + , unsafeRunMutableProperty + + , mkMutable + + -- ** Primitive types + , PrimBase + , PrimState + + -- ** Internal + -- | These exports should never be used directly. + -- They are required by the "mkMutable" TH function. + , PrimRef + , readPrimRef + , writePrimRef + , newPrimRef + , helper_liftM + ) + where + +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Deriving +import SubHask.TemplateHaskell.Mutable + +import Prelude (($),(.)) +import Control.Monad +import Control.Monad.Primitive +import Control.Monad.ST +import Data.Primitive +import Data.PrimRef +import System.IO.Unsafe + +-------------------------------------------------------------------------------- + +-- | The mutable version of an immutable data type. +-- This is equivalent to the "PrimRef" type, which generalizes "STRef" and "IORef". +-- +-- Unlike "PrimRef", "Mutable" is implemented using a data family. +-- This means that data types can provide more efficient implementations. +-- The canonical example is "Vector". +-- Vectors in standard Haskell use a different interface than the standard "PrimRef". +-- This requires the programmer learn multiple interfaces, and prevents the programmer from reusing code. +-- Very un-Haskelly. +-- This implementation of mutability gives a consistent interface for all data types. +data family Mutable (m :: * -> *) a + +instance (Show a, IsMutable a, PrimBase m) => Show (Mutable m a) where + show mx = unsafePerformIO $ unsafePrimToIO $ do + x <- freeze mx + return $ "Mutable ("++show x++")" + +instance (IsMutable a, PrimBase m, Arbitrary a) => Arbitrary (Mutable m a) where + arbitrary = do + a <- arbitrary + return $ unsafePerformIO $ unsafePrimToIO $ thaw a + +-- | A Simple default implementation for mutable operations. +{-# INLINE immutable2mutable #-} +immutable2mutable :: IsMutable a => (a -> b -> a) -> (PrimBase m => Mutable m a -> b -> m ()) +immutable2mutable f ma b = do + a <- freeze ma + write ma (f a b) + +-- | A Simple default implementation for immutable operations. +{-# INLINE mutable2immutable #-} +mutable2immutable :: IsMutable a => (forall m. PrimBase m => Mutable m a -> b -> m ()) -> a -> b -> a +mutable2immutable f a b = runST ( do + ma <- thaw a + f ma b + unsafeFreeze ma + ) + +-- | This function should only be used from within quickcheck properties. +-- All other uses are unsafe. +unsafeRunMutableProperty :: PrimBase m => m a -> a +unsafeRunMutableProperty = unsafePerformIO . unsafePrimToIO + + +-- | This class implements conversion between mutable and immutable data types. +-- It is the equivalent of the functions provided in "Contol.Monad.Primitive", +-- but we use the names of from the "Data.Vector" interface because they are simpler and more intuitive. +-- +-- Every data type is an instance of this class using a default implementation based on "PrimRef"s. +-- We use OverlappingInstances to allow some instances to provide more efficient implementations. +-- We require that any overlapping instance be semantically equivalent to prevent unsafe behavior. +-- The use of OverlappingInstances should only affect you if your creating your own specialized instances of the class. +-- You shouldn't have to do this unless you are very concerned about performance on a complex type. +-- +-- FIXME: +-- It's disappointing that we still require this class, the "Primitive" class, and the "Storable" class. +-- Can these all be unified? +class IsMutable a where + -- | Convert a mutable object into an immutable one. + -- The implementation is guaranteed to copy the object within memory. + -- The overhead is linear with the size of the object. + freeze :: PrimBase m => Mutable m a -> m a + + -- | Convert an immutable object into a mutable one + -- The implementation is guaranteed to copy the object within memory. + -- The overhead is linear with the size of the object. + thaw :: PrimBase m => a -> m (Mutable m a) + + -- | Assigns the value of the mutable variable to the immutable one. + write :: PrimBase m => Mutable m a -> a -> m () + + -- | Return a copy of the mutable object. + -- Changes to the copy do not update in the original, and vice-versa. + copy :: PrimBase m => Mutable m a -> m (Mutable m a) + copy ma = do + a <- unsafeFreeze ma + thaw a + + -- | Like "freeze", but much faster on some types + -- because the implementation is not required to perform a memory copy. + -- + -- WARNING: + -- You must not modify the mutable variable after calling unsafeFreeze. + -- This might change the value of the immutable variable. + -- This breaks referential transparency and is very bad. + unsafeFreeze :: PrimBase m => Mutable m a -> m a + unsafeFreeze = freeze + + -- | Like "thaw", but much faster on some types + -- because the implementation is not required to perform a memory copy. + -- + -- WARNING: + -- You must not access the immutable variable after calling unsafeThaw. + -- The contents of this variable might have changed arbitrarily. + -- This breaks referential transparency and is very bad. + unsafeThaw :: PrimBase m => a -> m (Mutable m a) + unsafeThaw = thaw + +-------------------------------------------------------------------------------- + +mkMutable [t| Int |] +mkMutable [t| Integer |] +mkMutable [t| Rational |] +mkMutable [t| Float |] +mkMutable [t| Double |] +mkMutable [t| Bool |] + +mkMutable [t| forall a. [a] |] +mkMutable [t| () |] +mkMutable [t| forall a b. (a,b) |] +mkMutable [t| forall a b c. (a,b,c) |] +mkMutable [t| forall a b. a -> b |] diff --git a/src/SubHask/SubType.hs b/src/SubHask/SubType.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/SubType.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE NoAutoDeriveTypeable #-} -- can't derive typeable of data families + +-- | This module defines the subtyping mechanisms used in subhask. +module SubHask.SubType + ( (<:) (..) + , Sup + +-- , toRational + + -- ** + , Embed (..) + , embedType + , embedType1 + , embedType2 +-- , Embed0 (..) +-- , Embed1 (..) +-- , Embed2 (..) + + -- * Template Haskell + , mkSubtype + , mkSubtypeInstance + ) + where + +import Control.Monad +import Language.Haskell.TH +import Language.Haskell.TH.Quote +-- import Language.Haskell.Meta + +import SubHask.Internal.Prelude +import Prelude + +------------------------------------------------------------------------------- +-- common helper functions + +toRational :: (a <: Rational) => a -> Rational +toRational = embedType + +------------------------------------------------------------------------------- + +-- | Subtypes are partially ordered. +-- Unfortunately, there's no way to use the machinery of the "POrd"/"Lattice" classes. +-- The "Sup" type family is a promotion of the "sup" function to the type level. +-- +-- It must obey the laws: +-- +-- > Sup a b c <===> ( a <: c, b <: c ) +-- +-- > Sub a b c <===> Sup b a c +-- +-- And there is no smaller value of "c" that can be used instead. +-- +-- FIXME: it would be nicer if this were a type family; is that possible? +class Sup (s::k) (t::k) (u::k) | s t -> u + +instance Sup s s s + +-- | We use `s <: t` to denote that s is s subtype of t. +-- The "embedType" function must be s homomorphism from s to t. +-- +-- class (Sup s t t, Sup t s t) => (s :: k) <: (t :: k) where +class (s :: k) <: (t :: k) where + embedType_ :: Embed s t -- a b + + +-- | This data type is a huge hack to work around some unimplemented features in the type system. +-- In particular, we want to be able to declare any type constructor to be a subtype of any other type constructor. +-- The main use case is for making subcategories use the same subtyping mechanism as other types. +-- +-- FIXME: replace this data family with a system based on type families; +-- everything I've tried so far requires injective types or foralls in constraints. +data family Embed (s::k) (t::k) -- (a::ka) (b::kb) + +newtype instance Embed (s :: *) (t :: *) + = Embed0 { unEmbed0 :: s -> t } +embedType :: (s <: t) => s -> t +embedType = unEmbed0 embedType_ +instance (a :: *) <: (a :: *) where + embedType_ = Embed0 $ id + +newtype instance Embed (s :: ka -> *) (t :: ka -> *) + = Embed1 { unEmbed1 :: forall a. s a -> t a } +embedType1 :: (s <: t) => s a -> t a +embedType1 = unEmbed1 embedType_ +instance (a :: k1 -> *) <: (a :: k1 -> *) where + embedType_ = Embed1 $ id + +newtype instance Embed (s :: ka -> kb -> *) (t :: ka -> kb -> *) + = Embed2 { unEmbed2 :: forall a b. s a b -> t a b} +embedType2 :: (s <: t) => s a b -> t a b +embedType2 = unEmbed2 embedType_ +instance (a :: k1 -> k2 -> *) <: (a :: k1 -> k2 -> *) where + embedType_ = Embed2 $ id + + +-- | FIXME: can these laws be simplified at all? +-- In particular, can we automatically infer ctx from just the function parameter? +law_Subtype_f1 :: + ( a <: b + , Eq b + , ctx a + , ctx b + ) => proxy ctx -- ^ this parameter is only for type inference + -> b -- ^ this parameter is only for type inference + -> (forall c. ctx c => c -> c) + -> a + -> Bool +law_Subtype_f1 _ b f a = embedType (f a) == f (embedType a) `asTypeOf` b + +law_Subtype_f2 :: + ( a <: b + , Eq b + , ctx a + , ctx b + ) => proxy ctx -- ^ this parameter is only for type inference + -> b -- ^ this parameter is only for type inference + -> (forall c. ctx c => c -> c -> c) + -> a + -> a + -> Bool +law_Subtype_f2 _ b f a1 a2 = embedType (f a1 a2) == f (embedType a1) (embedType a2) `asTypeOf` b + +------------------- + +type family a == b :: Bool where + a == a = True + a == b = False + +type family If (a::Bool) (b::k) (c::k) :: k where + If True b c = b + If False b c = c + +type family When (a::Bool) (b::Constraint) :: Constraint where + When True b = b + When False b = () + +------------------- + +apEmbedType1 :: + ( a1 <: b1 + ) => (b1 -> c) -> a1 -> c +apEmbedType1 f a = f (embedType a) + +apEmbedType2 :: + ( a1 <: b1 + , a2 <: b2 + , When (b1==b2) (Sup a1 a2 b1) + ) => (b1 -> b2 -> c) + -> (a1 -> a2 -> c) +apEmbedType2 f a b = f (embedType a) (embedType b) + +-------------------------------------------------------------------------------- +-- template haskell +-- FIXME: move this into the template haskell folder? + +-- | +-- +-- FIXME: This should automatically search for other subtypes that can be inferred from t1 and t2 +-- +mkSubtype :: Q Type -> Q Type -> Name -> Q [Dec] +mkSubtype qt1 qt2 f = do + t1 <- liftM stripForall qt1 + t2 <- liftM stripForall qt2 + return $ mkSubtypeInstance t1 t2 f:mkSup t1 t2 t2 + +-- | converts types created by `[t| ... |]` into a more useful form +stripForall :: Type -> Type +stripForall (ForallT _ _ t) = stripForall t +stripForall (VarT t) = VarT $ mkName $ nameBase t +stripForall (ConT t) = ConT t +stripForall (AppT t1 t2) = AppT (stripForall t1) (stripForall t2) + +-- | Calling: +-- +-- > mkSubtypeInstance a b f +-- +-- generates the following code: +-- +-- > instance a <: b where +-- > embedType_ = Embed0 f +-- +-- FIXME: What if the type doesn't have kind *? +mkSubtypeInstance :: Type -> Type -> Name -> Dec +mkSubtypeInstance t1 t2 f = InstanceD + [] + ( AppT + ( AppT + ( ConT $ mkName "<:" ) + t1 + ) + t2 + ) + [ FunD + ( mkName "embedType_" ) + [ Clause + [] + ( NormalB $ AppE + ( ConE $ mkName "Embed0" ) + ( VarE f ) + ) + [] + ] + ] + +-- | Calling: +-- +-- > mkSup a b c +-- +-- generates the following code: +-- +-- > instance Sup a b c +-- > instance Sup b a c +-- +mkSup :: Type -> Type -> Type -> [Dec] +mkSup t1 t2 t3 = + [ InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t1) t2) t3) [] + , InstanceD [] (AppT (AppT (AppT (ConT $ mkName "Sup") t2) t1) t3) [] + ] diff --git a/src/SubHask/TemplateHaskell/Base.hs b/src/SubHask/TemplateHaskell/Base.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/TemplateHaskell/Base.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE NoRebindableSyntax #-} + +-- | This file contains the template haskell code for deriving SubHask class instances from Base instances. +-- All of the standard instances are created in "SubHask.Compatibility.Base". +-- This module is exported so that you can easily make instances for your own types without any extra work. +-- To do this, just put the line +-- +-- > deriveAll +-- +-- at the bottom of your file. +-- Any types in scope that do not already have SubHask instances will have them created automatically. +-- +-- FIXME: +-- Most classes aren't implemented yet. +-- I don't want to go through the work until their definitions stabilize somewhat. +module SubHask.TemplateHaskell.Base + where + +import qualified Prelude as Base +import qualified Control.Applicative as Base +import qualified Control.Monad as Base +import Language.Haskell.TH +import System.IO + +import SubHask.Category +import SubHask.Algebra +import SubHask.Monad +import SubHask.Internal.Prelude + +import Debug.Trace + +-------------------------------------------------------------------------------- +-- We need these instances to get anything done + +type instance Logic Name = Bool +instance Eq_ Name where (==) = (Base.==) + +type instance Logic Dec = Bool +instance Eq_ Dec where (==) = (Base.==) + +type instance Logic Type = Bool +instance Eq_ Type where (==) = (Base.==) + +-------------------------------------------------------------------------------- +-- generic helper functions + +-- | Derives instances for all data types in scope. +-- This is the only function you should need to use. +-- The other functions are exported only for debugging purposes if this function should fail. +deriveAll :: Q [Dec] +deriveAll = Base.liftM concat $ Base.mapM go + [ (''Base.Eq, mkPreludeEq) + , (''Base.Functor, mkPreludeFunctor) + , (''Base.Applicative,mkPreludeApplicative) + , (''Base.Monad,mkPreludeMonad) + ] + where + go (n,f) = forAllInScope n f + +-- | Constructs an instance using the given function for everything in scope. +forAllInScope :: Name -> (Cxt -> Q Type -> Q [Dec]) -> Q [Dec] +forAllInScope preludename f = do + info <- reify preludename + case info of + ClassI _ xs -> Base.liftM concat $ Base.sequence $ map mgo $ Base.filter fgo xs + where + mgo (InstanceD ctx (AppT _ t) _) = f ctx (Base.return t) + + fgo (InstanceD _ (AppT _ t) _ ) = not elem '>' $ show t + +-- | This is an internal helper function. +-- It prevents us from defining two instances for the same class/type pair. +runIfNotInstance :: Name -> Type -> Q [Dec] -> Q [Dec] +runIfNotInstance n t q = do + inst <- alreadyInstance n t + if inst + then trace ("skipping instance: "++show n++" / "++show t) $ Base.return [] + else trace ("deriving instance: "++show n++" / "++show t) $ q + where + alreadyInstance :: Name -> Type -> Q Bool + alreadyInstance n t = do + info <- reify n + Base.return $ case info of + ClassI _ xs -> or $ map (genericTypeEq t.rmInstanceD) xs + + -- FIXME: + -- This function was introduced to fix a name capture problem where `Eq a` and `Eq b` are not recognized as the same type. + -- The current solution is not correct, but works for some cases. + genericTypeEq (AppT s1 t1) (AppT s2 t2) = genericTypeEq s1 s2 && genericTypeEq t1 t2 + genericTypeEq (ConT n1) (ConT n2) = n1==n2 + genericTypeEq (VarT _) (VarT _) = true + genericTypeEq (SigT _ _) (SigT _ _) = true + genericTypeEq (TupleT n1) (TupleT n2) = n1==n2 + genericTypeEq ArrowT ArrowT = true + genericTypeEq ListT ListT = true + genericTypeEq _ _ = false + + + rmInstanceD (InstanceD _ (AppT _ t) _) = t + +-------------------------------------------------------------------------------- +-- comparison hierarchy + +-- | Create an "Eq" instance from a "Prelude.Eq" instance. +mkPreludeEq :: Cxt -> Q Type -> Q [Dec] +mkPreludeEq ctx qt = do + t <- qt + runIfNotInstance ''Eq_ t $ Base.return + [ TySynInstD + ( mkName "Logic" ) + ( TySynEqn + [ t ] + ( ConT $ mkName "Bool" ) + ) + , InstanceD + ctx + ( AppT ( ConT $ mkName "Eq_" ) t ) + [ FunD ( mkName "==" ) [ Clause [] (NormalB $ VarE $ mkName "Base.==") [] ] + ] + ] + +-------------------------------------------------------------------------------- +-- monad hierarchy + + +-- | Create a "Functor" instance from a "Prelude.Functor" instance. +mkPreludeFunctor :: Cxt -> Q Type -> Q [Dec] +mkPreludeFunctor ctx qt = do + t <- qt + runIfNotInstance ''Functor t $ Base.return + [ InstanceD + ctx + ( AppT + ( AppT + ( ConT $ mkName "Functor" ) + ( ConT $ mkName "Hask" ) + ) + t + ) + [ FunD ( mkName "fmap" ) [ Clause [] (NormalB $ VarE $ mkName "Base.fmap") [] ] + ] + ] + +-- | Create an "Applicative" instance from a "Prelude.Applicative" instance. +mkPreludeApplicative :: Cxt -> Q Type -> Q [Dec] +mkPreludeApplicative cxt qt = do + t <- qt + runIfNotInstance ''Applicative t $ Base.return + [ InstanceD + cxt + ( AppT + ( AppT + ( ConT $ mkName "Applicative" ) + ( ConT $ mkName "Hask" ) + ) + t + ) + [ FunD ( mkName "pure" ) [ Clause [] (NormalB $ VarE $ mkName "Base.pure") [] ] + , FunD ( mkName "<*>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.<*>") [] ] + ] + ] + +-- | Create a "Monad" instance from a "Prelude.Monad" instance. +-- +-- FIXME: +-- Monad transformers still require their parameter monad to be an instance of "Prelude.Monad". +mkPreludeMonad :: Cxt -> Q Type -> Q [Dec] +mkPreludeMonad cxt qt = do + t <- qt + -- can't call + -- > runIfNotInstance ''Monad t $ + -- due to lack of TH support for type families + trace ("deriving instance: Monad / "++show t) $ if cannotDeriveMonad t + then Base.return [] + else Base.return + [ InstanceD + cxt + ( AppT + ( ConT $ mkName "Then" ) + t + ) + [ FunD ( mkName ">>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>") [] ] + ] + , InstanceD +-- ( ClassP ''Functor [ ConT ''Hask , t ] : cxt ) + ( AppT (AppT (ConT ''Functor) (ConT ''Hask)) t : cxt ) + ( AppT + ( AppT + ( ConT $ mkName "Monad" ) + ( ConT $ mkName "Hask" ) + ) + t + ) + [ FunD ( mkName "return_" ) [ Clause [] (NormalB $ VarE $ mkName "Base.return") [] ] + , FunD ( mkName "join" ) [ Clause [] (NormalB $ VarE $ mkName "Base.join" ) [] ] + , FunD ( mkName ">>=" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>>=" ) [] ] + , FunD ( mkName ">=>" ) [ Clause [] (NormalB $ VarE $ mkName "Base.>=>" ) [] ] + , FunD ( mkName "=<<" ) [ Clause [] (NormalB $ VarE $ mkName "Base.=<<" ) [] ] + , FunD ( mkName "<=<" ) [ Clause [] (NormalB $ VarE $ mkName "Base.<=<" ) [] ] + ] + ] + where + -- | This helper function "filters out" monads for which we can't automatically derive an implementation. + -- This failure can be due to missing Functor instances or weird type errors. + cannotDeriveMonad t = elem (show $ getName t) badmonad + where + getName :: Type -> Name + getName t = case t of + (ConT t) -> t + ListT -> mkName "[]" + (SigT t _) -> getName t + (AppT (ConT t) _) -> t + (AppT (AppT (ConT t) _) _) -> t + (AppT (AppT (AppT (ConT t) _) _) _) -> t + (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) -> t + (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) -> t + (AppT (AppT (AppT (AppT (AppT (AppT (ConT t) _) _) _) _) _) _) -> t + t -> error ("cannotDeriveMonad error="++show t) + + badmonad = + [ "Text.ParserCombinators.ReadBase.P" + , "Control.Monad.ST.Lazy.Imp.ST" + , "Data.Proxy.Proxy" + ] diff --git a/src/SubHask/TemplateHaskell/Common.hs b/src/SubHask/TemplateHaskell/Common.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/TemplateHaskell/Common.hs @@ -0,0 +1,26 @@ +module SubHask.TemplateHaskell.Common + where + +import Prelude +import Data.List (init,last,nub,intersperse) +import Language.Haskell.TH.Syntax +import Control.Monad + +bndr2type :: TyVarBndr -> Type +bndr2type (PlainTV n) = VarT n +bndr2type (KindedTV n _) = VarT n + +isStar :: TyVarBndr -> Bool +isStar (PlainTV _) = True +isStar (KindedTV _ StarT) = True +isStar _ = False + +apply2varlist :: Type -> [TyVarBndr] -> Type +apply2varlist contype xs = go $ reverse xs + where + go (x:[]) = AppT contype (mkVar x) + go (x:xs) = AppT (go xs) (mkVar x) + + mkVar (PlainTV n) = VarT n + mkVar (KindedTV n _) = VarT n + diff --git a/src/SubHask/TemplateHaskell/Deriving.hs b/src/SubHask/TemplateHaskell/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/TemplateHaskell/Deriving.hs @@ -0,0 +1,332 @@ +-- | +-- +-- FIXME: doesn't handle multiparameter classes like Integral and Vector +-- +-- FIXME: should this be separated out into another lib when finished? +module SubHask.TemplateHaskell.Deriving + ( + -- * template haskell functions + deriveHierarchy + , deriveHierarchyFiltered + , deriveSingleInstance + , deriveTypefamilies + , mkMutableNewtype + , listSuperClasses + + -- ** compatibility functions + , fromPreludeEq + + -- ** helpers + , BasicType + , helper_liftM + , helper_id + ) + where + +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Common +import SubHask.TemplateHaskell.Mutable +import Prelude +import Data.List (init,last,nub,intersperse) + +import Language.Haskell.TH.Syntax +import Control.Monad +import Debug.Trace + + +-- | This class provides an artificial hierarchy that defines all the classes that a "well behaved" data type should implement. +-- All newtypes will derive them automatically. +type BasicType t = (Show t, Read t, Arbitrary t, NFData t) + +-- | We need to export this function for deriving of Monadic functions to work +helper_liftM :: Monad m => (a -> b) -> m a -> m b +helper_liftM = liftM + +helper_id :: a -> a +helper_id x = x + +-- | List all the superclasses of a one parameter class. +-- This does not include: +-- * constraints involving types other than the parameter (e.g. made with type families). +-- * type synonyms (although these will get substituted in the recursion) +-- +-- For example, convert ''Group into [''Semigroup, ''Monoid, ''Cancellative, ''Group] +listSuperClasses :: Name -> Q [Name] +listSuperClasses className = do + info <- reify className + case info of + + ClassI (ClassD ctx _ bndrs _ _) _ -> + liftM (className:) $ liftM concat $ mapM (go $ bndrs2var bndrs) ctx + + TyConI (TySynD _ bndrs t) -> + liftM concat $ mapM (go $ bndrs2var bndrs) $ tuple2list t + + info -> error $ "type "++nameBase className++" not a unary class\n\ninfo="++show info + + where + bndrs2var bndrs = case bndrs of + [PlainTV var ] -> var + [KindedTV var StarT] -> var + + go var (AppT (ConT name) (VarT var')) = if var==var' + then listSuperClasses name + else return [] -- class depends on another type tested elsewhere + go var _ = return [] + +tuple2list :: Type -> [Type] +tuple2list (AppT (AppT (TupleT 2) t1) t2) = [t1,t2] +tuple2list (AppT (AppT (AppT (TupleT 3) t1) t2) t3) = [t1,t2,t3] +tuple2list (AppT (AppT (AppT (AppT (TupleT 4) t1) t2) t3) t4) = [t1,t2,t3,t4] +tuple2list (AppT (AppT (AppT (AppT (AppT (TupleT 5) t1) t2) t3) t4) t5) = [t1,t2,t3,t4,t5] +tuple2list t = [t] + +-- | creates the instance: +-- +-- > type instance Scalar (Newtype s) = Scalar s +-- +deriveTypefamilies :: [Name] -> Name -> Q [Dec] +deriveTypefamilies familynameL typename = do + info <- reify typename + let (tyvarbndr,tyvar) = case info of + TyConI (NewtypeD _ _ xs (NormalC _ [( _,t)]) _) -> (xs,t) + TyConI (NewtypeD _ _ xs (RecC _ [(_,_,t)]) _) -> (xs,t) + return $ map (go tyvarbndr tyvar) familynameL + where + go tyvarbndr tyvar familyname = TySynInstD familyname $ TySynEqn + [ apply2varlist (ConT typename) tyvarbndr ] + ( AppT (ConT familyname) tyvar ) + +-- | This is the main TH function to call when deriving classes for a newtype. +-- You only need to list the final classes in the hierarchy that are supposed to be derived. +-- All the intermediate classes will be derived automatically. +deriveHierarchy :: Name -> [Name] -> Q [Dec] +deriveHierarchy typename classnameL = deriveHierarchyFiltered typename classnameL [] + +-- | Like "deriveHierarchy" except classes in the second list will not be derived. +deriveHierarchyFiltered :: Name -> [Name] -> [Name] -> Q [Dec] +deriveHierarchyFiltered typename classnameL filterL = do + classL <- liftM concat $ mapM listSuperClasses $ mkName "BasicType":classnameL + instanceL <- mapM (deriveSingleInstance typename) $ filter (\x -> not (elem x filterL)) $ nub classL + mutableL <- mkMutableNewtype typename + return $ mutableL ++ concat instanceL + +-- | Given a single newtype and single class, constructs newtype instances +deriveSingleInstance :: Name -> Name -> Q [Dec] +deriveSingleInstance typename classname = if show classname == "SubHask.Mutable.IsMutable" + then return [] -- this special case is handled by mkMutableNewtype + else do + typeinfo <- reify typename + (conname,typekind,typeapp) <- case typeinfo of + TyConI (NewtypeD [] _ typekind (NormalC conname [( _,typeapp)]) _) + -> return (conname,typekind,typeapp) + + TyConI (NewtypeD [] _ typekind (RecC conname [(_,_,typeapp)]) _) + -> return (conname,typekind,typeapp) + + _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo + + typefamilies <- deriveTypefamilies + [ mkName "Scalar" + , mkName "Elem" + -- , mkName "Index" + , mkName "Logic" + , mkName "Actor" + ] typename + + classinfo <- reify classname + liftM ( typefamilies++ ) $ case classinfo of + + -- if the class has exactly one instance that applies to everything, + -- then don't create an overlapping instance + -- These classes only exist because TH has problems with type families + -- FIXME: this is probably not a robust solution + ClassI (ClassD _ _ _ _ _) [InstanceD _ (VarT _) _] -> return [] + ClassI (ClassD _ _ _ _ _) [InstanceD _ (AppT (ConT _) (VarT _)) _] -> return [] + + -- otherwise, create the instance + ClassI classd@(ClassD ctx classname [bndr] [] decs) _ -> do + let varname = case bndr of + PlainTV v -> v + KindedTV v StarT -> v + + alreadyInstance <- isNewtypeInstance typename classname + if alreadyInstance + then return [] + else do + let notDefaultSigD (DefaultSigD _ _) = False + notDefaultSigD _ = True + + funcL <- forM (filter notDefaultSigD decs) $ \dec -> do + let (f,sigtype) = case dec of + SigD f_ sigtype_ -> (f_,sigtype_) + DefaultSigD f_ sigtype_ -> (f_,sigtype_) + body <- returnType2newtypeApplicator conname varname + (last (arrow2list sigtype)) + (list2exp $ (VarE f):(typeL2expL $ init $ arrow2list sigtype )) + + return + [ FunD f $ + [ Clause + ( typeL2patL conname varname $ init $ arrow2list sigtype ) + ( NormalB body ) + [] + ] + , PragmaD $ InlineP f Inline FunLike AllPhases + ] + + -- trace ("classname="++show classname++"; typename="++show typename) + -- $ trace (" funcL="++show funcL) + -- $ trace (" decs="++show decs) + -- $ return () + return [ InstanceD + -- ( ClassP classname [typeapp] : map (substitutePat varname typeapp) ctx ) + ( AppT (ConT classname) typeapp : map (substitutePat varname typeapp) ctx ) + ( AppT (ConT classname) $ apply2varlist (ConT typename) typekind ) + ( concat funcL ) + ] + +expandTySyn :: Type -> Q Type +expandTySyn (AppT (ConT tysyn) vartype) = do + info <- reify tysyn + case info of + TyConI (TySynD _ [PlainTV var] syntype) -> + return $ substituteVarE var vartype syntype + + TyConI (TySynD _ [KindedTV var StarT] syntype) -> + return $ substituteVarE var vartype syntype + + qqq -> error $ "expandTySyn: qqq="++show qqq + +substitutePat :: Name -> Type -> Pred -> Pred +substitutePat n t (AppT (AppT EqualityT t1) t2) + = AppT (AppT EqualityT (substituteVarE n t t1)) (substituteVarE n t t2) +substitutePat n t (AppT classname x) = AppT classname $ substituteVarE n t x +-- substitutePat n t (AppT classname xs) = go $ classname : map (substituteVarE n t) xs +-- where +-- go (x:y:[]) = AppT x y +-- go (x:y:zs) = go $ AppT x y : zs + +substituteVarE :: Name -> Type -> Type -> Type +substituteVarE varname vartype = go + where + go (VarT e) = if e==varname + then vartype + else VarT e + go (ConT e) = ConT e + go (AppT e1 e2) = AppT (go e1) (go e2) + go ArrowT = ArrowT + go ListT = ListT + go (TupleT n) = TupleT n + go zzz = error $ "substituteVarE: zzz="++show zzz + +returnType2newtypeApplicator :: Name -> Name -> Type -> Exp -> Q Exp +returnType2newtypeApplicator conname varname t exp = do + ret <- go t + return $ AppE ret exp + + where + + id = return $ VarE $ mkName "helper_id" + + go (VarT v) = if v==varname + then return $ ConE conname + else id + go (ConT c) = id + + -- | FIXME: The cases below do not cover all the possible functions we might want to derive + go (TupleT 0) = id + go t@(AppT (ConT c) t2) = do + info <- reify c + case info of + TyConI (TySynD _ _ _) -> expandTySyn t >>= go + FamilyI (FamilyD TypeFam _ _ _) _ -> id + TyConI (NewtypeD _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 + TyConI (DataD _ _ _ _ _) -> liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 + qqq -> error $ "returnType2newtypeApplicator: qqq="++show qqq + + go (AppT ListT t2) = liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 + go (AppT (AppT ArrowT _) t2) = liftM (AppE (VarE $ mkName "helper_liftM")) $ go t2 + go (AppT (AppT (TupleT 2) t1) t2) = do + e1 <- go t1 + e2 <- go t2 + return $ LamE + [ TupP [VarP $ mkName "v1", VarP $ mkName "v2"] ] + ( TupE + [ AppE e1 (VarE $ mkName "v1") + , AppE e2 (VarE $ mkName "v2") + ] + ) + + -- FIXME: this is a particularly fragile deriving clause only designed for the mutable operators + go (AppT (VarT m) (TupleT 0)) = id + + go xxx = error $ "returnType2newtypeApplicator:\n xxx="++show xxx++"\n t="++show t++"\n exp="++show exp + +isNewtypeInstance :: Name -> Name -> Q Bool +isNewtypeInstance typename classname = do + info <- reify classname + case info of + ClassI _ inst -> return $ or $ map go inst + where + go (InstanceD _ (AppT _ (AppT (ConT n) _)) _) = n==typename + go _ = False + + +substituteNewtype :: Name -> Name -> Name -> Type -> Type +substituteNewtype conname varname newvar = go + where + go (VarT v) = if varname==v + then AppT (ConT conname) (VarT varname) + else VarT v + go (AppT t1 t2) = AppT (go t1) (go t2) + go (ConT t) = ConT t + +typeL2patL :: Name -> Name -> [Type] -> [Pat] +typeL2patL conname varname xs = map go $ zip (map (\a -> mkName [a]) ['a'..]) xs + where + go (newvar,VarT v) = if v==varname + then ConP conname [VarP newvar] + else VarP newvar + go (newvar,AppT (AppT (ConT c) _) v) = if nameBase c=="Mutable" + then ConP (mkName $ "Mutable_"++nameBase conname) [VarP newvar] + else VarP newvar + go (newvar,AppT (ConT _) (VarT v)) = VarP newvar + go (newvar,AppT ListT (VarT v)) = VarP newvar + 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 + +arrow2list :: Type -> [Type] +arrow2list (ForallT _ _ xs) = arrow2list xs +arrow2list (AppT (AppT ArrowT t1) t2) = t1:arrow2list t2 +arrow2list x = [x] + +list2exp :: [Exp] -> Exp +list2exp xs = go $ reverse xs + where + go (x:[]) = x + go (x:xs) = AppE (go xs) x + +-- | Generate an Eq_ instance from the Prelude's Eq instance. +-- This requires that Logic t = Bool, so we also generate this type instance. +fromPreludeEq :: Q Type -> Q [Dec] +fromPreludeEq qt = do + t<-qt + return + [ TySynInstD + ( mkName "Logic" ) + ( TySynEqn [t] (ConT $ mkName "Bool" )) + , InstanceD + [] + ( AppT ( ConT $ mkName "Eq_" ) t ) + [ FunD + ( mkName "==" ) + [ Clause [] (NormalB $ VarE $ mkName "P.==") [] ] + ] + ] diff --git a/src/SubHask/TemplateHaskell/Mutable.hs b/src/SubHask/TemplateHaskell/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/TemplateHaskell/Mutable.hs @@ -0,0 +1,169 @@ +-- | Template Haskell functions for deriving "Mutable" instances. +module SubHask.TemplateHaskell.Mutable + ( mkMutable + , mkMutablePrimRef + , mkMutableNewtype + ) + where + +import SubHask.TemplateHaskell.Common + +import Prelude +import Control.Monad +import Language.Haskell.TH + +showtype :: Type -> String +showtype t = map go (show t) + where + go ' ' = '_' + go '.' = '_' + go '[' = '_' + go ']' = '_' + go '(' = '_' + go ')' = '_' + go '/' = '_' + go '+' = '_' + go '>' = '_' + go '<' = '_' + go x = x + +type2name :: Type -> Name +type2name t = mkName $ "Mutable_"++showtype t + +-- | Inspects the given type and creates the most efficient "Mutable" instance possible. +-- +-- FIXME: implement properly +mkMutable :: Q Type -> Q [Dec] +mkMutable = mkMutablePrimRef + + +-- | Create a "Mutable" instance for newtype wrappers. +-- The instance has the form: +-- +-- > newtype instance Mutable m (TyCon t) = Mutable_TyCon (Mutable m t) +-- +-- Also create the appropriate "IsMutable" instance. +-- +-- FIXME: +-- Currently uses default implementations which are slow. +mkMutableNewtype :: Name -> Q [Dec] +mkMutableNewtype typename = do + typeinfo <- reify typename + (conname,typekind,typeapp) <- case typeinfo of + TyConI (NewtypeD [] _ typekind (NormalC conname [( _,typeapp)]) _) + -> return (conname,typekind,typeapp) + TyConI (NewtypeD [] _ typekind (RecC conname [(_,_,typeapp)]) _) + -> return (conname,typekind,typeapp) + _ -> error $ "\nderiveSingleInstance; typeinfo="++show typeinfo + + let mutname = mkName $ "Mutable_" ++ nameBase conname + + nameexists <- lookupValueName (show mutname) + return $ case nameexists of + Just x -> [] + Nothing -> + [ NewtypeInstD + [ ] + ( mkName $ "Mutable" ) + [ VarT (mkName "m"), apply2varlist (ConT typename) typekind ] + ( NormalC + mutname + [( NotStrict + , AppT + ( AppT + ( ConT $ mkName "Mutable" ) + ( VarT $ mkName "m" ) + ) + typeapp + )] + ) + [ ] + , InstanceD + ( map (\x -> AppT (ConT $ mkName "IsMutable") (bndr2type x)) $ filter isStar $ typekind ) + ( AppT + ( ConT $ mkName "IsMutable" ) + ( apply2varlist (ConT typename) typekind ) + ) + [ FunD (mkName "freeze") + [ Clause + [ ConP mutname [ VarP $ mkName "x" ] ] + ( NormalB $ AppE + ( AppE (VarE $ mkName "helper_liftM") (ConE conname) ) + ( AppE (VarE $ mkName "freeze") (VarE $ mkName "x") ) + ) + [] + ] + , FunD (mkName "thaw") + [ Clause + [ ConP conname [ VarP $ mkName "x" ] ] + ( NormalB $ AppE + ( AppE (VarE $ mkName "helper_liftM") (ConE mutname) ) + ( AppE (VarE $ mkName "thaw") (VarE $ mkName "x") ) + ) + [] + ] + , FunD (mkName "write") + [ Clause + [ ConP mutname [ VarP $ mkName "x" ] + , ConP conname [ VarP $ mkName "x'" ] + ] + ( NormalB $ + AppE ( AppE (VarE $ mkName "write") (VarE $ mkName "x") ) (VarE $ mkName "x'" ) + ) + [] + ] + ] + ] + +-- | Create a "Mutable" instance that uses "PrimRef"s for the underlying implementation. +-- This method will succeed for all types. +-- But certain types can be implemented for efficiently. +mkMutablePrimRef :: Q Type -> Q [Dec] +mkMutablePrimRef qt = do + _t <- qt + let (cxt,t) = case _t of + (ForallT _ cxt t) -> (cxt,t) + _ -> ([],_t) + + return $ + [ NewtypeInstD + cxt + ( mkName $ "Mutable" ) + [ VarT (mkName "m"), t ] + ( NormalC + ( type2name t ) + [( NotStrict + , AppT (AppT (ConT $ mkName "PrimRef") (VarT $ mkName "m")) t + )] + ) + [ ] + , InstanceD + cxt + ( AppT ( ConT $ mkName "IsMutable" ) t ) + [ FunD (mkName "freeze") + [ Clause + [ ConP (type2name t) [ VarP $ mkName "x"] ] + ( NormalB $ AppE (VarE $ mkName "readPrimRef") (VarE $ mkName "x")) + [] + ] + , FunD (mkName "thaw") + [ Clause + [ VarP $ mkName "x" ] + ( NormalB $ AppE + ( AppE (VarE $ mkName "helper_liftM") (ConE $ type2name t) ) + ( AppE (VarE $ mkName "newPrimRef") (VarE $ mkName "x") ) + ) + [] + ] + , FunD (mkName "write") + [ Clause + [ ConP (type2name t) [VarP $ mkName "x"], VarP $ mkName "x'" ] + ( NormalB $ AppE + ( AppE (VarE $ mkName "writePrimRef") (VarE $ mkName "x") ) + ( VarE $ mkName "x'" ) + ) + [] + ] + ] + ] + diff --git a/src/SubHask/TemplateHaskell/Test.hs b/src/SubHask/TemplateHaskell/Test.hs new file mode 100644 --- /dev/null +++ b/src/SubHask/TemplateHaskell/Test.hs @@ -0,0 +1,343 @@ +module SubHask.TemplateHaskell.Test + where + +import Prelude +import Control.Monad + +import qualified Data.Map as Map +import Debug.Trace + +import Language.Haskell.TH +import GHC.Exts + +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Deriving +-- import SubHask.Category +-- import SubHask.Algebra + +-- | Ideally, this map would be generated automatically via template haskell. +-- Due to bug , however, we must enter these manually. +testMap :: Map.Map String [String] +testMap = Map.fromList + [ ( "Eq",[] ) + , ( "MinBound",[]) + , ( "Lattice",[]) + , ( "Ord",[]) + , ( "POrd",[]) + , ( "IsMutable", []) + + -- comparison + + , ( "Eq_", + [ "law_Eq_reflexive" + , "law_Eq_symmetric" + , "law_Eq_transitive" + ] ) + , ( "POrd_", + [ "law_POrd_commutative" + , "law_POrd_associative" + , "theorem_POrd_idempotent" + ]) + , ("MinBound_", + [ "law_MinBound_inf" + ] ) + , ( "Lattice_", + [ "law_Lattice_infabsorption" + , "law_Lattice_supabsorption" + ] ) + , ( "Ord_", + [ "law_Ord_totality" + , "law_Ord_min" + , "law_Ord_max" + ] ) + , ("Bounded", + [ "law_Bounded_sup" + ] ) + , ("Complemented", + [ "law_Complemented_not" + ] ) + , ("Heyting", + [ "law_Heyting_maxbound" + , "law_Heyting_infleft" + , "law_Heyting_infright" + , "law_Heyting_distributive" + ] ) + , ("Boolean", + [ "law_Boolean_infcomplement" + , "law_Boolean_supcomplement" + , "law_Boolean_infdistributivity" + , "law_Boolean_supdistributivity" + ]) + , ( "Graded", + [ "law_Graded_pred" + , "law_Graded_fromEnum" + ] ) + , ( "Enum", + [ "law_Enum_succ" + , "law_Enum_toEnum" + ] ) + + -- algebra + + , ( "Semigroup" , + [ "law_Semigroup_associativity" + , "defn_Semigroup_plusequal" + ] ) + , ( "Action" , + [ "law_Action_compatibility" + , "defn_Action_dotplusequal" + ] ) + , ( "Cancellative", + [ "law_Cancellative_rightminus1" + , "law_Cancellative_rightminus2" + , "defn_Cancellative_plusequal" + ]) + , ( "Monoid", + [ "law_Monoid_leftid" + , "law_Monoid_rightid" + , "defn_Monoid_isZero" + ] ) + , ( "Abelian", + [ "law_Abelian_commutative" + ] ) + , ( "Group", + [ "defn_Group_negateminus" + , "law_Group_leftinverse" + , "law_Group_rightinverse" + ] ) + + , ("Rg", + [ "law_Rg_multiplicativeAssociativity" + , "law_Rg_multiplicativeCommutivity" + , "law_Rg_annihilation" + , "law_Rg_distributivityLeft" + , "theorem_Rg_distributivityRight" + , "defn_Rg_timesequal" + ]) + , ("Rig", + [ "law_Rig_multiplicativeId" + ] ) + , ("Rng", []) + , ("Ring", + [ "defn_Ring_fromInteger" + ] ) + , ("Integral", + [ "law_Integral_divMod" + , "law_Integral_quotRem" + , "law_Integral_toFromInverse" + ]) + + , ("Module", + [ "law_Module_multiplication" + , "law_Module_addition" + , "law_Module_action" + , "law_Module_unital" + , "defn_Module_dotstarequal" + ] + ) + , ("FreeModule", + [ "law_FreeModule_commutative" + , "law_FreeModule_associative" + , "law_FreeModule_id" + , "defn_FreeModule_dotstardotequal" + ] + ) + + , ("VectorSpace", + [] + ) + + -- sizes + + , ( "HasScalar", [] ) + , ( "Normed", + [ + ] ) + , ( "Metric", + [ "law_Metric_nonnegativity" + , "law_Metric_indiscernables" + , "law_Metric_symmetry" + , "law_Metric_triangle" + ] ) + + -- containers + + , ( "Container", + [ "law_Container_preservation" + ] ) + , ( "Constructible", + [ "law_Constructible_singleton" + , "defn_Constructible_cons" + , "defn_Constructible_snoc" + , "defn_Constructible_fromList" + , "defn_Constructible_fromListN" + , "theorem_Constructible_cons" + ] ) + , ( "Foldable", +-- [ "law_Foldable_sum" + [ "theorem_Foldable_tofrom" + , "defn_Foldable_foldr" + , "defn_Foldable_foldr'" + , "defn_Foldable_foldl" + , "defn_Foldable_foldl'" +-- , "defn_Foldable_foldr1" +-- , "defn_Foldable_foldr1'" +-- , "defn_Foldable_foldl1" +-- , "defn_Foldable_foldl1'" + ] ) + , ( "Partitionable", + [ "law_Partitionable_length" + , "law_Partitionable_monoid" + ] ) + + -- indexed containers + + , ( "IxConstructible", + [ "law_IxConstructible_lookup" + , "defn_IxConstructible_consAt" + , "defn_IxConstructible_snocAt" + , "defn_IxConstructible_fromIxList" + ] ) + , ( "IxContainer", + [ "law_IxContainer_preservation" + , "defn_IxContainer_bang" + , "defn_IxContainer_findWithDefault" + , "defn_IxContainer_hasIndex" + ] ) + + ] + +-- | makes tests for all instances of a class that take no type variables +mkClassTests :: Name -> Q Exp +mkClassTests className = do + info <- reify className + typeTests <- case info of + ClassI _ xs -> go xs + otherwise -> error "mkClassTests called on something not a class" + return $ AppE + ( AppE + ( VarE $ mkName "testGroup" ) + ( LitE $ StringL $ nameBase className ) + ) + ( typeTests ) + where + go [] = return $ ConE $ mkName "[]" + go ((InstanceD ctx (AppT _ t) _):xs) = case t of + (ConT a) -> do + tests <- mkSpecializedClassTest (ConT a) className + next <- go xs + return $ AppE + ( AppE + ( ConE $ mkName ":" ) + ( tests ) + ) + ( next ) +-- (AppT _ _) -> do +-- let specializedType = specializeType t (ConT ''Int) +-- tests <- mkSpecializedClassTest specializedType className +-- next <- go xs +-- return $ AppE +-- ( AppE +-- ( ConE $ mkName ":" ) +-- ( tests ) +-- ) +-- ( next ) +-- otherwise -> trace ("mkClassTests: skipping "++show ctx++" => "++show t) $ go xs + otherwise -> go xs + + +-- | Given a type and a class, searches "testMap" for all tests for the class; +-- then specializes those tests to test on the given type +mkSpecializedClassTest + :: Type -- ^ type to create tests for + -> Name -- ^ class to create tests for + -> Q Exp +mkSpecializedClassTest typeName className = case Map.lookup (nameBase className) testMap of + Nothing -> error $ "mkSpecializedClassTest: no tests defined for type " ++ nameBase className + Just xs -> do + tests <- mkTests typeName $ map mkName xs + return $ AppE + ( AppE + ( VarE $ mkName "testGroup" ) +-- ( LitE $ StringL $ show $ ppr typeName ) + ( LitE $ StringL $ nameBase className ) + ) + ( tests ) + +-- | Like "mkSpecializedClassTests", but takes a list of classes +mkSpecializedClassTests :: Q Type -> [Name] -> Q Exp +mkSpecializedClassTests typeNameQ xs = do + typeName <- typeNameQ + testnames <- liftM concat $ mapM listSuperClasses xs + tests <- liftM listExp2Exp $ mapM (mkSpecializedClassTest typeName) testnames + return $ AppE + ( AppE + ( VarE $ mkName "testGroup" ) + ( LitE $ StringL $ show $ ppr typeName ) + ) + ( tests ) + +-- | replace all variables with a concrete type +specializeType + :: Type -- ^ type with variables + -> Type -- ^ instantiate variables to this type + -> Type +specializeType t n = case t of + VarT _ -> n + AppT t1 t2 -> AppT (specializeType t1 n) (specializeType t2 n) + ForallT xs ctx t -> {-ForallT xs ctx $-} specializeType t n +-- ForallT xs ctx t -> ForallT xs (specializeType ctx n) $ specializeType t n + x -> x + +specializeLaw + :: Type -- ^ type to specialize the law to + -> Name -- ^ law (i.e. function) that we're testing + -> Q Exp +specializeLaw typeName lawName = do + lawInfo <- reify lawName + let newType = case lawInfo of + VarI _ t _ _ -> specializeType t typeName + otherwise -> error "mkTest lawName not a function" + return $ SigE (VarE lawName) newType + +-- | creates an expression of the form: +-- +-- > testProperty "testname" (law_Classname_testname :: typeName -> ... -> Bool) +-- +mkTest + :: Type -- ^ type to specialize the law to + -> Name -- ^ law (i.e. function) that we're testing + -> Q Exp +mkTest typeName lawName = do + spec <- specializeLaw typeName lawName + return $ AppE + ( AppE + ( VarE $ mkName "testProperty" ) + ( LitE $ StringL $ extractTestStr lawName ) + ) + ( spec ) + +-- | Like "mkTest", but takes a list of laws and returns a list of tests +mkTests :: Type -> [Name] -> Q Exp +mkTests typeName xs = liftM listExp2Exp $ mapM (mkTest typeName) xs + +listExp2Exp :: [Exp] -> Exp +listExp2Exp [] = ConE $ mkName "[]" +listExp2Exp (x:xs) = AppE + ( AppE + ( ConE $ mkName ":" ) + ( x ) + ) + ( listExp2Exp xs ) + +-- | takes a "Name" of the form +-- +-- > law_Class_test +-- +-- and returns the string +-- +-- > test +extractTestStr :: Name -> String +extractTestStr name = nameBase name +-- extractTestStr name = last $ words $ map (\x -> if x=='_' then ' ' else x) $ nameBase name + diff --git a/subhask.cabal b/subhask.cabal new file mode 100644 --- /dev/null +++ b/subhask.cabal @@ -0,0 +1,261 @@ +name: subhask +version: 0.1.0.0 +synopsis: Type safe interface for programming in subcategories of Hask +homepage: http://github.com/mikeizbicki/subhask +license: BSD3 +license-file: LICENSE +author: Mike Izbicki +maintainer: mike@izbicki.me +category: Control, Categories, Algebra +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +description: + 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*. + The main idea is to use a type safe interface for programming in arbitrary subcategories of [Hask](https://wiki.haskell.org/Hask). + For example, the category [Vect](http://ncatlab.org/nlab/show/Vect) of linear functions is a subcategory of Hask, and SubHask exploits this fact to give a nice interface for linear algebra. + To achieve this goal, almost every class hierarchy is redefined to be more general. + + I recommend reading the file and the before looking at the documetation here. + +source-repository head + type: git + location: http://github.com/mikeizbicki/subhask + +-------------------------------------------------------------------------------- + +library + exposed-modules: + SubHask + + SubHask.Algebra + SubHask.Algebra.Array + SubHask.Algebra.Container + SubHask.Algebra.Group + SubHask.Algebra.Logic + SubHask.Algebra.Metric + SubHask.Algebra.Ord + SubHask.Algebra.Parallel +-- SubHask.Algebra.Trans.Kernel + SubHask.Algebra.Vector + + SubHask.Category + SubHask.Category.Finite + SubHask.Category.Product + 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 + SubHask.Compatibility.BloomFilter + SubHask.Compatibility.ByteString + SubHask.Compatibility.Cassava + SubHask.Compatibility.Containers + SubHask.Compatibility.HyperLogLog + + SubHask.Monad + SubHask.Mutable + SubHask.SubType + + SubHask.TemplateHaskell.Base + SubHask.TemplateHaskell.Deriving + SubHask.TemplateHaskell.Mutable + SubHask.TemplateHaskell.Test + + other-modules: + SubHask.Internal.Prelude + SubHask.TemplateHaskell.Common + + default-extensions: + TypeFamilies, + ConstraintKinds, + DataKinds, + GADTs, + MultiParamTypeClasses, + FlexibleInstances, + FlexibleContexts, + TypeOperators, + RankNTypes, + InstanceSigs, + ScopedTypeVariables, + UndecidableInstances, + PolyKinds, + StandaloneDeriving, + GeneralizedNewtypeDeriving, + TemplateHaskell, + BangPatterns, + FunctionalDependencies, + TupleSections, + MultiWayIf, + + AutoDeriveTypeable, + RebindableSyntax +-- OverloadedLists + + hs-source-dirs: + src + + c-sources: + cbits/Lebesgue.c + + cc-options: +-- -O3 + -ffast-math + -msse3 + + ghc-options: +-- -O2 +-- -O + -funbox-strict-fields + + build-depends: + -- NOTE: + -- We specify the *exact* versions of all non-base libraries to ensure that we get reproducible builds. + -- This helps prevent performance regressions. + -- The downside of exact version dependencies is that the user probably doesn't have these versions installed. + -- This can result in significantly longer build times and build conflicts. + -- But since subhask is designed as an alternative to base, this is an acceptable tradeoff. + + -- haskell language + base >= 4.8 && <4.9, + ghc-prim == 0.4.0.0, + template-haskell == 2.10.0.0, + + -- special functionality + parallel == 3.2.0.6, + deepseq == 1.4.1.1, + primitive == 0.6, + monad-primitive == 0.1, + QuickCheck == 2.8.1, + + -- 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, + + -- compatibility data structures + bytestring == 0.10.6.0, + bloomfilter == 2.0.1.0, + cassava == 0.4.2.3, + containers == 0.5.6.2, + hyperloglog == 0.3.1, + + -- required for hyperloglog compatibility + semigroups == 0.16.2, + bytes == 0.15, + approximate == 0.2.1.1, + lens == 4.9.1 + + default-language: + Haskell2010 + +-------------------------------------------------------------------------------- + +Test-Suite TestSuite-Unoptimized + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: TestSuite.hs + + ghc-options: + -O0 + + build-depends: + subhask, + test-framework-quickcheck2 >= 0.3.0, + test-framework >= 0.8.0 + +-- FIXME: +-- The test below takes a long time to compile. +-- The slow builds are cosing travis tests to fail. +-- +-- Test-Suite TestSuite-Optimized +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: TestSuite.hs +-- +-- build-depends: +-- subhask, +-- test-framework-quickcheck2 >= 0.3.0, +-- test-framework >= 0.8.0 +-- +-- ghc-options: +-- -O2 +-- -fllvm + +-------------------- + +Test-Suite Example0001 + type: exitcode-stdio-1.0 + hs-source-dirs: examples + main-is: example0001-polynomials.lhs + build-depends: subhask, base + +Test-Suite Example0002 + type: exitcode-stdio-1.0 + hs-source-dirs: examples + main-is: example0002-monad-instances-for-set.lhs + build-depends: subhask, base + +Test-Suite Example0003 + type: exitcode-stdio-1.0 + hs-source-dirs: examples + main-is: example0003-linear-algebra.lhs + build-depends: subhask, base + +-------------------------------------------------------------------------------- + +benchmark Vector + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Vector.hs + build-depends: + base, + subhask, + criterion == 1.1.0.0, + MonadRandom + + ghc-options: + -O2 + -funbox-strict-fields + -fexcess-precision + +-- -fliberate-case-threshold=100000 +-- -fexpose-all-unfoldings +-- -fmax-simplifier-iterations=10 +-- -fmax-worker-args=100 +-- -fsimplifier-phases=5 +-- -fspec-constr-count=50 + + -fllvm + -optlo-O3 + -optlo-enable-fp-mad + -optlo-enable-no-infs-fp-math + -optlo-enable-no-nans-fp-math + -optlo-enable-unsafe-fp-math + +-- -ddump-to-file +-- -ddump-rule-firings +-- -ddump-rule-rewrites +-- -ddump-rules +-- -ddump-cmm +-- -ddump-simpl +-- -ddump-simpl-stats +-- -dppr-debug +-- -dsuppress-module-prefixes +-- -dsuppress-uniques +-- -dsuppress-idinfo +-- -dsuppress-coercions +-- -dsuppress-type-applications diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} + +module Main + where + +import SubHask +import SubHask.Algebra.Array +import SubHask.Algebra.Group +import SubHask.Algebra.Container +import SubHask.Algebra.Logic +import SubHask.Algebra.Metric +import SubHask.Algebra.Parallel +import SubHask.Algebra.Vector +import SubHask.Compatibility.ByteString +import SubHask.Compatibility.Containers + +import SubHask.TemplateHaskell.Deriving +import SubHask.TemplateHaskell.Test + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Runners.Console +import Test.Framework.Runners.Options + +-------------------------------------------------------------------------------- + +main = defaultMainWithOpts + [ testGroup "simple" + [ testGroup "numeric" + [ $( mkSpecializedClassTests [t| Int |] [''Enum,''Ring, ''Bounded, ''Metric] ) + , $( mkSpecializedClassTests [t| Integer |] [''Enum,''Ring, ''Lattice, ''Metric] ) + , $( mkSpecializedClassTests [t| Rational |] [''Ord,''Ring, ''Lattice, ''Metric] ) + , $( mkSpecializedClassTests [t| Float |] [''Bounded] ) + , $( mkSpecializedClassTests [t| Double |] [''Bounded] ) + , testGroup "transformers" + [ $( mkSpecializedClassTests [t| NonNegative Int |] [''Enum,''Rig, ''Bounded, ''Metric] ) + , $( mkSpecializedClassTests [t| Z 57 |] [''Ring] ) + , $( mkSpecializedClassTests [t| NonNegative (Z 57) |] [''Rig] ) + ] + ] + , testGroup "vector" + [ $( mkSpecializedClassTests [t| SVector 0 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| SVector 1 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| SVector 2 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| SVector 19 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| SVector 1001 Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| SVector "dyn" Int |] [ ''Module ] ) + , $( mkSpecializedClassTests [t| UVector "dyn" Int |] [ ''Module ] ) + ] + , testGroup "non-numeric" + [ $( mkSpecializedClassTests [t| Bool |] [''Enum,''Boolean] ) + , $( mkSpecializedClassTests [t| Char |] [''Enum,''Bounded] ) + , $( mkSpecializedClassTests [t| Goedel |] [''Heyting] ) + , $( mkSpecializedClassTests [t| H3 |] [''Heyting] ) + , $( mkSpecializedClassTests [t| K3 |] [''Bounded] ) + , testGroup "transformers" + [ $( mkSpecializedClassTests [t| Boolean2Ring Bool |] [''Ring] ) + ] + ] + ] + , testGroup "objects" + [ $( mkSpecializedClassTests [t| Labeled' Int Int |] [ ''Action,''Ord,''Metric ] ) + ] + , 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 ] ) + , testGroup "transformers" + [ $( mkSpecializedClassTests [t| Lexical [Char] |] [''Ord,''MinBound] ) + , $( mkSpecializedClassTests [t| ComponentWise [Char] |] [''Lattice,''MinBound] ) + , $( mkSpecializedClassTests [t| Hamming [Char] |] [''Metric] ) + , $( mkSpecializedClassTests [t| Levenshtein [Char] |] [''Metric] ) + ] + , testGroup "metric" +-- [ $( mkSpecializedClassTests [t| Ball Int |] [''Eq,''Container] ) +-- , $( mkSpecializedClassTests [t| Ball (Hamming [Char]) |] [''Eq,''Container] ) + [ $( mkSpecializedClassTests [t| Box Int |] [''Eq,''Container] ) + , $( mkSpecializedClassTests [t| Box (ComponentWise [Char]) |] [''Eq,''Container] ) + ] + ] + ] + $ RunnerOptions + { ropt_threads = Nothing + , ropt_test_options = Nothing + , ropt_test_patterns = Nothing + , ropt_xml_output = Nothing + , ropt_xml_nested = Nothing + , ropt_color_mode = Just ColorAlways + , ropt_hide_successes = Just True + , ropt_list_only = Just True + } + +-------------------------------------------------------------------------------- +-- orphan instances needed for compilation + +instance (Show a, Show b) => Show (a -> b) where + show _ = "function"