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 +14/−11
- src/library/Control/Monad/Trans/Order/Algorithm.hs +0/−102
- src/library/Control/Monad/Trans/Order/Algorithm/DietzSleatorAmortizedLog.hs +0/−185
- src/library/Control/Monad/Trans/Order/Algorithm/Dumb.hs +0/−102
- src/library/Control/Monad/Trans/Order/Algorithm/Type.hs +0/−9
- src/library/Control/Monad/Trans/Order/Lazy.hs +24/−79
- src/library/Control/Monad/Trans/Order/Lazy/Internals.hs +0/−66
- src/library/Control/Monad/Trans/Order/Lazy/Type.hs +27/−0
- src/library/Control/Monad/Trans/Order/Raw.hs +0/−51
- src/library/Control/Monad/Trans/Order/Strict.hs +10/−16
- src/library/Data/Order.hs +25/−0
- src/library/Data/Order/Algorithm.hs +109/−0
- src/library/Data/Order/Algorithm/Type.hs +9/−0
- src/library/Data/Order/Internals.hs +151/−0
- src/library/Data/Order/Raw.hs +51/−0
- src/library/Data/Order/Raw/Algorithm.hs +15/−0
- src/library/Data/Order/Raw/Algorithm/DietzSleatorAmortizedLog.hs +170/−0
- src/library/Data/Order/Raw/Algorithm/Dumb.hs +99/−0
- src/test-suites/TestSuite.hs +3/−5
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