Algorithms and Data Structures

Martin Steffen

Abstract: This document describes the some of the algorithms of our lecture in ocaml It is automtically generated by the literate-programming tool ocamlweb.

Introduction

This document contains the literate-programming output of some Ocaml-implementations of algorithms of the lectures. The code is separated in a number of modules and compilation units. In case, an Ocaml-interface .mli-file contains a module type, only one of the files are shown in general. Neither are included opening statements for modules.

Section 1 Section 2 Section 5 Section 3 Section 4 Section 6



1   Some basic definitions

Module Basic

This module collects basic interface type for repeatedly needed data structures. Especially, the module type ORDERED is the signature for ordered types, and DICT for dictionaries.
module type TYPE = (* unspecified data *)
   sig
     type t
   end

module type ORDERED = (* type with an order relation. *)
   sig
     type t
     val eq: t × t ® bool
     val lt: t × t ® bool
     val leq: t × t ® bool
     val gt: t × t ® bool
     val geq: t × t ® bool
   end

module type SET =
   sig
     type elem
     type set
     val empty: set
     val insert: elem × set ® elem
     val member: elem × set ® elem
   end

module type DICT = (* a dictionary is a finite map from keys to elements of type elem *)
   sig 
     type key
     type elem
     type dict
     exception Not_Found
     val empty: dict 
     val insert: dict ® (key × elem) ® dict
     val delete: dict ® key ® dict
     val print_dict: dict ® unit
   end


2   Sorting

This section contains a number of well-known sorting algorithms, mostly programmed as list-soring in a functional style. The functional implementations all given as functors with the same inface, where SORT specifies the interface for list-sorting. This interface is shown only for bubble-sort; the others are analogous.

To test the implementation, the module Randlist allows to generate random lists of integers.

Interface for module Randlists

Generate a random list of integers. The first argument is the length of the list, the second the maximum -1.
val randomlist: int ® int ® int list

Module Sort

Interface for (functional) list-sorting.
module type SORT = 
   sig
     type elem
     val sort: elem list ® elem list
   end

Interface for module Bubblesort

module BubblesortFun (E: ORDERED) : SORT with type elem = E.t

Module Bubblesort

A functional implementation of bubble-sort.
module BubblesortFun (E: ORDERED) : SORT with type elem = E. t =
   struct
     type elem = E.t

     let rec bubbleone (l1,l2) =
       match l1 with 
         [ ] ® ([ ], l2)
       | [x] ® ([ ],x::l2)
       | x1::x2::l ® 
           if (x1 £ x2)
           then 
             let (l1', l2') = bubbleone(x2::l, l2)
             in 
             (x1::l1', l2')
           else 
             let (l1', l2') = bubbleone(x1::l, l2)
             in 
             (x2::l1', l2')

     let sort l =
       let rec bubble_h(l1, l2) = 
         match l1 with 
           [ ] ® l2
         | _ ® bubble_h (bubbleone(l1,l2))
       in 
       bubble_h (l, [ ])
   end

Module Heapsort

module HeapsortFun (E: ORDERED) : (SORT with type elem = E.t) =
   struct
     module H = HeapFun (E) (* One can also use MHeapFun *)

     type elem = E.t
     let rec hsort (l,h) = 
       if H.is_empty h 
       then (l,h)
       else 
         let (max,h') = H.delete_max h
         in hsort (max::l, h')

     let sort l =
       let h = H.heap_of_list l (* h: heap: teilsortiert *)
       in fst (hsort ([ ],h))
   end

Module Mergesort

A functional implementation of merge sort. The functional implementation is a bit clumsy, since splitting the sequence is not well-supported by lists. In the implementation, this is dealt with by not splitting the list in the outer working of the divide-and-conquer strategy, but to split the list in a pre-processing step into a list of it's the basic one-element sublists (function explode), which are then merged pairwise. The basic conquer-step, the merging of two sorted lists into a larger, sorted one is done by merge_list.

The implementation is a bit clumsy, since it hides the divide-and-conquer structure of the algorithm.


module MergesortFun (E: ORDERED) : (SORT with type elem = E.t) =
   struct
     type elem = E.t
     let rec explode (l: a list) : ' a list list = 
       match l with 
         [ ] ® [ ]
       | x::tl ® [x] :: explode tl

     let rec merge_list (l1: a list) (l2: a list) = (* merge to sorted lists *)
       match (l1, l2) with
         ([ ], l2) ® l2
       | (l1, [ ]) ® l1
       | (x1::l1', x2::l2') ®
           if x1 < x2 then x1 :: merge_list l1' l2
           else x2 :: merge_list l1 l2'

     let rec merge (l : a list list) =
       let rec merge_step (l: a list list) : a list list =
         (* Take the elements (= lists) in pairs of twos and merge them pairwise. *) 
         (* So, the function approcimately cuts the length of l in half. *)
         match l with 
           [ ] ® [ ]
         | [sl] ® [sl]
         | l1 :: l2 :: rl ® merge_list l1 l2 :: (merge_step rl)
       in
       match l with
         [ ] ® [ ]
       | [sl] ® sl
       | _ ® merge (merge_step l) (* start once again *)

     let sort (l :elem list) = merge (explode l)
   end

Module Quicksort

A functional implementation of quicksort. The divide-and-conquer approach is visible in the recursive inner sort-function: It chooses as pivot the first element. Using the auxiliary function filter,1 it splits the remainder of the list into two halves, the elements less or equal the pivot and those larger than the pivot. The sublists are sorted and, together with the pivot in the middle, put together to the sorted list.


module QuicksortFun (E: ORDERED) : (SORT with type elem = E.t) =
     struct
       type elem = E.t

       let rec filter p l = match l with (* auxiliary function *)
         [ ] ® [ ]
       | x :: tl ® 
           if (p x) 
           then x::(filter p tl)
           else filter p tl

       let rec sort (l : elem list) = 
         match l with 
           [ ] ® [ ]
         | x :: tl ® (* x = pivot *)
             sort (filter (function y ® E.lt(y,x)) tl)
             @ [x] @ 
             sort (filter (function y ® E.geq(y,x)) tl)
     end

Interface for module Quicksort1

val qsort_a_r: int array ® unit

Module Quicksort1

Imperative implementation of quicksort, using (integer) arrays
let qsort_a_r (a: int array) =
   let partition ((p: int), (r: int)) =
     (if (p < r) then 
       (
       let x = a.(p) (* Pivot *)
       and i = ref p and j = ref r and h = ref 0
       in 
       while (!i)£(!j) 
       do 
         while a.(!i) < x do i := !i + 1; done;
         while a.(!j) > x do j := !j - 1; done;
         if (!i)<(!j) 
         then 
           (h := a.(!i); a.(!i) ¬ a.(!j); a.(!j) ¬ !h; (* exchange *)
             i := !i+1; j:=!j-1)
         else (i:=!i+1)
       done;
       !j) (* return *)
     else p)
   in let rec qsort((p: int), (r: int)) =
     if (p < r)
     then
       (let q = ref 0
       in
       q := partition(p,r);
       qsort(p,!q);
       qsort(!q+1,r))
     else 
       ()
   in qsort(0, Array.length a - 1)

Interface for module Quicksort2

val qsort_a_i: int array ® unit

iterative Variante von quicksort

Module Quicksort2

let qsort_a_i (a : int array) = 
   let (s : (int × int) Stack.t) = Stack.create()
   and partition ((p: int),(r: int)) =
     (if (p < r) 
     then ( 
       let x = a.(p) (* Pivot *)
       and i = ref p and j = ref r and h = ref 0 in 
       while (!i)£(!j) 
       do 
         while a.(!i) < x do i := !i + 1; done;
         while a.(!j) > x do j := !j - 1; done;
         if (!i)<(!j) 
         then 
             (h := a.(!i); a.(!i) ¬ a.(!j); a.(!j) ¬ !h; (* Austausch *)
             i := !i+1; j:=!j-1)
         else (i:=!i+1)
       done;
       !j) (* Rueckgabe *)
     else p)
   in
   let p = ref 0 and r = ref ((Array.length a) - 1) and q = ref 0
   in 
   Stack.push (!p, !r) s;
   while Stack.length s > 0
   do 
     let (p,r) = Stack.pop s
     in
     q := partition (p,r);
     if (p < !q) then Stack.push ( p,!q) s else ();
     if (!q< r) then Stack.push (!q+1, r) s else ();
   done

Module Insertion

A functional implementation of insertion sort. The sorting proceeds in reverse direction of the list.


   module InsertionsortFun (E: ORDERED) : (SORT with type elem = E.t) =
     struct
       type elem = E.t

       let rec sort (l: elem list) =
         let rec i_one (x: elem) (l': elem list) = (* insert x at the right place *)
           match l' with
             [ ] ® [x]
           | y::l'' ® 
           if (x £ y) then x::l' else y:: (i_one x l'')
         in match l with
           [ ] ® [ ]
         | x:: l' ® i_one x (sort l')

     end

Module Selsort

A functional implementation of selection sort. Selection sort iteratively finds a minimal element of a list, removes it and puts it a the the start of the list.


module SelectionsortFun (E: ORDERED) : (SORT with type elem = E.t) =
   struct
     type elem = E.t
     let rec sort l = 
       let rec extract_min (l': a list): (a × a list) = (* find and remove a minimum *)
         match l' with 
           [ ] ® raise (Failure ("Empty list"))
         | [x] ® (x, [ ])
         | x::tl ® 
         let (min, tl') = (extract_min tl)
         in 
         if E.lt(x, min) then (x, tl) else (min, x::tl')
       in
       match l with
         [ ] ® [ ]
       | _ ® let (min, l') = (extract_min l) in min::sort l'
   end


3   Miscellaneous

Interface for module Maxseq

Given a list of integers, determine a sub-sequence
whose sum is maximal.
val maxseq: int list ® int list

Module Maxseq

let rec max_praefix l = (* determine the ``maximal'' prefix *)
   match l with
     [ ] ® ([ ],0)
   | x::tl ® 
       let (l', m) = (max_praefix tl)
       in
       if (x+m) ³ 0
       then (x::l', x+m)
       else ( [ ], 0)

let max_postfix l = (* analogoulsy for postfix *)
   let (postfix, m) = (max_praefix (List.rev l))
   in (List.rev postfix, m)

let rec step (l: (int list × int list × int) list) =
(* sub list max seq max *)
   match l with
     [ ] ® [ ]
   | [e] ® [e]
   | (ll, seq_l, max_l) :: (lr, seq_r, max_r) :: tl ® 
       let (post, max_1) = max_postfix ll
       and (prae, max_2) = max_praefix lr
       in 
       match ( max_1+max_2£ max_l, max_l £ max_r, max_r £ max_1+max_2) 
       with 
         (true, true, _ ) ® (ll@lr, seq_r, max_r) :: step tl
       | (true, _ , true) ® (ll@lr, seq_l, max_l) :: step tl
       | ( _ , true, true) ® (ll@lr, post@prae, max_1+max_2) :: step tl
       | (true, false,false) ® (ll@lr, seq_l, max_l) :: step tl
       | (false,true, false) ® (ll@lr, seq_r, max_r) :: step tl
       | (false,false,true) ® (ll@lr, post@prae, max_1+max_2) :: step tl
       | _ ® raise ( Failure "Cannot happen")

let rec steps (l: (int list × int list × int) list) =
   match l with
     [ ] ® ([ ],[ ],0)
   | [l1] ® l1
   | _ ® steps (step l)

let rec explode_seq (l : int list) =
   match l with
     [ ] ® [ ]
   | x::tl ® 
       if x³0 
       then ([x], [x], x) :: explode_seq tl
       else ([x], [ ], 0) :: explode_seq tl

let maxseq (l : int list) = 
   let (_,s,_) = steps(explode_seq l) in s

Interface for module Linpartition

Given a list of integers and a positive integer k,
recursive solution, not efficient
val linpart: int ® int ® int list ® int

Module Linpartition

let list_sum = List.fold_left (fun x ® fun y ® x+y) 0

let rec part l1 l2 m k = (* Number of trenner in l2 *)
   let (s1: int) = list_sum l1 
   in let (s2: int) = list_sum l2
   in
   match l2 with
     [ ] ® m
   | x::l2' ® 
       let max1 = max (m+x) (linpart (k) m l2')
       in let max2 = max m (linpart (k-1) m l2)
       in (min max1 max2)

and linpart k m l2 =
   if k = 0 
   then ((m + (list_sum l2)))
   else (part [ ] l2 m k)

-------------------------------- linpart: input: k >0 l : list of integers

output: best k-partition of l, i.e. the partition with at most k subsequences, where the max. the sums of each partition is minimal. -------------------------------

recursive, non-efficient variant of




4   Heaps

Interface for module Heap

open Basic

module type HEAP = 
   sig
     type elem
     type heap = Leaf | Node of heap × elem × heap

     val empty: heap
     val is_empty: heap ® bool
     val insert: heap ® elem ® heap
     val delete_max: heap ® (elem × heap)
     val get_max: heap ® elem
     val heap_of_list: elem list ® heap
   end

module type MHEAP = (* Heap with merging *)
   sig
     type elem
     type heap

     val empty: heap
     val is_empty: heap ® bool
     val merge: heap ® heap ® heap
     val insert: heap ® elem ® heap
     val delete_max: heap ® (elem × heap)
     val get_max: heap ® elem
     val heap_of_list: elem list ® heap
   end

module HeapFun (E:ORDERED) : HEAP with type elem = E.t
module MHeapFun (E:ORDERED) : MHEAP with type elem = E.t

Module Heap

open Basic

module type HEAP = 
   sig
     type elem
     type heap = Leaf | Node of heap × elem × heap

     val empty: heap
     val is_empty: heap ® bool
     val insert: heap ® elem ® heap
     val delete_max: heap ® (elem × heap)
     val get_max: heap ® elem
     val heap_of_list: elem list ® heap
   end

module type MHEAP = (* Heap with merging *)
   sig
     type elem
     type heap

     val empty: heap
     val is_empty: heap ® bool
     val merge: heap ® heap ® heap
     val insert: heap ® elem ® heap
     val delete_max: heap ® (elem × heap)
     val get_max: heap ® elem
     val heap_of_list: elem list ® heap
   end

module HeapFun (E:ORDERED) : (HEAP with type elem = E.t) = 
   struct

     type elem = E.t
     type heap = Leaf | Node of heap × elem × heap
     (* ------------------------------------------ *)

     let empty = Leaf

     let is_empty h = match h with
         Leaf ® true
     | _ ® false

     let rec insert (h:heap) (e:elem) =
       match h with 
         Leaf ® Node (Leaf,e,Leaf)
       | Node(h_l,e',h_r) ®
           let (max,min) = (if (E.gt (e,e')) then (e,e') else (e',e))
           in Node(insert h_r min , max, h_l)

     let rec delete (h: heap) = 
     (* deleting a leaf-element, and giving it back, too *)
     (* Stucturually, it's the reverse of insert. *)
     (* The left subtree has always one element more *)
     (* than the right subtree or the same elements *)

       match h with 
         Leaf ® raise (Failure "Empty heap")
       | Node(Leaf,e,Leaf) ® (Leaf,e)
       | Node (Leaf,_,_) ® raise (Failure "cannot happend")
       | Node (h_l,e,h_r) ®
           let (h_l', e') = delete h_l
           in (Node (h_r,e,h_l'),e')

     let get_max (h: heap) =
       match h with 
         Leaf ® raise (Failure "2Empty heap")
       | Node(_,e,_) ® e

     let max3 (e1,e2,e3) = 
       match (E.geq(e1,e2), E.geq(e2,e3), E.geq(e1,e3))
       with 
         (true,_,true) ® e1
       | (false,true,_) ® e2
       | (_,false,false) ® e3
       | _ ® raise (Failure "Must not happen")

     let rec siftdown h =
   (* taking 2 heaps and an element, give back the combined heap. The structure of Node(h1,e,h2) is not changed. *)
       match h with 
         Leaf ® Leaf
       | Node(h1,e,h2) ®
           (match (h1,h2) with 
             (Leaf,Leaf) ® h
           | (Node(h1_l,e',h1_r), Leaf) ®
               if E.geq(e,e') 
               then Node (h1,e,Leaf)
               else Node (siftdown (Node(h1_l,e,h1_r)),e',Leaf) 
           | 
             (Node(h1_l,e',h1_r), Node(h2_l,e'',h2_r))
               ® 
                 let m = max3 (e,e',e'')
                 in if E.eq(e, m) then h
                 else if E.eq(e',m) then
                   Node(siftdown (Node(h1_l,e,h1_r)),e',h2)
                 else 
                   Node(h1,e'',siftdown (Node(h2_l,e,h2_r)))
             )

     let delete_max (h: heap) =
       match h with 
         Leaf ® raise (Failure "Empty heap")
       | Node(Leaf,e,Leaf) ® (e,Leaf)
       | Node(h_l,e,h_r) ® 
           let (h_l',e') = delete h_l
           in (e, siftdown (Node(h_r,e',h_l')))

     let rec heap_of_list l = 
       match l with 
         [ ] ® Leaf
       | e::l' ® insert (heap_of_list l') e;

   end

------------------------------
module MHeapFun (E:ORDERED) : (MHEAP with type elem = E.t) = 
   struct

     type elem = E.t
     type rank = int
     type heap = Leaf | Node of heap × rank × elem × heap

     let empty = Leaf

     let is_empty h = 
       match h with 
         Leaf ® true
       | _ ® false

     let rank (h: heap) = 
       match h with 
         Leaf ® 0
       | Node(_,r,_,_) ® r

     let makeNode (h1,e,h2) =
       if (rank h1) ³ (rank h2) 
       then Node(h1,(rank h2) + 1,e,h2)
       else Node(h2,(rank h1) + 1,e,h1)

     let rec merge h1 h2 =
       match (h1,h2) with
         (Leaf, _) ® h2
       | (_, Leaf) ® h1
       | (Node(h1_l,r1,e1,h1_r),Node(h2_l,r2,e2,h2_r)) ®
           if E.geq(e1,e2)
           then makeNode(h1_l,e1, merge h1_r h2)
           else makeNode(h2_l,e2,merge h1 h2_r)

     let insert h e = merge h (Node(Leaf,1,e,Leaf))

     let get_max h = match h with
       Leaf ® raise (Failure "Empty heap")
     | Node(_,_,e,_) ® e

     let delete_max h = match h with
       Leaf ® raise (Failure "Empty heap")
     | Node(h1,r,e,h2) ® (e, merge h1 h2)

     let rec heap_of_list l =
       match l with 
         [ ] ® Leaf
       | e::l' ® insert (heap_of_list l') e;

   end


5   Trees

Interface for module Trees

module STREEFun : functor(Key: ORDERED) ® functor(Elem:TYPE) ®
   (DICT with type key = Key.t and type elem = Elem.t)

Module Trees

The module contains an implementation of a dictionary by binary search trees. The condition on the search-tree is that for all nodes the keys are ordered, i.e. keyl £ key £ keyr, where key is the key of the node and keyl and keyr are the keys of the two children. The tree may contain two elements with the same key (see insert).

The constructor implementation in ocaml means that they are unidirectionally chained. Therefore determining the successor or a predecessor is complicated.


module STREEFun(Key:ORDERED)(Elem:TYPE) =
   struct
     exception Not_Found

     type elem = Elem.t
     type key = Key.t

     type (a, b) bstree = (* binary search tree *)
         Leaf | Node of (a,b) bstree × (a ×b) × (a,b) bstree

     type dict = (key,elem) bstree (* dictionary as binary search tree *)

     let empty = Leaf

     let rec delete_succ tr = (* deletes the first element, where first is defined in appearing in in-order. Succeeds exactly if tr is not a leaf.

Additionally it gives back the info of the deleted node. *)

       match tr with
         Leaf ® raise Not_Found
       | Node(Leaf,n,tr_r) ® (tr_r, n)
       | Node(tr_l,n,tr_r) ® 
           let (tr_l',n') = delete_succ tr_l
           in (Node(tr_l', n, tr_r), n')

     let rec insert tr (key, elem) = (* Insert always at the leaves *)
       match tr with
         Leaf ® Node (Leaf, (key, elem), Leaf)
       | Node(tr_l, (key', elem'), tr_r) ®
           if key = key' (* Fifo insertion, right-side is important, too *)
           then Node(tr_l , (key, elem), insert tr_r (key', elem'))
           else if (key<key')
           then Node(insert tr_l (key, elem), (key', elem'), tr_r)
           else Node( tr_l , (key', elem'), insert tr_r (key, elem))

     let rec search tr key =
       match tr with 
         Leaf ® raise Not_Found
       | Node(tr_l, (key', elem'), tr_r) ®
           if (key = key') then elem'
           else 
             if key < key' 
             then search tr_l key
             else search tr_r key

     let delete tr key = 
       let rec delete' tr key = 
         match tr with
           Leaf ® raise Not_Found
         | Node(Leaf, (k,e), Leaf) ® 
             if key = k (* found *)
             then (Leaf, (k,e))
             else raise Not_Found
         | Node(tr_l, (k,e), tr_r) ® 
             if key = k (* found *)
             then 
               match (tr_l, tr_r) with
                 (Leaf, _) ® (tr_r,(k,e))
               | (_ , Leaf) ® (tr_l,(k,e)) 
               | _ ® (* Nachfolger *)
                   match 
                     (delete_succ tr_r)
                   with 
                     (tr_r',(ks,es)) ® 
                       (Node(tr_l, (ks, es), tr_r'), (k,e))
             else if (key<k)
             then 
               let (tr_l',n') = delete' tr_l key
               in 
               (Node(tr_l',(k,e),tr_r),n')
             else 
               let (tr_r', n') = delete' tr_r key
               in 
               (Node(tr_l,(k,e),tr_r'),n')
       in
       fst (delete' tr key)

     let print_dict d = print_endline (" no info")

   end

delete: in CLR90, deletion takes the actual node as parameter (the pointer to it) and deletes it. In G90 wird angenommen, dass der Schluessel eindeutig ist, damit ist das Loeschen einfacher.

Interface for module Rbtrees

exception Not_Found

type color = Red | Black

type entry = int

type key = int

type (a ,b) rbtree =
     Leaf of color 
   | Node of (a,b) rbtree × (a ×b × color) × (a,b) rbtree

'a = key, 'b is the data
val insert: (a, b) rbtree ® (a × b) ® (a, b) rbtree 
val delete: (a, b) rbtree ® a ® (a, b) rbtree 
val search: (a, b) rbtree ® a ® b

Module Rbtrees

red-black trees. Those are modelled like the ones in CLR90.


exception Not_Found

exception Illegal_Rotation

not visible for the outside
exception Will_Not_Happen

type color = Red | Black

type entry = int

type key = int

type (a, b) rbtree = (* 'a: key, b': elem *)
     Leaf of color 
   | Node of (a,b) rbtree × (a ×b × color) × (a,b) rbtree

let toggle x = 
   match x with 
     (k,e, Black) ® (k,e, Red)
   | (k,e, Red) ® (k,e, Black)

let rotate_r tr (b: bool) =
   match tr with
     Leaf c ® raise Illegal_Rotation
   | Node (Leaf _, _, _) ® raise Illegal_Rotation
   | Node (Node (tr_1,c_y,tr_2), c_x, tr_3) ® 
       if b
       then Node(tr_1, toggle c_y, Node(tr_2, toggle c_x, tr_3))
       else Node(tr_1, c_y, Node(tr_2, c_x, tr_3))

let rotate_l tr (b:bool) =
   match tr with 
     Leaf c ® raise Illegal_Rotation 
   | Node (_,_,Leaf c) ® raise Illegal_Rotation
   | Node (tr_1, c_x, Node(tr_2,c_y,tr_3)) ®
       if b 
       then Node(Node(tr_1, toggle c_x, tr_2), toggle c_y, tr_3)
       else Node(Node(tr_1, c_x, tr_2), c_y, tr_3)

let finish tr =
   match tr with
   | Node(Node(t1_l, (k_1, e_1, Red), t1_r), 
           (k_2,e_2,Red), 
           t3)
     ®
       Node(Node(t1_l, (k_1, e_1, Red), t1_r),
             (k_2,e_2,Black), 
             t3)
   | Node(t1, (k_2, e_2, Red), Node(t3_l, (k_3, e_3,Red), t3_r)) (* 5' *)
     ®
       Node(t1, (k_2, e_2, Black), Node(t3_l, (k_3, e_3,Red), t3_r))
   | _ ® tr

let rec insert' tr (key, elem) = (* Insert always at the leaves *)
   match tr with
     Leaf c ® 
       Node (Leaf Black, (key, elem, Red), Leaf Black) 
   | Node(tr_l, (key', elem',c'), tr_r) ®
       if key < key'
       then 
         (let tr'= Node(insert' tr_l (key, elem), (key', elem', c'), tr_r)
           in 
           match tr' with 
             Node (Node(t2_l, (* 1 *)
                       (key_2, elem_2, Red), 
                       Node(t1_l,(key_1,elem_1,Red),t1_r)), 
                   (key_3,elem_3,Black), 
                   Node(t4_l,(key_4,elem_4,Red),t4_r))
             ®
               Node (Node(t2_l, 
                         (key_2, elem_2, Black), 
                         Node(t1_l,(key_1,elem_1,Red),t1_r)), 
                     (key_3,elem_3, Red), 
                     Node(t4_l,(key_4,elem_4,Black),t4_r))
           | Node (Node(Node(t1_l,(key_1,elem_1,Red),t1_r), (* 2 *)
                       (key_2, elem_2, Red), 
                       t2_r), 
                   (key_3,elem_3,Black), 
                   Node(t4_l,(key_4,elem_4,Red),t4_r))
             ®
               Node (Node(Node(t1_l,(key_1,elem_1,Red),t1_r), 
                         (key_2, elem_2, Black), 
                         t2_r), 
                     (key_3,elem_3, Red), 
                     Node(t4_l,(key_4,elem_4,Black),t4_r))
           | Node (Node(t2_l, (* 3 *)
                       (key_2, elem_2, Red), 
                       Node(t1_l,(key_1,elem_1,Red),t1_r)), 
                   (key_3,elem_3,Black), 
                   t4) (* t4 is black (matching): leaf or node *)
             ®
               Node (rotate_l(Node(t2_l, 
                                   (key_2, elem_2, Red), 
                                   Node(t1_l,(key_1,elem_1,Red),t1_r))) false, 
                     (key_3,elem_3, Black), 
                     t4)
           | Node (Node(Node(t1_l,(key_1,elem_1,Red),t1_r), (* 4 *)
                       (key_2, elem_2, Red), 
                       t2_r), 
                   (key_3,elem_3,Black), 
                   t4) (* t4 must be black *)
             ®
               rotate_r
                 (Node( Node( Node(t1_l,(key_1,elem_1,Red),t2_r), 
                             (key_2, elem_2, Red), 
                             t2_r), 
                       (key_3,elem_3, Black), 
                       t4))
                 true 
                   (* we recolor! *)
           | _ ® tr'

                 )
       else (* key >=key' *)
         (let tr'= Node(tr_l, (key', elem', c'), insert' tr_r (key, elem))
         in 
         match tr' with
           Node(Node(t4_l,(k4,e4,Red), t4_r), (* 1' *)
                 (k3,e3,Black),
                 Node(Node(t1_l,(k1,e1,Red),t1_r),
                     (k2,e2,Red),
                     t2_r))
             ®
               Node(Node(t4_l,(k4,e4,Black), t4_r),
                     (k3,e3,Red),
                     Node(Node(t1_l,(k1,e1,Red),t1_r),
                         (k2,e2,Black),
                         t2_r))
         | Node(Node(t4_l,(k4,e4,Red), t4_r), (* 2' *)
                 (k3,e3,Black),
                 Node(t2_l,
                     (k2,e2,Red),
                     Node(t1_l,(k1,e1,Red),t1_r)))
           ® 
             Node(Node(t4_l,(k4,e4,Black), t4_r),
                   (k3,e3,Red),
                   Node(t2_l,
                       (k2,e2,Black),
                       Node(t1_l,(k1,e1,Red),t1_r)))

         | Node(t4, (* 3' *)
                 (k3,e3,Black),
                 Node(Node(t1_l,(k1,e1,Red),t1_r),
                     (k2,e2,Red),
                     t2_r))
           ® 
             Node(t4, 
                   (k3,e3,Black),
                   rotate_r
                     (Node(Node(t1_l,(k1,e1,Red),t1_r),
                           (k2,e2,Red),
                           t2_r))
                     false

                     )
         | Node(t4, (* 4' *)
                 (k3,e3,Black),
                 Node(t2_l,
                       (k2,e2,Red),
                       Node(t1_l,(k1,e1,Red),t1_r)))
           ® 
             rotate_l
               (Node(t4, 
                     (k3,e3,Black),
                     Node(t2_l,
                           (k2,e2,Red),
                           Node(t1_l,(k1,e1,Red),t1_r))))
               true
         | _ ® tr'

               )

let insert tr (key, elem) =
   finish (insert' tr (key, elem))

let rec search tr key =
   match tr with 
     Leaf c ® raise Not_Found
   | Node(tr_l, (key', elem', c), tr_r) ®
       if (key = key') then elem'
       else 
         if key < key' 
         then search tr_l key
         else if key' > key 
         then search tr_r key
         else elem' (* <= ist eine totale Ordnung *)

Delete deletes the first fitting node and gives back the the node-info, too
let rec delete' tr key = 
     match tr with
       Leaf _ ® raise Not_Found
     | Node(Leaf _, (k,e,c), Leaf _) ® (* A leaf can safely be erased *)
         if key = k 
         then (Leaf Black, (k,e,c))
         else raise Not_Found
     | Node(tr_l, (k,e,c), tr_r) ® raise Will_Not_Happen

let delete tr key = tr

Interface for module Rbtrees2

Simplified form of red-black trees. The conditions are a bit simplified.


open Basic

module RBFun: functor(Key: ORDERED) ® functor(Elem:TYPE) ® 
   (DICT with type key = Key.t and type elem = Elem.t)

Module Rbtrees2

module RBFun(Key:ORDERED) (Elem:TYPE) =
   struct

     exception Not_Found
     type color = Red | Black
     type key = Key.t
     type elem = Elem.t

     type (a, b) rbtree = 
         Leaf of color | Node of (a,b) rbtree × (a ×b × color) × (a,b) rbtree

     type dict = (key, elem) rbtree (* schoener waere: 'a dict = (key, 'a) rbtree *)

     let empty = Leaf Black

     let balance tr = match tr with
     | Node(Node(Node(ta,(k1,e1,Red),tb),(k2,e2,Red),tc),(k3,e3,Black), td)
       ® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
     | Node(Node(ta,(k1,e1,Red), Node(tb,(k2,e2,Red),tc)), (k3,e3,Black), td)
       ® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
     | Node(ta,(k1,e1,Black),Node(tb,(k2,e2,Red),Node(tc,(k3,e3,Red),td))) 
       ® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
     | Node(ta,(k1,e1,Black),Node(Node(tb,(k2,e2,Red),tc),(k3,e3,Red),td))
       ® Node(Node(ta,(k1,e1,Black),tb),(k2,e2,Red),Node(tc,(k3,e3,Black),td))
     | t ® t

     let insert tr (key, elem) =
       let rec insert_h tr = 
         match tr with
           Leaf c ® Node(Leaf Black, (key, elem, Red), Leaf Black)
         | Node(tr_l,(key',elem',c'),tr_r) ®
             if (Key.lt (key, key'))
             then balance (Node( (insert_h tr_l), (key',elem',c'), tr_r ))
             else balance (Node( tr_l , (key',elem',c'), (insert_h tr_r)))
       in 
       let Node(l,(k,e,_), r) = insert_h tr
       in Node(l,(k,e,Black), r) (* Wurzel immer schwarz *)

     let rec search tr key =
       match tr with 
         Leaf c ® (raise Not_Found)
       | Node(tr_l, (key',elem', c'), tr_r) ®
           if (Key.lt(key, key')) then search tr_l key
           else if (Key.gt(key, key')) then search tr_r key
           else elem' (* < ist eine totale Ordnung *)

     let fixup_r t ok =
       if ok then (t, ok)
       else
         match t with
           Node(Node(t1,(k,e,Red),t2),n, t3) ®
             (Node(Node(t1,(k,e,Black),t2),n, t3), true)
         | Node(t1,(k1,e1,c1),Node(t2,(k2,e2,Black),t3)) ®
             (balance (Node(Node(t1,(k1,e1,Red),t2),(k2,e2,Black),t3)),
               (c1 = Red))
         | Node(t1,
                 (k1,e1,Black),
                 Node(Node(t2,(k2,e2,Black),t3),
                     (k3,e3,Red),
                     Node(t4,(k4,e4,Black),t5)))
           ®
             (Node(balance(Node(t1,(k1,e1,Black),Node(t2,(k2,e2,Red),t3))),
                   (k3,e3,Black),
                   Node(t4,(k4,e4,Black),t5)),
               true)
         | Node(_,(_,_,Red), Node(_,(_,_,Red),_)) ® raise (Failure "Cannot happen 1")
         | _ ® raise (Failure "cannot happen 2")

     let fixup_l t ok =
       if ok then (t, ok)
       else
         match t with 
           Node(t1, n, Node(t2,(k,e,Red),t3)) ® (* rechts R => einfach auf B *)
             (Node(t1, n, Node(t2,(k,e,Black),t3)), true) 
         | Node(Node(t1,(k,e,Black),t2),(k2,e2,c2),t3) ®
             (balance(Node(t1,(k,e,Black),Node(t2,(k2,e2,Red), t3))), (c2=Red))
         | Node(Node(Node(t1,(k1,e1,Black),t2),
                     (k2,e2,Red),
                     Node(t3,(k3,e3,Black),t4)),
                 (k4,e4,Black),
                 t5) ®
                   (Node(Node(t1,(k1,e1,Black),t2),
                         (k2,e2,Black), (* to make it stop *)
                         (balance (Node(Node(t3,(k3,e3,Red),t4),
                                       (k4,e4,Black),
                                       t5 )))),
                   true)
         | Node(Node(_,(_,_,Red),_),(_,_,Red), _) ® raise (Failure "cannot happen 3")
         | _ ® raise (Failure "cannot happen 4")

     let rec delete_succ tr = 
       match tr with
         Leaf _ ® raise (Not_Found)
       | Node(Leaf _,n,tr_r) ® (tr_r, n)
       | Node(tr_l,n,tr_r) ® 
           match (delete_succ tr_l) with
             (tr_l', (k,e,Red)) ® (Node(tr_l', n, tr_r), (k,e,Red))
           | (tr_l', (k,e,Black)) ® 
               let (t',b) = (fixup_r (Node(tr_l', n, tr_r)) false)
               in 
               (if b 
               then (t', (k,e,Red))
               else (t', (k,e,Black)))

     let rec delete_h tr key = 
       match tr with 
         Leaf _ ® raise (Not_Found)
       | Node(Leaf _, (k,e,c), Leaf _) ® 
           if key = k 
           then let ok = (if (c = Red) then true else false) in ((Leaf Black), ok)
           else raise (Not_Found)
       | Node(tr_l,(k,e,c), tr_r) ®
           if key < k
           then match (delete_h tr_l key) with 
             (tr_l', ok) ® (fixup_r (Node(tr_l',(k,e,c),tr_r)) ok)
           else if key > k
           then match (delete_h tr_r key) with 
             (tr_r', ok) ® (fixup_l (Node(tr_l,(k,e,c),tr_r')) ok)
           else (* Treffer *)
             match (tr_l, tr_r) with (* beide koennen nicht mehr Blaetter sein *)
               (Leaf _, _) ® (tr_r, (if c = Red then true else false))
             | (_,Leaf _) ® (tr_l, (if c = Red then true else false))
             | _ ® 
                 match ((delete_succ tr_r),c) with
                   ((tr_r',(k',e',Black)),Black) ® 
                     (fixup_l (Node(tr_l,(k',e',Black),tr_r')) false)
                 | ((tr_r',(k',e',Black)),Red) ® 
                     (fixup_l (Node(tr_l,(k',e',Red),tr_r')) false)
                   (* must be set to red! *)
                 | ((tr_r',(k',e', Red)),Black) ® 
                     (Node(tr_l,(k',e',Black),tr_r'), true)
                 | ((tr_r',(k',e', Red)),Red) ® 
                     (Node(tr_l,(k',e',Red),tr_r'), true)

     let blacken_root t =
       match t with 
         Leaf _ ® Leaf Black (* Blatt sollte sowieso schwarz sein *)
       | Node(t1,(k,e,_),t2) ® Node(t1,(k,e,Black),t2)

     let delete t key =
       let (t', _) = (delete_h t key)
       in blacken_root t'

------------------------------------------------------
     let string_of_color c = 
       match c with 
         Red ® "R"
       | Black ® "B"

     let string_of_node n =
       match n with
         (k,e,c) ®
           "(" ^ (string_of_int k) ^ "," ^ (string_of_int e) ^ "," ^ (string_of_color c) ^ ")"

     let rec string_of_tree tr = 
       match tr with
         Leaf Red ® "r" 
       | Leaf Black ® "b" 
       | Node (tl, n, tr) ®
           "["^
           (string_of_node n)^" "^
           (string_of_tree tl)^" "^
           (string_of_tree tr)^"]"

     let rec string_of_inordertree tr = 
       match tr with
         Leaf Red ® "r" 
       | Leaf Black ® "b" 
       | Node (tl, n, tr) ®
           (string_of_inordertree tl)^""^
           (string_of_node n)^""^
           (string_of_inordertree tr)

     let rec sort_ok tr =
       match tr with
         Leaf _ ® true
       | Node(Leaf _, (k,_,_), Leaf _ ) ® true
       | Node(Node(_,(k1,_,_),_) as t1, (k2,_,_), Leaf _) ® 
           (k1£k2) & (sort_ok t1);
       | Node(Leaf _, (k2,_,_), (Node(_,(k3,e,_),_) as t3)) ®
           (k2£ k3) & (sort_ok t3)
       | Node((Node(_, (k1,_,_), _)) as t1,
               (k2,_,_), (Node(_,(k3,e,_),_) as t3)) ®
                 ((k1 £ k2) & (k2 £ k3) & (sort_ok t1) & (sort_ok t3))

     let rec red_ok tr =
       match tr with 
         Leaf _ ® true
       | Node(((Leaf _) as t_l), (_,_,_), ((Leaf _) as t_r)) ® 
           red_ok(t_l) & red_ok(t_r)
       | Node(((Node(_,_,_) as t_l), 
               (_,_,Black), 
               ((Node(_,_,_)) as t_r))) ® (red_ok t_l) & (red_ok t_r)
       | Node(_, (_,_,Red), Node(_,(_,_,Red),_)) ® false
       | Node(Node(_,(_,_,Red),_), (_,_,Red), _) ® false
       | Node(t_l, _, t_r) ® (red_ok t_l) & (red_ok t_r)

     let rec depth_rbtree tr =
       match tr with 
         Leaf _ ® 0
       | Node(t_l, _, t_r) ® (max (depth_rbtree t_r) (depth_rbtree t_l)) + 1

     let black_ok t =
       let rec black_h tr =
         match tr with 
           Leaf Black ® 0
         | Leaf Red ® raise (Failure ("Black error"))
         | Node(t1,(_,_,Black), t2) ®
             (match ((black_h t1), (black_h t2)) 
             with (h1, h2) ® 
               if (h1 = h2) 
               then h1 + 1 
               else raise (Failure ("Black error")))
         | Node(t1,(_,_,Red), t2) ®
             (match ((black_h t1), (black_h t2)) with
               (h1, h2) ® 
                 if (h1 = h2) 
                 then h1 
                 else raise (Failure ("Black error")))
       in 
       match t with
         Leaf Black ® true
       | Leaf Red ® false
       | t ® 
           try let h =(black_h t) in true
           with (Failure s) ® false

     let print_rbtinfo tr = 
       (if (red_ok tr) 
       then print_string("Red-OK, ") 
       else print_string("Red: FEHLER, ");
         if (black_ok tr)
         then print_string("Black-OK, ") 
         else print_string("Black: FEHLER, ");
         if (sort_ok tr)
         then print_string("Sort ok, ") 
         else print_string("Sort: FEHLER, ");
         print_string("Tiefe = ");
         print_int (depth_rbtree tr);
         print_string(": ");
         print_endline(string_of_tree tr))


     let print_dict d = print_endline("")

   end


6   Graphs

Interface for module Graphs

type a dgraph = 
       Graph of (a ® a list)

exception Not_Found

val dfs : a dgraph ® (a ® bool) ® a ® a
val dfs_collect : a dgraph ® (a ® bool) ® a ® a list

Module Graphs

type a dgraph =
     Graph of (a ® a list)

exception Not_Found

let dfs (g: a dgraph) (p: a ® bool) (start: a) = 
   match g with Graph succ ®
     let rec search visited l =
       match l with
             [ ] ® raise Not_Found
       | a::rl ® 
           if (List.mem a visited)
           then (search visited rl)
           else 
             if (p a) 
             then a 
             else search (a::visited) (rl @ (succ a))
     in 
     search [ ] [start]

     let dfs_collect (g: a dgraph) (p: a ® bool) (start: a) : a list = 
       match g with Graph succ ®
         let rec search (visited: a list) (l:a list) (hits: a list): a list =
           match l with
             [ ] ® hits
           | a::rl ® 
               if (List.mem a visited)
               then (search visited rl hits)
               else 
                 if (p a) 
                 then search (a::visited) ((succ a) @ rl) (a::hits)
                 else search (a::visited) ((succ a) @ rl) hits
         in search [ ] [start] [ ]

Module Scc

The file contains an implementation of ``Tarjan's algorithm'' to compute the strongly connected components of a graph. The algorithm is modelled similar to the one of CLR 90.


Graphs are ``doubly-linked'', i.e., each node knows the list of successors (the normal adjacency list) as well as the the predecessors. These are computed ``on-the-fly'', therefore the type dgraph for ``dynamic graph''.
type a dgraph = Graph of ((a ® a list) × (a ® a list))

dfs-collect finds by df-traversal all nodes for which the predicate holds. Additionally it give back the finishing time. The real work is done in the local search procedure.

l is the list of known but not yet finished nodes. Since the algorithm works on-the-fly, it doesn't contain all nodes at the beginning. A node is white, when it has not been treated and checked, grey when it has been checked, and black, when it has been finished. Since we are interested in the order in which the nodes are finished, we keep a separate list where we collect the finished nodes in the required order.
The returned list is ordered with the decreasing finishing times. It assumes that all nodes of the graph can be reached from the intial list.
One application of dfs_visit takes an entry node and calculates the list of reachable states (the black ones) in the reversed order of ``finishing'' times. Nodes listed in old_blacks are ignored.
type a color = White of a | Grey of a

type direction = Forward | Backward

let dfs_visit_f
     (g: a dgraph) 
     (d: direction)
     (start: a) (* start node for current descend *)
     (old_blacks: a list list) (* treated at previous dfs-descends *)
     : a list = 
   let list_cmem (e: a) (l: a color list) : bool = 
     List.exists (fun (e2: a color) ® (Grey e = e2)) l (* white doesn't count! *)
   in match g with Graph (succ, pred) ® 
     let f_neighbor = (
       match d with
         Forward ® succ
       | Backward ® pred)
     in
     let rec search 
         (l: (a color) list) 
         (black: a list)
         : (a list) = 
       match l with 
         [ ] ® black (* that's it *)
       | (White e):: l' ® 
           let nextnodes = (List.map (fun x ® White x) (f_neighbor e))
           in
           if 
             (list_cmem e l') or 
             (List.mem e black) or
             List.exists (fun (bl: a list) ® (List.mem e bl)) old_blacks
           then search l' black
           else search (nextnodes @ ((Grey e) :: l')) black
       | (Grey e) :: l' ® (search l' (e::black))
     in search [White start] [ ]

The function dfs_visit_iter iterates the previous function, collecting the ``black'' nodes of the recursive descends.


let dfs_visit_iter (g: a dgraph) 
     (d: direction)
     (startnodes: a list) (* they are considered a white *)
     : a list list = (* collection of reached nodes *)
   let rec f_iter 
       (startnodes: a list)
       (blacks: a list list)
       =
     match startnodes with
       [ ] ® (blacks)
     | i::startnodes' ® 
         let new_blacks = dfs_visit_f g d i blacks
         in match new_blacks with
           [ ] ® f_iter startnodes' blacks (* we don't count that *)
         | _ ® f_iter startnodes' (new_blacks :: blacks)
   in (f_iter startnodes [ ])

The ssc gives back the list of ssc's, each a list of nodes. The algorithm works by traversing two times the graph in a depth-first manner, one in forward, and one in backward direction, where the second traversal starts the df-searches in decreasing order of the finishing times of the forward run.
let scc (g: a dgraph) (start: a list) : (a list) list = 
   dfs_visit_iter g Backward (List.flatten (dfs_visit_iter g Forward start))


7   Index





1
The function is directly available from the standard-library. It's included here for sake of reference.
January 31, 2002
This document was translated from LATEX by HEVEA.