diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for sized-grid +## 0.1.1.0 -- 2018-05-10 + +* Added Field instances for coord +* Added ways of manipulating coords + ## 0.1.0.0 -- 2018-04-18 * First version. diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -1,5 +1,7 @@ [![Build Status](https://travis-ci.org/edwardwas/sized-grid.svg?branch=master)](https://travis-ci.org/edwardwas/sized-grid) +![Hackage](https://img.shields.io/hackage/v/sized-grid) + sized-grid =========== @@ -21,6 +23,8 @@ The last type value of `Grid` is the type of each element. The other main type is `Coord cs`, where `cs` is, again, a type level list of coordinate types. For example, `Coord '[Periodic 3, HardWrap 4]` is a coordinate in a 3 by 4 2D space. The different types (`Periodic` and `HardWrap`) tell how to handle combining theses different numbers. `Coord cs` is an instance of `Semigroup`, `Monoid` and `AdditiveGroup` as long as each of the coordinates is also an instance of that typeclass. `Coord` is also an instance of of `AffineSpace`, where `Diff` is a n-tuple, meaning we can pattern match and do all sorts of nice things. + +For working directly with `Coord`s, one can construct them with `singleCoord` and `appendCoord` and consume and update them with `coordHead` and `coordTail`. They are also instances of `FieldN` from lens, allowing one to directly update or get a certain dimension. There is a deliberately small number of functions that work over `Grid`: we instead opt for using typeclasses to create the required functionality. `Grid` is an instance of the following types (with some required constraints): diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ [![Build Status](https://travis-ci.org/edwardwas/sized-grid.svg?branch=master)](https://travis-ci.org/edwardwas/sized-grid) +![Hackage](https://img.shields.io/hackage/v/sized-grid) + sized-grid =========== @@ -21,6 +23,8 @@ The last type value of `Grid` is the type of each element. The other main type is `Coord cs`, where `cs` is, again, a type level list of coordinate types. For example, `Coord '[Periodic 3, HardWrap 4]` is a coordinate in a 3 by 4 2D space. The different types (`Periodic` and `HardWrap`) tell how to handle combining theses different numbers. `Coord cs` is an instance of `Semigroup`, `Monoid` and `AdditiveGroup` as long as each of the coordinates is also an instance of that typeclass. `Coord` is also an instance of of `AffineSpace`, where `Diff` is a n-tuple, meaning we can pattern match and do all sorts of nice things. + +For working directly with `Coord`s, one can construct them with `singleCoord` and `appendCoord` and consume and update them with `coordHead` and `coordTail`. They are also instances of `FieldN` from lens, allowing one to directly update or get a certain dimension. There is a deliberately small number of functions that work over `Grid`: we instead opt for using typeclasses to create the required functionality. `Grid` is an instance of the following types (with some required constraints): diff --git a/sized-grid.cabal b/sized-grid.cabal --- a/sized-grid.cabal +++ b/sized-grid.cabal @@ -1,5 +1,5 @@ name: sized-grid -version: 0.1.0.0 +version: 0.1.1.0 cabal-version: >=1.10 category: Data build-type: Simple @@ -31,7 +31,7 @@ SizedGrid.Grid.Focused SizedGrid build-depends: - base >=4.8 && <4.12, + base >=4.9 && <4.12, lens >=4.16.1 && <4.17, vector >=0.12.0.1 && <0.13, vector-space ==0.13.*, @@ -53,7 +53,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: - base >=4.8 && <4.12, + base >=4.9 && <4.12, sized-grid -any, hedgehog >=0.5.3 && <0.6, tasty >=1.0.1.1 && <1.1, @@ -73,7 +73,7 @@ type: exitcode-stdio-1.0 main-is: README.lhs build-depends: - base >=4.10.1.0 && <4.11, + base >=4.9 && <4.12, markdown-unlit >=0.5.0 && <0.6, sized-grid -any, distributive >=0.5.3 && <0.6, diff --git a/src/SizedGrid.hs b/src/SizedGrid.hs --- a/src/SizedGrid.hs +++ b/src/SizedGrid.hs @@ -2,6 +2,7 @@ module SizedGrid ( + -- This reexports all of SizedGrid. Import this and you're godo to go module X -- * Rexported for generics-sop , All diff --git a/src/SizedGrid/Coord.hs b/src/SizedGrid/Coord.hs --- a/src/SizedGrid/Coord.hs +++ b/src/SizedGrid/Coord.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,12 +17,11 @@ import Control.Applicative (liftA2) import Control.Applicative (empty) -import Control.Lens ((^.)) +import Control.Lens hiding (from, to) import Control.Monad.State import Data.AdditiveGroup import Data.Aeson import Data.AffineSpace -import Data.Functor.Identity import Data.List (intercalate) import Data.Semigroup (Semigroup (..)) import qualified Data.Vector as V @@ -41,6 +41,9 @@ newtype Coord cs = Coord {unCoord :: NP I cs} deriving (Generic) +_WrappedCoord :: Lens' (Coord cs) (NP I cs) +_WrappedCoord f (Coord n) = Coord <$> f n + instance All Eq cs => Eq (Coord cs) where Coord a == Coord b = and $ @@ -76,7 +79,6 @@ (hcmap (Proxy @FromJSON) (\(K x) -> parseJSON x) a) Nothing -> empty - instance All Semigroup cs => Semigroup (Coord cs) where Coord a <> Coord b = Coord $ hcliftA2 (Proxy :: Proxy Semigroup) (liftA2 (<>)) a b @@ -111,6 +113,37 @@ ma) g in (Coord c, g') + +-- | Get the first element of a coord. Thanks to type level information, we can write this as a total `Lens` +coordHead :: Lens (Coord (a ': as)) (Coord (a' ': as)) a a' +coordHead f (Coord (I a :* as)) = (\a' -> Coord (I a' :* as)) <$> f a + +-- | A `Lens` into the the tail of `Coord` +coordTail :: Lens (Coord (a ': as)) (Coord (a ': as')) (Coord as) (Coord as') +coordTail f (Coord (a :* as)) = (\(Coord as') -> Coord (a :* as')) <$> f (Coord as) + +-- | Turn a single element into a one dimensional `Coord` +singleCoord :: a -> Coord '[a] +singleCoord a = Coord (I a :* Nil) + +-- | Add a new element to a `Coord`. This increases the dimensionality +appendCoord :: a -> Coord as -> Coord (a ': as) +appendCoord a (Coord as) = Coord (I a :* as) + +instance Field1 (Coord (a ': cs)) (Coord (a' ': cs)) a a' where + _1 = coordHead + +instance Field2 (Coord (a ': b ': cs)) (Coord (a ': b' ': cs)) b b' where + _2 = coordTail . _1 + +instance Field3 (Coord (a ': b ': c ': cs)) (Coord (a ': b ': c' ': cs)) c c' where + _3 = coordTail . _2 + +instance Field4 (Coord (a ': b ': c ': d ': cs)) (Coord (a ': b ': c ': d' ': cs)) d d' where + _4 = coordTail . _3 + +instance Field5 (Coord (a ': b ': c ': d ': e ': cs)) (Coord (a ': b ': c ': d ': e' ': cs)) e e' where + _5 = coordTail . _4 -- | The type of difference between two coords. A n-dimensional coord should have a `Diff` of an n-tuple of `Integers`. We use `Identity` and our 1-tuple. Unfortuantly, each instance is manual at the moment. type family CoordDiff (cs :: [k]) :: * diff --git a/src/SizedGrid/Coord/Class.hs b/src/SizedGrid/Coord/Class.hs --- a/src/SizedGrid/Coord/Class.hs +++ b/src/SizedGrid/Coord/Class.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module SizedGrid.Coord.Class where @@ -17,7 +19,7 @@ -- | Everything that can be uses as a Coordinate. The only required function is `asOrdinal` and the type instance of `CoordSized`: the rest can be derived automatically. -- --- This is kind * -> Constraint for ease of use later. There is some argument that it should be of kind (Nat -> *) -> Constraint and we can remove `CoordSized` +-- This is kind * -> Constraint for ease of use later. There is some argument that it should be of kind (Nat -> *) -> Constraint and we could remove `CoordSized`, but that has other complications class (1 <= CoordSized c, KnownNat (CoordSized c)) => IsCoord c where -- | The maximum number of values that a Coord can take type CoordSized c :: Nat diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,23 +9,20 @@ module Main where -import SizedGrid.Coord -import SizedGrid.Coord.Class -import SizedGrid.Coord.HardWrap -import SizedGrid.Coord.Periodic -import SizedGrid.Grid.Grid +import SizedGrid import Test.Utils -import Control.Monad (replicateM) +import Control.Lens hiding (index) +import Control.Monad (replicateM) import Data.Functor.Rep import Data.Proxy -import Generics.SOP hiding (S, Z) +import Generics.SOP hiding (S, Z) import GHC.TypeLits -import qualified GHC.TypeLits as GHC +import qualified GHC.TypeLits as GHC import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Test.Tasty import Test.Tasty.Hedgehog import Test.Tasty.HUnit @@ -83,58 +80,107 @@ , testProperty "UnCollapse and Collapse" uncollapseCollapse ] +coordCreationTests :: + (All Show cs, All Eq cs, Eq a, Show a, Show c, Eq c) + => Gen (Coord (c ': cs)) + -> Gen a + -> [TestTree] +coordCreationTests genC gen = + [ testProperty "Create single coord" $ + property $ forAll gen >>= \g -> g === (singleCoord g ^. _1) + , testProperty "Create double coord" $ property $ do + a <- forAll gen + b <- forAll gen + let coord = appendCoord b $ singleCoord a + a === coord ^. _2 + b === coord ^. _1 + , testProperty "Create triple coord" $ property $ do + a <- forAll gen + b <- forAll gen + c <- forAll gen + let coord = appendCoord c $ appendCoord b $ singleCoord a + a === coord ^. _3 + b === coord ^. _2 + c === coord ^. _1 + , testProperty "Head and append" $ property $ do + coord <- forAll genC + a <- forAll gen + let newCoord = appendCoord a coord + a === newCoord ^. coordHead + coord === newCoord ^. coordTail + , testProperty "Tail destruction" $ property $ do + coord <- forAll genC + appendCoord (coord ^. coordHead) (coord ^. coordTail) === coord + ] + main :: IO () main = - let periodic = - let g :: Gen (Periodic 10) = genPeriodic - in [ semigroupLaws g - , monoidLaws g - , additiveGroupLaws g - , affineSpaceLaws g - , aesonLaws g - ] - hardWrap = - let g :: Gen (HardWrap 10) = HardWrap <$> Gen.enumBounded - in [semigroupLaws g, monoidLaws g, affineSpaceLaws g, aesonLaws g] - coord = - let g :: Gen (Coord '[ HardWrap 10, Periodic 20]) = - genCoord - ((HardWrap <$> Gen.enumBounded) :* - (Periodic <$> Gen.enumBounded) :* - Nil) - in [semigroupLaws g, monoidLaws g, affineSpaceLaws g, aesonLaws g, testAllCoordOrdered g] - coord2 = - let g :: Gen (Coord '[ Periodic 10, Periodic 20]) = - genCoord - ((Periodic <$> Gen.enumBounded) :* - (Periodic <$> Gen.enumBounded) :* - Nil) - in [ semigroupLaws g - , monoidLaws g - , affineSpaceLaws g - , additiveGroupLaws g - , aesonLaws g - , testAllCoordOrdered g - ] - in defaultMain $ - testGroup - "tests" - [ testGroup "Periodic 20" periodic - , testGroup "HardWrap 20" hardWrap - , testGroup "Coord [HardWrap 10, Periodic 20]" coord - , testGroup "Coord [Periodic 10, Periodic 20]" coord2 - , testGroup - "Grid" - ((gridTests @'[ Periodic 10, Periodic 11] - (genCoord $ - (Periodic <$> Gen.enumBounded) :* - (Periodic <$> Gen.enumBounded) :* - Nil)) (Gen.int $ Range.linear 0 100) ++ - [ applicativeLaws - (Proxy @(Grid '[ Periodic 10, Periodic 11])) - (Gen.int $ Range.linear 0 100) - , aesonLaws (sequenceA $ pure @(Grid '[Periodic 10, Periodic 11] ) $ - Gen.int $ Range.linear 0 100) - , eq1Laws (Proxy @(Grid '[Periodic 10, Periodic 20])) - ]) + let periodic = + let g :: Gen (Periodic 10) = genPeriodic + in [ semigroupLaws g + , monoidLaws g + , additiveGroupLaws g + , affineSpaceLaws g + , aesonLaws g ] + hardWrap = + let g :: Gen (HardWrap 10) = HardWrap <$> Gen.enumBounded + in [semigroupLaws g, monoidLaws g, affineSpaceLaws g, aesonLaws g] + coord = + let g :: Gen (Coord '[ HardWrap 10, Periodic 20]) = + genCoord + ((HardWrap <$> Gen.enumBounded) :* + (Periodic <$> Gen.enumBounded) :* + Nil) + in [ semigroupLaws g + , monoidLaws g + , affineSpaceLaws g + , aesonLaws g + , testAllCoordOrdered g + ] + coord2 = + let g :: Gen (Coord '[ Periodic 10, Periodic 20]) = + genCoord + ((Periodic <$> Gen.enumBounded) :* + (Periodic <$> Gen.enumBounded) :* + Nil) + in [ semigroupLaws g + , monoidLaws g + , affineSpaceLaws g + , additiveGroupLaws g + , aesonLaws g + , testAllCoordOrdered g + ] + in defaultMain $ + testGroup + "tests" + [ testGroup "Periodic 20" periodic + , testGroup "HardWrap 20" hardWrap + , testGroup "Coord [HardWrap 10, Periodic 20]" coord + , testGroup "Coord [Periodic 10, Periodic 20]" coord2 + , testGroup + "Coord creation" + (coordCreationTests + (genCoord + ((HardWrap <$> Gen.enumBounded) :* + (Periodic <$> Gen.enumBounded) :* + Nil) :: Gen (Coord '[ HardWrap 10, Periodic 10])) + (Gen.enumBounded :: Gen Int)) + , testGroup + "Grid" + ((gridTests + @'[ Periodic 10, Periodic 11] + (genCoord $ + (Periodic <$> Gen.enumBounded) :* (Periodic <$> Gen.enumBounded) :* + Nil)) + (Gen.int $ Range.linear 0 100) ++ + [ applicativeLaws + (Proxy @(Grid '[ Periodic 10, Periodic 11])) + (Gen.int $ Range.linear 0 100) + , aesonLaws + (sequenceA $ + pure @(Grid '[ Periodic 10, Periodic 11]) $ + Gen.int $ Range.linear 0 100) + , eq1Laws (Proxy @(Grid '[ Periodic 10, Periodic 20])) + ]) + ]