order-maintenance 0.0.0.0 → 0.0.1.0

raw patch · 20 files changed

+1023/−575 lines, 20 filesdep +Cabaldep +QuickCheckdep +cabal-test-quickcheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Cabal, QuickCheck, cabal-test-quickcheck, order-maintenance

API changes (from Hackage documentation)

Files

• dist/build/testsStub/testsStub-tmp/testsStub.hs +5/−0
• order-maintenance.cabal +26/−11
• src/Control/Monad/Trans/Order.hs +0/−7
• src/Control/Monad/Trans/Order/Algorithm.hs +0/−83
• src/Control/Monad/Trans/Order/Algorithm/Dumb.hs +0/−100
• src/Control/Monad/Trans/Order/Algorithm/Type.hs +0/−9
• src/Control/Monad/Trans/Order/Lazy.hs +0/−148
• src/Control/Monad/Trans/Order/Lazy/Internals.hs +0/−71
• src/Control/Monad/Trans/Order/Raw.hs +0/−39
• src/Control/Monad/Trans/Order/Strict.hs +0/−107
• src/library/Control/Monad/Trans/Order.hs +7/−0
• src/library/Control/Monad/Trans/Order/Algorithm.hs +102/−0
• src/library/Control/Monad/Trans/Order/Algorithm/DietzSleatorAmortizedLog.hs +185/−0
• src/library/Control/Monad/Trans/Order/Algorithm/Dumb.hs +102/−0
• src/library/Control/Monad/Trans/Order/Algorithm/Type.hs +9/−0
• src/library/Control/Monad/Trans/Order/Lazy.hs +164/−0
• src/library/Control/Monad/Trans/Order/Lazy/Internals.hs +66/−0
• src/library/Control/Monad/Trans/Order/Raw.hs +51/−0
• src/library/Control/Monad/Trans/Order/Strict.hs +107/−0
• src/test-suites/TestSuite.hs +199/−0

@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import TestSuite ( tests )+main :: IO ()+main = stubMain tests

@@ -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

@@ -1,7 +0,0 @@-module Control.Monad.Trans.Order (--    module Control.Monad.Trans.Order.Lazy--) where--import Control.Monad.Trans.Order.Lazy

@@ -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

@@ -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)

@@ -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)

@@ -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)

@@ -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

@@ -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 ()-}

@@ -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)

@@ -0,0 +1,7 @@+module Control.Monad.Trans.Order (++    module Control.Monad.Trans.Order.Lazy++) where++import Control.Monad.Trans.Order.Lazy

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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.+-}

@@ -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)

@@ -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