Red Black Tree

lib/Base/Types.fram

@@ -7,3 +7,6 @@ pub data rec List A = [] | (::) of A, List A
 pub data Pair X Y = (,) of X, Y
 
 pub data Either X Y = Left of X | Right of Y
+
+pub data Ordered = Lt | Eq | Gt
+

lib/Prelude.fram

@@ -48,3 +48,4 @@ pub module Int64
   pub let one  = 1L
   pub let ofInt (n : Int) = n.toInt64
 end
+

lib/Queue.fram

@@ -0,0 +1,144 @@
+{# This file is part of DBL, released under MIT license.
+ # See LICENSE for details.
+ #}
+
+import List
+
+data NotNegativeInt = Zero | Positive of Int
+
+let addOne value =
+  match value with
+  | Zero => Positive 1
+  | Positive n => Positive (n+1)
+  end
+
+let subOne value =
+  match value with
+  | Zero => Zero
+  | Positive n => if n == 1 then Zero else Positive (n-1)
+  end
+
+data RotationState Val =
+  | Idle
+  | Reversing of NotNegativeInt, List Val, List Val, List Val, List Val
+  | Appending of NotNegativeInt, List Val, List Val
+  | Done of List Val
+
+data HoodMelvilleQueue Val =
+  | HMQueue of NotNegativeInt, List Val, RotationState Val,
+   NotNegativeInt, List Val
+
+let exec state =
+  match state with
+    | Reversing ok (x::f) f' (y::r) r' =>
+      Reversing (addOne ok) f (x::f') r (y::r')
+    | Reversing ok [] f' [y] r' => Appending ok f' (y::r')
+    | Appending Zero f' r' => Done r'
+    | Appending ok (x::f') r' => Appending (subOne ok) f' (x::r')
+    | _ => state
+  end
+
+let invalidate state =
+  match state with
+    | Reversing ok f f' r r' => Reversing (subOne ok) f f' r r'
+    | Appending Zero f' (x::r') => Done r'
+    | Appending ok f' r' => Appending (subOne ok) f' r'
+    | _ => state
+  end
+
+let execTwice hmqueue =
+  match hmqueue with
+  | HMQueue lenf f state lenr r =>
+    match exec (exec state) with
+    | Done newf => HMQueue lenf newf Idle lenr r
+    | newstate => HMQueue lenf f newstate lenr r
+    end
+  end
+
+let leq v1 v2 =
+  match (v1,v2) with
+  | (Zero,Zero) => True
+  | (Zero,Positive _) => True
+  | (Positive _, Zero) => False
+  | (Positive n, Positive m) => n <= m
+  end
+
+let add v1 v2 =
+  match (v1,v2) with
+  | (Zero,any) => any
+  | (any,Zero) => any
+  | (Positive n, Positive m) => Positive (n+m)
+  end
+
+let check queue =
+  match queue with
+  | HMQueue lenf f state lenr r =>
+    if leq lenr lenf then execTwice queue
+    else (
+      let newstate = Reversing Zero f [] r [] in
+      execTwice (HMQueue (add lenf lenr) f newstate Zero [])
+    )
+  end
+
+pub let emptyQueue = HMQueue Zero [] Idle Zero []
+pub let isEmpty queue =
+  match queue with
+  | HMQueue Zero _ _ _ _ => True
+  | _ => False
+  end
+
+let snoc queue value =
+  match queue with
+  | HMQueue lenf f state lenr r =>
+    check (HMQueue lenf f state (addOne lenr) (value :: r))
+  end
+
+let head queue =
+  match queue with
+  | HMQueue Zero _ _ _ _ => None
+  | HMQueue _ (x::xs) _ _ _ => Some x
+  | _ => impossible ()
+  end
+
+let tail queue =
+  match queue with
+  | HMQueue Zero _ _ _ _ => emptyQueue
+  | HMQueue _ [] _ _ _ => emptyQueue
+  | HMQueue lenf (x::xs) state lenr r =>
+    check (HMQueue (subOne lenf) xs (invalidate state) lenr r)
+  end
+
+let mapRotationState f state =
+  match state with
+    | Idle => Idle
+    | Done list => Done (List.map f list)
+    | Appending v list1 list2 =>
+        Appending v (List.map f list1) (List.map f list2)
+    | Reversing v list1 list2 list3 list4 =>
+        Reversing v (List.map f list1) (List.map f list2)
+          (List.map f list3) (List.map f list4)
+  end
+
+let mapQueue queue f =
+  match queue with
+  | HMQueue v1 list1 state v2 list2 =>
+    HMQueue v1 (List.map f list1)
+      (mapRotationState f state) v2 (List.map f list2)
+  end
+
+let rec toList queue =
+  match head queue with
+  | None => []
+  | Some x => x :: toList (tail queue)
+  end
+
+pub let fromList list = List.foldLeft snoc emptyQueue list
+
+pub method isEmpty self = isEmpty self
+pub method snoc self = snoc self
+pub method tail self = tail self
+pub method push self = snoc self
+pub method pop self = tail self
+pub method head self = head self
+pub method map self = mapQueue self
+pub method toList self = toList self