discrete-space-map (empty) → 0

raw patch · 5 files changed

+237/−0 lines, 5 filesdep +basedep +comonaddep +comonads-fdsetup-changed

Dependencies added: base, comonad, comonads-fd, keys, representable-functors, semigroupoids

Files

• Data/DiscreteSpaceMap.hs +97/−0
• Data/DiscreteSpaceMap/Internal.hs +86/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• discrete-space-map.cabal +22/−0

@@ -0,0 +1,97 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}+module Data.DiscreteSpaceMap (Pos(..), Map(..), modify) where++import Control.Comonad+import Control.Comonad.Store.Class+import Data.Key+import Data.Functor.Bind+import Data.Functor.Representable+import Data.Foldable+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable++import Data.DiscreteSpaceMap.Internal++-- | `Map` is a zipper on an infinite perfect binary tree.+--   It contains the position and value of the focus.+--   The other values are stored in the derivative of a perfect binary tree.+--+--   Functions that combine 2 maps like `zipWith`, `zipWithKey` and `<@>` preserve the focus position of the second argument.+data Map p a = Map !p !a (MapD a) deriving Show++-- | Modify the value of the focus.+modify :: (a -> a) -> Map p a -> Map p a+modify m (Map p a f) = Map p (m a) f++type instance Key (Map p) = p++-- | @ `zipWith` :: Pos p => (a -> b -> c) -> Map p a -> Map p b -> Map p c@+instance Pos p => Zip (Map p) where+  zipWith f = zipWithKey (const f)+-- | @ `zipWithKey` :: Pos p => (p -> a -> b -> c) -> Map p a -> Map p b -> Map p c@+instance Pos p => ZipWithKey (Map p) where+  zipWithKey f as bs = Map p (f p a b) $ zipWithKeyD f p ca cb+    where+      Map p b cb = bs+      Map _ a ca = seek p as++-- | @ (`<@>`) :: Pos p => Map p (a -> b) -> Map p a -> Map p b@+instance Pos p => ComonadApply (Map p) where+  (<@>) = zap++-- | @+-- `extract` :: Map p a -> a+-- `extend` :: (Map p a -> b) -> Map p a -> Map p b@+instance Comonad (Map p) where+  extract (Map _ a _) = a+  extend f z@(Map p _ c) = Map p (f z) $ fmap (\a -> f (Map p a c)) c++-- | @+-- `pos` :: Pos p => Map p a -> p+-- `peek` :: Pos p => p -> Map p a -> a+-- `seek` :: Pos p => p -> Map p a -> Map p a+-- `seeks` :: Pos p => (p -> p) -> Map p a -> Map p a@+instance Pos p => ComonadStore p (Map p) where+  pos (Map p _ _) = p+  peek tp (Map sp a c) = fst $ gotoD sp tp (a, c)+  seek tp (Map sp a c) = let (a', c') = gotoD sp tp (a, c) in Map tp a' c'+  seeks f w = seek (f (pos w)) w++-- | @ `index` :: Pos p => Map p a -> p -> a@+instance Pos p => Indexable (Map p) where+  index = flip peek+instance Pos p => Lookup (Map p) where +  lookup = lookupDefault+instance Pos p => Adjustable (Map p) where+  adjust f p z = seek (pos z) . modify f . seek p $ z+-- | @ `tabulate` :: Pos p => (p -> a) -> Map p a@+instance Pos p => Representable (Map p) where+  tabulate f = Map zero (f zero) (tabulateD f)++-- | @ `fmap` :: (a -> b) -> Map p a -> Map p b@+instance Functor (Map p) where+  fmap = fmapDefault  +-- | @ `mapWithKey` :: Pos p => (p -> a -> b) -> Map p a -> Map p b@+instance Pos p => Keyed (Map p) where+  mapWithKey = mapWithKeyDefault+-- | @ `foldMap` :: Monoid m => (a -> m) -> Map p a -> m@+instance Foldable (Map p) where +  foldMap = foldMapDefault+-- | @ `foldMapWithKey` :: (Pos p, Monoid m) => (p -> a -> m) -> Map p a -> m@+instance Pos p => FoldableWithKey (Map p) where+  foldMapWithKey = foldMapWithKeyDefault+instance Foldable1 (Map p) where +  foldMap1 = foldMap1Default+instance Pos p => FoldableWithKey1 (Map p) where+  foldMapWithKey1 = foldMapWithKey1Default+-- | @ `traverse` :: Applicative f => (a -> f b) -> Map p a -> f (Map p b)@+instance Traversable (Map p) where+  traverse f = unwrapApplicative . traverse1 (WrapApplicative . f)+-- | @ `traverseWithKey` :: (Pos p, Applicative f) => (p -> a -> f b) -> Map p a -> f (Map p b)@+instance Pos p => TraversableWithKey (Map p) where+  traverseWithKey f = unwrapApplicative . traverseWithKey1 (\k a -> WrapApplicative (f k a))+instance Traversable1 (Map p) where+  traverse1 f (Map p a c) = Map p <$> f a <.> traverse1 f c+instance Pos p => TraversableWithKey1 (Map p) where+  traverseWithKey1 f (Map p a c) = Map p <$> f p a <.> traverseWithKey1D f p c

@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleInstances #-}+module Data.DiscreteSpaceMap.Internal where++import Data.Functor.Bind+import Data.Foldable+import Data.Traversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable++-- | To be a key in the map, a position needs to be convertible to and from a stream of bits.+class Eq p => Pos p where+  uncons :: p -> (p, Bool)+  cons   :: (p, Bool) -> p+  -- ^ > cons . uncons == id +  zero :: p+  -- ^ > uncons zero == (zero, False)+++-- | 1D discrete space+instance Pos Integer where+  zero = 0+  uncons i = let (d, m) = i `divMod` 2 in (negate d, m == 1)+  cons (i, b) = (if b then 1 else 0) - 2 * i++-- | 2D discrete space+instance Pos p => Pos (p, p) where+  zero = (zero, zero)+  uncons (x, y) = let (x', b) = uncons x in ((y, x'), b)+  cons ((x, y), b) = (cons (y, b), x)++-- | 3D discrete space+instance Pos p => Pos (p, p, p) where+  zero = (zero, zero, zero)+  uncons (x, y, z) = let (x', b) = uncons x in ((y, z, x'), b)+  cons ((x, y, z), b) = (cons (z, b), x, y)++-- | @[Bool]@ is the free instance of `Pos`.+instance Pos [Bool] where+  zero = []+  uncons [] = ([], False)+  uncons (b:bs) = (bs, b)+  cons (bs, b) = b:bs+++data MapD a = MapD a (MapD (a, a)) deriving Show++instance Functor MapD where+  fmap = fmapDefault+instance Foldable MapD where+  foldMap = foldMapDefault+instance Foldable1 MapD where+  foldMap1 = foldMap1Default+instance Traversable MapD where+  traverse f = unwrapApplicative . traverse1 (WrapApplicative . f)+instance Traversable1 MapD where+  traverse1 f (MapD a ca) = MapD <$> f a <.> traverse1 (\(a1, a2) -> (,) <$> f a1 <.> f a2) ca++gotoD :: Pos p => p -> p -> (a, MapD a) -> (a, MapD a)+gotoD sp tp | sp == tp = id+            | otherwise = down tb . gotoD sp' tp' . up sb+  where+    (tp', tb) = uncons tp+    (sp', sb) = uncons sp+    up   False (a, MapD b c) = ((a, b), c)+    up   True  (b, MapD a c) = ((a, b), c)+    down False ((a, b), c) = (a, MapD b c)+    down True  ((a, b), c) = (b, MapD a c)++tabulateD :: Pos p => (p -> a) -> MapD a+tabulateD f = MapD (f (cons (zero, True))) $ tabulateD (\p -> (f (cons (p, False)), f (cons (p, True)))) ++zipWithKeyD :: Pos p => (p -> a -> b -> c) -> p -> MapD a -> MapD b -> MapD c+zipWithKeyD f p (MapD a ca) (MapD b cb) = +  MapD (f pOther a b) (zipWithKeyD f' pUp ca cb)+  where +    (pUp, s) = uncons p+    pOther = cons (pUp, not s)+    f' p' (a1, a2) (b1, b2) = (f (cons (p', False)) a1 b1, f (cons (p', True)) a2 b2)++traverseWithKey1D :: (Pos p, Apply f) => (p -> a -> f b) -> p -> MapD a -> f (MapD b)+traverseWithKey1D f p (MapD a ca) = +  MapD <$> f pOther a <.> traverseWithKey1D f' pUp ca+  where +    (pUp, s) = uncons p+    pOther = cons (pUp, not s)+    f' p' (a1, a2) = (,) <$> f (cons (p', False)) a1 <.> f (cons (p', True)) a2

@@ -0,0 +1,30 @@+Copyright (c) 2013, Sjoerd Visscher++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 Sjoerd Visscher 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,22 @@+name:                discrete-space-map+version:             0+synopsis:            A discrete space map.+description:         A discrete space map implemented as a zipper on an infinite perfect binary tree.+homepage:            https://github.com/sjoerdvisscher/discrete-space-map+license:             BSD3+license-file:        LICENSE+author:              Sjoerd Visscher+maintainer:          sjoerd@w3future.com+category:            Data+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:     Data.DiscreteSpaceMap+  other-modules:       Data.DiscreteSpaceMap.Internal+  build-depends:       base ==4.6.*,+                       comonad ==3.0.*,+                       comonads-fd ==3.0.*,+                       keys ==3.0.*,+                       semigroupoids ==3.0.*, +                       representable-functors ==3.0.*