{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Data.Grid.Internal.Grid
( Grid(..)
, IsGrid
, Coord
, NestedLists
, generate
, toNestedLists
, fromNestedLists
, fromNestedLists'
, fromList
, fromList'
, (//)
, Neighboring(..)
, joinGrid
, splitGrid
)
where
import Data.Kind
import Data.Grid.Internal.NestedLists
import Data.Grid.Internal.Coord
import Data.Grid.Internal.Pretty
import Data.Distributive
import Data.Functor.Rep
import qualified Data.Vector as V
import Data.Proxy
import GHC.TypeNats as N hiding (Mod)
import Control.Applicative
import Data.Bifunctor
import Data.Maybe
import Data.Singletons.Prelude
import Control.DeepSeq
type family AllC (c :: x -> Constraint) (ts :: [x]) :: Constraint where
AllC c '[] = ()
AllC c (x:xs) = (c x, AllC c xs)
type IsGrid dims =
( AllC KnownNat dims
, SingI dims
, Sizable dims
, Representable (Grid dims)
, Enum (Coord dims)
, Bounded (Coord dims)
, Neighboring dims
)
newtype Grid (dims :: [Nat]) a =
Grid {toVector :: V.Vector a}
deriving (Eq, Functor, Foldable, Traversable, NFData)
instance (PrettyList (NestedLists dims a), IsGrid dims, Show (NestedLists dims a)) => Show (Grid dims a) where
show g = "fromNestedLists \n" ++ (unlines . fmap (" " ++ ) . lines $ prettyList (toNestedLists g))
instance (IsGrid dims, Semigroup a) => Semigroup (Grid dims a) where
(<>) = liftA2 (<>)
instance (IsGrid dims, Monoid a) => Monoid (Grid dims a) where
mempty = pure mempty
instance (IsGrid dims) => Applicative (Grid dims) where
pure a = tabulate (const a)
liftA2 f (Grid v) (Grid u) = Grid $ V.zipWith f v u
instance (IsGrid dims) => Distributive (Grid dims) where
distribute = distributeRep
instance (IsGrid dims) => Representable (Grid dims) where
type Rep (Grid dims) = Coord dims
index (Grid v) c = v V.! fromEnum c
tabulate f = Grid $ V.generate (fromIntegral $ gridSize (Proxy @dims)) (f . toEnum . fromIntegral)
instance (Num n, IsGrid dims) => Num (Grid dims n) where
(+) = liftA2 (+)
(*) = liftA2 (*)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
negate = fmap negate
generate :: forall dims a . (IsGrid dims) => (Int -> a) -> Grid dims a
generate f = Grid $ V.generate (gridSize $ Proxy @dims) f
toNestedLists
:: forall dims a . (IsGrid dims) => Grid dims a -> NestedLists dims a
toNestedLists (Grid v) = nestLists (Proxy @dims) v
fromNestedLists
:: forall dims a
. IsGrid dims
=> NestedLists dims a
-> Maybe (Grid dims a)
fromNestedLists = fromList . unNestLists (Proxy @dims)
fromNestedLists'
:: forall dims a . IsGrid dims => NestedLists dims a -> Grid dims a
fromNestedLists' = fromJust . fromNestedLists
fromList :: forall dims a . (IsGrid dims) => [a] -> Maybe (Grid dims a)
fromList xs =
let v = V.fromList xs
in if V.length v == gridSize (Proxy @dims) then Just $ Grid v else Nothing
fromList' :: forall dims a . (IsGrid dims) => [a] -> Grid dims a
fromList' = fromJust . fromList
(//)
:: forall dims a
. IsGrid dims
=> Grid dims a
-> [(Coord dims , a)]
-> Grid dims a
(Grid v) // xs = Grid (v V.// fmap (first fromEnum) xs)
class Neighboring dims where
neighborCoords :: Grid dims (Coord dims)
instance {-# OVERLAPPING #-} (IsGrid '[n]) => Neighboring '[n] where
neighborCoords = fromList' . fmap (Coord . pure . subtract (numVals `div` 2)) . take numVals $ [0 .. ]
where
numVals = gridSize (Proxy @'[n])
instance (KnownNat n, Neighboring ns) => Neighboring (n:ns) where
neighborCoords = joinGrid (addCoord <$> currentLevelNeighbors)
where
addCoord :: Coord '[n] -> Grid ns (Coord (n : ns) )
addCoord c = appendC c <$> nestedNeighbors
nestedNeighbors :: Grid ns (Coord ns )
nestedNeighbors = neighborCoords
currentLevelNeighbors :: Grid '[n] (Coord '[n] )
currentLevelNeighbors = neighborCoords
joinGrid :: Grid dims (Grid ns a) -> Grid (dims ++ ns) a
joinGrid (Grid v) = Grid (v >>= toVector)
splitGrid :: forall outer inner a from.
( IsGrid from
, IsGrid inner
, IsGrid outer
, NestedLists from a ~ NestedLists outer (NestedLists inner a)
)
=> Grid from a
-> Grid outer (Grid inner a)
splitGrid = fmap fromNestedLists' . fromNestedLists' . toNestedLists