diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,58 @@ +Copyright © 2016 Jaan Elken +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 the copyright holders nor the names of the + 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 HOLDERS 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. + + +License from incremental-computing-0.0.0.0 package: + +Copyright © 2014, 2015 Denis Firsov, © 2014, 2015 Wolfgang Jeltsch +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 the copyright holders nor the names of the + 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 HOLDERS 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/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/dist/build/map-testsStub/map-testsStub-tmp/map-testsStub.hs b/dist/build/map-testsStub/map-testsStub-tmp/map-testsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/map-testsStub/map-testsStub-tmp/map-testsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import MapTests ( tests ) +main :: IO () +main = stubMain tests diff --git a/incremental-maps.cabal b/incremental-maps.cabal new file mode 100644 --- /dev/null +++ b/incremental-maps.cabal @@ -0,0 +1,101 @@ +Name: incremental-maps +Version: 0.0.0.0 +Synopsis: Package for doing incremental computations on maps +Description: This package is about incremental computing. +Author: Jaan Elken (supervisor Denis Firsov) +Cabal-Version: >= 1.16 +Maintainer: jelken@itcollege.ee +Category: Data +License: BSD3 +License-File: LICENSE +Build-Type: Simple + + +Library + + Build-Depends: base >= 3.0 && < 5, + containers >= 0.1 && < 0.6, + dlist >= 0.7 && < 0.8, + fingertree >= 0.1 && < 0.2, + order-maintenance >= 0.0 && < 0.1, + transformers >= 0.3 && < 0.5 + + Default-Language: Haskell2010 + + Default-Extensions: FlexibleContexts + GeneralizedNewtypeDeriving + RankNTypes + TypeFamilies + TypeOperators + AllowAmbiguousTypes + DeriveGeneric + + + if impl(ghc >= 7.8) { + Default-Extensions: AutoDeriveTypeable + } + + Exposed-Modules: Data.Incremental + Data.Incremental.Tuple + Data.Incremental.Map + Data.Incremental.Set + Data.MultiChange + + + HS-Source-Dirs: src/library + +Test-Suite map-tests + + Type: detailed-0.9 + + Build-Depends: base >= 3.0 && < 5, + Cabal >= 1.16 && < 2, + cabal-test-quickcheck >= 0.1 && < 0.2, + containers >= 0.1 && < 0.6, + QuickCheck == 2.8.2, + incremental-maps == 0.0.0.0 + + Default-Language: Haskell2010 + + Default-Extensions: FlexibleContexts + GeneralizedNewtypeDeriving + StandaloneDeriving + TypeFamilies + TypeOperators + TemplateHaskell + + Other-Extensions: UndecidableInstances + + Test-Module: MapTests + + HS-Source-Dirs: src/test-suites + +Benchmark benchmarks + + Type: exitcode-stdio-1.0 + + Main-Is: MapBenchmarks.hs + + Build-Depends: base >= 3.0 && < 5, + aeson == 0.11.1.0, + QuickCheck == 2.8.2, + criterion == 1.1.1.0, + containers >= 0.1 && < 0.6, + deepseq-generics == 0.2.0.0, + deepseq == 1.4.1.1, + dlist >= 0.7 && < 0.8, + incremental-maps == 0.0.0.0 + + Default-Language: Haskell2010 + + Default-Extensions: FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + StandaloneDeriving + TypeFamilies + TypeOperators + DeriveGeneric + + Other-Extensions: UndecidableInstances + + HS-Source-Dirs: src/benchmarks diff --git a/src/benchmarks/MapBenchmarks.hs b/src/benchmarks/MapBenchmarks.hs new file mode 100644 --- /dev/null +++ b/src/benchmarks/MapBenchmarks.hs @@ -0,0 +1,347 @@ +module Main where + +-- Prelude + +import Prelude hiding (id, (.)) + +-- Control + +import Control.Applicative + +-- Data + +import Data.Foldable (toList) +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple +import qualified Data.Incremental.Map as IncMap + +-- Criterion +import Criterion.Main +import Criterion.Types +import Control.DeepSeq +import GHC.Generics hiding (C) + + +-- Test + +import Test.QuickCheck +import Test.QuickCheck.Poly + +instance Arbitrary a => Arbitrary (PrimitiveChange a) where + + arbitrary = frequency [(1, keepGen), (5, replaceGen)] where + + keepGen = return Keep + + replaceGen = fmap ReplaceBy arbitrary + + shrink Keep = [] + shrink (ReplaceBy val) = Keep : map ReplaceBy (shrink val) + + +instance Arbitrary p => Arbitrary (MultiChange p) where + + arbitrary = fmap MultiChange.singleton arbitrary + + shrink change = map MultiChange.fromList (shrink (toList change)) + + +-- Pair changes +deriving instance (Show (DefaultChange a), Show (DefaultChange b)) => + Show (Tuple.AtomicChange a b) + +instance (Arbitrary (DefaultChange a), Arbitrary (DefaultChange b)) => + Arbitrary (Tuple.AtomicChange a b) where + + arbitrary = oneof [firstGen, secondGen] where + + firstGen = fmap Tuple.First arbitrary + + secondGen = fmap Tuple.Second arbitrary + + shrink (Tuple.First change) = map Tuple.First (shrink change) + shrink (Tuple.Second change) = map Tuple.Second (shrink change) + +-- Map changes +instance (Arbitrary k, Arbitrary (DefaultChange k),Arbitrary v, Arbitrary (DefaultChange v)) => + Arbitrary (IncMap.AtomicChange k v) where + + arbitrary = oneof [delete, insert] where + + delete = liftA IncMap.Delete arbitrary + + insert = liftA2 IncMap.Insert arbitrary arbitrary + + shrink (IncMap.Insert k v) + = [IncMap.Insert k' v' + | (k', v') <- shrink (k, v)] + shrink (IncMap.Delete k) + = [IncMap.Delete k' + | k' <- shrink k] + +newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary, Generic) + +instance Change AtomicAChange where + + type Value AtomicAChange = A + + DoubleAndAdd diff $$ A integer = A (2 * integer + diff) + +instance Changeable A where + + type DefaultChange A = MultiChange AtomicAChange + +deriving instance Ord A + +newtype AtomicBChange = TripleAndAdd Integer deriving (Show, Arbitrary, Generic) + +instance Change AtomicBChange where + + type Value AtomicBChange = B + + TripleAndAdd diff $$ B integer = B (3 * integer + diff) + +instance Changeable B where + + type DefaultChange B = MultiChange AtomicBChange + +deriving instance Ord B + +newtype AtomicCChange = QuadrupleAndAdd Integer deriving (Show, Arbitrary, Generic) + +instance Change AtomicCChange where + + type Value AtomicCChange = C + + QuadrupleAndAdd diff $$ C integer = C (4 * integer + diff) + +instance Changeable C where + + type DefaultChange C = MultiChange AtomicCChange + +deriving instance Ord C + + +instance (NFData a) => NFData (MultiChange a) +instance NFData (Tuple.AtomicChange (Map A B) (Map A B)) +instance NFData (Tuple.AtomicChange A B) +instance (Generic a, Generic b, NFData a, NFData b) => NFData (IncMap.AtomicChange a b) +instance NFData AtomicBChange +instance NFData AtomicAChange +instance NFData A +instance NFData B +instance NFData C + +deriving instance (Generic a, Generic b) => Generic (IncMap.AtomicChange a b) +deriving instance Generic A +deriving instance Generic B +deriving instance Generic C + +applyChanges :: Change p => (Value p, [p]) -> [Value p] +applyChanges (val, changes) = scanl (flip ($$)) val changes + + +testMap r n = do + pairs <- generate $ vectorOf n $ resize r $ arbitrary + let resultMap = Map.fromList pairs + return resultMap + +--testMapSize :: Int -> IO (Int,Int) +--testMapSize n = do +-- pairs <- generate $ vectorOf n $ resize n $ (arbitrary :: Gen (A,B)) +-- let resultMap = Map.fromList pairs +-- let resultMapSize = Map.size resultMap +-- return (n,resultMapSize) + +testChanges r n = do + changes <- generate $ vectorOf n (resize r $ arbitrary) + return changes + +testFun r = do + fun <- generate $ resize r $ arbitrary + return fun + +testKey r = do + key <- generate $ resize r $ arbitrary + return key + +checkTrans trans (val,changes) = applyChanges (runTrans trans (val,changes)) +checkOriginal trans (val,changes) = map trans (applyChanges (val,changes)) + +--benchmarks +main :: IO () +main = + defaultMainWith + (defaultConfig {reportFile = Just "performance.html"}) $ concat [ + map (benchFilter 10) [1000,10000,100000,1000000], + map (benchMap 10) [1000,10000,100000,1000000], + map (benchLookup 10) [1000,10000,100000,1000000], + map (benchMember 10) [1000,10000,100000,1000000], + map (benchPartition 10) [1000,10000,100000,1000000], + map (benchUnion 10) [1000,10000,100000,1000000], + map (benchDifference 10) [1000,10000,100000,1000000], + map (benchIntersection 10) [1000,10000,100000,1000000], + map (benchKeysSet 10) [1000,10000,100000,1000000], + map (benchSubmapOf 10) [1000,10000,100000,1000000], + map (benchSubmapOf 10) [1000,10000,100000,1000000], + map (benchSplit 10) [1000,10000,100000,1000000], + map (benchMapKeys 10) [1000,10000,100000,1000000] + ] + + + +benchFilter ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + tFun <- testFun n :: IO (B -> Bool) + return (testValAndChanges,tFun)) + (\ ~(valAndChanges,fun) -> + bgroup ("filter " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.filter fun)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.filter fun)) (valAndChanges !! x)) [0..ncgh] + ]) +benchMap ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + tFun <- testFun n :: IO (B -> C) + return (testValAndChanges,tFun)) + (\ ~(valAndChanges,fun) -> + bgroup ("map " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.map fun)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.map fun)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchLookup ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + tKey <- testKey n :: IO (A) + return (testValAndChanges,tKey)) + (\ ~(valAndChanges,key) -> + bgroup ("lookup " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.lookup key)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.lookup key)) (valAndChanges !! x)) [0..ncgh] + ]) +benchMember ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + tKey <- testKey n :: IO (A) + return (testValAndChanges,tKey)) + (\ ~(valAndChanges,key) -> + bgroup ("member " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.member key)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.member key)) (valAndChanges !! x)) [0..ncgh] + ]) +benchPartition ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + tFun <- testFun n :: IO (B -> Bool) + return (testValAndChanges,tFun)) + (\ ~(valAndChanges,fun) -> + bgroup ("partition " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.partition fun)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.partition fun)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchUnion ncgh n = env (do + tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap2)) tChangesScan + return testValAndChanges) + (\ ~(valAndChanges) -> + bgroup ("union " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.union)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.union)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchDifference ncgh n = env (do + tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap2)) tChangesScan + return testValAndChanges) + (\ ~(valAndChanges) -> + bgroup ("difference " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.difference)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.difference)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchIntersection ncgh n = env (do + tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap2)) tChangesScan + return testValAndChanges) + (\ ~(valAndChanges) -> + bgroup ("intersection " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.intersection)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.intersection)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchKeysSet ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + return testValAndChanges) + (\ ~(valAndChanges) -> + bgroup ("keysSet " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.keysSet)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.keysSet)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchSubmapOf ncgh n = env (do + tMap1 <- testMap n n :: IO (Map A B) + tMap2 <- testMap n n :: IO (Map A B) + tChanges <- testChanges n ncgh :: IO [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) (tMap1,tMap1)) tChangesScan + return testValAndChanges) + (\ ~(valAndChanges) -> + bgroup ("submapOf " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (uncurry Map.isSubmapOf)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.isSubmapOf)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchSplit ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tKey <- testKey n :: IO (A) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + return (testValAndChanges,tKey)) + (\ ~(valAndChanges,key) -> + bgroup ("split " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.split key)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.split key)) (valAndChanges !! x)) [0..ncgh] + ]) + +benchMapKeys ncgh n = env (do + tMap <- testMap n n :: IO (Map A B) + tFun <- testFun n :: IO (A -> C) + tChanges <- testChanges n ncgh :: IO [MultiChange (IncMap.AtomicChange A B)] + let tChangesScan = scanl (\x y -> x ++ [y]) [] tChanges + let testValAndChanges = zip (replicate (ncgh+1) tMap) tChangesScan + return (testValAndChanges,tFun)) + (\ ~(valAndChanges,fun) -> + bgroup ("mapKeys " ++ show n) $ concat + [map (\x -> bench ("original change=" ++ show x) $ nf (checkOriginal (Map.mapKeys fun)) (valAndChanges !! x)) [0..ncgh], + map (\x -> bench ("incremental change=" ++ show x) $ nf (checkTrans (IncMap.mapKeys fun)) (valAndChanges !! x)) [0..ncgh] + ]) diff --git a/src/library/Data/Incremental.hs b/src/library/Data/Incremental.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/Incremental.hs @@ -0,0 +1,348 @@ +module Data.Incremental ( + + -- * Changes + + Change (Value, ($$)), + PrimitiveChange (Keep, ReplaceBy), + + -- * Transformations + + Trans, + TransProc, + + -- ** Construction + + simpleTrans, + stateTrans, + stTrans, + trans, + + -- ** Deconstruction + + runTrans, + toFunction, + toSTProc, + + -- ** Utilities + + const, + fromFunction, + sanitize, + + -- * Changeables + + Changeable (DefaultChange), + type (->>) + +) where + +-- Prelude + +import Prelude hiding (id, (.), const) +import qualified Prelude + +-- Control + +import Control.Category +import Control.Monad.ST.Lazy +import Control.Monad.ST.Lazy.Unsafe + +-- Data + +import Data.Monoid +import Data.Functor.Identity +import Data.STRef.Lazy + +infixr 0 $$ +infixr 0 ->> + +{-NOTE: + Our policy regarding class constraints with Change and Changeable is as + follows: + + • Global values that are about changes directly and do not use ($$) (which + are almost all of them) should not have Change constraints. Adding all + these change constraints everywhere would give us nothing and only + introduce clutter and possibly performance issues. + + • Global values that are about changeables (which first and foremost + includes all that are about (->>)) should have Changeable constraints, + because this ensures that standard changes are monoids and the value + type of standard changes is the type that we started with. +-} + +-- * Changes + +class Change p where + + type Value p :: * + + -- NOTE: Operator $$ is at least not used in the base library. + ($$) :: p -> Value p -> Value p + +data PrimitiveChange a = Keep | ReplaceBy a deriving (Show, Read) + +instance Functor PrimitiveChange where + + fmap _ Keep = Keep + fmap fun (ReplaceBy val) = ReplaceBy (fun val) + +instance Monoid (PrimitiveChange a) where + + mempty = Keep + + Keep `mappend` change = change + ReplaceBy val `mappend` _ = ReplaceBy val + +instance Change (PrimitiveChange a) where + + type Value (PrimitiveChange a) = a + + Keep $$ val = val + ReplaceBy val $$ _ = val + +-- * Transformations + +newtype Trans p q = Trans ((Value p, [p]) -> (Value q, [q])) + +instance Category Trans where + + id = Trans id + + Trans conv2 . Trans conv1 = Trans (conv2 . conv1) + +type TransProc m p q = Value p -> m (Value q, p -> m q) + +-- ** Construction + +simpleTrans :: (Value p -> Value q) -> (p -> q) -> Trans p q +simpleTrans fun prop = trans (\ cont -> runIdentity (cont transProc)) where + + transProc val = return (fun val, return . prop) + +stateTrans :: (Value p -> (Value q, s)) -> (p -> s -> (q, s)) -> Trans p q +stateTrans init prop = stTrans (\ val -> do + let (val', initState) = init val + stateRef <- newSTRef initState + let stProp change = do + oldState <- readSTRef stateRef + let (change', newState) = prop change oldState + writeSTRef stateRef newState + return change' + return (val', stProp)) + +stTrans :: (forall s . TransProc (ST s) p q) -> Trans p q +stTrans transProc = trans (\ cont -> runST (cont transProc)) + +{-NOTE: + ST with OrderT layers around can be run as follows: + + transNested :: (forall o1 ... on s . + TransProc (OrderT o1 (... (OrderT on (ST s)))) p q) + -> Trans p q + transNested transProc = trans (\ cont -> runST ( + evalOrderT ( + ... ( + evalOrderT (cont transProc))))) +-} + +{-FIXME: + We have to mention in the documentation that the monad is supposed to be + lazy. If it is strict, the constructed transformation trans will (probably) + have the following properties: + + • Reducing any expression runTrans trans valAndChanges to WHNF results in + the initialization being run and the constructed propagator being run on + all the changes. + + • The expression toSTProc trans is a processor that always yields ⊥ as the + output value and constructs propagators that always yield ⊥ as the + output change. +-} +trans :: (forall r . (forall m . Monad m => TransProc m p q -> m r) -> r) + -> Trans p q +trans cpsProcAndRun = errorIfStrictMonad `seq` Trans conv where + + errorIfStrictMonad = cpsProcAndRun $ + Prelude.const (strictMonadError >> return ()) + + strictMonadError = error "Data.Incremental: \ + \Transformation processor uses strict monad" + + conv valAndChanges = cpsProcAndRun $ + \ transProc -> monadicConv transProc valAndChanges + + monadicConv transProc ~(val, changes) = do + ~(val', prop) <- transProc val + changes' <- mapM prop changes + return (val', changes') + +-- ** Deconstruction + +runTrans :: Trans p q -> (Value p, [p]) -> (Value q, [q]) +runTrans (Trans conv) = conv + +toFunction :: Trans p q -> (Value p -> Value q) +toFunction (Trans conv) val = fst (conv (val, undefined)) + +{-FIXME: + We have to mention the following in the documentation: + + The function toSTProc . stTrans is not the identity. A computation in + the original value of type forall s . TransProc (ST s) may yield an + undefined state, but for computations in the constructed value, + undefinedness can only occur in the values they output. + + On the other hand, stTrans . toSTProc is the identity. [At least, it + should be.] +-} +{-FIXME: + It is crucial that toSTProc cannot be called on functions of type + + (Value p, [p]) -> (Value q, [q]) , + + but only on transformations, which correspond only to sensible, in + particular causal, functions. + + Take, for example, the following function: + + \ ~(val, ~(change1 : ~(change2 : rest))) -> (val, change2 : change1 : rest) + + (Maybe, we do not even need to use lazy patterns.) If we would apply a + function like toSTProc to it, and apply runTrans to the result, we would get + a function that is not referentially transparent. Let this function be + called f. Let us proceed as follows: + + let input = (False, [ReplaceBy False, ReplaceBy True]) + let output = f input + let changes' = snd output + let change1' = changes' !! 0 + let change2' = changes' !! 1 + + If we now evaluate change1', we will hit ⊥, because the second input change + has not been written into the channel. However, if we first evaluate + change2' and then change1', then change1' will evaluate to ReplaceBy True. + + This particular problem should not occur with our toSTProc, which only works + with transformations. If a user would reimplement toSTProc such that it + works with arbitrary functions of the above-mentioned type, he would have to + use unsafeInterleaveST directly, where there would be no guarantees anyhow. + + That said, we have to analyze very carefully whether our toSTProc is really + completely safe. Only if it is, we should declare a module that contains it + trustworthy (in the sense of Safe Haskell). We have to take into account + that trans works with arbitrary runnable monad families and an instantiation + of the Monad class could be bogus. The argument that running a + transformation always yields causal functions relies on the assumption that + the output of the first argument of (>>=) cannot depend on data that is only + contained in the second argument of (>>=). Maybe, this assumption can be + broken with a bogus Monad instance. But maybe, parametricity ensures that + this assumption holds. +-} + +toSTProc :: Trans p q -> TransProc (ST s) p q +toSTProc (Trans conv) val = do + (chan, changes) <- newChannel + let (val', changes') = conv (val, changes) + remainderRef <- newSTRef changes' + let prop change = do + writeChannel chan change + next : further <- readSTRef remainderRef + writeSTRef remainderRef further + return next + return (val', prop) + +-- ** Utilities + +const :: Monoid q => Value q -> Trans p q +const val = simpleTrans (Prelude.const val) (Prelude.const mempty) + +fromFunction :: (a -> b) -> Trans (PrimitiveChange a) (PrimitiveChange b) +fromFunction fun = simpleTrans fun (fmap fun) + +sanitize :: Eq a => Trans (PrimitiveChange a) (PrimitiveChange a) +sanitize = stateTrans init prop where + + init val = (val, val) + + prop Keep state = (Keep, state) + prop (ReplaceBy val) state = if val == state + then (Keep, state) + else (ReplaceBy val, val) + +-- * Changeables + +class (Monoid (DefaultChange a), + Change (DefaultChange a), + Value (DefaultChange a) ~ a) => + Changeable a where + + type DefaultChange a :: * + type DefaultChange a = PrimitiveChange a + +instance Changeable Bool + +instance Changeable Int + +{-FIXME: + Add default instance declarations for all remaining Prelude types and + replace them by something more decent if there is something more decent. +-} + +type a ->> b = Trans (DefaultChange a) (DefaultChange b) + +-- * Channels in the ST monad + +data Cell s a = Cell a (CellRef s a) + +type CellRef s a = STRef s (Cell s a) + +type Channel s a = STRef s (CellRef s a) + +newChannel :: ST s (Channel s a, [a]) +newChannel = do + cellRef <- newSTRef undefined + chan <- newSTRef cellRef + let getContents cellRef = unsafeInterleaveST $ do + Cell val cellRef' <- readSTRef cellRef + vals <- getContents cellRef' + return (val : vals) + -- FIXME: Is this use of unsafeInterleaveST safe? + contents <- getContents cellRef + return (chan, contents) + +writeChannel :: Channel s a -> a -> ST s () +writeChannel chan val = do + cellRef <- readSTRef chan + cellRef' <- newSTRef undefined + writeSTRef cellRef (Cell val cellRef') + writeSTRef chan cellRef' + +{-FIXME: + Is there already an implementation of ST channels? +-} + +{-FIXME: + Remove Control.Monad.ST.Lazy.Unsafe from the import list, if the channel + code moves to its own module. +-} + +{-FIXME: + The following things are to be considered: + + • Does our framework correspond to update lenses? How is it related to + update lenses? Look at the slides of Tarmo’s seminar talk from + 11 September 2014. + + • Our work on order maintenance could be turned into a paper. Currently, + one has to read more than one paper to understand the algorithm (Dietz + and Sleator 1987; Willard 1986) and Dietz and Sleator (1987) do not + explain deletion. + + • The incrementalized version of maps cannot allow conversion to sequences + of key–value pairs, but only to sequences of values, because if the map + was created from a sequence and was then converted to a sequence of + key–value pairs, the choice of keys from equivalence classes of keys + would depend on the history of changes to the original sequence, not + just on the current value of the sequence. +-} diff --git a/src/library/Data/Incremental/Map.hs b/src/library/Data/Incremental/Map.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/Incremental/Map.hs @@ -0,0 +1,470 @@ +module Data.Incremental.Map ( + + -- * Changes + + insert, + delete, + id, + + -- * Atomic changes + + AtomicChange (Insert, Delete), + + -- * Transformations + + member, + lookup, + filter, + map, + partition, + union, + difference, + intersection, + isSubmapOf, + keysSet, + split, + mapKeys + +) where + +import Prelude hiding (id, + lookup, + filter, + map) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Maybe (Maybe) +import qualified Data.Maybe as Maybe +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Incremental.Set as IncSet + +-- maps implementation +data AtomicChange k v = Insert k v | Delete k deriving Show + +-- teeme mapi muudetavaks +instance (Ord k) => Changeable (Map k v) where + + type DefaultChange (Map k v) = MultiChange (AtomicChange k v) + +insert :: (Ord k) => k -> v -> DefaultChange (Map k v) +insert k v = MultiChange.singleton (Insert k v) + +delete :: (Ord k) => k -> DefaultChange (Map k v) +delete k = MultiChange.singleton (Delete k) + +id :: (Ord k) => DefaultChange (Map k v) +id = MultiChange.fromList [] + + +instance (Ord k) => Change (AtomicChange k v) where + + type Value (AtomicChange k v) = Map k v + Insert k v $$ m = Map.insert k v m + Delete k $$ m = Map.delete k m + +append :: AtomicChange k v -> MultiChange (AtomicChange k v) -> MultiChange (AtomicChange k v) +append change changes = mappend (MultiChange.singleton change) changes + +-- teeme maybe muudetavaks +instance Changeable (Maybe a) + + +empty :: Map k v +empty = Map.empty + + +singleton :: (Ord k, Changeable k, Changeable v) => (k,v) ->> Map k v +singleton = MultiChange.composeMap $ stateTrans initSingleton propSingleton + +type SingletonState k v = Map k v + +initSingleton :: (Ord k) => (k,v) -> (Map k v,SingletonState k v) +initSingleton (k,v) = (result,state) where + result = Map.singleton k v + state = result + +propSingleton :: (Ord k, Changeable k, Changeable v) => Tuple.AtomicChange k v -> SingletonState k v -> (MultiChange (AtomicChange k v), SingletonState k v) +propSingleton multiChange m = + case multiChange of + (Tuple.First change) -> (mapChange, mapChange $$ m) where + mapChange = MultiChange.fromList [(Delete k),(Insert (change $$ k) v)] + (Tuple.Second change) -> (mapChange, mapChange $$ m) where + mapChange = (insert k (change $$ v)) + where (k,v) = Map.elemAt 0 m + +--member +type MemberState k = k + +member :: (Ord k) => k -> (Map k v) ->> Bool +member k = MultiChange.composeMap $ stateTrans (initMember k) propMember + +initMember :: (Ord k) => k -> Map k v -> (Bool, MemberState k) +initMember k m = (isMember, state) where + isMember = Map.member k m + state = k + +propMember :: (Ord k) => (AtomicChange k v) -> MemberState k -> (PrimitiveChange Bool, MemberState k) +propMember (Insert k v) k' + | k == k' = (ReplaceBy True,k') + | otherwise = (Keep,k') +propMember (Delete k) k' + | k == k' =(ReplaceBy False,k') + | otherwise = (Keep,k') + +--lookup +type LookupState k = k + +lookup :: Ord k => k -> (Map k v) ->> Maybe v +lookup k = MultiChange.composeMap $ stateTrans (initLookup k) propLookup + +initLookup :: (Ord k) => k -> Map k v -> (Maybe v, LookupState k) +initLookup k m = (result, state) + where result = Map.lookup k m + state = k + +propLookup :: Ord k => AtomicChange k v -> LookupState k -> (PrimitiveChange (Maybe v), LookupState k) +propLookup (Insert k v) k' + | k == k' = (ReplaceBy (Just v),k') + | otherwise = (Keep,k') +propLookup (Delete k) k' + | k == k' =(ReplaceBy Nothing,k') + | otherwise = (Keep,k') + + + +--filter +type FilterState v = (v -> Bool) + +filter :: (Ord k) => (v -> Bool) -> Map k v ->> Map k v +filter f = MultiChange.composeMap $ stateTrans (initFilter f) propFilter + +initFilter :: (Ord k) => (v -> Bool) -> Map k v -> (Map k v, FilterState v) +initFilter f m = (result, state) + where result = Map.filter f m + state = f + +propFilter :: (Ord k) => AtomicChange k v -> FilterState v -> (MultiChange (AtomicChange k v), FilterState v) +propFilter (Insert k v) f + | f v = (insert k v, f) + | otherwise = (delete k, f) +propFilter (Delete k) f = (delete k, f) + + +--map +type MapState v a = (v -> a) + +map :: (Ord k) => (v -> a) -> Map k v ->> Map k a +map f = MultiChange.composeMap $ stateTrans (initMap f) propMap + +initMap :: (Ord k) => (v -> a) -> Map k v -> (Map k a, MapState v a) +initMap f m = (result,state) + where result = Map.map f m + state = f + +propMap :: (Ord k) => AtomicChange k v -> MapState v a -> (MultiChange (AtomicChange k a), MapState v a) +propMap (Insert k v) f = (insert k (f v),f) +propMap (Delete k) f = (delete k,f) + + +--partition +type PartitionState v = ((v -> Bool)) + +partition :: (Ord k) => (v -> Bool) -> Map k v ->> (Map k v, Map k v) +partition f = MultiChange.composeMap $ stateTrans (initPartition f) propPartition + +initPartition :: (Ord k) => (v -> Bool) -> Map k v -> ((Map k v, Map k v), PartitionState v) +initPartition f m = (result, state) + where result = Map.partition f m + state = f + +propPartition :: (Ord k) => AtomicChange k v -> PartitionState v -> (MultiChange (Tuple.AtomicChange (Map k v) (Map k v)), PartitionState v) +propPartition mapChange f = + case mapChange of + (Insert k v) + | f v -> (MultiChange.fromList [Tuple.First (insert k v), Tuple.Second (delete k)],f) + | otherwise -> (MultiChange.fromList [Tuple.First (delete k), Tuple.Second (insert k v)],f) + (Delete k) -> (MultiChange.fromList [Tuple.First (delete k), Tuple.Second (delete k)],f) + +--union +type UnionState k v = (Map k v, Map k v) + +union :: (Ord k) => (Map k v, Map k v) ->> Map k v +union = MultiChange.composeMap $ stateTrans initUnion propUnion + +initUnion :: Ord k => (Map k v, Map k v) -> (Map k v, UnionState k v) +initUnion (l,r) = (result, state) + where result = Map.union l r + state = (l,r) + +propUnion :: (Ord k) => (Tuple.AtomicChange (Map k v) (Map k v)) -> UnionState k v -> (MultiChange (AtomicChange k v), UnionState k v) +propUnion multiChange state = + case multiChange of + (Tuple.First changes) -> foldl applyUnionLeft (id,state) changes + (Tuple.Second changes) -> foldl applyUnionRight (id,state) changes + +--hetkel ei näe võimalust neid kokku tõsta, sest need ei ole päris samasugused meetodid, mis tuleneb unioni asümmeetrilisusest. +applyUnionLeft :: Ord k => (MultiChange (AtomicChange k v), UnionState k v) -> AtomicChange k v -> (MultiChange (AtomicChange k v), UnionState k v) +applyUnionLeft (multiChange,(l,r)) change = prop change where + prop (Delete k) + | inFirst && inSecond == False = (append change multiChange, (change $$ l, r)) + | inFirst && inSecond = case secondElem of (Just v) -> (append (Insert k v) multiChange, (change $$ l, r)) + | otherwise = (multiChange, (l, r)) + where secondElem = Map.lookup k r + inFirst = Map.member k l + inSecond = Maybe.isJust secondElem + prop (Insert k v) = (append change multiChange, (change $$ l, r)) + +applyUnionRight :: Ord k => (MultiChange (AtomicChange k v), UnionState k v) -> AtomicChange k v -> (MultiChange (AtomicChange k v), UnionState k v) +applyUnionRight (multiChange,(l,r)) change = prop change where + prop (Delete k) + | inFirst = (multiChange, (l, change $$ r)) + | otherwise = (append change multiChange, (l, change $$ r)) + where inFirst = Map.member k l + prop (Insert k v) + | inFirst = (multiChange, (l, change $$ r)) + | otherwise = (append change multiChange, (l, change $$ r)) + where inFirst = Map.member k l + +--difference +type DifferenceState k v = (Map k v, Map k v) + +difference :: (Ord k) => (Map k v, Map k v) ->> Map k v +difference = MultiChange.composeMap $ stateTrans initDifference propDifference + +initDifference :: Ord k => (Map k v, Map k v) -> (Map k v, DifferenceState k v) +initDifference (l,r) = (result, state) + where result = Map.difference l r + state = (l,r) + +propDifference :: (Ord k) => (Tuple.AtomicChange (Map k v) (Map k v)) -> DifferenceState k v -> (MultiChange (AtomicChange k v), DifferenceState k v) +propDifference multiChange state = + case multiChange of + (Tuple.First changes) -> foldl applyDifferenceLeft (id,state) changes + (Tuple.Second changes) -> foldl applyDifferenceRight (id,state) changes + +applyDifferenceLeft :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), (Map k v, Map k v)) +applyDifferenceLeft (multiChange,(l,r)) change = + case change of + (Insert k v) + | inSecond == False -> (append change multiChange, (change $$ l, r)) + | otherwise -> (multiChange, (change $$ l, r)) + where inSecond = Map.member k r + (Delete k) -> (append change multiChange, (change $$ l, r)) + +applyDifferenceRight :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), (Map k v, Map k v)) +applyDifferenceRight (multiChange,(l,r)) change = + case change of + (Insert k v) + | inFirst -> (append (Delete k) multiChange, (l, change $$ r)) + | otherwise -> (multiChange, (l, change $$ r)) + where inFirst = Map.member k l + (Delete k) -> case Map.lookup k l of + (Just v) -> (append (Insert k v) multiChange, (l, change $$ r)) + Nothing -> (multiChange, (l, change $$ r)) + +--intersection +type IntersectionState k v = (Map k v, Map k v) + +intersection :: (Ord k) => (Map k v, Map k v) ->> Map k v +intersection = MultiChange.composeMap $ stateTrans initIntersection propIntersection + +initIntersection :: Ord k => (Map k v, Map k v) -> (Map k v, IntersectionState k v) +initIntersection (l,r) = (result, state) + where result = Map.intersection l r + state = (l,r) + +propIntersection :: (Ord k) => (Tuple.AtomicChange (Map k v) (Map k v)) -> IntersectionState k v -> (MultiChange (AtomicChange k v), IntersectionState k v) +propIntersection multiChange state = + case multiChange of + (Tuple.First changes) -> foldl applyIntersectionLeft (id,state) changes + (Tuple.Second changes) -> foldl applyIntersectionRight (id,state) changes + +applyIntersectionLeft :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), IntersectionState k v) +applyIntersectionLeft (multiChange,(l,r)) change = + case change of + (Insert k v) + | inSecond -> (append change multiChange, (change $$ l, r)) + | otherwise -> (multiChange, (change $$ l, r)) + where inSecond = Map.member k r + (Delete k) + | inSecond -> (append change multiChange, (change $$ l, r)) + | otherwise -> (multiChange, (change $$ l, r)) + where inSecond = Map.member k r + + +applyIntersectionRight :: Ord k => (MultiChange (AtomicChange k v), (Map k v, Map k v)) -> AtomicChange k v -> (MultiChange (AtomicChange k v), IntersectionState k v) +applyIntersectionRight (multiChange,(l,r)) change = + case change of + (Insert k v) -> + case Map.lookup k l of + (Just v) -> (append (Insert k v) multiChange, (l, change $$ r)) --testimine tuvastas vea mis sai parandatud + Nothing -> (multiChange, (l, change $$ r)) + (Delete k) + | inFirst -> (append change multiChange, (l, change $$ r)) + | otherwise -> (multiChange, (l, change $$ r)) + where inFirst = Map.member k l + +--submap +--state: left, right, difference +--efektiivne ainult sellisel juhul, kui hulgad on piisavalt sarnased +--originaalalgoritmi puhul piisab ühest vastunäitest, et anda vastus False, seega vähim +--keerukus on O(1)! Samas allpoololevas tehakse igal juhul kolm O(log n) keerukusega operatsiooni +type SubmapOfState k v = (Map k v, Map k v, Map k v) + +isSubmapOf :: (Ord k, Eq v) => (Map k v, Map k v) ->> Bool +isSubmapOf = MultiChange.composeMap $ stateTrans initSubmapOf propSubmapOf + +initSubmapOf :: (Ord k, Eq v) => (Map k v, Map k v) -> (Bool, SubmapOfState k v) +initSubmapOf (l,r) = (result, state) + where result = Map.isSubmapOf l r + state = (l, r, Map.differenceWith discardEqualValues l r) + +discardEqualValues :: (Eq a) => (a -> a -> Maybe a) +discardEqualValues a b + | a == b = Nothing + | otherwise = Just a + +propSubmapOf :: (Ord k, Eq v) => (Tuple.AtomicChange (Map k v) (Map k v)) -> SubmapOfState k v -> (PrimitiveChange Bool, SubmapOfState k v) +propSubmapOf multiChange state = + case multiChange of + (Tuple.First changes) -> foldl applySubmapOfLeft (Keep,state) changes + (Tuple.Second changes) -> foldl applySubmapOfRight (Keep,state) changes + +applySubmapOfLeft :: (Ord k, Eq v) => (PrimitiveChange Bool, SubmapOfState k v) -> AtomicChange k v -> (PrimitiveChange Bool, SubmapOfState k v ) +applySubmapOfLeft (boolChange,(l,r,lrDiff)) change = prop change where + prop (Insert k v) = right k v (Map.lookup k r) where + right k v (Just v') = if (v == v') + then (mappend (Keep) boolChange, (insert k v $$ l, r, delete k $$ lrDiff)) + else (mappend (ReplaceBy False) boolChange, (insert k v $$ l, r, insert k v $$ lrDiff)) + right k v (Nothing) = (mappend (ReplaceBy False) boolChange, (insert k v $$ l, r, insert k v $$ lrDiff)) + prop (Delete k) = diff k (Map.lookup k lrDiff) where + diff k (Just _) = if (length lrDiff == 1) + then (mappend (ReplaceBy True) boolChange, (delete k $$ l, r, delete k $$ lrDiff)) + else (mappend Keep boolChange, (delete k $$ l, r, delete k $$ lrDiff)) + diff k (Nothing) = (mappend Keep boolChange, (delete k $$ l, r, delete k $$ lrDiff)) + +applySubmapOfRight :: (Ord k, Eq v) => (PrimitiveChange Bool, SubmapOfState k v) -> AtomicChange k v -> (PrimitiveChange Bool, SubmapOfState k v ) +applySubmapOfRight (boolChange,(l,r,lrDiff)) change = prop change where + prop (Insert k v) = diff k v (Map.lookup k lrDiff) where + diff k v (Just v') = if (v == v' && length lrDiff == 1) then (mappend (ReplaceBy True) boolChange, (l,insert k v' $$ r, delete k $$ lrDiff)) + else if (v == v') then (mappend (Keep) boolChange, (l,insert k v $$ r, delete k $$ lrDiff)) + else (mappend Keep boolChange, (l, insert k v $$ r, lrDiff)) + diff k v (Nothing) = left k v (Map.lookup k l) where + left k v (Just v') = if (v == v') then (mappend Keep boolChange, (l, insert k v $$ r, lrDiff)) + else (mappend (ReplaceBy False) boolChange, (l, insert k v $$ r, insert k v' $$ lrDiff)) + left k v (Nothing) = (mappend Keep boolChange, (l, insert k v $$ r, lrDiff)) + prop (Delete k) = left k (Map.lookup k l) where + left k (Just v') = (mappend (ReplaceBy False) boolChange, (l, delete k $$ r, insert k v' $$ lrDiff)) + left k (Nothing) = (mappend (Keep) boolChange, (l, delete k $$ r, lrDiff)) + + +--kas siin võiks kasutada (Map k ()) ? Aga sellisel juhul ei oleks väljund võrreldav Data.Map omaga +--keysset +keysSet :: (Ord k) => Map k v ->> (Set k) +keysSet = MultiChange.bind $ simpleTrans initKeysSet propKeysSet + +initKeysSet :: (Ord k) => Map k v -> (Set k) +initKeysSet m = Map.keysSet m + +propKeysSet :: (Ord k) => AtomicChange k v -> MultiChange (IncSet.AtomicChange k) +propKeysSet mapChange = + case mapChange of + (Insert k v) -> MultiChange.singleton (IncSet.Insert k) + (Delete k) -> MultiChange.singleton (IncSet.Delete k) + +--split +--O(logn ) -> O(log n), mõttetu +type SplitState k = k + +split :: (Ord k) => k -> Map k v ->> (Map k v, Map k v) +split k = MultiChange.composeMap $ stateTrans (initSplit k) propSplit + +initSplit :: (Ord k) => k -> Map k v -> ((Map k v, Map k v), SplitState k) +initSplit k m = (result,state) + where result = Map.split k m + state = k + +propSplit :: (Ord k) => AtomicChange k v -> SplitState k -> (MultiChange (Tuple.AtomicChange (Map k v) (Map k v)), SplitState k) +propSplit change state = + case change of + (Insert k v) + | k < state -> (MultiChange.fromList [Tuple.First (insert k v)], state) + | k > state -> (MultiChange.fromList [Tuple.Second (insert k v)], state) + | otherwise -> (MultiChange.fromList [], state) + (Delete k) + | k < state -> (MultiChange.fromList [Tuple.First (delete k)], state) + | k > state -> (MultiChange.fromList [Tuple.Second (delete k)], state) + | otherwise -> (MultiChange.fromList [], state) + + +--mapkeys +--values of the new keys are collapsed +--to the value of largest key (before f is applied) +type MapKeysState a b v = ((a -> b), Map b (Map a v)) + +mapKeys :: (Ord a, Ord b) => (a -> b) -> Map a v ->> Map b v +mapKeys fun = MultiChange.composeMap $ stateTrans (initMapKeys fun) propMapKeys + +initMapKeys :: (Ord a, Ord b) => (a -> b) -> Map a v -> (Map b v, MapKeysState a b v) +initMapKeys fun m = (result,state) where + result = Map.mapKeys fun m + state = (fun, (Map.foldrWithKey (groupKeys fun) Map.empty m)) + +--creates a map of keys and list of values +groupKeys :: (Ord a, Ord b) => (a -> b) -> a -> v -> Map b (Map a v) -> Map b (Map a v) +groupKeys fun key value bMap = + let fKey = fun key + entry = Map.lookup fKey bMap + addTo Nothing = Map.insert fKey (Map.singleton key value) bMap + addTo (Just aMap) = Map.insert fKey (Map.insert key value aMap) bMap + in (addTo entry) + +propMapKeys :: (Ord a, Ord b) => AtomicChange a v -> MapKeysState a b v -> (MultiChange (AtomicChange b v), MapKeysState a b v) +propMapKeys change state = prop change state where + prop (Insert k v) (f,bMap) = (chg', (f,bMap')) where + bMap' = updateBmap $ Map.lookup (f k) bMap + chg' = chg $ initVal $ Map.lookup (f k) bMap' + updateBmap Nothing = Map.insert (f k) (Map.singleton k v) bMap + updateBmap (Just aMap) = Map.insert (f k) (Map.insert k v aMap) bMap + chg Nothing = insert (f k) v + chg (Just (_,v')) = insert (f k) v' + initVal (Nothing) = Nothing + initVal (Just m) = if (length m > 0) + then Just (Map.findMax m) + else Nothing + --NOTE have to make sure, that the order of evaluation is correct + --this can be achieved, by giving bMap' as an argument to chg' + + --loogika: + --1. uuendan bMap + --2. otsin uue key järgi bMapist kõiki vanu vasteid + --3. kui ei ole, siis võib teha chg Delete + --4. kui on, siis tuleb teha suurimale vanale vastele Insert + prop (Delete k) (f,bMap) = (chg', (f,bMap')) where + bMap' = updateBmap $ Map.lookup (f k) bMap + chg' = chg $ initVal $ Map.lookup (f k) bMap' + updateBmap Nothing = bMap + updateBmap (Just aMap) = Map.insert (f k) (Map.delete k aMap) bMap + chg Nothing = delete (f k) + chg (Just (k',v')) = insert (f k) v' + initVal (Nothing) = Nothing + initVal (Just m) = if (length m > 0) + then Just (Map.findMax m) + else Nothing + --loogika: + --1. uuendan bMap + --2. otsin uue key järgi bMapist kõiki vanu vasteid + --3. kui ei ole, siis võib teha chg Delete + --4. kui on, siis tuleb teha suurimale vanale vastele Insert + + + + + diff --git a/src/library/Data/Incremental/Set.hs b/src/library/Data/Incremental/Set.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/Incremental/Set.hs @@ -0,0 +1,34 @@ +module Data.Incremental.Set ( + AtomicChange (Delete, Insert) +) where + + +-- Data + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Monoid (Monoid (mempty, mappend)) +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Incremental + +-- Benchmarking + +import GHC.Generics + +-- * Changes + +instance (Ord k) => Changeable (Set k) where + + type DefaultChange (Set k) = MultiChange (AtomicChange k) + +-- * Atomic changes + +data AtomicChange k = Delete k | Insert k deriving (Show,Generic) + +instance (Ord k) => Change (AtomicChange k) where + + type Value (AtomicChange k) = Set k + + Delete k $$ seq = Set.delete k seq + Insert k $$ seq = Set.insert k seq diff --git a/src/library/Data/Incremental/Tuple.hs b/src/library/Data/Incremental/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/Incremental/Tuple.hs @@ -0,0 +1,96 @@ +module Data.Incremental.Tuple ( + + {-NOTE: + We would have liked to re-export (,), like we re-export Seq from + Data.Incremental.Sequence. However, we could not find a way to + re-export (,). + -} + + -- * Changes + + first, + second, + + -- * Atomic changes + + AtomicChange (First, Second), + + -- * Transformations + + (&&&), + fst, + snd, + swap + +) where + +-- Prelude + +import Prelude hiding (fst, snd) +import qualified Prelude + +-- Data + +import Data.Monoid (Monoid (mempty, mappend)) +import qualified Data.Tuple as Tuple +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Incremental + +-- Benchmarking + +import GHC.Generics + +-- * Changes + +instance (Changeable a, Changeable b) => Changeable (a, b) where + type DefaultChange (a, b) = MultiChange (AtomicChange a b) + +first :: DefaultChange a -> DefaultChange (a, b) +first = MultiChange.singleton . First + +second :: DefaultChange b -> DefaultChange (a, b) +second = MultiChange.singleton . Second + +-- * Atomic changes + +data AtomicChange a b = First (DefaultChange a) | Second (DefaultChange b) deriving Generic + +instance (Changeable a, Changeable b) => Change (AtomicChange a b) where + + type Value (AtomicChange a b) = (a, b) + + First change $$ (val1, val2) = (change $$ val1, val2) + Second change $$ (val1, val2) = (val1, change $$ val2) + + +-- * Transformations + +(&&&) :: (Changeable a, Changeable b, Changeable c) => + (a ->> b) -> (a ->> c) -> (a ->> (b, c)) +trans1 &&& trans2 = stTrans (\ val -> do + ~(val1, prop1) <- toSTProc trans1 val + ~(val2, prop2) <- toSTProc trans2 val + let prop change = do + change1 <- prop1 change + change2 <- prop2 change + return (first change1 `mappend` second change2) + return ((val1, val2), prop)) + +fst :: (Changeable a, Changeable b) => (a, b) ->> a +fst = MultiChange.composeMap $ simpleTrans Prelude.fst prop where + + prop (First change) = change + prop (Second _) = mempty + +snd :: (Changeable a, Changeable b) => (a, b) ->> b +snd = MultiChange.composeMap $ simpleTrans Prelude.snd prop where + + prop (First _) = mempty + prop (Second change) = change + +swap :: (Changeable a, Changeable b) => (a, b) ->> (b, a) +swap = MultiChange.map $ simpleTrans Tuple.swap prop where + + prop (First change) = Second change + prop (Second change) = First change diff --git a/src/library/Data/MultiChange.hs b/src/library/Data/MultiChange.hs new file mode 100644 --- /dev/null +++ b/src/library/Data/MultiChange.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Data.MultiChange ( + + -- * Type + + MultiChange, + + -- * Construction + + singleton, + fromList, + + -- * Monad structure + + map, + return, + join, + bind, + + -- * Multi composition + + compose, + composeMap + +) where + +-- Prelude + +import Prelude hiding (id, (.), map, return) +import qualified Prelude +{-FIXME: + After establishment of the Applicative–Monad proposal, we have to optionally + hide join. +-} + +-- Control + +import Control.Category +import Control.Arrow (second) +import Control.Monad (liftM) + +-- Data + +import Data.Monoid +import Data.Foldable as Foldable +import qualified Data.List as List +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Incremental + +-- Benchmarking + +import GHC.Generics + +-- * Type + +newtype MultiChange p = MultiChange (Dual (DList p)) deriving (Monoid, Generic) + +instance Show p => Show (MultiChange p) where + + showsPrec prec xs = showParen (prec > 10) $ + showString "fromList " . shows (toList xs) + -- NOTE: This is basically taken from Data.Sequence. + +instance Read p => Read (MultiChange p) where + + readsPrec prec = readParen (prec > 10) $ \ str -> do + ("fromList", rest) <- lex str + (list, rest') <- reads rest + Prelude.return (fromList list, rest') + -- NOTE: This is basically taken from Data.Sequence. + +instance Foldable MultiChange where + + foldMap fun (MultiChange (Dual dList)) = foldMap fun dList + + foldr next init (MultiChange (Dual dList)) = Foldable.foldr next init dList + +instance Change p => Change (MultiChange p) where + + type Value (MultiChange p) = Value p + + change $$ val = List.foldl' (flip ($$)) val (toList change) + +-- * Construction + +singleton :: p -> MultiChange p +singleton = MultiChange . Dual . DList.singleton + +{-NOTE: + The lists are “in diagramatic order” (first atomic change at the beginning). +-} + +fromList :: [p] -> MultiChange p +fromList = MultiChange . Dual . DList.fromList + +-- * Monad structure + +map :: Trans p q -> Trans (MultiChange p) (MultiChange q) +map trans = stTrans (\ val -> do + ~(val', prop) <- toSTProc trans val + let multiProp change = do + atomics' <- mapM prop (toList change) + Prelude.return (fromList atomics') + Prelude.return (val', multiProp)) + +return :: Trans p (MultiChange p) +return = simpleTrans id singleton + +join :: Trans (MultiChange (MultiChange p)) (MultiChange p) +join = compose + +bind :: Trans p (MultiChange q) -> Trans (MultiChange p) (MultiChange q) +bind = composeMap + +-- * Multi composition + +compose :: Monoid p => Trans (MultiChange p) p +compose = simpleTrans id (mconcat . reverse . toList) +{-FIXME: + Check whether the use of mconcat . reverse is questionable regarding space + usage or strictness. If it is, consider using foldr (flip mappend) mempty + instead. +-} + +composeMap :: Monoid q => Trans p q -> Trans (MultiChange p) q +composeMap trans = compose . map trans diff --git a/src/test-suites/MapTests.hs b/src/test-suites/MapTests.hs new file mode 100644 --- /dev/null +++ b/src/test-suites/MapTests.hs @@ -0,0 +1,194 @@ +module MapTests where + +-- Prelude + +import Prelude hiding (id, (.)) + +-- Control + +import Control.Category +import Control.Applicative + +-- Data + +import Data.Foldable (toList) +import Data.MultiChange (MultiChange) +import qualified Data.MultiChange as MultiChange +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Incremental +import qualified Data.Incremental.Tuple as Tuple +import qualified Data.Incremental.Map as IncMap + +import Test.QuickCheck.Function +import Distribution.TestSuite.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Poly + +instance Arbitrary a => Arbitrary (PrimitiveChange a) where + + arbitrary = frequency [(1, keepGen), (5, replaceGen)] where + + keepGen = return Keep + + replaceGen = fmap ReplaceBy arbitrary + + shrink Keep = [] + shrink (ReplaceBy val) = Keep : map ReplaceBy (shrink val) + +instance Arbitrary p => Arbitrary (MultiChange p) where + + arbitrary = fmap MultiChange.fromList arbitrary + + shrink change = map MultiChange.fromList (shrink (toList change)) + +-- Pair changes +deriving instance (Show (DefaultChange a), Show (DefaultChange b)) => + Show (Tuple.AtomicChange a b) + +instance (Arbitrary (DefaultChange a), Arbitrary (DefaultChange b)) => + Arbitrary (Tuple.AtomicChange a b) where + + arbitrary = oneof [firstGen, secondGen] where + + firstGen = fmap Tuple.First arbitrary + + secondGen = fmap Tuple.Second arbitrary + + shrink (Tuple.First change) = map Tuple.First (shrink change) + shrink (Tuple.Second change) = map Tuple.Second (shrink change) + +-- Map changes +instance (Arbitrary k, Arbitrary v) => + Arbitrary (IncMap.AtomicChange k v) where + + arbitrary = oneof [delete, insert] where + + insert = liftA2 IncMap.Insert arbitrary arbitrary + + delete = liftA IncMap.Delete arbitrary + + shrink (IncMap.Insert k v) + = [IncMap.Insert k' v' + | (k', v') <- shrink (k, v)] + shrink (IncMap.Delete k) + = [IncMap.Delete k' + | k' <- shrink k] + +newtype AtomicAChange = DoubleAndAdd Integer deriving (Show, Arbitrary) + +instance Change AtomicAChange where + + type Value AtomicAChange = A + + DoubleAndAdd diff $$ A integer = A (2 * integer + diff) + +deriving instance Ord A + +newtype AtomicBChange = TripleAndAdd Integer deriving (Show, Arbitrary) + +instance Change AtomicBChange where + + type Value AtomicBChange = B + + TripleAndAdd diff $$ B integer = B (3 * integer + diff) + +deriving instance Ord B + +newtype AtomicCChange = QuadrupleAndAdd Integer deriving (Show, Arbitrary) + +instance Change AtomicCChange where + + type Value AtomicCChange = C + + QuadrupleAndAdd diff $$ C integer = C (4 * integer + diff) + +deriving instance Ord C + +-- * Tests +prop_lookupTest :: A -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_lookupTest k valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.lookup k) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.lookup k) valAndChanges + +prop_memberTest :: A -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_memberTest k valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.member k) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.member k) valAndChanges + +prop_filterTest :: Fun B Bool -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_filterTest fun valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.filter f) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.filter f) valAndChanges + f = apply fun + +prop_mapTest :: Fun B C -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_mapTest fun valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.map f) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.map f) valAndChanges + f = apply fun + +prop_partitionTest :: Fun B Bool -> (Map A B, [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_partitionTest fun valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.partition f) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.partition f) valAndChanges + f = apply fun + +prop_unionTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool +prop_unionTest valAndChanges = prop valAndChanges where + prop valAndChanges = map (uncurry Map.union) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.union) valAndChanges + +prop_differenceTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool +prop_differenceTest valAndChanges = prop valAndChanges where + prop valAndChanges = map (uncurry Map.difference) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.difference) valAndChanges + +prop_intersectionTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool +prop_intersectionTest valAndChanges = prop valAndChanges where + prop valAndChanges = map (uncurry Map.intersection) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.intersection) valAndChanges + +prop_keysSetTest :: ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_keysSetTest valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.keysSet) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.keysSet) valAndChanges + +prop_submapOfTest :: ((Map A B,Map A B), [MultiChange (Tuple.AtomicChange (Map A B) (Map A B))]) -> Bool +prop_submapOfTest valAndChanges = prop valAndChanges where + prop valAndChanges = map (uncurry Map.isSubmapOf) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.isSubmapOf) valAndChanges + +prop_splitTest :: A -> ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_splitTest key valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.split key) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = runTrans (IncMap.split key) valAndChanges + +prop_mapKeysTest :: Fun A C -> ((Map A B), [MultiChange (IncMap.AtomicChange A B)]) -> Bool +prop_mapKeysTest fun valAndChanges = prop valAndChanges where + prop valAndChanges = map (Map.mapKeys f) (applyChanges valAndChanges) == applyChanges valAndChanges' where + valAndChanges' = (runTrans (IncMap.mapKeys f) valAndChanges) + f = apply fun + +applyChanges :: (Change p) => (Value p, [p]) -> [Value p] +applyChanges (val, changes) = scanl (flip ($$)) val changes + + +tests :: IO [Test] +tests = return + [ + testProperty "lookup" prop_lookupTest + , testProperty "member" prop_memberTest + , testProperty "filter" prop_filterTest + , testProperty "map" prop_mapTest + , testProperty "partition" prop_partitionTest + , testProperty "union" prop_unionTest + , testProperty "difference" prop_differenceTest + , testProperty "intersection" prop_intersectionTest + , testProperty "keysSet" prop_keysSetTest + , testProperty "isSubmapOf" prop_submapOfTest + , testProperty "split" prop_splitTest + , testProperty "mapKeys" prop_mapKeysTest + ] + +