order-maintenance 0.0.1.0 → 0.2.1.0
raw patch · 29 files changed
Files
- LICENSE +23/−20
- order-maintenance.cabal +35/−24
- 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 +37/−111
- src/library/Control/Monad/Trans/Order/Lazy/Internals.hs +0/−66
- src/library/Control/Monad/Trans/Order/Lazy/Type.hs +88/−0
- src/library/Control/Monad/Trans/Order/Raw.hs +0/−51
- src/library/Control/Monad/Trans/Order/Representation.hs +254/−0
- src/library/Control/Monad/Trans/Order/Strict.hs +133/−53
- src/library/Data/Order/Algorithm.hs +110/−0
- src/library/Data/Order/Algorithm/Raw.hs +47/−0
- src/library/Data/Order/Algorithm/Raw/Default.hs +20/−0
- src/library/Data/Order/Algorithm/Raw/DietzSleatorAmortizedLog.hs +169/−0
- src/library/Data/Order/Algorithm/Raw/Dumb.hs +106/−0
- src/library/Data/Order/Algorithm/Type.hs +9/−0
- src/library/Data/Order/Element.hs +11/−0
- src/library/Data/Order/Element/IO.hs +11/−0
- src/library/Data/Order/Element/IO/Type.hs +13/−0
- src/library/Data/Order/Element/Representation.hs +87/−0
- src/library/Data/Order/Element/Type.hs +29/−0
- src/library/Data/Order/Gate.hs +25/−0
- src/library/Data/Order/Pair.hs +41/−0
- src/library/Data/Order/Pair/Type.hs +17/−0
- src/library/Data/Order/Representation.hs +27/−0
- src/library/System/IO/Order.hs +35/−0
- src/test-suites/TestSuite.hs +21/−23
LICENSE view
@@ -1,27 +1,30 @@-Copyright © 2014, 2015 Denis Firsov, © 2014, 2015 Wolfgang Jeltsch+Copyright © 2014–2015 Denis Firsov, © 2014–2017 Wolfgang Jeltsch All rights reserved. -Redistribution and use in source and binary forms, with or without modification,-are permitted provided that the following conditions are met:+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met: - • Redistributions of source code must retain the above copyright notice,- this list of conditions and the following disclaimer.+ • Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer. - • Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+ • Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution. • Neither the name of the copyright holders nor the names of the- contributors may be used to endorse or promote products derived from this- software without specific prior written permission.+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR-TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF-THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS+IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED+TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
order-maintenance.cabal view
@@ -1,57 +1,68 @@ Name: order-maintenance-Version: 0.0.1.0+Version: 0.2.1.0 Cabal-Version: >= 1.16 Build-Type: Simple License: BSD3 License-File: LICENSE-Copyright: © 2014, 2015 Denis Firsov; © 2014, 2015 Wolfgang Jeltsch+Copyright: © 2014–2015 Denis Firsov; © 2014–2017 Wolfgang Jeltsch Author: Wolfgang Jeltsch-Maintainer: wolfgang@cs.ioc.ee+Maintainer: wolfgang-it@jeltsch.info 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+Homepage: http://hackage.haskell.org/package/order-maintenance+Package-URL: http://hackage.haskell.org/package/order-maintenance-0.2.1.0/order-maintenance-0.2.1.0.tar.gz Synopsis: Algorithms for the order maintenance problem with a safe interface Description: This package is about order maintenance. Category: Data-Tested-With: GHC == 7.10.1+Tested-With: GHC == 8.0.1 Source-Repository head Type: darcs- Location: http://darcs.wolfgang.jeltsch.info/haskell/order-maintenance/main+ Location: http://hub.darcs.net/jeltsch/order-maintenance Source-Repository this Type: darcs- Location: http://darcs.wolfgang.jeltsch.info/haskell/order-maintenance/main- Tag: order-maintenance-0.0.1.0+ Location: http://hub.darcs.net/jeltsch/order-maintenance+ Tag: order-maintenance-0.2.1.0 Library - Build-Depends: base >= 3.0 && < 5,+ Build-Depends: base >= 4.8 && < 5, containers >= 0.5 && < 0.6,- transformers >= 0.3 && < 0.5+ transformers >= 0.3 && < 0.6 Default-Language: Haskell2010 - Default-Extensions: EmptyDataDecls- ExistentialQuantification- FlexibleContexts+ Default-Extensions: ExistentialQuantification GeneralizedNewtypeDeriving- RankNTypes- TypeFamilies+ KindSignatures+ Rank2Types+ TupleSections 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.Pair+ Data.Order.Element+ Data.Order.Element.IO+ Data.Order.Algorithm+ Data.Order.Algorithm.Raw+ System.IO.Order - 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+ Control.Monad.Trans.Order.Representation+ Data.Order.Pair.Type+ Data.Order.Element.Type+ Data.Order.Element.IO.Type+ Data.Order.Representation+ Data.Order.Element.Representation+ Data.Order.Gate+ Data.Order.Algorithm.Type+ Data.Order.Algorithm.Raw.Default+ Data.Order.Algorithm.Raw.Dumb+ Data.Order.Algorithm.Raw.DietzSleatorAmortizedLog HS-Source-Dirs: src/library @@ -64,8 +75,8 @@ cabal-test-quickcheck >= 0.1 && < 0.2, containers >= 0.5 && < 0.6, QuickCheck >= 2.6 && < 3,- transformers >= 0.3 && < 0.5,- order-maintenance == 0.0.1.0+ transformers >= 0.3 && < 0.6,+ order-maintenance == 0.2.1.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
@@ -3,18 +3,17 @@ -- * The Order monad Order,- evalOrder,- evalOrderWith,+ perform, -- * The OrderT monad transformer OrderT,- evalOrderT,- force,+ performT,+ getOrderToken,+ lift, - -- * Elements+ -- * Element creation - Element, newMinimum, newMaximum, newAfter,@@ -24,36 +23,18 @@ -- 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.Applicative+import Control.Monad.Trans.Order.Lazy.Type+import qualified Control.Monad.Trans.Order.Representation as OrderTRep -- Data import Data.Functor.Identity-import Data.IORef---- System--import System.IO.Unsafe---- GHC--import GHC.IORef -- for converting from STRef RealWorld to IORef+import Data.Order.Pair.Type+import Data.Order.Element {-FIXME:- Introduce conversions between the lazy and the strict variant, similar to- the conversions for ST.--}-{-FIXME:- Consider introducing a restricted variant of mapStateT (for the lazy and the- strict OrderT monad):+ Consider introducing a restricted variant of mapStateT: mapOrderT :: (forall a . m a -> n a) -> OrderT o m a -> OrderT o n a @@ -62,103 +43,48 @@ -} {-FIXME: Probably we should also have variants of liftCallCC, etc., which are present- for StateT (for the lazy and the strict OrderT monad).+ for StateT. -} -- * The Order monad type Order o = OrderT o Identity -evalOrder :: (forall o . Order o a) -> a-evalOrder order = runIdentity (evalOrderT order)--evalOrderWith :: Algorithm -> (forall o . Order o a) -> a-evalOrderWith alg order = runIdentity (evalOrderTWith alg order)+perform :: (a -> Order o b) -> OrderPair o a -> OrderPair o b+perform fun pair = runIdentity (performT fun pair) -- * The OrderT monad transformer --- NOTE: OrderT is imported from Control.Monad.Trans.Order.Lazy.Internals.--evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a-evalOrderT = evalOrderTWith defaultAlgorithm--evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a-evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where-- monad = evalStateT stateT (emptyOrderRep rawAlg)--force :: Monad m => OrderT o m ()-force = OrderT $ get >>= \ order -> order `seq` return ()---- * Elements--data Element o = Element (RawAlgorithm o RealWorld)- (Gate o)- (RawElement o RealWorld)--- NOTE: Evaluation of the Element constructor triggers the I/O for insertions.--instance Eq (Element o) where-- (==) (Element (RawAlgorithm _ _ _ _ _ _ _) _ rawElem1)- (Element _ _ rawElem2) = equal where+-- NOTE: OrderT is imported from Control.Trans.Order.Lazy.Type. - equal = rawElem1 == rawElem2+performT :: Functor f+ => (a -> OrderT o f b)+ -> OrderPair o a+ -> f (OrderPair o b)+performT fun (OrderPair ~(val, orderRep)) = output where -instance Ord (Element o) where+ output = OrderTRep.performT (runOrderT . fun) val orderRep - compare (Element rawAlg gate rawElem1)- (Element _ _ rawElem2) = ordering where+getOrderToken :: Applicative f => OrderT o f ()+getOrderToken = OrderT $ OrderTRep.getOrderToken - 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.+lift :: Functor f => f a -> OrderT o f a+lift struct = OrderT $ OrderTRep.lift struct+{-NOTE:+ This version is more general than the one from MonadTrans, since it works+ with arbitrary functors, not just monads. -} -fromRawNew :: Monad m- => (RawAlgorithm o RealWorld- -> RawOrder o RealWorld- -> ST RealWorld (RawElement o RealWorld))- -> OrderT o m (Element o)-fromRawNew rawNew = OrderT $ StateT (return . explicitStateNew) where-- explicitStateNew order@(OrderRep rawAlg gate) = output where-- output = unsafePerformIO $- withRawOrder gate $ \ rawOrder ->- do- rawElem <- stToIO $ rawNew rawAlg rawOrder- mkWeakIORef (IORef rawElem)- (withRawOrder gate $ \ rawOrder ->- stToIO $- delete rawAlg rawOrder rawElem)- return (Element rawAlg gate rawElem, order)- {-FIXME:- Introduce the safety measures for unsafePerformIO. The I/O must occur only- once.- -}--newMinimum :: Monad m => OrderT o m (Element o)-newMinimum = fromRawNew Raw.newMinimum--newMaximum :: Monad m => OrderT o m (Element o)-newMaximum = fromRawNew Raw.newMaximum+-- * Element creation -newAfter :: Monad m => Element o -> OrderT o m (Element o)-newAfter (~(Element _ _ rawElem)) = fromRawNeighbor Raw.newAfter rawElem+newMinimum :: Applicative f => OrderT o f (Element o)+newMinimum = OrderT $ OrderTRep.newMinimum -newBefore :: Monad m => Element o -> OrderT o m (Element o)-newBefore (~(Element _ _ rawElem)) = fromRawNeighbor Raw.newBefore rawElem+newMaximum :: Applicative f => OrderT o f (Element o)+newMaximum = OrderT $ OrderTRep.newMaximum -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+newAfter :: Applicative f => Element o -> OrderT o f (Element o)+newAfter elem = OrderT $ OrderTRep.newAfter elem - rawNew rawAlg rawOrder = rawNewNeighbor rawAlg rawOrder rawElem+newBefore :: Applicative f => Element o -> OrderT o f (Element o)+newBefore elem = OrderT $ OrderTRep.newBefore elem
− 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,88 @@+module Control.Monad.Trans.Order.Lazy.Type (++ OrderT (OrderT, runOrderT)++) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import qualified Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.Order.Representation hiding (lift)++newtype OrderT o m a = OrderT {+ runOrderT :: OrderTRep Lazy.StateT o m a+ } deriving (+ Functor,+ Applicative,+ Alternative,+ Monad,+ MonadPlus,+ MonadFix,+ MonadTrans,+ MonadIO+ )++instance StateMonadTrans Lazy.StateT where++ -- Construction and destruction++ stateT = Lazy.StateT++ runStateT = Lazy.runStateT++ -- Functor++ fmap' = fmap++ (<$!) = (<$)++ -- Applicative++ pure' = pure++ (<*>!) = (<*>)++ (*>!) = (*>)++ (<*!) = (<*)++ -- Alternative++ empty' = empty++ (<|>!) = (<|>)++ some' = some++ many' = many++ -- Monad++ (>>=!) = (>>=)++ (>>!) = (>>)++ return' = return++ fail' = fail++ -- MonadPlus++ mzero' = mzero++ mplus' = mplus++ -- MonadFix++ mfix' = mfix++ -- MonadTrans++ lift' = lift++ -- MonadIO++ liftIO' = liftIO
− 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/Representation.hs view
@@ -0,0 +1,254 @@+module Control.Monad.Trans.Order.Representation (++ -- * The OrderTRep monad transformer++ OrderTRep (OrderTRep),+ performT,+ getOrderToken,+ lift,++ -- * Element creation++ newMinimum,+ newMaximum,+ newAfter,+ newBefore,++ -- * State monad transformers++ state,+ StateMonadTrans (..)++) where++-- Control++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.Class (MonadTrans)+import qualified Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class++-- Data++import Data.Order.Pair.Type+import Data.Order.Element.Type+import Data.Order.Representation+import Data.Order.Element.Representation (ElementRep)+import qualified Data.Order.Element.Representation as ElementRep++-- System++import System.IO.Unsafe++-- Unsafe++import Unsafe.Coerce++-- Fixities++infixl 4 <$!+infixl 4 <*>!+infixl 4 *>!+infixl 4 <*!+infixl 3 <|>!+infixl 1 >>=!+infixl 1 >>!++-- * The OrderTRep monad transformer++newtype OrderTRep t o (m :: * -> *) a = OrderTRep {+ runOrderTRep :: forall o' e' . t (OrderRep o' e') m a+}+{-NOTE:+ There are two type variables named o. The parameter o of OrderT is the tag+ that is used to make the user interface safe. The universally quantified+ variable o is the type of order cells used by the respective algorithm.+-}++instance (StateMonadTrans t, Functor f) => Functor (OrderTRep t o f) where++ fmap fun (OrderTRep comp) = OrderTRep $ fmap' fun comp++ val <$ OrderTRep comp = OrderTRep $ val <$! comp++instance (StateMonadTrans t, Monad f) => Applicative (OrderTRep t o f) where++ pure val = OrderTRep $ pure' val++ OrderTRep funComp <*> OrderTRep valComp = OrderTRep $ funComp <*>! valComp++ OrderTRep comp1 *> OrderTRep comp2 = OrderTRep $ comp1 *>! comp2++ OrderTRep comp1 <* OrderTRep comp2 = OrderTRep $ comp1 <*! comp2++instance (StateMonadTrans t, MonadPlus m) => Alternative (OrderTRep t o m) where++ empty = OrderTRep $ empty'++ OrderTRep comp1 <|> OrderTRep comp2 = OrderTRep $ comp1 <|>! comp2++ some (OrderTRep comp) = OrderTRep $ some' comp++ many (OrderTRep comp) = OrderTRep $ many' comp++instance (StateMonadTrans t, Monad m) => Monad (OrderTRep t o m) where++ OrderTRep comp >>= fun = OrderTRep $ comp >>=! runOrderTRep . fun++ OrderTRep comp1 >> OrderTRep comp2 = OrderTRep $ comp1 >>! comp2++ return val = OrderTRep $ return' val++ fail msg = OrderTRep $ fail' msg++instance (StateMonadTrans t, MonadPlus m) => MonadPlus (OrderTRep t o m) where++ mzero = OrderTRep $ mzero'++ mplus (OrderTRep comp1) (OrderTRep comp2) = OrderTRep $ mplus' comp1 comp2++instance (StateMonadTrans t, MonadFix m) => MonadFix (OrderTRep t o m) where++ mfix fun = OrderTRep $ mfix' (runOrderTRep . fun)++instance StateMonadTrans t => MonadTrans (OrderTRep t o) where++ lift struct = OrderTRep $ lift' struct++instance (StateMonadTrans t, MonadIO m) => MonadIO (OrderTRep t o m) where++ liftIO io = OrderTRep $ liftIO' io++performT :: (StateMonadTrans t, Functor f)+ => (a -> OrderTRep t o f b)+ -> a+ -> OrderRep o' e'+ -> f (OrderPair o b)+performT fun val orderRep = OrderPair <$> struct where++ struct = (runStateT $ runOrderTRep $ fun val) orderRep++getOrderToken :: (StateMonadTrans t, Applicative f) => OrderTRep t o f ()+getOrderToken = OrderTRep $ state $ \ orderRep -> (orderRep `seq` (), orderRep)++lift :: (StateMonadTrans t, Functor f) => f a -> OrderTRep t o f a+lift struct = OrderTRep $ stateT $ \ orderRep -> (, orderRep) <$> struct+{-NOTE:+ This version is more general than the one from MonadTrans, since it works+ with arbitrary functors, not just monads.+-}++-- * Element creation++newMinimum :: (StateMonadTrans t, Applicative f)+ => OrderTRep t o f (Element o)+newMinimum = fromRepNew ElementRep.newMinimum++newMaximum :: (StateMonadTrans t, Applicative f)+ => OrderTRep t o f (Element o)+newMaximum = fromRepNew ElementRep.newMaximum++newAfter :: (StateMonadTrans t, Applicative f)+ => Element o+ -> OrderTRep t o f (Element o)+newAfter (Element elemRep) = fromRepNewNeighbor ElementRep.newAfter elemRep++newBefore :: (StateMonadTrans t, Applicative f)+ => Element o+ -> OrderTRep t o f (Element o)+newBefore (Element elemRep) = fromRepNewNeighbor ElementRep.newBefore elemRep++fromRepNewNeighbor :: (StateMonadTrans t, Applicative f)+ => (forall o' e' . ElementRep o' e' ->+ OrderRep o' e' ->+ IO (ElementRep o' e'))+ -> ElementRep o'' e''+ -> OrderTRep t o f (Element o)+fromRepNewNeighbor repNewNeighbor elemRep = orderTRep where++ orderTRep = fromRepNew (repNewNeighbor (unsafeCoerce elemRep))++fromRepNew :: (StateMonadTrans t, Applicative f)+ => (forall o' e' . OrderRep o' e' -> IO (ElementRep o' e'))+ -> OrderTRep t o f (Element o)+fromRepNew repNew = OrderTRep $ state fun where++ fun orderRep = (elem, elem `seq` orderRep) where++ {-# NOINLINE elem #-}+ elem = unsafePerformIO $ Element <$> repNew orderRep++-- * State monad transformers++state :: (StateMonadTrans t, Applicative f) => (s -> (a, s)) -> t s f a+state fun = stateT $ pure . fun++{-NOTE:+ We cannot write constraints like (forall m . Monad m => Monad t s m) to+ constrain t. So we introduce the class StateMonadTrans, which has, for+ example, monad operations for t s m with a constraint Monad m, witnessing+ that t s m is a monad if m is.+-}+class StateMonadTrans t where++ -- Construction and running++ stateT :: (s -> f (a, s)) -> t s f a++ runStateT :: t s f a -> s -> f (a, s)++ -- Functor++ fmap' :: Functor f => (a -> b) -> t s f a -> t s f b++ (<$!) :: Functor f => b -> t s f a -> t s f b++ -- Applicative++ pure' :: Monad m => a -> t s m a++ (<*>!) :: Monad m => t s m (a -> b) -> t s m a -> t s m b++ (*>!) :: Monad m => t s m a -> t s m b -> t s m b++ (<*!) :: Monad m => t s m a -> t s m b -> t s m a++ -- Alternative++ empty' :: MonadPlus m => t s m a++ (<|>!) :: MonadPlus m => t s m a -> t s m a -> t s m a++ some' :: MonadPlus m => t s m a -> t s m [a]++ many' :: MonadPlus m => t s m a -> t s m [a]++ -- Monad++ (>>=!) :: Monad m => t s m a -> (a -> t s m b) -> t s m b++ (>>!) :: Monad m => t s m a -> t s m b -> t s m b++ return' :: Monad m => a -> t s m a++ fail' :: Monad m => String -> t s m a++ -- MonadPlus++ mzero' :: MonadPlus m => t s m a++ mplus' :: MonadPlus m => t s m a -> t s m a -> t s m a++ -- MonadFix++ mfix' :: MonadFix m => (a -> t s m a) -> t s m a++ -- MonadTrans++ lift' :: Monad m => m a -> t s m a++ -- MonadIO++ liftIO' :: MonadIO m => IO a -> t s m a
src/library/Control/Monad/Trans/Order/Strict.hs view
@@ -3,18 +3,16 @@ -- * The Order monad Order,- evalOrder,- evalOrderWith,+ perform, -- * The OrderT monad transformer OrderT,- evalOrderT,- force,+ performT,+ getOrderToken, - -- * Elements+ -- * Element creation - Element, newMinimum, newMaximum, newAfter,@@ -29,79 +27,161 @@ -- Control -import Control.Monad import Control.Applicative-import Control.Monad.Trans.Class+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.Class (MonadTrans)+import qualified Control.Monad.Trans.Class as Trans (lift) import Control.Monad.IO.Class-import qualified Control.Monad.Trans.State.Lazy- as Lazy-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Order.Lazy- (Element)-import qualified Control.Monad.Trans.Order.Lazy- as Lazy-import Control.Monad.Trans.Order.Lazy.Internals- (OrderRep, emptyOrderRep)-import qualified Control.Monad.Trans.Order.Lazy.Internals- as Lazy-import Control.Monad.Trans.Order.Algorithm-import Control.Monad.Trans.Order.Algorithm.Type+import qualified Control.Monad.Trans.State.Strict as Strict+import Control.Monad.Trans.Order.Representation+ (OrderTRep (OrderTRep), StateMonadTrans (..))+import qualified Control.Monad.Trans.Order.Representation as OrderTRep+import qualified Control.Monad.Trans.Order.Lazy.Type as Lazy (OrderT (OrderT)) -- Data import Data.Functor.Identity+import Data.Order.Pair.Type+import Data.Order.Element +{-FIXME:+ Consider introducing a restricted variant of mapStateT:++ mapOrderT :: (forall a . m a -> n a) -> OrderT o m a -> OrderT o n a++ Maybe this should not be called mapOrderT, since it is only a restricted+ variant and a corresponding mapOrder would be trivial.+-}+{-FIXME:+ Probably we should also have variants of liftCallCC, etc., which are present+ for StateT.+-}+ -- * The Order monad type Order o = OrderT o Identity -evalOrder :: (forall o . Order o a) -> a-evalOrder order = runIdentity (evalOrderT order)--evalOrderWith :: Algorithm -> (forall o . Order o a) -> a-evalOrderWith alg order = runIdentity (evalOrderTWith alg order)+perform :: (a -> Order o b) -> OrderPair o a -> OrderPair o b+perform fun pair = runIdentity (performT fun pair) -- * The OrderT monad transformer -newtype OrderT o m a = OrderT (StateT (OrderRep o) m a) deriving (- Functor,- Applicative,- Alternative,- Monad,- MonadPlus,- MonadTrans,- MonadIO)- -- FIXME: Should we also have a MonadFix instance?+newtype OrderT o m a = OrderT {+ runOrderT :: OrderTRep Strict.StateT o m a+ } deriving (+ Functor,+ Applicative,+ Alternative,+ Monad,+ MonadPlus,+ MonadFix,+ MonadTrans,+ MonadIO+ ) -evalOrderT :: Monad m => (forall o . OrderT o m a) -> m a-evalOrderT = evalOrderTWith defaultAlgorithm+instance StateMonadTrans Strict.StateT where -evalOrderTWith :: Monad m => Algorithm -> (forall o . OrderT o m a) -> m a-evalOrderTWith (Algorithm rawAlg) (OrderT stateT) = monad where+ -- Construction and destruction - monad = evalStateT stateT (emptyOrderRep rawAlg)+ stateT = Strict.StateT -force :: Monad m => OrderT o m ()-force = lazyToStrictOrderT Lazy.force+ runStateT = Strict.runStateT --- * Elements+ -- Functor -newMinimum :: Monad m => OrderT o m (Element o)-newMinimum = lazyToStrictOrderT Lazy.newMinimum+ fmap' = fmap -newMaximum :: Monad m => OrderT o m (Element o)-newMaximum = lazyToStrictOrderT Lazy.newMaximum+ (<$!) = (<$) -newAfter :: Monad m => Element o -> OrderT o m (Element o)-newAfter = lazyToStrictOrderT . Lazy.newAfter+ -- Applicative -newBefore :: Monad m => Element o -> OrderT o m (Element o)-newBefore = lazyToStrictOrderT . Lazy.newBefore+ pure' = pure + (<*>!) = (<*>)++ (*>!) = (*>)++ (<*!) = (<*)++ -- Alternative++ empty' = empty++ (<|>!) = (<|>)++ some' = some++ many' = many++ -- Monad++ (>>=!) = (>>=)++ (>>!) = (>>)++ return' = return++ fail' = fail++ -- MonadPlus++ mzero' = mzero++ mplus' = mplus++ -- MonadFix++ mfix' = mfix++ -- MonadTrans++ lift' = Trans.lift++ -- MonadIO++ liftIO' = liftIO++performT :: Functor f+ => (a -> OrderT o f b)+ -> OrderPair o a+ -> f (OrderPair o b)+performT fun (OrderPair (val, orderRep)) = output where++ output = OrderTRep.performT (runOrderT . fun) val orderRep++getOrderToken :: Applicative f => OrderT o f ()+getOrderToken = OrderT $ OrderTRep.getOrderToken++lift :: Functor f => f a -> OrderT o f a+lift struct = OrderT $ OrderTRep.lift struct+{-NOTE:+ This version is more general than the one from MonadTrans, since it works+ with arbitrary functors, not just monads.+-}++-- * Element creation++newMinimum :: Applicative f => OrderT o f (Element o)+newMinimum = OrderT $ OrderTRep.newMinimum++newMaximum :: Applicative f => OrderT o f (Element o)+newMaximum = OrderT $ OrderTRep.newMaximum++newAfter :: Applicative f => Element o -> OrderT o f (Element o)+newAfter elem = OrderT $ OrderTRep.newAfter elem++newBefore :: Applicative f => Element o -> OrderT o f (Element o)+newBefore elem = OrderT $ OrderTRep.newBefore elem+ -- * Converting between lazy and strict OrderT lazyToStrictOrderT :: Lazy.OrderT o m a -> OrderT o m a-lazyToStrictOrderT (Lazy.OrderT (Lazy.StateT fun)) = OrderT (StateT fun)+lazyToStrictOrderT (Lazy.OrderT (OrderTRep comp)) = strictOrderT where + strictOrderT = OrderT $ OrderTRep $ stateT (runStateT comp)+ strictToLazyOrderT :: OrderT o m a -> Lazy.OrderT o m a-strictToLazyOrderT (OrderT (StateT fun)) = Lazy.OrderT (Lazy.StateT fun)+strictToLazyOrderT (OrderT (OrderTRep comp)) = lazyOrderT where++ lazyOrderT = Lazy.OrderT $ OrderTRep $ stateT (runStateT comp)
+ src/library/Data/Order/Algorithm.hs view
@@ -0,0 +1,110 @@+module Data.Order.Algorithm (++ -- * Algorithms in general++ Algorithm,+ withRawAlgorithm,++ -- * Specific algorithms++ defaultAlgorithm,+ dumb,+ dietzSleatorAmortizedLog,+ dietzSleatorAmortizedLogWithSize++) where++-- Control++import Control.Monad.ST++-- Data++import Data.Order.Algorithm.Type+import Data.Order.Algorithm.Raw+import qualified Data.Order.Algorithm.Raw.Default+ as Default+import qualified Data.Order.Algorithm.Raw.Dumb+ as Dumb+import qualified Data.Order.Algorithm.Raw.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.+-}++-- * Algorithms in general++-- NOTE: Algorithm is imported from Data.OrderMaintenance.Algorithm.Type.++withRawAlgorithm :: Algorithm+ -> (forall o e . (forall s . RawAlgorithm s o e) -> r)+ -> r+withRawAlgorithm (Algorithm rawAlg) cont = cont rawAlg++-- * Specific algorithms++defaultAlgorithm :: Algorithm+defaultAlgorithm = Algorithm Default.rawAlgorithm++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/Raw.hs view
@@ -0,0 +1,47 @@+module Data.Order.Algorithm.Raw (++ RawOrder,+ RawElement,+ RawAlgorithm (+ RawAlgorithm,+ newOrder,+ compareElements,+ newMinimum,+ newMaximum,+ newAfter,+ newBefore,+ delete+ )++) where++-- Control++import Control.Monad.ST++-- Data++import Data.STRef++type RawOrder s o = STRef s (o s)++type RawElement s e = STRef s (e s)++data RawAlgorithm s o e = RawAlgorithm {+ newOrder :: ST s (RawOrder s o),+ compareElements :: RawElement s e -> RawElement s e -> RawOrder s o -> ST s Ordering,+ newMinimum :: RawOrder s o -> ST s (RawElement s e),+ newMaximum :: RawOrder s o -> ST s (RawElement s e),+ newAfter :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),+ newBefore :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),+ delete :: RawElement s e -> RawOrder s o -> 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/Algorithm/Raw/Default.hs view
@@ -0,0 +1,20 @@+module Data.Order.Algorithm.Raw.Default (++ OrderCell,+ ElementCell,+ rawAlgorithm++) where++-- Data++import Data.Order.Algorithm.Raw+import qualified Data.Order.Algorithm.Raw.DietzSleatorAmortizedLog+ as DietzSleatorAmortizedLog++type OrderCell = DietzSleatorAmortizedLog.OrderCell++type ElementCell = DietzSleatorAmortizedLog.ElementCell++rawAlgorithm :: RawAlgorithm s OrderCell ElementCell+rawAlgorithm = DietzSleatorAmortizedLog.rawAlgorithm
+ src/library/Data/Order/Algorithm/Raw/DietzSleatorAmortizedLog.hs view
@@ -0,0 +1,169 @@+module Data.Order.Algorithm.Raw.DietzSleatorAmortizedLog (++ OrderCell,+ ElementCell,+ rawAlgorithm,+ rawAlgorithmWithSize++) where++-- Control++import Control.Applicative+import Control.Monad+import Control.Monad.ST++-- Data++import Data.Order.Algorithm.Raw+import Data.Word+import Data.Bits+import Data.STRef++type OrderCell = Cell++type ElementCell = Cell++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 s OrderCell ElementCell+rawAlgorithm = rawAlgorithmWithSize defaultSize++defaultSize :: Int+defaultSize = 63++rawAlgorithmWithSize :: Int -> RawAlgorithm s OrderCell ElementCell+rawAlgorithmWithSize size+ | size < 0 || size >= labelWordSize+ = error "Data.Order.Algorithm.dietzSleatorAmortizedLogWithSize: \+ \Size out of bounds"+ | otherwise+ = RawAlgorithm {+ newOrder = fixST $+ \ ref -> newSTRef $ Cell {+ label = initialBaseLabel,+ next = ref,+ prev = ref+ },+ compareElements = \ ref1 ref2 baseRef -> 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 "Data.Order.Algorithm.\+ \dietzSleatorAmortizedLogWithSize: \+ \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 ix = when (ref /= delimRef) $ do+ cell <- readSTRef ref+ let lbl = labelSum+ (label startCell)+ (Label (ix * smallGap + min largeGapCount ix))+ writeSTRef ref (cell { label = lbl })+ changeLabels (next cell) (succ ix)+ 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/Algorithm/Raw/Dumb.hs view
@@ -0,0 +1,106 @@+module Data.Order.Algorithm.Raw.Dumb (++ OrderCell,+ ElementCell,+ rawAlgorithm++) where++-- Control++import Control.Applicative+import Control.Monad.ST++-- Data++import Data.Order.Algorithm.Raw+import Data.Ratio+import Data.Set (Set)+import qualified Data.Set as Set+import Data.STRef++newtype OrderCell s = OrderCell (Set Label)++newtype ElementCell s = ElementCell Label++type Label = Rational++rawAlgorithm :: RawAlgorithm s OrderCell ElementCell+rawAlgorithm = RawAlgorithm {+ newOrder = newSTRef (OrderCell Set.empty),+ compareElements = \ rawElem1 rawElem2 _ -> do+ ElementCell label1 <- readSTRef rawElem1+ ElementCell label2 <- readSTRef rawElem2+ return (compare label1 label2),+ newMinimum = fromPureInsert pureInsertMinimum,+ newMaximum = fromPureInsert pureInsertMaximum,+ newAfter = relative fromPureInsert pureInsertAfter,+ newBefore = relative fromPureInsert pureInsertBefore,+ delete = relative fromPure pureDelete+}++fromPure :: (OrderCell s -> (a, OrderCell s))+ -> RawOrder s OrderCell+ -> ST s a+fromPure trans rawOrder = do+ orderCell <- readSTRef rawOrder+ let (output, orderCell') = trans orderCell+ writeSTRef rawOrder orderCell'+ return output++fromPureInsert :: (OrderCell s -> ElementCell s)+ -> RawOrder s OrderCell+ -> ST s (RawElement s ElementCell)+fromPureInsert trans rawOrder = fromPure trans' rawOrder >>= newSTRef where++ trans' orderCell@(OrderCell labels) = (elemCell, orderCell') where++ elemCell@(ElementCell label) = trans orderCell++ orderCell'= OrderCell (Set.insert label labels)++relative :: ((OrderCell s -> a) -> RawOrder s OrderCell -> ST s b)+ -> (ElementCell s -> OrderCell s -> a)+ -> RawElement s ElementCell+ -> RawOrder s OrderCell+ -> ST s b+relative conv trans rawElem rawOrder = do+ elemCell <- readSTRef rawElem+ conv (trans elemCell) rawOrder++pureInsertMinimum :: OrderCell s -> ElementCell s+pureInsertMinimum (OrderCell labels) = ElementCell label where++ label | Set.null labels = 1 % 2+ | otherwise = Set.findMin labels / 2++pureInsertMaximum :: OrderCell s -> ElementCell s+pureInsertMaximum (OrderCell labels) = ElementCell label where++ label | Set.null labels = 1 % 2+ | otherwise = (Set.findMax labels + 1) / 2++pureInsertAfter :: ElementCell s -> OrderCell s -> ElementCell s+pureInsertAfter (ElementCell label)+ (OrderCell labels) = ElementCell label' where++ greater = snd (Set.split label labels)++ label' | Set.null greater = (label + 1) / 2+ | otherwise = (label + Set.findMin greater) / 2++pureInsertBefore :: ElementCell s -> OrderCell s -> ElementCell s+pureInsertBefore (ElementCell label)+ (OrderCell labels) = ElementCell label' where+++ lesser = fst (Set.split label labels)++ label' | Set.null lesser = label / 2+ | otherwise = (label + Set.findMax lesser) / 2++pureDelete :: ElementCell s -> OrderCell s -> ((), OrderCell s)+pureDelete (ElementCell label)+ (OrderCell labels) = ((), OrderCell labels') where++ labels' = Set.delete label labels
+ src/library/Data/Order/Algorithm/Type.hs view
@@ -0,0 +1,9 @@+module Data.Order.Algorithm.Type (++ Algorithm (Algorithm)++) where++import Data.Order.Algorithm.Raw++data Algorithm = forall o e . Algorithm (forall s . RawAlgorithm s o e)
+ src/library/Data/Order/Element.hs view
@@ -0,0 +1,11 @@+module Data.Order.Element (++ Element++) where++-- Data++import Data.Order.Element.Type++-- NOTE: Element is imported from Data.Order.Element.Type.
+ src/library/Data/Order/Element/IO.hs view
@@ -0,0 +1,11 @@+module Data.Order.Element.IO (++ Element++) where++-- Data++import Data.Order.Element.IO.Type++-- NOTE: Element is imported from Data.Order.Element.IO.Type.
+ src/library/Data/Order/Element/IO/Type.hs view
@@ -0,0 +1,13 @@+module Data.Order.Element.IO.Type (++ Element (Element)++) where++-- Data++import Data.Order.Element.Representation+import qualified Data.Order.Algorithm.Raw.Default as Default++newtype Element = Element (ElementRep Default.OrderCell Default.ElementCell)+ deriving (Eq, Ord)
+ src/library/Data/Order/Element/Representation.hs view
@@ -0,0 +1,87 @@+module Data.Order.Element.Representation (++ ElementRep (ElementRep),+ newMinimum,+ newMaximum,+ newAfter,+ newBefore++) where++-- Control++import Control.Monad.ST++-- Data++import Data.Order.Representation+import Data.Order.Algorithm.Raw (RawOrder, RawElement, RawAlgorithm)+import qualified Data.Order.Algorithm.Raw as Raw+import Data.Order.Gate+import Data.IORef++-- System++import System.IO.Unsafe++-- GHC++import GHC.IORef (IORef (IORef))++data ElementRep o e = ElementRep (RawAlgorithm RealWorld o e)+ (Gate o)+ (RawElement RealWorld e)+{-NOTE:+ When using OrderT, reduction of an ElementRep value to WHNF triggers the I/O+ for insertions.+-}++instance Eq (ElementRep o e) where++ ElementRep _ _ rawElem1 == ElementRep _ _ rawElem2 = rawElem1 == rawElem2++instance Ord (ElementRep o e) where++ compare (ElementRep rawAlg gate rawElem1)+ (ElementRep _ _ rawElem2) = ordering where+ + ordering = unsafePerformIO $+ withRawOrder gate $ \ rawOrder ->+ stToIO $+ Raw.compareElements rawAlg rawElem1 rawElem2 rawOrder++newMinimum :: OrderRep o e -> IO (ElementRep o e)+newMinimum = fromRawNew Raw.newMinimum++newMaximum :: OrderRep o e -> IO (ElementRep o e)+newMaximum = fromRawNew Raw.newMaximum++newAfter :: ElementRep o e -> OrderRep o e -> IO (ElementRep o e)+newAfter = fromRawNewNeighbor Raw.newAfter++newBefore :: ElementRep o e -> OrderRep o e -> IO (ElementRep o e)+newBefore = fromRawNewNeighbor Raw.newBefore++fromRawNewNeighbor :: (RawAlgorithm RealWorld o e ->+ RawElement RealWorld e ->+ RawOrder RealWorld o ->+ ST RealWorld (RawElement RealWorld e))+ -> ElementRep o e+ -> OrderRep o e+ -> IO (ElementRep o e)+fromRawNewNeighbor rawNewNeighbor (ElementRep _ _ rawElem) = fromRawNew rawNew where++ rawNew rawAlg = rawNewNeighbor rawAlg rawElem++fromRawNew :: (RawAlgorithm RealWorld o e ->+ RawOrder RealWorld o ->+ ST RealWorld (RawElement RealWorld e))+ -> OrderRep o e+ -> IO (ElementRep o e)+fromRawNew rawNew (OrderRep rawAlg gate) = withRawOrder gate $ \ rawOrder -> do+ rawElem <- stToIO $ rawNew rawAlg rawOrder+ mkWeakIORef (IORef rawElem)+ (withRawOrder gate $ \ rawOrder ->+ stToIO $+ Raw.delete rawAlg rawElem rawOrder)+ return (ElementRep rawAlg gate rawElem)
+ src/library/Data/Order/Element/Type.hs view
@@ -0,0 +1,29 @@+module Data.Order.Element.Type (++ Element (Element)++) where++-- Data++import Data.Order.Element.Representation++-- Unsafe++import Unsafe.Coerce++data Element o = forall o e . Element !(ElementRep o e)+{-NOTE:+ When using OrderT, reduction of an Element value to WHNF triggers the I/O+ for insertions.+-}++instance Eq (Element o) where++ Element elemRep1 == Element elemRep2 = elemRep1 == unsafeCoerce elemRep2++instance Ord (Element o) where++ compare (Element elemRep1) (Element elemRep2) = ordering where++ ordering = compare elemRep1 (unsafeCoerce elemRep2)
+ src/library/Data/Order/Gate.hs view
@@ -0,0 +1,25 @@+module Data.Order.Gate (++ Gate,+ newGate,+ withRawOrder++) where++-- Control++import Control.Monad.ST+import Control.Exception+import Control.Concurrent.MVar++-- Data++import Data.Order.Algorithm.Raw++newtype Gate o = Gate (MVar (RawOrder RealWorld o))++newGate :: RawOrder RealWorld o -> IO (Gate o)+newGate rawOrder = Gate <$> newMVar rawOrder++withRawOrder :: Gate o -> (RawOrder RealWorld o -> IO r) -> IO r+withRawOrder (Gate mVar) cont = bracket (takeMVar mVar) (putMVar mVar) cont
+ src/library/Data/Order/Pair.hs view
@@ -0,0 +1,41 @@+module Data.Order.Pair (++ OrderPair,+ emptyOrderPair,+ emptyOrderPairUsing,+ withoutOrder++) where++-- Control++import Control.Monad.ST++-- Data++import Data.Order.Pair.Type+import Data.Order.Representation+import Data.Order.Algorithm+import Data.Order.Algorithm.Type+import Data.Order.Algorithm.Raw++-- System++import System.IO.Unsafe++-- NOTE: OrderPair is imported from Data.Order.Pair.Type.++emptyOrderPair :: a -> OrderPair o a+emptyOrderPair = emptyOrderPairUsing defaultAlgorithm++emptyOrderPairUsing :: Algorithm -> a -> OrderPair o a+emptyOrderPairUsing (Algorithm rawAlg) val = orderPair where++ orderPair = OrderPair (val, emptyOrderRepUsing rawAlg)++{-# NOINLINE emptyOrderRepUsing #-}+emptyOrderRepUsing :: RawAlgorithm RealWorld o e -> OrderRep o e+emptyOrderRepUsing rawAlg = unsafePerformIO $ newOrderRep rawAlg++withoutOrder :: (forall o . OrderPair o a) -> a+withoutOrder (OrderPair (comp, _)) = comp
+ src/library/Data/Order/Pair/Type.hs view
@@ -0,0 +1,17 @@+module Data.Order.Pair.Type (++ OrderPair (OrderPair)++) where++-- Data++import Data.Order.Representation++data OrderPair o a = forall o' e' . OrderPair (a, OrderRep o' e')++instance Functor (OrderPair o) where++ fmap fun (OrderPair (val, orderRep)) = OrderPair (fun val, orderRep)++ val <$ OrderPair (_, orderRep) = OrderPair (val, orderRep)
+ src/library/Data/Order/Representation.hs view
@@ -0,0 +1,27 @@+module Data.Order.Representation (++ OrderRep (OrderRep),+ newOrderRep++) where++-- Control++import Control.Monad.ST++-- Data++import Data.Order.Algorithm.Raw+import Data.Order.Gate++data OrderRep o e = OrderRep (RawAlgorithm RealWorld o e) (Gate o)+{-NOTE:+ When using OrderT, reduction of an OrderRep value to WHNF triggers the I/O+ for insertions.+-}++newOrderRep :: RawAlgorithm RealWorld o e -> IO (OrderRep o e)+newOrderRep rawAlg = do+ rawOrder <- stToIO $ newOrder rawAlg+ gate <- newGate rawOrder+ return (OrderRep rawAlg gate)
+ src/library/System/IO/Order.hs view
@@ -0,0 +1,35 @@+module System.IO.Order (++ newMinimum,+ newMaximum,+ newAfter,+ newBefore++) where++-- Data++import Data.Order.Element.IO.Type+import Data.Order.Representation+import qualified Data.Order.Element.Representation as ElementRep+import qualified Data.Order.Algorithm.Raw.Default as Default++-- System++import System.IO.Unsafe++newMinimum :: IO Element+newMinimum = Element <$> ElementRep.newMinimum orderRep++newMaximum :: IO Element+newMaximum = Element <$> ElementRep.newMaximum orderRep++newAfter :: Element -> IO Element+newAfter (Element elemRep) = Element <$> ElementRep.newAfter elemRep orderRep++newBefore :: Element -> IO Element+newBefore (Element elemRep) = Element <$> ElementRep.newBefore elemRep orderRep++{-# NOINLINE orderRep #-}+orderRep :: OrderRep Default.OrderCell Default.ElementCell+orderRep = unsafePerformIO $ newOrderRep Default.rawAlgorithm
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.Algorithm.Raw -- Test @@ -77,13 +75,13 @@ runComp :: Algorithm -> OrderComp -> ComparisonMatrix runComp alg comp = compMatrix where - compMatrix = runST (withRawAlgorithm alg (\ rawAlg -> execComp rawAlg comp))+ compMatrix = withRawAlgorithm alg (\ rawAlg -> runST $ execComp rawAlg comp) -data CompExecState a s = CompExecState (ElementMap a s) Int+data CompExecState s e = CompExecState (ElementMap s e) Int -type ElementMap a s = Map Int (RawElement a s)+type ElementMap s e = Map Int (RawElement s e) -execComp :: RawAlgorithm a s -> OrderComp -> ST s ComparisonMatrix+execComp :: RawAlgorithm s o e -> OrderComp -> ST s ComparisonMatrix execComp rawAlg (OrderComp stmts) = do rawOrder <- newOrder rawAlg let execStmts = mapM_ (execStmt rawAlg rawOrder) stmts@@ -91,7 +89,7 @@ ((), CompExecState elemMap _) <- runStateT execStmts initState let idElemPairs = Map.toList elemMap let comparisonPair (id1, elem1) (id2, elem2) = do- ordering <- compareElements rawAlg rawOrder elem1 elem2+ ordering <- compareElements rawAlg elem1 elem2 rawOrder return ((id1, id2), ordering) comparisonPairs <- sequence $ liftM2 comparisonPair idElemPairs idElemPairs return $ Map.fromList comparisonPairs@@ -103,11 +101,11 @@ | Delete Int newElemCount :: OrderStmt -> Int-newElemCount NewMinimum = 1-newElemCount NewMaximum = 1-newElemCount (NewAfter id) = 1-newElemCount (NewBefore id) = 1-newElemCount (Delete id) = 0+newElemCount NewMinimum = 1+newElemCount NewMaximum = 1+newElemCount (NewAfter _) = 1+newElemCount (NewBefore _) = 1+newElemCount (Delete _) = 0 showStmt :: OrderStmt -> Int -> String showStmt NewMinimum = showNewStmt "newMinimum"@@ -132,9 +130,9 @@ else frequency [ (1, return NewMinimum), (1, return NewMaximum),- (3, fmap NewAfter liveIdGen),- (3, fmap NewBefore liveIdGen),- (2, fmap Delete liveIdGen)+ (3, NewAfter <$> liveIdGen),+ (3, NewBefore <$> liveIdGen),+ (2, Delete <$> liveIdGen) ] let newStmtIds = (Set.singleton nextId, Set.empty) let (newIds, deadIds) = case stmt of@@ -147,10 +145,10 @@ (nextId + Set.size newIds) return stmt -execStmt :: RawAlgorithm a s- -> RawOrder a s+execStmt :: RawAlgorithm s o e+ -> RawOrder s o -> OrderStmt- -> StateT (CompExecState a s) (ST s) ()+ -> StateT (CompExecState s e) (ST s) () execStmt rawAlg rawOrder = exec where exec NewMinimum = execNew newMinimum@@ -166,12 +164,12 @@ execNewNeighbor newNeighbor id = do CompExecState elemMap _ <- get- let new rawAlg rawOrder = newNeighbor rawAlg rawOrder (elemMap Map.! id)+ let new rawAlg = newNeighbor rawAlg (elemMap Map.! id) execNew new execDelete id = do CompExecState elemMap nextId <- get- lift $ delete rawAlg rawOrder (elemMap Map.! id)+ lift $ delete rawAlg (elemMap Map.! id) rawOrder put $ CompExecState (Map.delete id elemMap) nextId -- * Named algorithms