{-# LANGUAGE DeriveGeneric #-}

{- Author: Arne Winter
   Date: 01/07/2022
   Description: Haskell implementation of interval tree clocks, as per the paper
   Almeida, Paulo & Baquero, Carlos & Fonte, Victor. (2008). Interval Tree Clocks: A Logical Clock for Dynamic Systems. 5401. 259-274. 10.1007/978-3-540-92221-6_18.
-}

{- | An interval tree clock implementation as per Interval Tree Clocks: A Logical Clock for Dynamic Systems.
   Paper by Almeida, Paulo & Baquero, Carlos & Fonte, Victor.
   This implementation by Arne Winter.
-}
module Data.Clock.IntervalTree (
    -- * Types
    Stamp (..),
    ITCId (..),
    ITCEvent (..),

    -- * Seed
    seed,

    -- * Operations
    fork,
    join,
    peek,
    event,

    -- * Comparison
    happenedBefore,
    StampComparison (..),
    stampCompare,
) where

import GHC.Generics

data Stamp = Stamp ITCId ITCEvent deriving (Stamp -> Stamp -> Bool
(Stamp -> Stamp -> Bool) -> (Stamp -> Stamp -> Bool) -> Eq Stamp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stamp -> Stamp -> Bool
$c/= :: Stamp -> Stamp -> Bool
== :: Stamp -> Stamp -> Bool
$c== :: Stamp -> Stamp -> Bool
Eq, Int -> Stamp -> ShowS
[Stamp] -> ShowS
Stamp -> String
(Int -> Stamp -> ShowS)
-> (Stamp -> String) -> ([Stamp] -> ShowS) -> Show Stamp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stamp] -> ShowS
$cshowList :: [Stamp] -> ShowS
show :: Stamp -> String
$cshow :: Stamp -> String
showsPrec :: Int -> Stamp -> ShowS
$cshowsPrec :: Int -> Stamp -> ShowS
Show, (forall x. Stamp -> Rep Stamp x)
-> (forall x. Rep Stamp x -> Stamp) -> Generic Stamp
forall x. Rep Stamp x -> Stamp
forall x. Stamp -> Rep Stamp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Stamp x -> Stamp
$cfrom :: forall x. Stamp -> Rep Stamp x
Generic)

data ITCId
    = ITCIdBranch ITCId ITCId
    | ITCIdOff
    | ITCIdOn
    deriving (ITCId -> ITCId -> Bool
(ITCId -> ITCId -> Bool) -> (ITCId -> ITCId -> Bool) -> Eq ITCId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ITCId -> ITCId -> Bool
$c/= :: ITCId -> ITCId -> Bool
== :: ITCId -> ITCId -> Bool
$c== :: ITCId -> ITCId -> Bool
Eq, Int -> ITCId -> ShowS
[ITCId] -> ShowS
ITCId -> String
(Int -> ITCId -> ShowS)
-> (ITCId -> String) -> ([ITCId] -> ShowS) -> Show ITCId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ITCId] -> ShowS
$cshowList :: [ITCId] -> ShowS
show :: ITCId -> String
$cshow :: ITCId -> String
showsPrec :: Int -> ITCId -> ShowS
$cshowsPrec :: Int -> ITCId -> ShowS
Show, (forall x. ITCId -> Rep ITCId x)
-> (forall x. Rep ITCId x -> ITCId) -> Generic ITCId
forall x. Rep ITCId x -> ITCId
forall x. ITCId -> Rep ITCId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ITCId x -> ITCId
$cfrom :: forall x. ITCId -> Rep ITCId x
Generic)

data ITCEvent
    = ITCEventBranch !Integer ITCEvent ITCEvent
    | ITCEventLeaf !Integer
    deriving (ITCEvent -> ITCEvent -> Bool
(ITCEvent -> ITCEvent -> Bool)
-> (ITCEvent -> ITCEvent -> Bool) -> Eq ITCEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ITCEvent -> ITCEvent -> Bool
$c/= :: ITCEvent -> ITCEvent -> Bool
== :: ITCEvent -> ITCEvent -> Bool
$c== :: ITCEvent -> ITCEvent -> Bool
Eq, Int -> ITCEvent -> ShowS
[ITCEvent] -> ShowS
ITCEvent -> String
(Int -> ITCEvent -> ShowS)
-> (ITCEvent -> String) -> ([ITCEvent] -> ShowS) -> Show ITCEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ITCEvent] -> ShowS
$cshowList :: [ITCEvent] -> ShowS
show :: ITCEvent -> String
$cshow :: ITCEvent -> String
showsPrec :: Int -> ITCEvent -> ShowS
$cshowsPrec :: Int -> ITCEvent -> ShowS
Show, (forall x. ITCEvent -> Rep ITCEvent x)
-> (forall x. Rep ITCEvent x -> ITCEvent) -> Generic ITCEvent
forall x. Rep ITCEvent x -> ITCEvent
forall x. ITCEvent -> Rep ITCEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ITCEvent x -> ITCEvent
$cfrom :: forall x. ITCEvent -> Rep ITCEvent x
Generic)

{- | The seed stamp.
   The first peer is to use this, then fork others.
-}
seed :: Stamp
seed :: Stamp
seed = ITCId -> ITCEvent -> Stamp
Stamp ITCId
iT (Integer -> ITCEvent
ITCEventLeaf Integer
0)

{- | use to register new peers.
   one stamp must be consecutively owned be the forking peer.
   the other stamp owned by host.
-}
fork :: Stamp -> (Stamp, Stamp)
fork :: Stamp -> (Stamp, Stamp)
fork (Stamp ITCId
i ITCEvent
e) = let (ITCId
i1, ITCId
i2) = ITCId -> (ITCId, ITCId)
split ITCId
i in (ITCId -> ITCEvent -> Stamp
Stamp ITCId
i1 ITCEvent
e, ITCId -> ITCEvent -> Stamp
Stamp ITCId
i2 ITCEvent
e)

{- | inverse of fork. s = uncurry join (fork s)
   Note that the internal call to `sumId` may be partial, if the ITC Stamp was constructed through direct constructor usage.
   Using only `fork` and `join` as the safe API to create stamps will not lead to this inconsistency.
-}
join :: Stamp -> Stamp -> Stamp
join :: Stamp -> Stamp -> Stamp
join (Stamp ITCId
i1 ITCEvent
e1) (Stamp ITCId
i2 ITCEvent
e2) = ITCId -> ITCEvent -> Stamp
Stamp (ITCId -> ITCId -> ITCId
sumId ITCId
i1 ITCId
i2) (ITCEvent -> ITCEvent -> ITCEvent
joinEv ITCEvent
e1 ITCEvent
e2)

{- | Anonymizes this stamp.
   Useful when sending messages or logging debug stamps.
-}
peek :: Stamp -> Stamp
peek :: Stamp -> Stamp
peek (Stamp ITCId
_ ITCEvent
e) = ITCId -> ITCEvent -> Stamp
Stamp ITCId
iF ITCEvent
e

{- | when something happened on this peer.
   use the new stamp afterwards.
-}
event :: Stamp -> Stamp
event :: Stamp -> Stamp
event s :: Stamp
s@(Stamp ITCId
i ITCEvent
e) =
    ITCId -> ITCEvent -> Stamp
Stamp ITCId
i (ITCEvent -> Stamp) -> ITCEvent -> Stamp
forall a b. (a -> b) -> a -> b
$
        if ITCEvent
potentiallyNew ITCEvent -> ITCEvent -> Bool
forall a. Eq a => a -> a -> Bool
/= ITCEvent
e
            then ITCEvent
potentiallyNew
            else ITCEvent
e'
  where
    potentiallyNew :: ITCEvent
potentiallyNew = ITCId -> ITCEvent -> ITCEvent
fill' ITCId
i ITCEvent
e
    (ITCEvent
e', Cost
_) = Stamp -> (ITCEvent, Cost)
grow' Stamp
s

data StampComparison
    = -- | A happened before B.
      Before
    | -- | A happened after B.
      After
    | -- | A happened concurrent to B in logical time.
      Concurrent
    deriving (StampComparison -> StampComparison -> Bool
(StampComparison -> StampComparison -> Bool)
-> (StampComparison -> StampComparison -> Bool)
-> Eq StampComparison
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StampComparison -> StampComparison -> Bool
$c/= :: StampComparison -> StampComparison -> Bool
== :: StampComparison -> StampComparison -> Bool
$c== :: StampComparison -> StampComparison -> Bool
Eq, Int -> StampComparison -> ShowS
[StampComparison] -> ShowS
StampComparison -> String
(Int -> StampComparison -> ShowS)
-> (StampComparison -> String)
-> ([StampComparison] -> ShowS)
-> Show StampComparison
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StampComparison] -> ShowS
$cshowList :: [StampComparison] -> ShowS
show :: StampComparison -> String
$cshow :: StampComparison -> String
showsPrec :: Int -> StampComparison -> ShowS
$cshowsPrec :: Int -> StampComparison -> ShowS
Show)

{- | Compare two stamps.
   Note that stamp is not an instance of Ord because a <= b and b <= a does not imply a = b:
   rather that a happened concurrent to b per logical time.
-}
stampCompare :: Stamp -> Stamp -> StampComparison
stampCompare :: Stamp -> Stamp -> StampComparison
stampCompare Stamp
s1 Stamp
s2
    | Stamp -> Stamp -> Bool
happenedBefore Stamp
s1 Stamp
s2 = StampComparison
Before
    | Stamp -> Stamp -> Bool
happenedBefore Stamp
s2 Stamp
s1 = StampComparison
After
    | Bool
otherwise = StampComparison
Concurrent

{- | the `happened before` relation for two stamps. (Note that I am unsure whether this is really the same relation as described by Lamport).
   Use this to examine causality of stamps.
-}
happenedBefore :: Stamp -> Stamp -> Bool
(Stamp ITCId
_ ITCEvent
e1) happenedBefore :: Stamp -> Stamp -> Bool
`happenedBefore` (Stamp ITCId
_ ITCEvent
e2) =
    (ITCEvent
e1 ITCEvent -> ITCEvent -> Bool
`evLeq` ITCEvent
e2) Bool -> Bool -> Bool
&& Bool -> Bool
not (ITCEvent
e2 ITCEvent -> ITCEvent -> Bool
`evLeq` ITCEvent
e1)

-- | some utility functions because the constructors are so verbose.
iF, iT :: ITCId
iF :: ITCId
iF = ITCId
ITCIdOff
iT :: ITCId
iT = ITCId
ITCIdOn

iB :: ITCId -> ITCId -> ITCId
iB :: ITCId -> ITCId -> ITCId
iB = ITCId -> ITCId -> ITCId
ITCIdBranch

normId :: ITCId -> ITCId
normId :: ITCId -> ITCId
normId (ITCIdBranch ITCId
ITCIdOff ITCId
ITCIdOff) = ITCId
iF
normId (ITCIdBranch ITCId
ITCIdOn ITCId
ITCIdOn) = ITCId
iT
normId ITCId
leaf = ITCId
leaf

sumId :: ITCId -> ITCId -> ITCId
sumId :: ITCId -> ITCId -> ITCId
sumId ITCId
ITCIdOff ITCId
i = ITCId
i
sumId ITCId
i ITCId
ITCIdOff = ITCId
i
sumId (ITCIdBranch ITCId
l1 ITCId
r1) (ITCIdBranch ITCId
l2 ITCId
r2) = ITCId -> ITCId
normId (ITCId -> ITCId -> ITCId
ITCIdBranch (ITCId -> ITCId -> ITCId
sumId ITCId
l1 ITCId
l2) (ITCId -> ITCId -> ITCId
sumId ITCId
r1 ITCId
r2))
sumId ITCId
_ ITCId
_ = String -> ITCId
forall a. HasCallStack => String -> a
error String
"internal consistency error. Create ID's only by means of fork and join."

split :: ITCId -> (ITCId, ITCId)
split :: ITCId -> (ITCId, ITCId)
split ITCId
ITCIdOff = (ITCId
iF, ITCId
iF)
split ITCId
ITCIdOn = (ITCId -> ITCId -> ITCId
iB ITCId
iT ITCId
iF, ITCId -> ITCId -> ITCId
iB ITCId
iF ITCId
iT)
split (ITCIdBranch ITCId
ITCIdOff ITCId
i) = (ITCId -> ITCId -> ITCId
iB ITCId
iF ITCId
i1, ITCId -> ITCId -> ITCId
iB ITCId
iF ITCId
i2) where (ITCId
i1, ITCId
i2) = ITCId -> (ITCId, ITCId)
split ITCId
i
split (ITCIdBranch ITCId
i ITCId
ITCIdOff) = (ITCId -> ITCId -> ITCId
iB ITCId
i1 ITCId
iF, ITCId -> ITCId -> ITCId
iB ITCId
i2 ITCId
iF) where (ITCId
i1, ITCId
i2) = ITCId -> (ITCId, ITCId)
split ITCId
i
split (ITCIdBranch ITCId
l ITCId
r) = (ITCId -> ITCId -> ITCId
iB ITCId
l ITCId
iF, ITCId -> ITCId -> ITCId
iB ITCId
iF ITCId
r)

fill' :: ITCId -> ITCEvent -> ITCEvent
fill' :: ITCId -> ITCEvent -> ITCEvent
fill' ITCId
ITCIdOff ITCEvent
e = ITCEvent
e
fill' ITCId
ITCIdOn ITCEvent
e = Integer -> ITCEvent
ITCEventLeaf (Integer -> ITCEvent) -> Integer -> ITCEvent
forall a b. (a -> b) -> a -> b
$ ITCEvent -> Integer
maxEv ITCEvent
e
fill' ITCId
_ n :: ITCEvent
n@(ITCEventLeaf Integer
_) = ITCEvent
n
fill' (ITCIdBranch ITCId
ITCIdOn ITCId
ir) (ITCEventBranch Integer
n ITCEvent
l ITCEvent
r) =
    ITCEvent -> ITCEvent
normEv (ITCEvent -> ITCEvent) -> ITCEvent -> ITCEvent
forall a b. (a -> b) -> a -> b
$
        Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch
            Integer
n
            (Integer -> ITCEvent
ITCEventLeaf (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (ITCEvent -> Integer
maxEv ITCEvent
l) (ITCEvent -> Integer
minEv ITCEvent
r')))
            ITCEvent
r'
  where
    r' :: ITCEvent
r' = ITCId -> ITCEvent -> ITCEvent
fill' ITCId
ir ITCEvent
r
fill' (ITCIdBranch ITCId
il ITCId
ITCIdOn) (ITCEventBranch Integer
n ITCEvent
l ITCEvent
r) =
    ITCEvent -> ITCEvent
normEv (ITCEvent -> ITCEvent) -> ITCEvent -> ITCEvent
forall a b. (a -> b) -> a -> b
$
        Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch
            Integer
n
            ITCEvent
l'
            (Integer -> ITCEvent
ITCEventLeaf (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (ITCEvent -> Integer
maxEv ITCEvent
r) (ITCEvent -> Integer
minEv ITCEvent
l')))
  where
    l' :: ITCEvent
l' = ITCId -> ITCEvent -> ITCEvent
fill' ITCId
il ITCEvent
l
fill' (ITCIdBranch ITCId
il ITCId
ir) (ITCEventBranch Integer
n ITCEvent
l ITCEvent
r) = ITCEvent -> ITCEvent
normEv (ITCEvent -> ITCEvent) -> ITCEvent -> ITCEvent
forall a b. (a -> b) -> a -> b
$ Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n (ITCId -> ITCEvent -> ITCEvent
fill' ITCId
il ITCEvent
l) (ITCId -> ITCEvent -> ITCEvent
fill' ITCId
ir ITCEvent
r)

newtype Cost = Cost Integer deriving (Cost -> Cost -> Bool
(Cost -> Cost -> Bool) -> (Cost -> Cost -> Bool) -> Eq Cost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cost -> Cost -> Bool
$c/= :: Cost -> Cost -> Bool
== :: Cost -> Cost -> Bool
$c== :: Cost -> Cost -> Bool
Eq, Eq Cost
Eq Cost
-> (Cost -> Cost -> Ordering)
-> (Cost -> Cost -> Bool)
-> (Cost -> Cost -> Bool)
-> (Cost -> Cost -> Bool)
-> (Cost -> Cost -> Bool)
-> (Cost -> Cost -> Cost)
-> (Cost -> Cost -> Cost)
-> Ord Cost
Cost -> Cost -> Bool
Cost -> Cost -> Ordering
Cost -> Cost -> Cost
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cost -> Cost -> Cost
$cmin :: Cost -> Cost -> Cost
max :: Cost -> Cost -> Cost
$cmax :: Cost -> Cost -> Cost
>= :: Cost -> Cost -> Bool
$c>= :: Cost -> Cost -> Bool
> :: Cost -> Cost -> Bool
$c> :: Cost -> Cost -> Bool
<= :: Cost -> Cost -> Bool
$c<= :: Cost -> Cost -> Bool
< :: Cost -> Cost -> Bool
$c< :: Cost -> Cost -> Bool
compare :: Cost -> Cost -> Ordering
$ccompare :: Cost -> Cost -> Ordering
$cp1Ord :: Eq Cost
Ord)

ltCost :: Cost -> Cost -> Bool
ltCost :: Cost -> Cost -> Bool
ltCost (Cost Integer
c1) (Cost Integer
c2) = Integer
c1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
c2

addCost :: Cost -> Cost -> Cost
addCost :: Cost -> Cost -> Cost
addCost (Cost Integer
c1) (Cost Integer
c2) = Integer -> Cost
Cost (Integer -> Cost) -> Integer -> Cost
forall a b. (a -> b) -> a -> b
$ Integer
c1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
c2

grow' :: Stamp -> (ITCEvent, Cost)
grow' :: Stamp -> (ITCEvent, Cost)
grow' (Stamp ITCId
ITCIdOn (ITCEventLeaf Integer
n)) =
    (Integer -> ITCEvent
ITCEventLeaf (Integer -> ITCEvent) -> Integer -> ITCEvent
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, Integer -> Cost
Cost Integer
0)
grow' (Stamp ITCId
i (ITCEventLeaf Integer
n)) =
    (ITCEvent
e', Cost
c Cost -> Cost -> Cost
`addCost` Cost
largeCost)
  where
    largeCost :: Cost
largeCost = Integer -> Cost
Cost Integer
1000
    (ITCEvent
e', Cost
c) = Stamp -> (ITCEvent, Cost)
grow' (Stamp -> (ITCEvent, Cost)) -> Stamp -> (ITCEvent, Cost)
forall a b. (a -> b) -> a -> b
$ ITCId -> ITCEvent -> Stamp
Stamp ITCId
i (Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n (Integer -> ITCEvent
ITCEventLeaf Integer
0) (Integer -> ITCEvent
ITCEventLeaf Integer
0))
grow' (Stamp (ITCIdBranch ITCId
ITCIdOff ITCId
i) (ITCEventBranch Integer
n ITCEvent
l ITCEvent
r)) =
    (Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n ITCEvent
l ITCEvent
r', Cost
cr Cost -> Cost -> Cost
`addCost` (Integer -> Cost
Cost Integer
1))
  where
    (ITCEvent
r', Cost
cr) = Stamp -> (ITCEvent, Cost)
grow' (Stamp -> (ITCEvent, Cost)) -> Stamp -> (ITCEvent, Cost)
forall a b. (a -> b) -> a -> b
$ ITCId -> ITCEvent -> Stamp
Stamp ITCId
i ITCEvent
r
grow' (Stamp (ITCIdBranch ITCId
i ITCId
ITCIdOff) (ITCEventBranch Integer
n ITCEvent
l ITCEvent
r)) =
    ((Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n ITCEvent
l' ITCEvent
r), Cost
cl Cost -> Cost -> Cost
`addCost` (Integer -> Cost
Cost Integer
1))
  where
    (ITCEvent
l', Cost
cl) = Stamp -> (ITCEvent, Cost)
grow' (Stamp -> (ITCEvent, Cost)) -> Stamp -> (ITCEvent, Cost)
forall a b. (a -> b) -> a -> b
$ ITCId -> ITCEvent -> Stamp
Stamp ITCId
i ITCEvent
l
grow' (Stamp (ITCIdBranch ITCId
il ITCId
ir) (ITCEventBranch Integer
n ITCEvent
l ITCEvent
r))
    | Cost
costL Cost -> Cost -> Bool
`ltCost` Cost
costR = ((Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n ITCEvent
l' ITCEvent
r), Cost
costL Cost -> Cost -> Cost
`addCost` (Integer -> Cost
Cost Integer
1))
    | Bool
otherwise = ((Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n ITCEvent
l ITCEvent
r'), Cost
costR Cost -> Cost -> Cost
`addCost` (Integer -> Cost
Cost Integer
1))
  where
    (ITCEvent
l', Cost
costL) = Stamp -> (ITCEvent, Cost)
grow' (Stamp -> (ITCEvent, Cost)) -> Stamp -> (ITCEvent, Cost)
forall a b. (a -> b) -> a -> b
$ ITCId -> ITCEvent -> Stamp
Stamp ITCId
il ITCEvent
l
    (ITCEvent
r', Cost
costR) = Stamp -> (ITCEvent, Cost)
grow' (Stamp -> (ITCEvent, Cost)) -> Stamp -> (ITCEvent, Cost)
forall a b. (a -> b) -> a -> b
$ ITCId -> ITCEvent -> Stamp
Stamp ITCId
ir ITCEvent
r

-- | event comparison.
evLeq :: ITCEvent -> ITCEvent -> Bool
(ITCEventLeaf Integer
n1) evLeq :: ITCEvent -> ITCEvent -> Bool
`evLeq` (ITCEventLeaf Integer
n2) = Integer
n1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n2
(ITCEventLeaf Integer
n1) `evLeq` (ITCEventBranch Integer
n2 ITCEvent
_ ITCEvent
_) = Integer
n1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n2
(ITCEventBranch Integer
n1 ITCEvent
l1 ITCEvent
r1) `evLeq` (ITCEventLeaf Integer
n2) =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
        [ Integer
n1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n2
        , (ITCEvent
l1 ITCEvent -> Integer -> ITCEvent
`liftEv` Integer
n1) ITCEvent -> ITCEvent -> Bool
`evLeq` (Integer -> ITCEvent
ITCEventLeaf Integer
n2)
        , (ITCEvent
r1 ITCEvent -> Integer -> ITCEvent
`liftEv` Integer
n1) ITCEvent -> ITCEvent -> Bool
`evLeq` (Integer -> ITCEvent
ITCEventLeaf Integer
n2)
        ]
(ITCEventBranch Integer
n1 ITCEvent
l1 ITCEvent
r1) `evLeq` (ITCEventBranch Integer
n2 ITCEvent
l2 ITCEvent
r2) =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
        [ Integer
n1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n2
        , (ITCEvent
l1 ITCEvent -> Integer -> ITCEvent
`liftEv` Integer
n1) ITCEvent -> ITCEvent -> Bool
`evLeq` (ITCEvent
l2 ITCEvent -> Integer -> ITCEvent
`liftEv` Integer
n2)
        , (ITCEvent
r1 ITCEvent -> Integer -> ITCEvent
`liftEv` Integer
n1) ITCEvent -> ITCEvent -> Bool
`evLeq` (ITCEvent
r2 ITCEvent -> Integer -> ITCEvent
`liftEv` Integer
n2)
        ]

liftEv, sinkEv :: ITCEvent -> Integer -> ITCEvent
liftEv :: ITCEvent -> Integer -> ITCEvent
liftEv (ITCEventLeaf Integer
n) Integer
m = Integer -> ITCEvent
ITCEventLeaf (Integer -> ITCEvent) -> Integer -> ITCEvent
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
m
liftEv (ITCEventBranch Integer
n ITCEvent
e1 ITCEvent
e2) Integer
m = Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
m) ITCEvent
e1 ITCEvent
e2
sinkEv :: ITCEvent -> Integer -> ITCEvent
sinkEv ITCEvent
e Integer
m = ITCEvent -> Integer -> ITCEvent
liftEv ITCEvent
e (- Integer
m)

joinEv :: ITCEvent -> ITCEvent -> ITCEvent
joinEv :: ITCEvent -> ITCEvent -> ITCEvent
joinEv (ITCEventLeaf Integer
n1) (ITCEventLeaf Integer
n2) = Integer -> ITCEvent
ITCEventLeaf (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
n1 Integer
n2)
joinEv (ITCEventLeaf Integer
n1) b :: ITCEvent
b@(ITCEventBranch Integer
_ ITCEvent
_ ITCEvent
_) = ITCEvent -> ITCEvent -> ITCEvent
joinEv (Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n1 (Integer -> ITCEvent
ITCEventLeaf Integer
0) (Integer -> ITCEvent
ITCEventLeaf Integer
0)) ITCEvent
b
joinEv b :: ITCEvent
b@(ITCEventBranch Integer
_ ITCEvent
_ ITCEvent
_) (ITCEventLeaf Integer
n1) = ITCEvent -> ITCEvent -> ITCEvent
joinEv ITCEvent
b (Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch Integer
n1 (Integer -> ITCEvent
ITCEventLeaf Integer
0) (Integer -> ITCEvent
ITCEventLeaf Integer
0))
joinEv b1 :: ITCEvent
b1@(ITCEventBranch Integer
n1 ITCEvent
_ ITCEvent
_) b2 :: ITCEvent
b2@(ITCEventBranch Integer
n2 ITCEvent
_ ITCEvent
_) | Integer
n1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
n2 = ITCEvent -> ITCEvent -> ITCEvent
joinEv ITCEvent
b2 ITCEvent
b1
joinEv (ITCEventBranch Integer
n1 ITCEvent
l1 ITCEvent
r1) (ITCEventBranch Integer
n2 ITCEvent
l2 ITCEvent
r2) =
    ITCEvent -> ITCEvent
normEv (ITCEvent -> ITCEvent) -> ITCEvent -> ITCEvent
forall a b. (a -> b) -> a -> b
$
        Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch
            Integer
n1
            (ITCEvent -> ITCEvent -> ITCEvent
joinEv ITCEvent
l1 (ITCEvent -> ITCEvent) -> ITCEvent -> ITCEvent
forall a b. (a -> b) -> a -> b
$ ITCEvent -> Integer -> ITCEvent
liftEv ITCEvent
l2 (Integer -> ITCEvent) -> Integer -> ITCEvent
forall a b. (a -> b) -> a -> b
$ Integer
n2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n1)
            (ITCEvent -> ITCEvent -> ITCEvent
joinEv ITCEvent
r1 (ITCEvent -> ITCEvent) -> ITCEvent -> ITCEvent
forall a b. (a -> b) -> a -> b
$ ITCEvent -> Integer -> ITCEvent
liftEv ITCEvent
r2 (Integer -> ITCEvent) -> Integer -> ITCEvent
forall a b. (a -> b) -> a -> b
$ Integer
n2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n1)

normEv :: ITCEvent -> ITCEvent
normEv :: ITCEvent -> ITCEvent
normEv n :: ITCEvent
n@(ITCEventLeaf Integer
_) = ITCEvent
n
normEv (ITCEventBranch Integer
n (ITCEventLeaf Integer
m) (ITCEventLeaf Integer
m'))
    | Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
m' = Integer -> ITCEvent
ITCEventLeaf (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
m)
normEv (ITCEventBranch Integer
n ITCEvent
e1 ITCEvent
e2) = Integer -> ITCEvent -> ITCEvent -> ITCEvent
ITCEventBranch (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
m) (ITCEvent -> Integer -> ITCEvent
sinkEv ITCEvent
e1 Integer
m) (ITCEvent -> Integer -> ITCEvent
sinkEv ITCEvent
e2 Integer
m)
  where
    m :: Integer
m = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (ITCEvent -> Integer
minEv ITCEvent
e1) (ITCEvent -> Integer
minEv ITCEvent
e2)

minEv :: ITCEvent -> Integer
minEv :: ITCEvent -> Integer
minEv (ITCEventLeaf Integer
n) = Integer
n
minEv (ITCEventBranch Integer
n ITCEvent
e1 ITCEvent
e2) = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (ITCEvent -> Integer
minEv ITCEvent
e1) (ITCEvent -> Integer
minEv ITCEvent
e2)

maxEv :: ITCEvent -> Integer
maxEv :: ITCEvent -> Integer
maxEv (ITCEventLeaf Integer
n) = Integer
n
maxEv (ITCEventBranch Integer
n ITCEvent
e1 ITCEvent
e2) = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (ITCEvent -> Integer
maxEv ITCEvent
e1) (ITCEvent -> Integer
maxEv ITCEvent
e2)