diff --git a/dist/build/testsStub/testsStub-tmp/testsStub.hs b/dist/build/testsStub/testsStub-tmp/testsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/testsStub/testsStub-tmp/testsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import TestSuite ( tests ) +main :: IO () +main = stubMain tests diff --git a/order-maintenance.cabal b/order-maintenance.cabal --- a/order-maintenance.cabal +++ b/order-maintenance.cabal @@ -1,5 +1,5 @@ Name: order-maintenance -Version: 0.0.0.0 +Version: 0.0.1.0 Cabal-Version: >= 1.16 Build-Type: Simple License: BSD3 @@ -9,12 +9,12 @@ Maintainer: wolfgang@cs.ioc.ee Stability: provisional Homepage: http://darcs.wolfgang.jeltsch.info/haskell/order-maintenance -Package-URL: http://hackage.haskell.org/packages/archive/order-maintenance/0.0.0.0/order-maintenance-0.0.0.0.tar.gz +Package-URL: http://hackage.haskell.org/packages/archive/order-maintenance/0.0.1.0/order-maintenance-0.0.1.0.tar.gz Synopsis: Algorithms for the order maintenance problem with a safe interface Description: This package is about order maintenance. Category: Data -Tested-With: GHC == 7.8.3 +Tested-With: GHC == 7.10.1 Source-Repository head @@ -25,7 +25,7 @@ Type: darcs Location: http://darcs.wolfgang.jeltsch.info/haskell/order-maintenance/main - Tag: order-maintenance-0.0.0.0 + Tag: order-maintenance-0.0.1.0 Library @@ -42,18 +42,33 @@ RankNTypes TypeFamilies - if impl(ghc >= 7.8) { - Default-Extensions: AutoDeriveTypeable - } - Exposed-Modules: Control.Monad.Trans.Order Control.Monad.Trans.Order.Algorithm Control.Monad.Trans.Order.Lazy + Control.Monad.Trans.Order.Raw Control.Monad.Trans.Order.Strict - Other-Modules: Control.Monad.Trans.Order.Algorithm.Dumb + Other-Modules: Control.Monad.Trans.Order.Algorithm.DietzSleatorAmortizedLog + Control.Monad.Trans.Order.Algorithm.Dumb Control.Monad.Trans.Order.Algorithm.Type Control.Monad.Trans.Order.Lazy.Internals - Control.Monad.Trans.Order.Raw - HS-Source-Dirs: src + HS-Source-Dirs: src/library + +Test-Suite tests + + Type: detailed-0.9 + + Build-Depends: base >= 3.0 && < 5, + Cabal >= 1.16 && < 2, + cabal-test-quickcheck >= 0.1 && < 0.2, + containers >= 0.5 && < 0.6, + QuickCheck >= 2.6 && < 3, + transformers >= 0.3 && < 0.5, + order-maintenance == 0.0.1.0 + + Default-Language: Haskell2010 + + Test-Module: TestSuite + + HS-Source-Dirs: src/test-suites diff --git a/src/Control/Monad/Trans/Order.hs b/src/Control/Monad/Trans/Order.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Control.Monad.Trans.Order ( - - module Control.Monad.Trans.Order.Lazy - -) where - -import Control.Monad.Trans.Order.Lazy diff --git a/src/Control/Monad/Trans/Order/Algorithm.hs b/src/Control/Monad/Trans/Order/Algorithm.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order/Algorithm.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Control.Monad.Trans.Order.Algorithm ( - - -- * General things - - Algorithm, - defaultAlgorithm, - - -- * Specific algorithms - - dumb - -) where - -import Control.Monad.Trans.Order.Algorithm.Type -import Control.Monad.Trans.Order.Algorithm.Dumb as Dumb - -{-FIXME: - Implement the following: - - • an algorithm that uses arbitarily deep log-trees - - • the file maintenance algorithm by Bender et al. combined with log-trees - of fixed height - - • a function that converts any algorithm into one that shifts elements - between two orders upon deletion (for avoiding sparsly populated order - structures) - - Maybe it makes sense to additionally offer the file maintenance algorithm by - Bender et al. as an order maintenance algorithm in its own right. --} - -{-FIXME: - For implementing Bender et al., it might be good to store the calibrator - tree in an array, level by level from top to bottom. The array must then be - created without initializing its elements. Initially the tree would be - small; so few array elements would be used. When extending the tree, we - would face the problem that initializing all the additionally used elements - would take more than O(1) time. We can maybe use the trick by Barak A. - Pearlmutter¹ (or a variant of it, specialized for our particular - initialization pattern) to get O(1) time. - - ¹ See his e-mail to me from 5 December 2014. --} - -{-FIXME: - More notes regarding implementing Bender et al.: - - • We can store the set of all children of a single node of a log-tree in - an array of 48 64-bit words. Each word represents one child. Children - are stored in the temporal order of their allocation. 48 bits of a word - are the label, 3 are the left sibling index, 3 are the right sibling - index. The parent pointer (pointer to the array plus index in the array) - has to be stored only once per such an array, not for every child. - - • A block in the file maintenance data structure could encompass 48 or - maybe also 64 elements. A 64-bit word could be used to store which of - the array cells are taken by an element and which are free. - - • I think that on the upper two levels of a log tree, we need up to three - times as many nodes for storing log-many subtrees, because of overflow - nodes. This would mean that with the above approach, we could store up - to 48 × 12 × 12 ≈ 7000 elements in a log tree and ca. 7000 × 48 ≈ 350000 - actual elements per file maintenance block. The total memory use would - be a bit more than 8 × 350000 = 2.8 MB. - - • The number of actual elements per file maintenance block (350,000) would - be a bit more than 2^18. Since our k would be 48, we could have up to - 2^48 × 2^18 = 2^66 elements theoretically. So we could reach the maximum - of 2^64 elements. --} - --- * General things - --- NOTE: Algorithm is imported from Data.OrderMaintenance.Algorithm.Type. - -defaultAlgorithm :: Algorithm -defaultAlgorithm = dumb - --- * Specific algorithms - -dumb :: Algorithm -dumb = Dumb.algorithm diff --git a/src/Control/Monad/Trans/Order/Algorithm/Dumb.hs b/src/Control/Monad/Trans/Order/Algorithm/Dumb.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order/Algorithm/Dumb.hs +++ /dev/null @@ -1,100 +0,0 @@ -module Control.Monad.Trans.Order.Algorithm.Dumb ( - - algorithm - -) where - --- Control - -import Control.Applicative -import Control.Monad.ST - --- Data - -import Data.Function -import Data.Ratio -import Data.STRef -import qualified Data.Set as Set -import Data.Set (Set) -import Control.Monad.Trans.Order.Algorithm.Type -import Control.Monad.Trans.Order.Raw - -algorithm :: Algorithm -algorithm = Algorithm rawAlgorithm - -data Dumb - -type instance OrderCell Dumb s = PureOrder - -type instance ElementCell Dumb s = PureElement - -type PureOrder = Set PureElement - -type PureElement = Rational - -rawAlgorithm :: RawAlgorithm Dumb s -rawAlgorithm = RawAlgorithm { - newOrder = newSTRef Set.empty, - compareElements = liftA2 compare `on` readSTRef, - insertMinimum = fromPureInsert pureInsertMinimum, - insertMaximum = fromPureInsert pureInsertMaximum, - insertAfter = relative fromPureInsert pureInsertAfter, - insertBefore = relative fromPureInsert pureInsertBefore, - delete = relative fromPure pureDelete -} - -fromPure :: (PureOrder -> (a, PureOrder)) -> RawOrder Dumb s -> ST s a -fromPure trans rawOrder = do - pureOrder <- readSTRef rawOrder - let (output, pureOrder') = trans pureOrder - writeSTRef rawOrder pureOrder' - return output - -fromPureInsert :: (PureOrder -> PureElement) - -> RawOrder Dumb s - -> ST s (RawElement Dumb s) -fromPureInsert trans rawOrder = fromPure trans' rawOrder >>= newSTRef where - - trans' pureOrder = let - - pureElement = trans pureOrder - - in (pureElement, Set.insert pureElement pureOrder) - -relative :: ((PureOrder -> a) -> RawOrder Dumb s -> ST s b) - -> (PureElement -> PureOrder -> a) - -> RawElement Dumb s - -> RawOrder Dumb s - -> ST s b -relative conv trans rawElem rawOrder = do - pureElem <- readSTRef rawElem - conv (trans pureElem) rawOrder - -pureInsertMinimum :: PureOrder -> PureElement -pureInsertMinimum pureOrder - | Set.null pureOrder = 1 % 2 - | otherwise = Set.findMin pureOrder / 2 - -pureInsertMaximum :: PureOrder -> PureElement -pureInsertMaximum pureOrder - | Set.null pureOrder = 1 % 2 - | otherwise = (Set.findMax pureOrder + 1) / 2 - -pureInsertAfter :: PureElement -> PureOrder -> PureElement -pureInsertAfter pureElement pureOrder = pureElement' where - - greater = snd (Set.split pureElement pureOrder) - - pureElement' | Set.null greater = (pureElement + 1) / 2 - | otherwise = (pureElement + Set.findMin greater) / 2 - -pureInsertBefore :: PureElement -> PureOrder -> PureElement -pureInsertBefore pureElement pureOrder = pureElement' where - - lesser = fst (Set.split pureElement pureOrder) - - pureElement' | Set.null lesser = pureElement / 2 - | otherwise = (pureElement + Set.findMax lesser) / 2 - -pureDelete :: PureElement -> PureOrder -> ((), PureOrder) -pureDelete pureElement pureOrder = ((), Set.delete pureElement pureOrder) diff --git a/src/Control/Monad/Trans/Order/Algorithm/Type.hs b/src/Control/Monad/Trans/Order/Algorithm/Type.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order/Algorithm/Type.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Control.Monad.Trans.Order.Algorithm.Type ( - - Algorithm (Algorithm) - -) where - -import Control.Monad.Trans.Order.Raw - -data Algorithm = forall o . Algorithm (forall s . RawAlgorithm o s) diff --git a/src/Control/Monad/Trans/Order/Lazy.hs b/src/Control/Monad/Trans/Order/Lazy.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order/Lazy.hs +++ /dev/null @@ -1,148 +0,0 @@ -module Control.Monad.Trans.Order.Lazy ( - - -- * The Order monad - - Order, - evalOrder, - evalOrderWith, - - -- * The OrderT monad transformer - - OrderT, - evalOrderT, - force, - - -- * Elements - - Element, - newMinimum, - newMaximum, - newAfter, - newBefore - -) where - --- Control - -import Control.Monad.ST -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Order.Raw -import Control.Monad.Trans.Order.Lazy.Internals -import Control.Monad.Trans.Order.Algorithm -import Control.Monad.Trans.Order.Algorithm.Type - --- Data - -import Data.Functor.Identity -import Data.IORef - --- System - -import System.IO.Unsafe - --- GHC - -import GHC.IORef -- for converting from STRef RealWorld to IORef - -{-FIXME: - Introduce conversions between the lazy and the strict variant, similar to - the conversions for ST. --} -{-FIXME: - Consider introducing a restricted variant of mapStateT (for the lazy and the - strict OrderT monad): - - mapOrderT :: (forall a . m a -> n a) -> OrderT o m a -> OrderT o n a - - Maybe this should not be called mapOrderT, since it is only a restricted - variant and a corresponding mapOrder would be trivial. --} -{-FIXME: - Probably we should also have variants of liftCallCC, etc., which are present - for StateT (for the lazy and the strict OrderT monad). --} - --- * The Order monad - -type Order o = OrderT o Identity - -evalOrder :: (forall o . Order o a) -> a -evalOrder order = runIdentity (evalOrderT order) - -evalOrderWith :: Algorithm -> (forall o . Order o a) -> a -evalOrderWith alg order = runIdentity (evalOrderTWith alg order) - --- * The OrderT monad transformer - -evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a -evalOrderT = evalOrderTWith defaultAlgorithm - -evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a -evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where - - monad = evalStateT stateT (emptyOrderRep rawAlg) - -force :: Monad m => OrderT o m () -force = OrderT $ get >>= \ order -> order `seq` return () - --- * Elements - -data Element o = Element (RawElement o RealWorld) - (RawAlgorithm o RealWorld) - Lock --- NOTE: Evaluation of the Element constructor triggers the I/O for insertions. - -instance Eq (Element o) where - - (==) (Element rawElem1 (RawAlgorithm _ _ _ _ _ _ _) _) - (Element rawElem2 _ _) = equal where - - equal = rawElem1 == rawElem2 - -instance Ord (Element o) where - - compare (Element rawElem1 rawAlg lock) - (Element rawElem2 _ _) = ordering where - - ordering = unsafePerformIO $ - criticalSection lock $ - stToIO $ compareElements rawAlg rawElem1 rawElem2 -{-FIXME: - Introduce the safety measures for unsafePerformIO. It should not matter how - many times the I/O is performed. --} - -fromInsert :: Monad m - => (RawAlgorithm o RealWorld - -> RawOrder o RealWorld - -> ST RealWorld (RawElement o RealWorld)) - -> OrderT o m (Element o) -fromInsert insert = OrderT $ StateT (return . explicitStateInsert) where - - explicitStateInsert order@(OrderRep rawOrder rawAlg lock) = output where - - output = unsafePerformIO $ - criticalSection lock $ - do - rawElem <- stToIO $ insert rawAlg rawOrder - mkWeakIORef (IORef rawElem) - (criticalSection lock $ - stToIO $ - delete rawAlg rawElem rawOrder) - return (Element rawElem rawAlg lock, order) - {-FIXME: - Introduce the safety measures for unsafePerformIO. The I/O must occur only - once. - -} - -newMinimum :: Monad m => OrderT o m (Element o) -newMinimum = fromInsert insertMinimum - -newMaximum :: Monad m => OrderT o m (Element o) -newMaximum = fromInsert insertMaximum - -newAfter :: Monad m => Element o -> OrderT o m (Element o) -newAfter (~(Element rawElem _ _)) = fromInsert (flip insertAfter rawElem) - -newBefore :: Monad m => Element o -> OrderT o m (Element o) -newBefore (~(Element rawElem _ _)) = fromInsert (flip insertBefore rawElem) diff --git a/src/Control/Monad/Trans/Order/Lazy/Internals.hs b/src/Control/Monad/Trans/Order/Lazy/Internals.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order/Lazy/Internals.hs +++ /dev/null @@ -1,71 +0,0 @@ -module Control.Monad.Trans.Order.Lazy.Internals ( - - -- * The lazy OrderT monad transformer - - OrderT (OrderT), - OrderRep (OrderRep), - emptyOrderRep, - - -- * Locks - - Lock, - criticalSection - -) where - --- Control - -import Control.Monad -import Control.Applicative -import Control.Monad.Trans.Class -import Control.Monad.IO.Class -import Control.Monad.Trans.State.Lazy -import Control.Monad.ST -import Control.Concurrent.MVar -import Control.Monad.Trans.Order.Raw - --- System - -import System.IO.Unsafe - --- * The lazy OrderT monad transformer - -newtype OrderT o m a = OrderT (StateT (OrderRep o) m a) deriving ( - Functor, - Applicative, - Alternative, - Monad, - MonadPlus, - MonadTrans, - MonadIO) - -- FIXME: Should we also have a MonadFix instance? - -data OrderRep o = OrderRep (RawOrder o RealWorld) - (RawAlgorithm o RealWorld) - Lock --- FIXME: Maybe use OrderedSet instead of OrderRep. --- NOTE: Evaluation of the OrderRep constructor triggers the I/O for insertions. - -emptyOrderRep :: (forall s . RawAlgorithm o s) -> OrderRep o -emptyOrderRep rawAlg = unsafePerformIO $ do - rawOrder <- stToIO (newOrder rawAlg) - lock <- newLock - return (OrderRep rawOrder rawAlg lock) -{-FIXME: - Introduce the safety measures for unsafePerformIO. It should not matter - how many times the I/O is performed. --} - --- * Locks - -type Lock = MVar () - -newLock :: IO Lock -newLock = newEmptyMVar - -criticalSection :: Lock -> IO a -> IO a -criticalSection lock act = do - putMVar lock () - val <- act - takeMVar lock - return val diff --git a/src/Control/Monad/Trans/Order/Raw.hs b/src/Control/Monad/Trans/Order/Raw.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order/Raw.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Control.Monad.Trans.Order.Raw ( - - RawOrder, - OrderCell, - RawElement, - ElementCell, - RawAlgorithm ( - RawAlgorithm, - newOrder, - compareElements, - insertMinimum, - insertMaximum, - insertAfter, - insertBefore, - delete - ) - -) where - -import Control.Monad.ST -import Data.STRef - -type RawOrder o s = STRef s (OrderCell o s) - -type family OrderCell o s - -type RawElement o s = STRef s (ElementCell o s) - -type family ElementCell o s - -data RawAlgorithm o s = RawAlgorithm { - newOrder :: ST s (RawOrder o s), - compareElements :: RawElement o s -> RawElement o s -> ST s Ordering, - insertMinimum :: RawOrder o s -> ST s (RawElement o s), - insertMaximum :: RawOrder o s -> ST s (RawElement o s), - insertAfter :: RawElement o s -> RawOrder o s -> ST s (RawElement o s), - insertBefore :: RawElement o s -> RawOrder o s -> ST s (RawElement o s), - delete :: RawElement o s -> RawOrder o s -> ST s () -} diff --git a/src/Control/Monad/Trans/Order/Strict.hs b/src/Control/Monad/Trans/Order/Strict.hs deleted file mode 100644 --- a/src/Control/Monad/Trans/Order/Strict.hs +++ /dev/null @@ -1,107 +0,0 @@ -module Control.Monad.Trans.Order.Strict ( - - -- * The Order monad - - Order, - evalOrder, - evalOrderWith, - - -- * The OrderT monad transformer - - OrderT, - evalOrderT, - force, - - -- * Elements - - Element, - newMinimum, - newMaximum, - newAfter, - newBefore, - - -- * Converting between lazy and strict OrderT - - lazyToStrictOrderT, - strictToLazyOrderT - -) where - --- Control - -import Control.Monad -import Control.Applicative -import Control.Monad.Trans.Class -import Control.Monad.IO.Class -import qualified Control.Monad.Trans.State.Lazy - as Lazy -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Order.Lazy - (Element) -import qualified Control.Monad.Trans.Order.Lazy - as Lazy -import Control.Monad.Trans.Order.Lazy.Internals - (OrderRep, emptyOrderRep) -import qualified Control.Monad.Trans.Order.Lazy.Internals - as Lazy -import Control.Monad.Trans.Order.Algorithm -import Control.Monad.Trans.Order.Algorithm.Type - --- Data - -import Data.Functor.Identity - --- * The Order monad - -type Order o = OrderT o Identity - -evalOrder :: (forall o . Order o a) -> a -evalOrder order = runIdentity (evalOrderT order) - -evalOrderWith :: Algorithm -> (forall o . Order o a) -> a -evalOrderWith alg order = runIdentity (evalOrderTWith alg order) - --- * The OrderT monad transformer - -newtype OrderT o m a = OrderT (StateT (OrderRep o) m a) deriving ( - Functor, - Applicative, - Alternative, - Monad, - MonadPlus, - MonadTrans, - MonadIO) - -- FIXME: Should we also have a MonadFix instance? - -evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a -evalOrderT = evalOrderTWith defaultAlgorithm - -evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a -evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where - - monad = evalStateT stateT (emptyOrderRep rawAlg) - -force :: Monad m => OrderT o m () -force = lazyToStrictOrderT Lazy.force - --- * Elements - -newMinimum :: Monad m => OrderT o m (Element o) -newMinimum = lazyToStrictOrderT Lazy.newMinimum - -newMaximum :: Monad m => OrderT o m (Element o) -newMaximum = lazyToStrictOrderT Lazy.newMaximum - -newAfter :: Monad m => Element o -> OrderT o m (Element o) -newAfter = lazyToStrictOrderT . Lazy.newAfter - -newBefore :: Monad m => Element o -> OrderT o m (Element o) -newBefore = lazyToStrictOrderT . Lazy.newBefore - --- * Converting between lazy and strict OrderT - -lazyToStrictOrderT :: Lazy.OrderT o m a -> OrderT o m a -lazyToStrictOrderT (Lazy.OrderT (Lazy.StateT fun)) = OrderT (StateT fun) - -strictToLazyOrderT :: OrderT o m a -> Lazy.OrderT o m a -strictToLazyOrderT (OrderT (StateT fun)) = Lazy.OrderT (Lazy.StateT fun) diff --git a/src/library/Control/Monad/Trans/Order.hs b/src/library/Control/Monad/Trans/Order.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order.hs @@ -0,0 +1,7 @@ +module Control.Monad.Trans.Order ( + + module Control.Monad.Trans.Order.Lazy + +) where + +import Control.Monad.Trans.Order.Lazy diff --git a/src/library/Control/Monad/Trans/Order/Algorithm.hs b/src/library/Control/Monad/Trans/Order/Algorithm.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Algorithm.hs @@ -0,0 +1,102 @@ +module Control.Monad.Trans.Order.Algorithm ( + + -- * General things + + Algorithm, + defaultAlgorithm, + withRawAlgorithm, + + -- * Specific algorithms + + dumb, + dietzSleatorAmortizedLog, + dietzSleatorAmortizedLogWithSize + +) where + +import Control.Monad.ST +import Control.Monad.Trans.Order.Raw +import Control.Monad.Trans.Order.Algorithm.Type +import Control.Monad.Trans.Order.Algorithm.Dumb + as Dumb +import Control.Monad.Trans.Order.Algorithm.DietzSleatorAmortizedLog + as DietzSleatorAmortizedLog + +{-FIXME: + Implement the following: + + • an algorithm that uses arbitarily deep log-trees + + • the file maintenance algorithm by Bender et al. combined with log-trees + of fixed height + + • a function that converts any algorithm into one that shifts elements + between two orders upon deletion (for avoiding sparsly populated order + structures) + + Maybe it makes sense to additionally offer the file maintenance algorithm by + Bender et al. as an order maintenance algorithm in its own right. +-} + +{-FIXME: + For implementing Bender et al., it might be good to store the calibrator + tree in an array, level by level from top to bottom. The array must then be + created without initializing its elements. Initially the tree would be + small; so few array elements would be used. When extending the tree, we + would face the problem that initializing all the additionally used elements + would take more than O(1) time. We can maybe use the trick by Barak A. + Pearlmutter¹ (or a variant of it, specialized for our particular + initialization pattern) to get O(1) time. + + ¹ See his e-mail to me from 5 December 2014. +-} + +{-FIXME: + More notes regarding implementing Bender et al.: + + • We can store the set of all children of a single node of a log-tree in + an array of 48 64-bit words. Each word represents one child. Children + are stored in the temporal order of their allocation. 48 bits of a word + are the label, 3 are the left sibling index, 3 are the right sibling + index. The parent pointer (pointer to the array plus index in the array) + has to be stored only once per such an array, not for every child. + + • A block in the file maintenance data structure could encompass 48 or + maybe also 64 elements. A 64-bit word could be used to store which of + the array cells are taken by an element and which are free. + + • I think that on the upper two levels of a log tree, we need up to three + times as many nodes for storing log-many subtrees, because of overflow + nodes. This would mean that with the above approach, we could store up + to 48 × 12 × 12 ≈ 7000 elements in a log tree and ca. 7000 × 48 ≈ 350000 + actual elements per file maintenance block. The total memory use would + be a bit more than 8 × 350000 = 2.8 MB. + + • The number of actual elements per file maintenance block (350,000) would + be a bit more than 2^18. Since our k would be 48, we could have up to + 2^48 × 2^18 = 2^66 elements theoretically. So we could reach the maximum + of 2^64 elements. +-} + +-- * General things + +-- NOTE: Algorithm is imported from Data.OrderMaintenance.Algorithm.Type. + +defaultAlgorithm :: Algorithm +defaultAlgorithm = dietzSleatorAmortizedLog + +withRawAlgorithm :: Algorithm + -> (forall a . RawAlgorithm a s -> ST s r) + -> ST s r +withRawAlgorithm (Algorithm rawAlg) cont = cont rawAlg + +-- * Specific algorithms + +dumb :: Algorithm +dumb = Dumb.algorithm + +dietzSleatorAmortizedLog :: Algorithm +dietzSleatorAmortizedLog = DietzSleatorAmortizedLog.algorithm + +dietzSleatorAmortizedLogWithSize :: Int -> Algorithm +dietzSleatorAmortizedLogWithSize = DietzSleatorAmortizedLog.algorithmWithSize diff --git a/src/library/Control/Monad/Trans/Order/Algorithm/DietzSleatorAmortizedLog.hs b/src/library/Control/Monad/Trans/Order/Algorithm/DietzSleatorAmortizedLog.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Algorithm/DietzSleatorAmortizedLog.hs @@ -0,0 +1,185 @@ +module Control.Monad.Trans.Order.Algorithm.DietzSleatorAmortizedLog ( + + algorithm, + algorithmWithSize + +) where + +-- Control + +import Control.Applicative +import Control.Monad +import Control.Monad.ST +import Control.Monad.Trans.Order.Algorithm.Type +import Control.Monad.Trans.Order.Raw + +-- Data + +import Data.STRef +import Data.Word +import Data.Bits + +algorithm :: Algorithm +algorithm = algorithmWithSize defaultSize + +defaultSize :: Int +defaultSize = 63 + +algorithmWithSize :: Int -> Algorithm +algorithmWithSize size = Algorithm (rawAlgorithmWithSize size) + +data DietzSleatorAmortizedLog + +type instance OrderCell DietzSleatorAmortizedLog s = Cell s + +type instance ElementCell DietzSleatorAmortizedLog s = Cell s + +data Cell s = Cell { + label :: Label, + next :: CellRef s, + prev :: CellRef s + } + +type CellRef s = STRef s (Cell s) + +newtype Label = Label LabelWord deriving (Eq, Ord) + +type LabelWord = Word64 + +labelWordSize :: Int +labelWordSize = 64 + +initialBaseLabel :: Label +initialBaseLabel = Label 0 + +rawAlgorithmWithSize :: Int -> RawAlgorithm DietzSleatorAmortizedLog s +rawAlgorithmWithSize size + | size < 0 || size >= labelWordSize + = error "Control.Monad.Trans.Order.Algorithm.DietzSleatorAmortizedLog: \ + \Size out of bounds" + | otherwise + = RawAlgorithm { + newOrder = fixST $ + \ ref -> newSTRef $ Cell { + label = initialBaseLabel, + next = ref, + prev = ref + }, + compareElements = \ baseRef ref1 ref2 -> do + baseCell <- readSTRef baseRef + cell1 <- readSTRef ref1 + cell2 <- readSTRef ref2 + let offset1 = labelDiff (label cell1) + (label baseCell) + let offset2 = labelDiff (label cell2) + (label baseCell) + return $ compare offset1 offset2, + newMinimum = newAfterCell, + newMaximum = newBeforeCell, + newAfter = const newAfterCell, + newBefore = const newBeforeCell, + delete = \ _ ref -> do + cell <- readSTRef ref + modifySTRef + (prev cell) + (\ prevCell -> prevCell { + next = next cell + }) + modifySTRef + (next cell) + (\ nextCell -> nextCell { + prev = prev cell + }) + } where + + noOfLabels :: LabelWord + noOfLabels = shiftL 1 size + + labelMask :: LabelWord + labelMask = pred noOfLabels + + toLabel :: LabelWord -> Label + toLabel = Label . (.&. labelMask) + + labelSum :: Label -> Label -> Label + labelSum (Label word1) (Label word2) = toLabel (word1 + word2) + + labelDiff :: Label -> Label -> Label + labelDiff (Label word1) (Label word2) = toLabel (word1 - word2) + + labelDistance :: Label -> Label -> LabelWord + labelDistance lbl1 lbl2 = case labelDiff lbl1 lbl2 of + Label word | word == 0 -> noOfLabels + | otherwise -> word + + newAfterCell :: CellRef s -> ST s (CellRef s) + newAfterCell ref = do + relabel ref + lbl <- label <$> readSTRef ref + nextRef <- next <$> readSTRef ref + nextLbl <- label <$> readSTRef nextRef + newRef <- newSTRef $ Cell { + label = labelSum lbl (Label (labelDistance nextLbl lbl `div` 2)), + next = nextRef, + prev = ref + } + modifySTRef ref (\ cell -> cell { next = newRef }) + modifySTRef nextRef (\ nextCell -> nextCell { prev = newRef }) + return newRef + + relabel :: CellRef s -> ST s () + relabel startRef = do + startCell <- readSTRef startRef + let delimSearch ref gapCount = do + cell <- readSTRef ref + let gapSum = labelDistance (label cell) (label startCell) + if gapSum <= gapCount ^ 2 + then if ref == startRef + then error "Control.Monad.Trans.Order.Algorithm.\ + \DietzSleatorAmortizedLog: \ + \Order full" + else delimSearch (next cell) (succ gapCount) + else return (ref, gapSum, gapCount) + (delimRef, gapSum, gapCount) <- delimSearch (next startCell) 1 + let smallGap = gapSum `div` gapCount + let largeGapCount = gapSum `mod` gapCount + let changeLabels ref idx = when (ref /= delimRef) $ do + cell <- readSTRef ref + let lbl = labelSum + (label startCell) + (Label (idx * smallGap + min largeGapCount idx)) + writeSTRef ref (cell { label = lbl }) + changeLabels (next cell) (succ idx) + changeLabels (next startCell) 1 + {-FIXME: + We allow the number of cells to be larger than the square root of the + number of possible labels as long as we find a sparse part in our circle + of cells (since our order full condition is only true if the complete + circle is congested). This should not influence correctness and probably + also not time complexity, but we should check this more thoroughly. + -} + {-FIXME: + We arrange the large and small gaps differently from Dietz and Sleator + by putting all the large gaps at the beginning instead of distributing + them over the relabeled area. However, this should not influence time + complexity, as the complexity proof seems to only rely on the fact that + gap sizes differ by at most 1. We should check this more thoroughly + though. + -} + + newBeforeCell :: CellRef s -> ST s (CellRef s) + newBeforeCell ref = do + cell <- readSTRef ref + newAfterCell (prev cell) + +labels :: CellRef s -> ST s [LabelWord] +labels startRef = do + let aux ref = do + cell <- readSTRef ref + let ref' = next cell + lbls <- if ref' == startRef + then return [] + else aux ref' + return (label cell : lbls) + lbls <- aux startRef + return $ map (\ (Label word) -> word) lbls where diff --git a/src/library/Control/Monad/Trans/Order/Algorithm/Dumb.hs b/src/library/Control/Monad/Trans/Order/Algorithm/Dumb.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Algorithm/Dumb.hs @@ -0,0 +1,102 @@ +module Control.Monad.Trans.Order.Algorithm.Dumb ( + + algorithm + +) where + +-- Control + +import Control.Applicative +import Control.Monad.ST +import Control.Monad.Trans.Order.Algorithm.Type +import Control.Monad.Trans.Order.Raw + +-- Data + +import Data.Ratio +import Data.STRef +import qualified Data.Set as Set +import Data.Set (Set) + +algorithm :: Algorithm +algorithm = Algorithm rawAlgorithm + +data Dumb + +type instance OrderCell Dumb s = PureOrder + +type instance ElementCell Dumb s = PureElement + +type PureOrder = Set PureElement + +type PureElement = Rational + +rawAlgorithm :: RawAlgorithm Dumb s +rawAlgorithm = RawAlgorithm { + newOrder = newSTRef Set.empty, + compareElements = \ _ rawElem1 rawElem2 -> do + pureElem1 <- readSTRef rawElem1 + pureElem2 <- readSTRef rawElem2 + return (compare pureElem1 pureElem2), + newMinimum = fromPureInsert pureInsertMinimum, + newMaximum = fromPureInsert pureInsertMaximum, + newAfter = relative fromPureInsert pureInsertAfter, + newBefore = relative fromPureInsert pureInsertBefore, + delete = relative fromPure pureDelete +} + +fromPure :: (PureOrder -> (a, PureOrder)) -> RawOrder Dumb s -> ST s a +fromPure trans rawOrder = do + pureOrder <- readSTRef rawOrder + let (output, pureOrder') = trans pureOrder + writeSTRef rawOrder pureOrder' + return output + +fromPureInsert :: (PureOrder -> PureElement) + -> RawOrder Dumb s + -> ST s (RawElement Dumb s) +fromPureInsert trans rawOrder = fromPure trans' rawOrder >>= newSTRef where + + trans' pureOrder = let + + pureElement = trans pureOrder + + in (pureElement, Set.insert pureElement pureOrder) + +relative :: ((PureOrder -> a) -> RawOrder Dumb s -> ST s b) + -> (PureOrder -> PureElement -> a) + -> RawOrder Dumb s + -> RawElement Dumb s + -> ST s b +relative conv trans rawOrder rawElem = do + pureElem <- readSTRef rawElem + conv (flip trans pureElem) rawOrder + +pureInsertMinimum :: PureOrder -> PureElement +pureInsertMinimum pureOrder + | Set.null pureOrder = 1 % 2 + | otherwise = Set.findMin pureOrder / 2 + +pureInsertMaximum :: PureOrder -> PureElement +pureInsertMaximum pureOrder + | Set.null pureOrder = 1 % 2 + | otherwise = (Set.findMax pureOrder + 1) / 2 + +pureInsertAfter :: PureOrder -> PureElement -> PureElement +pureInsertAfter pureOrder pureElement = pureElement' where + + greater = snd (Set.split pureElement pureOrder) + + pureElement' | Set.null greater = (pureElement + 1) / 2 + | otherwise = (pureElement + Set.findMin greater) / 2 + +pureInsertBefore :: PureOrder -> PureElement -> PureElement +pureInsertBefore pureOrder pureElement = pureElement' where + + lesser = fst (Set.split pureElement pureOrder) + + pureElement' | Set.null lesser = pureElement / 2 + | otherwise = (pureElement + Set.findMax lesser) / 2 + +pureDelete :: PureOrder -> PureElement -> ((), PureOrder) +pureDelete pureOrder pureElement = ((), Set.delete pureElement pureOrder) diff --git a/src/library/Control/Monad/Trans/Order/Algorithm/Type.hs b/src/library/Control/Monad/Trans/Order/Algorithm/Type.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Algorithm/Type.hs @@ -0,0 +1,9 @@ +module Control.Monad.Trans.Order.Algorithm.Type ( + + Algorithm (Algorithm) + +) where + +import Control.Monad.Trans.Order.Raw + +data Algorithm = forall a . Algorithm (forall s . RawAlgorithm a s) diff --git a/src/library/Control/Monad/Trans/Order/Lazy.hs b/src/library/Control/Monad/Trans/Order/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Lazy.hs @@ -0,0 +1,164 @@ +module Control.Monad.Trans.Order.Lazy ( + + -- * The Order monad + + Order, + evalOrder, + evalOrderWith, + + -- * The OrderT monad transformer + + OrderT, + evalOrderT, + force, + + -- * Elements + + Element, + newMinimum, + newMaximum, + newAfter, + newBefore + +) where + +-- Control + +import Control.Monad.ST +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Order.Raw + hiding (newMinimum, newMaximum, newAfter, newBefore) +import qualified Control.Monad.Trans.Order.Raw + as Raw +import Control.Monad.Trans.Order.Lazy.Internals +import Control.Monad.Trans.Order.Algorithm +import Control.Monad.Trans.Order.Algorithm.Type + +-- Data + +import Data.Functor.Identity +import Data.IORef + +-- System + +import System.IO.Unsafe + +-- GHC + +import GHC.IORef -- for converting from STRef RealWorld to IORef + +{-FIXME: + Introduce conversions between the lazy and the strict variant, similar to + the conversions for ST. +-} +{-FIXME: + Consider introducing a restricted variant of mapStateT (for the lazy and the + strict OrderT monad): + + mapOrderT :: (forall a . m a -> n a) -> OrderT o m a -> OrderT o n a + + Maybe this should not be called mapOrderT, since it is only a restricted + variant and a corresponding mapOrder would be trivial. +-} +{-FIXME: + Probably we should also have variants of liftCallCC, etc., which are present + for StateT (for the lazy and the strict OrderT monad). +-} + +-- * The Order monad + +type Order o = OrderT o Identity + +evalOrder :: (forall o . Order o a) -> a +evalOrder order = runIdentity (evalOrderT order) + +evalOrderWith :: Algorithm -> (forall o . Order o a) -> a +evalOrderWith alg order = runIdentity (evalOrderTWith alg order) + +-- * The OrderT monad transformer + +-- NOTE: OrderT is imported from Control.Monad.Trans.Order.Lazy.Internals. + +evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a +evalOrderT = evalOrderTWith defaultAlgorithm + +evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a +evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where + + monad = evalStateT stateT (emptyOrderRep rawAlg) + +force :: Monad m => OrderT o m () +force = OrderT $ get >>= \ order -> order `seq` return () + +-- * Elements + +data Element o = Element (RawAlgorithm o RealWorld) + (Gate o) + (RawElement o RealWorld) +-- NOTE: Evaluation of the Element constructor triggers the I/O for insertions. + +instance Eq (Element o) where + + (==) (Element (RawAlgorithm _ _ _ _ _ _ _) _ rawElem1) + (Element _ _ rawElem2) = equal where + + equal = rawElem1 == rawElem2 + +instance Ord (Element o) where + + compare (Element rawAlg gate rawElem1) + (Element _ _ rawElem2) = ordering where + + ordering = unsafePerformIO $ + withRawOrder gate $ \ rawOrder -> + stToIO $ compareElements rawAlg rawOrder rawElem1 rawElem2 +{-FIXME: + Introduce the safety measures for unsafePerformIO. It should not matter how + many times the I/O is performed. +-} + +fromRawNew :: Monad m + => (RawAlgorithm o RealWorld + -> RawOrder o RealWorld + -> ST RealWorld (RawElement o RealWorld)) + -> OrderT o m (Element o) +fromRawNew rawNew = OrderT $ StateT (return . explicitStateNew) where + + explicitStateNew order@(OrderRep rawAlg gate) = output where + + output = unsafePerformIO $ + withRawOrder gate $ \ rawOrder -> + do + rawElem <- stToIO $ rawNew rawAlg rawOrder + mkWeakIORef (IORef rawElem) + (withRawOrder gate $ \ rawOrder -> + stToIO $ + delete rawAlg rawOrder rawElem) + return (Element rawAlg gate rawElem, order) + {-FIXME: + Introduce the safety measures for unsafePerformIO. The I/O must occur only + once. + -} + +newMinimum :: Monad m => OrderT o m (Element o) +newMinimum = fromRawNew Raw.newMinimum + +newMaximum :: Monad m => OrderT o m (Element o) +newMaximum = fromRawNew Raw.newMaximum + +newAfter :: Monad m => Element o -> OrderT o m (Element o) +newAfter (~(Element _ _ rawElem)) = fromRawNeighbor Raw.newAfter rawElem + +newBefore :: Monad m => Element o -> OrderT o m (Element o) +newBefore (~(Element _ _ rawElem)) = fromRawNeighbor Raw.newBefore rawElem + +fromRawNeighbor :: Monad m + => (RawAlgorithm o RealWorld + -> RawOrder o RealWorld + -> RawElement o RealWorld + -> ST RealWorld (RawElement o RealWorld)) + -> RawElement o RealWorld + -> OrderT o m (Element o) +fromRawNeighbor rawNewNeighbor rawElem = fromRawNew rawNew where + + rawNew rawAlg rawOrder = rawNewNeighbor rawAlg rawOrder rawElem diff --git a/src/library/Control/Monad/Trans/Order/Lazy/Internals.hs b/src/library/Control/Monad/Trans/Order/Lazy/Internals.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Lazy/Internals.hs @@ -0,0 +1,66 @@ +module Control.Monad.Trans.Order.Lazy.Internals ( + + -- * The lazy OrderT monad transformer + + OrderT (OrderT), + OrderRep (OrderRep), + emptyOrderRep, + + -- * Gates + + Gate, + withRawOrder + +) where + +-- Control + +import Control.Monad +import Control.Applicative +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Monad.Trans.State.Lazy +import Control.Monad.ST +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad.Trans.Order.Raw + +-- System + +import System.IO.Unsafe + +-- * The lazy OrderT monad transformer + +newtype OrderT o m a = OrderT (StateT (OrderRep o) m a) deriving ( + Functor, + Applicative, + Alternative, + Monad, + MonadPlus, + MonadTrans, + MonadIO) + -- FIXME: Should we also have a MonadFix instance? + +data OrderRep o = OrderRep (RawAlgorithm o RealWorld) (Gate o) +-- FIXME: Maybe use OrderedSet instead of OrderRep. +-- NOTE: Evaluation of the OrderRep constructor triggers the I/O for insertions. + +emptyOrderRep :: (forall s . RawAlgorithm o s) -> OrderRep o +emptyOrderRep rawAlg = unsafePerformIO $ do + rawOrder <- stToIO (newOrder rawAlg) + gate <- newGate rawOrder + return (OrderRep rawAlg gate) +{-FIXME: + Introduce the safety measures for unsafePerformIO. It should not matter + how many times the I/O is performed. +-} + +-- * Gates + +newtype Gate a = Gate (MVar (RawOrder a RealWorld)) + +newGate :: RawOrder a RealWorld -> IO (Gate a) +newGate = fmap Gate . newMVar + +withRawOrder :: Gate a -> (RawOrder a RealWorld -> IO r) -> IO r +withRawOrder (Gate mVar) cont = bracket (takeMVar mVar) (putMVar mVar) cont diff --git a/src/library/Control/Monad/Trans/Order/Raw.hs b/src/library/Control/Monad/Trans/Order/Raw.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Raw.hs @@ -0,0 +1,51 @@ +module Control.Monad.Trans.Order.Raw ( + + RawOrder, + OrderCell, + RawElement, + ElementCell, + RawAlgorithm ( + RawAlgorithm, + newOrder, + compareElements, + newMinimum, + newMaximum, + newAfter, + newBefore, + delete + ) + +) where + +import Control.Monad.ST +import Data.STRef + +type RawOrder a s = STRef s (OrderCell a s) + +type family OrderCell a s + +type RawElement a s = STRef s (ElementCell a s) + +type family ElementCell a s + +data RawAlgorithm a s = RawAlgorithm { + newOrder :: ST s (RawOrder a s), + compareElements :: RawOrder a s + -> RawElement a s + -> RawElement a s + -> ST s Ordering, + newMinimum :: RawOrder a s -> ST s (RawElement a s), + newMaximum :: RawOrder a s -> ST s (RawElement a s), + newAfter :: RawOrder a s -> RawElement a s -> ST s (RawElement a s), + newBefore :: RawOrder a s -> RawElement a s -> ST s (RawElement a s), + delete :: RawOrder a s -> RawElement a s -> ST s () +} +{-FIXME: + If we ever allow users to plug in their own algorithms, we have to flag the + respective function as unsafe and point out that referential transparency is + in danger if the algorithm does not fulfill the specification. This is + because element comparison is presented to the user as a pure function. The + important condition is that for any two elements, compareElements must + always return the same result as long as delete is not called on either + element. +-} diff --git a/src/library/Control/Monad/Trans/Order/Strict.hs b/src/library/Control/Monad/Trans/Order/Strict.hs new file mode 100644 --- /dev/null +++ b/src/library/Control/Monad/Trans/Order/Strict.hs @@ -0,0 +1,107 @@ +module Control.Monad.Trans.Order.Strict ( + + -- * The Order monad + + Order, + evalOrder, + evalOrderWith, + + -- * The OrderT monad transformer + + OrderT, + evalOrderT, + force, + + -- * Elements + + Element, + newMinimum, + newMaximum, + newAfter, + newBefore, + + -- * Converting between lazy and strict OrderT + + lazyToStrictOrderT, + strictToLazyOrderT + +) where + +-- Control + +import Control.Monad +import Control.Applicative +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.State.Lazy + as Lazy +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Order.Lazy + (Element) +import qualified Control.Monad.Trans.Order.Lazy + as Lazy +import Control.Monad.Trans.Order.Lazy.Internals + (OrderRep, emptyOrderRep) +import qualified Control.Monad.Trans.Order.Lazy.Internals + as Lazy +import Control.Monad.Trans.Order.Algorithm +import Control.Monad.Trans.Order.Algorithm.Type + +-- Data + +import Data.Functor.Identity + +-- * The Order monad + +type Order o = OrderT o Identity + +evalOrder :: (forall o . Order o a) -> a +evalOrder order = runIdentity (evalOrderT order) + +evalOrderWith :: Algorithm -> (forall o . Order o a) -> a +evalOrderWith alg order = runIdentity (evalOrderTWith alg order) + +-- * The OrderT monad transformer + +newtype OrderT o m a = OrderT (StateT (OrderRep o) m a) deriving ( + Functor, + Applicative, + Alternative, + Monad, + MonadPlus, + MonadTrans, + MonadIO) + -- FIXME: Should we also have a MonadFix instance? + +evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a +evalOrderT = evalOrderTWith defaultAlgorithm + +evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a +evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where + + monad = evalStateT stateT (emptyOrderRep rawAlg) + +force :: Monad m => OrderT o m () +force = lazyToStrictOrderT Lazy.force + +-- * Elements + +newMinimum :: Monad m => OrderT o m (Element o) +newMinimum = lazyToStrictOrderT Lazy.newMinimum + +newMaximum :: Monad m => OrderT o m (Element o) +newMaximum = lazyToStrictOrderT Lazy.newMaximum + +newAfter :: Monad m => Element o -> OrderT o m (Element o) +newAfter = lazyToStrictOrderT . Lazy.newAfter + +newBefore :: Monad m => Element o -> OrderT o m (Element o) +newBefore = lazyToStrictOrderT . Lazy.newBefore + +-- * Converting between lazy and strict OrderT + +lazyToStrictOrderT :: Lazy.OrderT o m a -> OrderT o m a +lazyToStrictOrderT (Lazy.OrderT (Lazy.StateT fun)) = OrderT (StateT fun) + +strictToLazyOrderT :: OrderT o m a -> Lazy.OrderT o m a +strictToLazyOrderT (OrderT (StateT fun)) = Lazy.OrderT (Lazy.StateT fun) diff --git a/src/test-suites/TestSuite.hs b/src/test-suites/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/test-suites/TestSuite.hs @@ -0,0 +1,199 @@ +module TestSuite ( + + tests + +) where + +-- Control + +import Control.Monad +import Control.Monad.ST +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import Control.Monad.Trans.Order.Algorithm + (Algorithm, withRawAlgorithm) +import qualified Control.Monad.Trans.Order.Algorithm + as Algorithm +import Control.Monad.Trans.Order.Raw + +-- Data + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map + +-- Test + +import Test.QuickCheck + +-- Distribution + +import Distribution.TestSuite +import Distribution.TestSuite.QuickCheck + +-- * Tests + +tests :: IO [Test] +tests = return $ map (uncurry comparisonTest) [ + (dumb, dietzSleatorAmortizedLogWithSize14) + ] + +-- * Order computations + +newtype OrderComp = OrderComp [OrderStmt] + +initialID :: Int +initialID = 1 + +instance Show OrderComp where + + show (OrderComp stmts) + | null stmts = "no statements" + | otherwise = str ++ concatMap (", " ++) strs where + + str : strs = zipWith showStmt stmts nextIds + + newElemCounts = map newElemCount stmts + + nextIds = scanl (+) initialID newElemCounts + +data CompGenState = CompGenState (Set Int) Int + +instance Arbitrary OrderComp where + + arbitrary = sized $ \ size -> do + len <- choose (0, size) + stmts <- evalStateT (replicateM len genStmt) + (CompGenState Set.empty initialID) + return (OrderComp stmts) + + shrink (OrderComp stmts) = if null stmts + then [] + else [OrderComp (init stmts)] + +type ComparisonMatrix = Map (Int, Int) Ordering + +runComp :: Algorithm -> OrderComp -> ComparisonMatrix +runComp alg comp = compMatrix where + + compMatrix = runST (withRawAlgorithm alg (\ rawAlg -> execComp rawAlg comp)) + +data CompExecState a s = CompExecState (ElementMap a s) Int + +type ElementMap a s = Map Int (RawElement a s) + +execComp :: RawAlgorithm a s -> OrderComp -> ST s ComparisonMatrix +execComp rawAlg (OrderComp stmts) = do + rawOrder <- newOrder rawAlg + let execStmts = mapM_ (execStmt rawAlg rawOrder) stmts + let initState = CompExecState Map.empty initialID + ((), CompExecState elemMap _) <- runStateT execStmts initState + let idElemPairs = Map.toList elemMap + let comparisonPair (id1, elem1) (id2, elem2) = do + ordering <- compareElements rawAlg rawOrder elem1 elem2 + return ((id1, id2), ordering) + comparisonPairs <- sequence $ liftM2 comparisonPair idElemPairs idElemPairs + return $ Map.fromList comparisonPairs + +data OrderStmt = NewMinimum + | NewMaximum + | NewAfter Int + | NewBefore Int + | Delete Int + +newElemCount :: OrderStmt -> Int +newElemCount NewMinimum = 1 +newElemCount NewMaximum = 1 +newElemCount (NewAfter id) = 1 +newElemCount (NewBefore id) = 1 +newElemCount (Delete id) = 0 + +showStmt :: OrderStmt -> Int -> String +showStmt NewMinimum = showNewStmt "newMinimum" +showStmt NewMaximum = showNewStmt "newMaximum" +showStmt (NewAfter id) = showNewStmt ("newAfter " ++ showElem id) +showStmt (NewBefore id) = showNewStmt ("newBefore " ++ showElem id) +showStmt (Delete id) = const ("delete " ++ showElem id) + +showNewStmt :: String -> Int -> String +showNewStmt base nextId = base ++ " -> " ++ showElem nextId + +showElem :: Int -> String +showElem id = "x_" ++ show id + +genStmt :: StateT CompGenState Gen OrderStmt +genStmt = do + CompGenState liveIds nextId <- get + let liveIdGen = elements (Set.toList liveIds) + stmt <- lift $ + if Set.null liveIds + then elements [NewMinimum, NewMaximum] + else frequency [ + (1, return NewMinimum), + (1, return NewMaximum), + (3, fmap NewAfter liveIdGen), + (3, fmap NewBefore liveIdGen), + (2, fmap Delete liveIdGen) + ] + let newStmtIds = (Set.singleton nextId, Set.empty) + let (newIds, deadIds) = case stmt of + NewMinimum -> newStmtIds + NewMaximum -> newStmtIds + NewAfter _ -> newStmtIds + NewBefore _ -> newStmtIds + Delete id -> (Set.empty, Set.singleton id) + put $ CompGenState ((liveIds `Set.union` newIds) `Set.difference` deadIds) + (nextId + Set.size newIds) + return stmt + +execStmt :: RawAlgorithm a s + -> RawOrder a s + -> OrderStmt + -> StateT (CompExecState a s) (ST s) () +execStmt rawAlg rawOrder = exec where + + exec NewMinimum = execNew newMinimum + exec NewMaximum = execNew newMaximum + exec (NewAfter id) = execNewNeighbor newAfter id + exec (NewBefore id) = execNewNeighbor newBefore id + exec (Delete id) = execDelete id + + execNew new = do + CompExecState elemMap nextId <- get + rawElem <- lift $ new rawAlg rawOrder + put $ CompExecState (Map.insert nextId rawElem elemMap) (succ nextId) + + execNewNeighbor newNeighbor id = do + CompExecState elemMap _ <- get + let new rawAlg rawOrder = newNeighbor rawAlg rawOrder (elemMap Map.! id) + execNew new + + execDelete id = do + CompExecState elemMap nextId <- get + lift $ delete rawAlg rawOrder (elemMap Map.! id) + put $ CompExecState (Map.delete id elemMap) nextId + +-- * Named algorithms + +data NamedAlgorithm = NamedAlgorithm String Algorithm + +dumb :: NamedAlgorithm +dumb = NamedAlgorithm "Dumb" Algorithm.dumb + +dietzSleatorAmortizedLogWithSize14 :: NamedAlgorithm +dietzSleatorAmortizedLogWithSize14 = NamedAlgorithm name alg where + + name = "Dietz and Sleator O(log n) amortized time" + + alg = Algorithm.dietzSleatorAmortizedLogWithSize 14 + +-- * Test pattern + +comparisonTest :: NamedAlgorithm -> NamedAlgorithm -> Test +comparisonTest (NamedAlgorithm name1 alg1) + (NamedAlgorithm name2 alg2) = testProperty name prop where + + name = name1 ++ " vs. " ++ name2 + + prop comp = runComp alg1 comp == runComp alg2 comp