module Reactive.Banana.Internal.TotalOrder (
TotalOrder, TotalOrderZipper,
open, close, fromAscList, ascend, descend, insertBeforeFocus, delete,
withTotalOrder,
Queue(..), insertList, isEmpty,
) where
import Control.Applicative
import Control.Arrow (second)
import qualified Data.List
import Data.Maybe
import Data.Ord
import Data.Hashable
import qualified Data.HashMap.Strict as Map
import qualified Data.Set as Set
type Map = Map.HashMap
type Set = Set.Set
newtype TotalOrder a = TO { unTO :: Map a Int }
data TotalOrderZipper a = TOZ { down :: [a], up :: [a] }
open :: TotalOrder a -> TotalOrderZipper a
open (TO order) = TOZ { down = [], up = Map.keys order }
close :: (Hashable a, Eq a) => TotalOrderZipper a -> TotalOrder a
close order = TO $ Map.fromList $ zip (reverse (down order) ++ up order) [1..]
fromAscList :: (Hashable a, Eq a) => [a] -> TotalOrder a
fromAscList xs = close $ TOZ { down = [], up = xs }
ascend :: TotalOrderZipper a -> TotalOrderZipper a
ascend (TOZ xs [] ) = TOZ xs []
ascend (TOZ xs (y:ys)) = TOZ (y:xs) ys
descend :: TotalOrderZipper a -> TotalOrderZipper a
descend (TOZ [] ys) = TOZ [] ys
descend (TOZ (x:xs) ys) = TOZ xs (x:ys)
insertBeforeFocus :: a -> TotalOrderZipper a -> TotalOrderZipper a
insertBeforeFocus x (TOZ xs ys) = TOZ (x:xs) ys
delete :: Eq a => a -> TotalOrderZipper a -> TotalOrderZipper a
delete x (TOZ xs ys) = TOZ (delete' x xs) (delete' x ys)
where delete' = Data.List.delete
withTotalOrder :: TotalOrder a -> (forall q. Queue q => q a -> b) -> b
withTotalOrder order f = f empty
where empty = Q { order = order, queue = Set.empty }
class Queue q where
insert :: (Hashable a, Eq a) => a -> q a -> q a
minView :: q a -> Maybe (a, q a)
size :: q a -> Int
isEmpty :: Queue q => q a -> Bool
isEmpty = isNothing . minView
insertList :: (Queue q, Hashable a, Eq a) => [a] -> q a -> q a
insertList xs q = foldl (flip insert) q xs
data MyQueue a = Q { order :: TotalOrder a, queue :: Set (Pair Int a) }
data Pair a b = Pair !a b
fstPair (Pair a _) = a
instance Eq a => Eq (Pair a b) where
x == y = fstPair x == fstPair y
instance Ord a => Ord (Pair a b) where
compare = comparing fstPair
setQueue :: MyQueue a -> Set (Pair Int a) -> MyQueue a
setQueue q b = q { queue = b }
position :: (Hashable a, Eq a) => TotalOrder a -> a -> Int
position (TO order) x = pos
where Just pos = Map.lookup x order
instance Queue MyQueue where
insert x q = q { queue = Set.insert (Pair pos x) (queue q) }
where pos = position (order q) x
minView q = f <$> Set.minView (queue q)
where f (Pair _ a,set) = (a, setQueue q set)
size q = Set.size (queue q)