packages feed

order-maintenance 0.0.1.0 → 0.1.0.0

raw patch · 19 files changed

+707/−626 lines, 19 filesdep ~order-maintenancePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: order-maintenance

API changes (from Hackage documentation)

- Control.Monad.Trans.Order.Algorithm: data Algorithm
- Control.Monad.Trans.Order.Algorithm: defaultAlgorithm :: Algorithm
- Control.Monad.Trans.Order.Algorithm: dietzSleatorAmortizedLog :: Algorithm
- Control.Monad.Trans.Order.Algorithm: dietzSleatorAmortizedLogWithSize :: Int -> Algorithm
- Control.Monad.Trans.Order.Algorithm: dumb :: Algorithm
- Control.Monad.Trans.Order.Algorithm: withRawAlgorithm :: Algorithm -> (forall a. RawAlgorithm a s -> ST s r) -> ST s r
- Control.Monad.Trans.Order.Lazy: data Element o
- Control.Monad.Trans.Order.Lazy: instance Eq (Element o)
- Control.Monad.Trans.Order.Lazy: instance Ord (Element o)
- Control.Monad.Trans.Order.Raw: RawAlgorithm :: ST s (RawOrder a s) -> (RawOrder a s -> RawElement a s -> RawElement a s -> ST s Ordering) -> (RawOrder a s -> ST s (RawElement a s)) -> (RawOrder a s -> ST s (RawElement a s)) -> (RawOrder a s -> RawElement a s -> ST s (RawElement a s)) -> (RawOrder a s -> RawElement a s -> ST s (RawElement a s)) -> (RawOrder a s -> RawElement a s -> ST s ()) -> RawAlgorithm a s
- Control.Monad.Trans.Order.Raw: compareElements :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> RawElement a s -> ST s Ordering
- Control.Monad.Trans.Order.Raw: data RawAlgorithm a s
- Control.Monad.Trans.Order.Raw: delete :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> ST s ()
- Control.Monad.Trans.Order.Raw: newAfter :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> ST s (RawElement a s)
- Control.Monad.Trans.Order.Raw: newBefore :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> ST s (RawElement a s)
- Control.Monad.Trans.Order.Raw: newMaximum :: RawAlgorithm a s -> RawOrder a s -> ST s (RawElement a s)
- Control.Monad.Trans.Order.Raw: newMinimum :: RawAlgorithm a s -> RawOrder a s -> ST s (RawElement a s)
- Control.Monad.Trans.Order.Raw: newOrder :: RawAlgorithm a s -> ST s (RawOrder a s)
- Control.Monad.Trans.Order.Raw: type RawElement a s = STRef s (ElementCell a s)
- Control.Monad.Trans.Order.Raw: type RawOrder a s = STRef s (OrderCell a s)
- Control.Monad.Trans.Order.Strict: data Element o
- Control.Monad.Trans.Order.Strict: instance (Functor m, MonadPlus m) => Alternative (OrderT o m)
- Control.Monad.Trans.Order.Strict: instance (Monad m, Functor m) => Applicative (OrderT o m)
- Control.Monad.Trans.Order.Strict: instance Functor m => Functor (OrderT o m)
- Control.Monad.Trans.Order.Strict: instance Monad m => Monad (OrderT o m)
- Control.Monad.Trans.Order.Strict: instance MonadIO m => MonadIO (OrderT o m)
- Control.Monad.Trans.Order.Strict: instance MonadPlus m => MonadPlus (OrderT o m)
- Control.Monad.Trans.Order.Strict: instance MonadTrans (OrderT o)
+ Control.Monad.Trans.Order.Lazy: evalOrderTWith :: Monad m => Algorithm -> (forall o. OrderT o m a) -> m a
+ Control.Monad.Trans.Order.Strict: evalOrderTWith :: Monad m => Algorithm -> (forall o. OrderT o m a) -> m a
+ Control.Monad.Trans.Order.Strict: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (Control.Monad.Trans.Order.Strict.OrderT o m)
+ Control.Monad.Trans.Order.Strict: instance Control.Monad.Trans.Class.MonadTrans (Control.Monad.Trans.Order.Strict.OrderT o)
+ Control.Monad.Trans.Order.Strict: instance GHC.Base.Functor m => GHC.Base.Functor (Control.Monad.Trans.Order.Strict.OrderT o m)
+ Control.Monad.Trans.Order.Strict: instance GHC.Base.Monad m => GHC.Base.Applicative (Control.Monad.Trans.Order.Strict.OrderT o m)
+ Control.Monad.Trans.Order.Strict: instance GHC.Base.Monad m => GHC.Base.Monad (Control.Monad.Trans.Order.Strict.OrderT o m)
+ Control.Monad.Trans.Order.Strict: instance GHC.Base.MonadPlus m => GHC.Base.Alternative (Control.Monad.Trans.Order.Strict.OrderT o m)
+ Control.Monad.Trans.Order.Strict: instance GHC.Base.MonadPlus m => GHC.Base.MonadPlus (Control.Monad.Trans.Order.Strict.OrderT o m)
+ Data.Order: data Element o
+ Data.Order: data Global
+ Data.Order.Algorithm: data Algorithm
+ Data.Order.Algorithm: defaultAlgorithm :: Algorithm
+ Data.Order.Algorithm: dietzSleatorAmortizedLog :: Algorithm
+ Data.Order.Algorithm: dietzSleatorAmortizedLogWithSize :: Int -> Algorithm
+ Data.Order.Algorithm: dumb :: Algorithm
+ Data.Order.Algorithm: withRawAlgorithm :: Algorithm -> (forall a. RawAlgorithm a s -> ST s r) -> ST s r
+ Data.Order.Raw: RawAlgorithm :: ST s (RawOrder a s) -> (RawOrder a s -> RawElement a s -> RawElement a s -> ST s Ordering) -> (RawOrder a s -> ST s (RawElement a s)) -> (RawOrder a s -> ST s (RawElement a s)) -> (RawOrder a s -> RawElement a s -> ST s (RawElement a s)) -> (RawOrder a s -> RawElement a s -> ST s (RawElement a s)) -> (RawOrder a s -> RawElement a s -> ST s ()) -> RawAlgorithm a s
+ Data.Order.Raw: [compareElements] :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> RawElement a s -> ST s Ordering
+ Data.Order.Raw: [delete] :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> ST s ()
+ Data.Order.Raw: [newAfter] :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> ST s (RawElement a s)
+ Data.Order.Raw: [newBefore] :: RawAlgorithm a s -> RawOrder a s -> RawElement a s -> ST s (RawElement a s)
+ Data.Order.Raw: [newMaximum] :: RawAlgorithm a s -> RawOrder a s -> ST s (RawElement a s)
+ Data.Order.Raw: [newMinimum] :: RawAlgorithm a s -> RawOrder a s -> ST s (RawElement a s)
+ Data.Order.Raw: [newOrder] :: RawAlgorithm a s -> ST s (RawOrder a s)
+ Data.Order.Raw: data RawAlgorithm a s
+ Data.Order.Raw: type RawElement a s = STRef s (ElementCell a s)
+ Data.Order.Raw: type RawOrder a s = STRef s (OrderCell a s)

Files

order-maintenance.cabal view
@@ -1,5 +1,5 @@ Name:          order-maintenance-Version:       0.0.1.0+Version:       0.1.0.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.1.0/order-maintenance-0.0.1.0.tar.gz+Package-URL:   http://hackage.haskell.org/packages/archive/order-maintenance/0.1.0.0/order-maintenance-0.1.0.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.10.1+Tested-With:   GHC == 7.8.3  Source-Repository head @@ -25,7 +25,7 @@      Type:     darcs     Location: http://darcs.wolfgang.jeltsch.info/haskell/order-maintenance/main-    Tag:      order-maintenance-0.0.1.0+    Tag:      order-maintenance-0.1.0.0  Library @@ -43,15 +43,18 @@                         TypeFamilies      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+                     Data.Order+                     Data.Order.Algorithm+                     Data.Order.Raw -    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+    Other-Modules: Control.Monad.Trans.Order.Lazy.Type+                   Data.Order.Algorithm.Type+                   Data.Order.Internals+                   Data.Order.Raw.Algorithm+                   Data.Order.Raw.Algorithm.DietzSleatorAmortizedLog+                   Data.Order.Raw.Algorithm.Dumb      HS-Source-Dirs: src/library @@ -65,7 +68,7 @@                    containers            >= 0.5  && < 0.6,                    QuickCheck            >= 2.6  && < 3,                    transformers          >= 0.3  && < 0.5,-                   order-maintenance     == 0.0.1.0+                   order-maintenance     == 0.1.0.0      Default-Language: Haskell2010 
− src/library/Control/Monad/Trans/Order/Algorithm.hs
@@ -1,102 +0,0 @@-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
− src/library/Control/Monad/Trans/Order/Algorithm/DietzSleatorAmortizedLog.hs
@@ -1,185 +0,0 @@-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
− src/library/Control/Monad/Trans/Order/Algorithm/Dumb.hs
@@ -1,102 +0,0 @@-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)
− src/library/Control/Monad/Trans/Order/Algorithm/Type.hs
@@ -1,9 +0,0 @@-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)
src/library/Control/Monad/Trans/Order/Lazy.hs view
@@ -10,11 +10,11 @@      OrderT,     evalOrderT,+    evalOrderTWith,     force,      -- * Elements -    Element,     newMinimum,     newMaximum,     newAfter,@@ -24,29 +24,23 @@  -- 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+import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Order.Lazy.Type  -- Data -import Data.Functor.Identity-import Data.IORef+import           Data.Functor.Identity+import           Data.Order.Algorithm+import           Data.Order.Algorithm.Type+import           Data.Order.Internals+                 hiding (newMinimum, newMaximum, newAfter, newBefore)+import qualified Data.Order.Internals as Internals+import           Data.Order.Raw (RawAlgorithm)  -- 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.@@ -77,7 +71,7 @@  -- * The OrderT monad transformer --- NOTE: OrderT is imported from Control.Monad.Trans.Order.Lazy.Internals.+-- NOTE: OrderT is imported from Control.Monad.Trans.Order.Lazy.Type.  evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a evalOrderT = evalOrderTWith defaultAlgorithm@@ -85,80 +79,31 @@ evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where -    monad = evalStateT stateT (emptyOrderRep rawAlg)+    monad = evalStateT stateT (localOrderRep 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+newMinimum = fromRepNew Internals.newMinimum  newMaximum :: Monad m => OrderT o m (Element o)-newMaximum = fromRawNew Raw.newMaximum+newMaximum = fromRepNew Internals.newMaximum  newAfter :: Monad m => Element o -> OrderT o m (Element o)-newAfter (~(Element _ _ rawElem)) = fromRawNeighbor Raw.newAfter rawElem+newAfter elem = fromRepNew (Internals.newAfter elem)  newBefore :: Monad m => Element o -> OrderT o m (Element o)-newBefore (~(Element _ _ rawElem)) = fromRawNeighbor Raw.newBefore rawElem+newBefore elem = fromRepNew (Internals.newBefore elem) -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+fromRepNew :: Monad m+           => (OrderRep o -> IO (Element o))+           -> OrderT o m (Element o)+fromRepNew repNew = OrderT $ state statefulNew where -    rawNew rawAlg rawOrder = rawNewNeighbor rawAlg rawOrder rawElem+    statefulNew orderRep = (elem, elem `seq` orderRep) where++        {-# NOINLINE elem #-}+        elem = unsafePerformIO $ repNew orderRep
− src/library/Control/Monad/Trans/Order/Lazy/Internals.hs
@@ -1,66 +0,0 @@-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
+ src/library/Control/Monad/Trans/Order/Lazy/Type.hs view
@@ -0,0 +1,27 @@+module Control.Monad.Trans.Order.Lazy.Type (++    OrderT (OrderT)++) where++-- Control++import Control.Monad+import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Lazy++-- Data++import Data.Order.Internals++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?
− src/library/Control/Monad/Trans/Order/Raw.hs
@@ -1,51 +0,0 @@-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.--}
src/library/Control/Monad/Trans/Order/Strict.hs view
@@ -10,11 +10,11 @@      OrderT,     evalOrderT,+    evalOrderTWith,     force,      -- * Elements -    Element,     newMinimum,     newMaximum,     newAfter,@@ -33,23 +33,17 @@ import           Control.Applicative import           Control.Monad.Trans.Class import           Control.Monad.IO.Class-import qualified Control.Monad.Trans.State.Lazy-                     as Lazy+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+import qualified Control.Monad.Trans.Order.Lazy as Lazy+import qualified Control.Monad.Trans.Order.Lazy.Type as Lazy  -- Data  import Data.Functor.Identity+import Data.Order.Algorithm+import Data.Order.Algorithm.Type+import Data.Order.Internals (OrderRep, localOrderRep, Element)  -- * The Order monad @@ -79,7 +73,7 @@ evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where -    monad = evalStateT stateT (emptyOrderRep rawAlg)+    monad = evalStateT stateT (localOrderRep rawAlg)  force :: Monad m => OrderT o m () force = lazyToStrictOrderT Lazy.force@@ -93,10 +87,10 @@ newMaximum = lazyToStrictOrderT Lazy.newMaximum  newAfter :: Monad m => Element o -> OrderT o m (Element o)-newAfter = lazyToStrictOrderT . Lazy.newAfter+newAfter elem = lazyToStrictOrderT (Lazy.newAfter elem)  newBefore :: Monad m => Element o -> OrderT o m (Element o)-newBefore = lazyToStrictOrderT . Lazy.newBefore+newBefore elem = lazyToStrictOrderT (Lazy.newBefore elem)  -- * Converting between lazy and strict OrderT 
+ src/library/Data/Order.hs view
@@ -0,0 +1,25 @@+module Data.Order (++    -- * Orders++    Global,++    -- * Elements++    Element++) where++-- Data++import Data.Order.Internals++-- * Orders++-- NOTE: Global is imported from Data.Order.Internals.++-- * Elements++{-NOTE:+    Element and its class instantiations are imported from Data.Order.Internals.+-}
+ src/library/Data/Order/Algorithm.hs view
@@ -0,0 +1,109 @@+module Data.Order.Algorithm (++    -- * General things++    Algorithm,+    defaultAlgorithm,+    withRawAlgorithm,++    -- * Specific algorithms++    dumb,+    dietzSleatorAmortizedLog,+    dietzSleatorAmortizedLogWithSize++) where++-- Control++import Control.Monad.ST++-- Data++import           Data.Order.Algorithm.Type+import           Data.Order.Raw+import           Data.Order.Raw.Algorithm+import qualified Data.Order.Raw.Algorithm.Dumb+                 as Dumb+import qualified Data.Order.Raw.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 = Algorithm defaultRawAlgorithm++withRawAlgorithm :: Algorithm+                 -> (forall a . RawAlgorithm a s -> ST s r)+                 -> ST s r+withRawAlgorithm (Algorithm rawAlg) cont = cont rawAlg++-- * Specific algorithms++dumb :: Algorithm+dumb = Algorithm Dumb.rawAlgorithm++dietzSleatorAmortizedLog :: Algorithm+dietzSleatorAmortizedLog = Algorithm DietzSleatorAmortizedLog.rawAlgorithm++dietzSleatorAmortizedLogWithSize :: Int -> Algorithm+dietzSleatorAmortizedLogWithSize size+    = Algorithm (DietzSleatorAmortizedLog.rawAlgorithmWithSize size)
+ src/library/Data/Order/Algorithm/Type.hs view
@@ -0,0 +1,9 @@+module Data.Order.Algorithm.Type (++    Algorithm (Algorithm)++) where++import Data.Order.Raw++data Algorithm = forall a . Algorithm (forall s . RawAlgorithm a s)
+ src/library/Data/Order/Internals.hs view
@@ -0,0 +1,151 @@+module Data.Order.Internals (++    -- * Order representations++    OrderRep (OrderRep),+    newOrderRep,+    localOrderRep,++    -- * Algorithms of orders++    AlgorithmOf,+    Local,+    Global,++    -- * Elements++    Element (Element),+    newMinimum,+    newMaximum,+    newAfter,+    newBefore++) where++-- Control++import Control.Monad.ST+import Control.Concurrent.MVar+import Control.Exception++-- Data++import           Data.IORef+import           Data.Order.Raw+                 hiding (newMinimum, newMaximum, newAfter, newBefore)+import qualified Data.Order.Raw as Raw+import           Data.Order.Raw.Algorithm++-- System++import System.IO.Unsafe++-- GHC++import GHC.IORef -- for converting from STRef RealWorld to IORef++-- * Algorithms of orders++type family AlgorithmOf o++data Local a++type instance AlgorithmOf (Local a) = a++data Global++type instance AlgorithmOf Global = DefaultAlgorithm++-- * Order representations++data OrderRep o = OrderRep (RawAlgorithm (AlgorithmOf o) RealWorld)+                           (Gate (AlgorithmOf o))+{-NOTE:+    When using OrderT, evaluation of the OrderRep constructor triggers the I/O+    for insertions.+-}++newOrderRep :: (forall s . RawAlgorithm (AlgorithmOf o) s) -> IO (OrderRep o)+newOrderRep rawAlg = do+    rawOrder <- stToIO $ Raw.newOrder rawAlg+    gate <- newGate rawOrder+    return (OrderRep rawAlg gate)++{-# NOINLINE localOrderRep #-}+localOrderRep :: (forall s . RawAlgorithm a s) -> OrderRep (Local a)+localOrderRep rawAlg = unsafePerformIO $ newOrderRep rawAlg++-- * Elements++data Element o = Element (RawAlgorithm (AlgorithmOf o) RealWorld)+                         (Gate (AlgorithmOf o))+                         (RawElement (AlgorithmOf o) RealWorld)+{-NOTE:+    When using OrderT, 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++    {-# NOINLINE compare #-}+    compare (Element rawAlg gate rawElem1)+            (Element _      _    rawElem2) = unsafePerformIO $+                                             withRawOrder gate $ \ rawOrder ->+                                             stToIO $+                                             compareElements rawAlg+                                                             rawOrder+                                                             rawElem1+                                                             rawElem2++newMinimum :: OrderRep o -> IO (Element o)+newMinimum = fromRawNew Raw.newMinimum++newMaximum :: OrderRep o -> IO (Element o)+newMaximum = fromRawNew Raw.newMaximum++newAfter :: Element o -> OrderRep o -> IO (Element o)+newAfter = fromRawNeighbor Raw.newAfter++newBefore :: Element o -> OrderRep o -> IO (Element o)+newBefore = fromRawNeighbor Raw.newBefore++fromRawNeighbor :: (RawAlgorithm (AlgorithmOf o) RealWorld+                        -> RawOrder (AlgorithmOf o) RealWorld+                        -> RawElement (AlgorithmOf o) RealWorld+                        -> ST RealWorld (RawElement (AlgorithmOf o) RealWorld))+                -> Element o+                -> OrderRep o+                -> IO (Element o)+fromRawNeighbor rawNewNeighbor (Element _ _ rawElem) = fromRawNew rawNew where++    rawNew rawAlg rawOrder = rawNewNeighbor rawAlg rawOrder rawElem++fromRawNew :: (RawAlgorithm (AlgorithmOf o) RealWorld+                   -> RawOrder (AlgorithmOf o) RealWorld+                   -> ST RealWorld (RawElement (AlgorithmOf o) RealWorld))+           -> OrderRep o+           -> IO (Element o)+fromRawNew rawNew (OrderRep rawAlg gate) = 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)++-- * 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
+ src/library/Data/Order/Raw.hs view
@@ -0,0 +1,51 @@+module Data.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.+-}
+ src/library/Data/Order/Raw/Algorithm.hs view
@@ -0,0 +1,15 @@+module Data.Order.Raw.Algorithm (++    type DefaultAlgorithm,+    defaultRawAlgorithm++) where++import Data.Order.Raw+import Data.Order.Raw.Algorithm.DietzSleatorAmortizedLog+       as DietzSleatorAmortizedLog++type DefaultAlgorithm = DietzSleatorAmortizedLog.Algorithm++defaultRawAlgorithm :: RawAlgorithm DefaultAlgorithm s+defaultRawAlgorithm = DietzSleatorAmortizedLog.rawAlgorithm
+ src/library/Data/Order/Raw/Algorithm/DietzSleatorAmortizedLog.hs view
@@ -0,0 +1,170 @@+module Data.Order.Raw.Algorithm.DietzSleatorAmortizedLog (++    Algorithm,+    rawAlgorithm,+    rawAlgorithmWithSize++) where++-- Control++import Control.Applicative+import Control.Monad+import Control.Monad.ST++-- Data++import Data.STRef+import Data.Word+import Data.Bits+import Data.Order.Raw++data Algorithm++type instance OrderCell Algorithm s = Cell s++type instance ElementCell Algorithm 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++rawAlgorithm :: RawAlgorithm Algorithm s+rawAlgorithm = rawAlgorithmWithSize defaultSize++defaultSize :: Int+defaultSize = 63++rawAlgorithmWithSize :: Int -> RawAlgorithm Algorithm 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)
+ src/library/Data/Order/Raw/Algorithm/Dumb.hs view
@@ -0,0 +1,99 @@+module Data.Order.Raw.Algorithm.Dumb (++    Algorithm,+    rawAlgorithm++) where++-- Control++import Control.Applicative+import Control.Monad.ST++-- Data++import           Data.Ratio+import           Data.STRef+import qualified Data.Set as Set+import           Data.Set (Set)+import           Data.Order.Raw++data Algorithm++type instance OrderCell Algorithm s = PureOrder++type instance ElementCell Algorithm s = PureElement++type PureOrder = Set PureElement++type PureElement = Rational++rawAlgorithm :: RawAlgorithm Algorithm 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 Algorithm 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 Algorithm s+               -> ST s (RawElement Algorithm 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 Algorithm s -> ST s b)+         -> (PureOrder -> PureElement -> a)+         -> RawOrder Algorithm s+         -> RawElement Algorithm 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)
src/test-suites/TestSuite.hs view
@@ -10,11 +10,6 @@ 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 @@ -22,6 +17,9 @@ import qualified Data.Set as Set import           Data.Map (Map) import qualified Data.Map as Map+import           Data.Order.Algorithm (Algorithm, withRawAlgorithm)+import qualified Data.Order.Algorithm as Algorithm+import           Data.Order.Raw  -- Test