Interval Tree Clocks test implementation

IntervalTreeClock.hs

data Event = Event Int | EventTree Int Event Event deriving(Eq, Show)

data Id = IdLo | IdHi | Id Id Id deriving(Eq, Show)

data Stamp = Stamp Id Event deriving(Eq, Show)

instance Ord Event where
	(<=) (EventTree n1 l1 r1) (EventTree n2 l2 r2) = n1 <= n2 && ((lift (Event n1) l1) <= (lift (Event n2) l2)) && ((lift (Event n1) r1) <= (lift (Event n2) r2))
	(<=) (EventTree n1 l1 r1) (Event n2) = n1 <= n2	&& ((lift (Event n1) l1) <= (Event n2)) && ((lift (Event n1) r1) <= (Event n2))
	(<=) (Event n1) (EventTree n2 _ _)   = n1 <= n2
	(<=) (Event n1) (Event n2) = n1 <= n2 

instance Ord Stamp where
	(<=) (Stamp _ e1) (Stamp _ e2) = e1 <= e2 


seed = Stamp IdHi (Event 0)


join (Stamp id1 ev1) (Stamp id2 ev2) =
	Stamp (sumId id1 id2) (joinEvent ev1 ev2)


fork (Stamp i e) = (Stamp i1 e, Stamp i2 e)
	where
		(i1, i2) = split i 


peek (Stamp i e) = (Stamp IdLo e, Stamp i e)


event (Stamp i e) = Stamp i e1
	where
		et = fill i e
		(_, ge) = grow i e
		e1 = if et == e then ge else et



sumId IdLo x = x
sumId x IdLo = x
sumId (Id l1 r1) (Id l2 r2) = normId $ Id (sumId l1 l2) (sumId r1 r2)


normId (Id IdLo IdLo) = IdLo
normId (Id IdHi IdHi) = IdHi
normId x = x


normEvent e@(EventTree n (Event m1) (Event m2))
	| m1 == m2  = Event $ n + m1
	| otherwise = normEvent' e
normEvent e = normEvent' e

normEvent' (EventTree n l r) =
	EventTree (n + m) (dropTree (Event m) l) (dropTree (Event m) r)
	where
		m = min (base l) (base r)


dropTree (Event m) (EventTree n l r)
	| m <= n    = EventTree (n - m) l r
	| otherwise = error "Wrong event combination for drop"
dropTree (Event m) (Event n)
	| m <= n    = Event $ n - m
	| otherwise = error "Wrong event combination for drop"


base (EventTree n _ _) = n
base (Event n)         = n


lift (Event m) (EventTree n l r) = EventTree (n + m) l r
lift (Event n) (Event m) = Event $ n + m


joinEvent e1@(EventTree n1 l1 r1) e2@(EventTree n2 l2 r2)
	| n1 > n2   = joinEvent e2 e1
	| otherwise = normEvent $ EventTree n1 (joinEvent l1 $ lift d l2) (joinEvent r1 $ lift d r2)
					where d = Event $ n2 - n1
joinEvent (Event n1) e2@(EventTree _ _ _) = joinEvent (EventTree n1 (Event 0) (Event 0)) e2
joinEvent e1@(EventTree _ _ _) (Event n2) = joinEvent e1 (EventTree n2 (Event 0) (Event 0))
joinEvent (Event n1) (Event n2) = Event $ max n1 n2


split IdLo = (IdLo, IdLo)
split IdHi = (Id IdHi IdLo, Id IdLo IdHi)
split (Id IdLo IdHi) = (Id IdLo (Id IdHi IdLo), Id IdLo (Id IdLo IdHi))
split (Id IdHi IdLo) = (Id (Id IdHi IdLo) IdLo, Id (Id IdLo IdHi) IdLo)
split (Id i1 i2)     = (Id i1 IdLo, Id IdLo i2)


grow :: Id -> Event -> (Int, Event)
grow IdHi (Event n) = (0, Event $ n + 1)
grow (Id IdLo IdHi) (EventTree n l r) = (h + 1, EventTree n l e1)
	where
		(h, e1) = grow IdHi r
grow (Id IdHi IdLo) (EventTree n l r) = (h + 1, EventTree n e1 r)
	where
		(h, e1) = grow IdHi l
grow (Id il ir) (EventTree n l r) = if hl < hr then (hl + 1, EventTree n el r) else (hr + 1, EventTree n l er)
	where
		(hl, el) = grow il l
		(hr, er) = grow ir r
grow i (Event n) = (h + 1000, e)
	where
		(h, e) = grow i (EventTree n (Event 0) (Event 0))


fill IdLo e = e
fill IdHi e@(EventTree _ _ _) = Event $ height e
fill _    e@(Event _) = e
fill (Id IdHi r) (EventTree n el er) = normEvent $ EventTree n d er1
	where
		er1 = fill r er
		d = Event $ max (height el) (base er1)
fill (Id l IdHi) (EventTree n el er) = normEvent $ EventTree n el1 d
	where
		el1 = fill l el
		d = Event $ max (height er) (base el1)
fill (Id l r) (EventTree n el er) = normEvent $ EventTree n (fill l el) (fill r er)


height (EventTree n l r) = n + max (height l) (height r)
height (Event n) = n


main = do
	putStrLn $ show $ s <= event ss1
	where
		s = seed
		(s1, s2) = fork s
		ss1 = event s1
		ss2 = event s2
		js  = join ss1 ss2
		js1 = event js