packages feed

order-maintenance 0.1.1.1 → 0.2.1.0

raw patch · 29 files changed

Files

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,15 +1,15 @@ Name:          order-maintenance-Version:       0.1.1.1+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.1.1.1/order-maintenance-0.1.1.1.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.@@ -19,43 +19,50 @@ 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.1.1.1+    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.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.Lazy                      Control.Monad.Trans.Order.Strict-                     Data.Order+                     Data.Order.Pair+                     Data.Order.Element+                     Data.Order.Element.IO                      Data.Order.Algorithm-                     Data.Order.Raw+                     Data.Order.Algorithm.Raw                      System.IO.Order      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.Internals-                   Data.Order.Raw.Algorithm-                   Data.Order.Raw.Algorithm.DietzSleatorAmortizedLog-                   Data.Order.Raw.Algorithm.Dumb+                   Data.Order.Algorithm.Raw.Default+                   Data.Order.Algorithm.Raw.Dumb+                   Data.Order.Algorithm.Raw.DietzSleatorAmortizedLog      HS-Source-Dirs: src/library @@ -69,7 +76,7 @@                    containers            >= 0.5  && < 0.6,                    QuickCheck            >= 2.6  && < 3,                    transformers          >= 0.3  && < 0.6,-                   order-maintenance     == 0.1.1.1+                   order-maintenance     == 0.2.1.0      Default-Language: Haskell2010
src/library/Control/Monad/Trans/Order/Lazy.hs view
@@ -3,17 +3,16 @@     -- * The Order monad      Order,-    evalOrder,-    evalOrderWith,+    perform,      -- * The OrderT monad transformer      OrderT,-    evalOrderT,-    evalOrderTWith,-    force,+    performT,+    getOrderToken,+    lift, -    -- * Elements+    -- * Element creation      newMinimum,     newMaximum,@@ -24,30 +23,18 @@  -- Control -import Control.Monad.Trans.State.Lazy-import Control.Monad.Trans.Order.Lazy.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.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+import Data.Functor.Identity+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 @@ -56,54 +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.Type.--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 (localOrderRep rawAlg)+-- NOTE: OrderT is imported from Control.Trans.Order.Lazy.Type. -force :: Monad m => OrderT o m ()-force = OrderT $ get >>= \ order -> order `seq` return ()+performT :: Functor f+         => (a -> OrderT o f b)+         -> OrderPair o a+         -> f (OrderPair o b)+performT fun (OrderPair ~(val, orderRep)) = output where --- * Elements+    output = OrderTRep.performT (runOrderT . fun) val orderRep -newMinimum :: Monad m => OrderT o m (Element o)-newMinimum = fromRepNew Internals.newMinimum+getOrderToken :: Applicative f => OrderT o f ()+getOrderToken = OrderT $ OrderTRep.getOrderToken -newMaximum :: Monad m => OrderT o m (Element o)-newMaximum = fromRepNew Internals.newMaximum+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.+-} -newAfter :: Monad m => Element o -> OrderT o m (Element o)-newAfter elem = fromRepNew (Internals.newAfter elem)+-- * Element creation -newBefore :: Monad m => Element o -> OrderT o m (Element o)-newBefore elem = fromRepNew (Internals.newBefore elem)+newMinimum :: Applicative f => OrderT o f (Element o)+newMinimum = OrderT $ OrderTRep.newMinimum -fromRepNew :: Monad m-           => (OrderRep o -> IO (Element o))-           -> OrderT o m (Element o)-fromRepNew repNew = OrderT $ state statefulNew where+newMaximum :: Applicative f => OrderT o f (Element o)+newMaximum = OrderT $ OrderTRep.newMaximum -    statefulNew orderRep = (elem, elem `seq` orderRep) where+newAfter :: Applicative f => Element o -> OrderT o f (Element o)+newAfter elem = OrderT $ OrderTRep.newAfter elem -        {-# NOINLINE elem #-}-        elem = unsafePerformIO $ repNew orderRep+newBefore :: Applicative f => Element o -> OrderT o f (Element o)+newBefore elem = OrderT $ OrderTRep.newBefore elem
src/library/Control/Monad/Trans/Order/Lazy/Type.hs view
@@ -1,27 +1,88 @@ module Control.Monad.Trans.Order.Lazy.Type ( -    OrderT (OrderT)+    OrderT (OrderT, runOrderT)  ) where --- Control+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) -import Control.Monad-import Control.Applicative-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Control.Monad.Trans.State.Lazy+newtype OrderT o m a = OrderT {+            runOrderT :: OrderTRep Lazy.StateT o m a+        } deriving (+            Functor,+            Applicative,+            Alternative,+            Monad,+            MonadPlus,+            MonadFix,+            MonadTrans,+            MonadIO+        ) --- Data+instance StateMonadTrans Lazy.StateT where -import Data.Order.Internals+    -- Construction and destruction -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?+    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/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,17 +3,15 @@     -- * The Order monad      Order,-    evalOrder,-    evalOrderWith,+    perform,      -- * The OrderT monad transformer      OrderT,-    evalOrderT,-    evalOrderTWith,-    force,+    performT,+    getOrderToken, -    -- * Elements+    -- * Element creation      newMinimum,     newMaximum,@@ -29,73 +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 qualified Control.Monad.Trans.Order.Lazy as Lazy-import qualified Control.Monad.Trans.Order.Lazy.Type as Lazy+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.Algorithm-import Data.Order.Algorithm.Type-import Data.Order.Internals (OrderRep, localOrderRep, Element)+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 (localOrderRep 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 elem = lazyToStrictOrderT (Lazy.newAfter elem)+    -- Applicative -newBefore :: Monad m => Element o -> OrderT o m (Element o)-newBefore elem = lazyToStrictOrderT (Lazy.newBefore elem)+    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.hs 
@@ -1,25 +0,0 @@-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
@@ -1,13 +1,13 @@ module Data.Order.Algorithm ( -    -- * General things+    -- * Algorithms in general      Algorithm,-    defaultAlgorithm,     withRawAlgorithm,      -- * Specific algorithms +    defaultAlgorithm,     dumb,     dietzSleatorAmortizedLog,     dietzSleatorAmortizedLogWithSize@@ -21,12 +21,13 @@ -- 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+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:@@ -84,19 +85,19 @@         of 2^64 elements. -} --- * General things+-- * Algorithms in general  -- 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+                 -> (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
+ 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
@@ -4,6 +4,6 @@  ) where -import Data.Order.Raw+import Data.Order.Algorithm.Raw -data Algorithm = forall a . Algorithm (forall s . RawAlgorithm a s)+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/Internals.hs 
@@ -1,150 +0,0 @@-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--    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/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/Raw.hs 
@@ -1,51 +0,0 @@-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 
@@ -1,15 +0,0 @@-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 
@@ -1,170 +0,0 @@-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 
@@ -1,99 +0,0 @@-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/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
@@ -9,27 +9,27 @@  -- Data -import           Data.Order-import           Data.Order.Internals (OrderRep, newOrderRep)-import qualified Data.Order.Internals as Internals-import           Data.Order.Raw.Algorithm+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 Global)-newMinimum = Internals.newMinimum globalOrderRep+newMinimum :: IO Element+newMinimum = Element <$> ElementRep.newMinimum orderRep -newMaximum :: IO (Element Global)-newMaximum = Internals.newMaximum globalOrderRep+newMaximum :: IO Element+newMaximum = Element <$> ElementRep.newMaximum orderRep -newAfter :: Element Global -> IO (Element Global)-newAfter elem = Internals.newAfter elem globalOrderRep+newAfter :: Element -> IO Element+newAfter (Element elemRep) = Element <$> ElementRep.newAfter elemRep orderRep -newBefore :: Element Global -> IO (Element Global)-newBefore elem = Internals.newBefore elem globalOrderRep+newBefore :: Element -> IO Element+newBefore (Element elemRep) = Element <$> ElementRep.newBefore elemRep orderRep -{-# NOINLINE globalOrderRep #-}-globalOrderRep :: OrderRep Global-globalOrderRep = unsafePerformIO $ newOrderRep defaultRawAlgorithm+{-# NOINLINE orderRep #-}+orderRep :: OrderRep Default.OrderCell Default.ElementCell+orderRep = unsafePerformIO $ newOrderRep Default.rawAlgorithm
src/test-suites/TestSuite.hs view
@@ -19,7 +19,7 @@ import qualified Data.Map as Map import           Data.Order.Algorithm (Algorithm, withRawAlgorithm) import qualified Data.Order.Algorithm as Algorithm-import           Data.Order.Raw+import           Data.Order.Algorithm.Raw  -- Test @@ -75,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@@ -89,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@@ -101,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"@@ -130,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@@ -145,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@@ -164,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