ocaml-reins-0.1a/0002755000175000017500000000000010676540775013017 5ustar furrmfurrmocaml-reins-0.1a/test/0002755000175000017500000000000010676540774013775 5ustar furrmfurrmocaml-reins-0.1a/test/unit/0002755000175000017500000000000010676540774014754 5ustar furrmfurrmocaml-reins-0.1a/test/unit/test_runner.ml0000644000175000017500000000444310676520540017646 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open OUnit open Test_helper module Test(T : TestSuite) = struct let test rs = T.desc >::: ["Unit Tests" >::: T.unit_suite; "Random Tests" >::: (List.map (fun (desc,suite) -> desc >:: (fun () -> suite rs)) T.random_suite) ] end let all_tests = fun rs -> "All Tests" >::: [ (let module T = Test(SListTest) in T.test rs); (let module T = Test(DoubleQueueTest) in T.test rs); (let module T = Test(DoubleListTest) in T.test rs); (let module T = Test(CatenableListTest) in T.test rs); (let module T = Test(SkewBinaryListTest) in T.test rs); (let module T = Test(AVLSetTest) in T.test rs); (let module T = Test(RBSetTest) in T.test rs); (let module T = Test(SplaySetTest) in T.test rs); (let module T = Test(PatriciaSetTest) in T.test rs); (let module T = Test(AVLMapTest) in T.test rs); (let module T = Test(RBMapTest) in T.test rs); (let module T = Test(SplayMapTest) in T.test rs); (let module T = Test(PatriciaMapTest) in T.test rs); (let module T = Test(BinomialHeapTest) in T.test rs); (let module T = Test(SkewBinomialHeapTest) in T.test rs); ] (* let stime = ref 0.0 let time_tests = function | EStart p -> stime := Unix.gettimeofday () | EEnd p -> let dtime = Unix.gettimeofday () in printf "%f : %s\n%!" (dtime -. !stime) (string_of_path p) | EResult(RError(p,s)) -> failwith s | EResult(RFailure(p,s)) -> failwith s | EResult _ -> () *) let _ = Format.printf "Running unit tests\n"; let rs = Random.State.make_self_init () in (* let _ = perform_test time_tests (all_tests rs) in ()*) let _ = run_test_tt_main (all_tests rs) in Format.printf "\n*** All tests passed ***\n\n" ocaml-reins-0.1a/test/unit/genericTest.ml0000644000175000017500000000323410676520540017547 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types open Test_helper module ComparableTests(C : Mono.ArbitraryComparable) = struct let random_suite = [ (let module T = RandCheck(struct module Arg = C let desc = "Compare is reflexive" let law t = C.compare t t = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(C)(C) let desc = "Compare is anti-symmetric" let law (t1,t2) = let c1 = C.compare t1 t2 in let c2 = C.compare t2 t1 in c1 = -c2 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.Gen3Tuple(C)(C)(C) let desc = "Compare is transitive" let law (t1, t2, t3) = match (C.compare t1 t2), (C.compare t2 t3) with | 0,0 -> (C.compare t1 t3) = 0 | x,y when x < 0 && y < 0 -> (C.compare t1 t3) < 0 | x,y when x > 0 && y > 0 -> (C.compare t1 t3) > 0 | x, y when x < 0 && y > 0 -> raise Quickcheck.Trivial | x, y (* x > 0 && y < 0*) -> raise Quickcheck.Trivial end) in (T.desc, T.test)); ] let unit_suite = [] end ocaml-reins-0.1a/test/unit/test_helper.ml0000644000175000017500000000177110676520540017615 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins module type TestSuite = sig val desc : string val unit_suite : OUnit.test list val random_suite : (string * (Random.State.t -> unit)) list end module Conf = struct let num_iterations = 100 let size_arg = Some 100 let max_trivial_percentage = 10.0 end module RandCheck = Quickcheck.Check(Conf) let rec do_times n f acc = if n <= 0 then acc else do_times (n-1) f (f acc) ocaml-reins-0.1a/test/unit/list/0002755000175000017500000000000010676540773015726 5ustar furrmfurrmocaml-reins-0.1a/test/unit/list/genericListTest.ml0000644000175000017500000001562610676520540021366 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types open Test_helper module GenList = Mono.ComposeGenComparable(SList) module Make(L : Lists.ListSig)(A : Mono.ArbitraryComparable) = struct module GenL = Mono.ComposeGenComparable(L)(A) module CmpTests = GenericTest.ComparableTests(GenL) let random_suite = CmpTests.random_suite @ [ (let module T = RandCheck(struct module Arg = A let desc = ".rev [x] = [x]" let law i = let t = L.cons i L.empty in GenL.compare (L.rev t) t = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GenL)(GenL) let desc = ".rev (x@y) = (.rev y) @ (.rev x)" let law (l1,l2) = let l1' = L.rev (L.append l1 l2) in let l2' = L.append (L.rev l2) (L.rev l1) in GenL.compare l1' l2' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenL let desc = ".rev x = .rev (.rev x)" let law l1 = let l2 = L.rev (L.rev l1) in GenL.compare l1 l2 = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenL) let desc = "hd (cons x t) is x" let law (x,l) = A.compare (L.hd (L.cons x l)) x = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenList(A) let desc = "Length is n after n cons" let law il = let dl = List.fold_left (fun acc x -> L.cons x acc) L.empty il in (List.length il) = (L.length dl) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenL) let desc = "tail of (cons x l) is l" let law (i,l) = let l' = L.tl (L.cons i l) in (GenL.compare l l') = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenL let desc = "from_list (to_list x) is x" let law l = GenL.compare l (L.from_list (L.to_list l)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module AL = GenList(A) module Arg = GenList(A) let desc = "to_list (from_list x) is x" let law l = AL.compare l (L.to_list (L.from_list l)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenList(GenL) let desc = "flatten mirrors List.flatten" let law l = let t = L.from_list l in let lst1 = L.to_list (L.flatten t) in let t' = List.map L.to_list l in let lst2 = List.flatten t' in let module ML = GenList(A) in (ML.compare lst1 lst2) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenL) let desc = "pop of (cons x l) is x,l" let law (i,l) = let x,tl = L.pop (L.cons i l) in (A.compare x i) = 0 && (GenL.compare tl l) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenL) let desc = "last (snoc x t) is x" let law (x,l) = let x' = L.last (L.snoc x l) in A.compare x x' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenList(A) let desc = "to_list preserves order" let law l = let lr = List.rev l in let t = List.fold_left (fun acc x -> L.cons x acc) L.empty lr in let l' = L.to_list t in let module ML = GenList(A) in ML.compare l l' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenL let desc = "(map id l) is same as l" let law l = let l' = L.map (fun x -> x) l in L.compare A.compare l l' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenL let desc = "l is same as (rev (rev_map id l))" let law l = let l' = L.rev (L.rev_map (fun x -> x) l) in L.compare A.compare l l' = 0 end) in (T.desc, T.test)); ] let assert_equal_int x y = assert_equal ~cmp:(=) ~printer:string_of_int ~msg:"ints not equal" x y let unit_suite = CmpTests.unit_suite @ [ ("is_empty empty" >:: fun () -> assert_equal true (L.is_empty L.empty)); ("empty,ins,del,is_empty" >:: fun () -> let dl = L.cons 10 L.empty in let dl = L.tl dl in assert_equal true (L.is_empty dl)); ("hd of empty raises Failure 'hd'" >:: fun () -> (try ignore(L.hd L.empty); assert_failure "hd of empty should raise an exception" with | Failure "hd" -> () | _ -> assert_failure "(hd empty) raised the wrong exception")); ("tl of empty raises Failure 'tl'" >:: fun () -> (try ignore(L.tl L.empty); assert_failure "tl of empty should raise an exception" with | Failure "tl" -> () | _ -> assert_failure "(tl empty) raised the wrong exception")); ("pop of empty raises Failure 'pop'" >:: fun () -> (try ignore(L.pop L.empty); assert_failure "pop of empty should raise an exception" with | Failure "pop" -> () | _ -> assert_failure "(pop empty) raised the wrong exception")); ("last of empty raises Failure 'last'" >:: fun () -> (try ignore(L.last L.empty); assert_failure "last of empty should raise an exception" with | Failure "last" -> () | _ -> assert_failure "(last empty) raised the wrong exception")); ("map of (+1) on [1..5] is [2..6]" >:: fun () -> let l = L.from_list [1;2;3;4;5] in let l' = L.map ((+) 1) l in let lr = L.from_list [2;3;4;5;6] in assert_equal ~cmp:(fun x y -> L.compare Int.compare x y = 0) ~printer:(L.to_string Int.to_string) l' lr ); ("rev_map of (+1) on [1..5] is [6..2]" >:: fun () -> let l = L.from_list [1;2;3;4;5] in let l' = L.rev_map ((+) 1) l in let lr = L.from_list [6;5;4;3;2] in assert_equal ~cmp:(fun x y -> L.compare Int.compare x y = 0) ~printer:(L.to_string Int.to_string) l' lr ); ("to_string of [1;2;3;4;5] is \"[1;2;3;4;5]\"" >:: fun () -> let l = L.from_list [1;2;3;4;5] in let s = L.to_string string_of_int l in let module ML = GenList(Int) in assert_equal ~cmp:(fun x y -> String.compare x y = 0) ~printer:(fun x -> x) s "[1; 2; 3; 4; 5]" ); ("to_string of [] is \"[]\"" >:: fun () -> let l = L.from_list [] in let s = L.to_string string_of_int l in let module ML = GenList(Int) in assert_equal ~cmp:(fun x y -> String.compare x y = 0) ~printer:(fun x -> x) s "[]" ); ] end ocaml-reins-0.1a/test/unit/list/catenableListTest.ml0000644000175000017500000000152110676520540021655 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Quickcheck open Types open Lists let desc = "CatenableList" module GTests = GenericListTest.Make(CatenableList)(Int) let random_suite = [ ] @ GTests.random_suite let unit_suite = GTests.unit_suite ocaml-reins-0.1a/test/unit/list/skewBinaryListTest.ml0000644000175000017500000000506110676520540022060 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins open Quickcheck open Types open Lists open Test_helper open OUnit let desc = "SkewBinaryList" module G = Mono.ComposeGenComparable(SkewBinaryList)(Int) module GTests = GenericListTest.Make(SkewBinaryList)(Int) let random_suite = [ (let module T = RandCheck(struct module Arg = Int let desc = "List of {0..n-1} can lookup {0,...,l-1}" let law len = let len = (max 1 len) mod 100 in let rec f n l = if n < 0 then l else f (n-1) (SkewBinaryList.cons n l) in let l = f len SkewBinaryList.empty in for i = 0 to (len-1) do assert (SkewBinaryList.lookup i l = i) done; true end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = G let desc = "List of length l can update {0,...,l-1}" let law l = let len = SkewBinaryList.length l in for i = 0 to (len-1) do ignore(SkewBinaryList.update i 10 l); done; true end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = G let desc = "lookup sees updates" let law l = if SkewBinaryList.is_empty l then raise Trivial; let i = Int.gen (Random.State.make_self_init()) in let len = SkewBinaryList.length l in let idx = Random.int len in SkewBinaryList.lookup idx (SkewBinaryList.update idx i l) = i end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = G let desc = "lookup failure raises Not_found" let law l = let len = SkewBinaryList.length l in try ignore(SkewBinaryList.lookup len l); false with Not_found -> true end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = G let desc = "update failure raises Not_found" let law l = let len = SkewBinaryList.length l in try ignore(SkewBinaryList.update len 10 l); false with Not_found -> true end) in (T.desc, T.test)); ] @ GTests.random_suite module L = SkewBinaryList let unit_suite = [ ] @ GTests.unit_suite ocaml-reins-0.1a/test/unit/list/sListTest.ml0000644000175000017500000000225010676520540020201 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types module List_IT = ListIterator.From_List(SList) module GTests = GenericListTest.Make(SList)(Int) let desc = "Standard List" let fold_test = "iterator fold" >:: fun () -> let lst = [1;2;3;4;5] in let it = List_IT.create List_IT.Left_Right List_IT.Traverse_All lst in let it_ans = List_IT.fold (+) 0 it in let std_ans = List.fold_left (+) 0 lst in assert_equal ~printer:Int.to_string std_ans it_ans let unit_suite = [ fold_test ] @ GTests.unit_suite let random_suite = [ ] @ GTests.random_suite ocaml-reins-0.1a/test/unit/list/doubleQueueTest.ml0000644000175000017500000000250210676520540021362 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Test_helper open Types let desc = "DoubleQueue" module GenList = Mono.ComposeGenComparable(SList) module GTests = GenericListTest.Make(DoubleQueue)(Int) let random_suite = [ (let module T = RandCheck(struct module Arg = GenList(Int) let desc = "queue all elements in list. repeated dequeue gives same order as list fold" let law l = let q = List.fold_left (fun acc x -> DoubleQueue.enqueue x acc) DoubleQueue.empty l in let t,_ = List.fold_left (fun (t,acc) x -> let hd,tl = DoubleQueue.dequeue acc in (t && hd = x),tl ) (true,q) l in t end) in (T.desc, T.test)); ] @ GTests.random_suite let unit_suite = [ ] @ GTests.unit_suite ocaml-reins-0.1a/test/unit/list/OMakefile0000644000175000017500000000024410672112566017472 0ustar furrmfurrm OCAMLINCLUDES += .. FILES[] += list/sListTest list/doubleListTest list/catenableListTest list/doubleQueueTest list/skewBinaryListTest list/genericListTest ocaml-reins-0.1a/test/unit/list/doubleListTest.ml0000644000175000017500000000536610676520540021224 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Test_helper open Types let desc = "DoubleList" module DSList = DoubleList.Make(SList) module G = Mono.ComposeGenComparable(DSList)(Int) module GTests = GenericListTest.Make(DSList)(Int) let random_suite = [ ( let module T = RandCheck(struct module Arg = Mono.GenPair(G)(G) let desc = "splice list is eq to cons each individual" let law (l1,l2) = let res1 = DSList.splice l1 l2 in let lfront = DSList.goto_front l1 in let res2 = DSList.fold (fun acc x -> DSList.next (DSList.cons x acc)) l2 lfront in G.compare res1 res2 = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = G let desc = "x = (prev (next x))" let law l = if DSList.at_back l then true else G.compare l (DSList.prev (DSList.next l)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = G let desc = "x = (next (prev x))" let law l = if DSList.at_front l then true else G.compare l (DSList.next (DSList.prev l)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(Int)(G) let desc = "pop of (cons x l) is x,l" let law (i,l) = let x,tl = DSList.pop (DSList.cons i l) in (Int.compare x i) = 0 && (G.compare tl l) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(G)(G) let desc = "append l is same as to cons'ing individually at end" let law (l1,l2) = let l = DSList.append l1 l2 in let l' = DSList.fold (fun acc x -> DSList.cons x (DSList.goto_back acc)) l1 (DSList.goto_front l2) in G.compare l l' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.ComposeGenComparable(DSList)(G) let desc = "DSList.flatten mirrors List.flatten" let law dll = let lst = List.map DSList.to_list (DSList.to_list dll) in let lst' = List.flatten lst in let dll1 = DSList.from_list lst' in let dll2 = DSList.flatten dll in G.compare dll1 dll2 = 0 end) in (T.desc, T.test)); ] @ GTests.random_suite let unit_suite = GTests.unit_suite ocaml-reins-0.1a/test/unit/set/0002755000175000017500000000000010676540773015546 5ustar furrmfurrmocaml-reins-0.1a/test/unit/set/genericSetTest.ml0000644000175000017500000002335710676520540021026 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types open Test_helper module GenList = Mono.ComposeGenComparable(SList) module RandomSetTests(GSet : Sets.GenSetSig) (A : Mono.ArbitraryComparable with type t = GSet.elt) = struct let add_list t l = List.fold_left (fun t e -> GSet.add e t) t l module CmpTests = GenericTest.ComparableTests(GSet) let random_suite = CmpTests.random_suite @ [ (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenList(A)) let desc = "[Set] Add first element" let law (i,lst) = let t = GSet.add i GSet.empty in let t = add_list t lst in GSet.of_result (GSet.mem i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.Gen3Tuple(GSet)(A)(GenList(A)) let desc = "[Set] Add middle element" let law (t,i,lst) = let t = GSet.add i t in let t = add_list t lst in GSet.of_result (GSet.mem i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GSet) let desc = "[Set] Add last element" let law (i,t) = GSet.of_result (GSet.mem i (GSet.add i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenList(A)) let desc = "[Set] Remove first element" let law (i,lst) = let t = GSet.add i GSet.empty in let t = add_list t lst in let t = GSet.remove i t in not (GSet.of_result (GSet.mem i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.Gen3Tuple(GSet)(A)(GenList(A)) let desc = "[Set] Remove middle element" let law (t,i,lst) = let t = GSet.add i t in let t = add_list t lst in let t = GSet.remove i t in not (GSet.of_result (GSet.mem i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(A) let desc = "[Set] Remove last element" let law (t,i) = let t = GSet.add i t in let t = GSet.remove i t in not (GSet.of_result (GSet.mem i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(GSet) let desc = "[Set] Union is commutative" let law (t1,t2) = let t = GSet.union t1 t2 in let t' = GSet.union t2 t1 in GSet.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GenList(A))(GenList(A)) let desc = "[Set] Union follows list concatenation" let law (l1,l2) = let t1 = add_list GSet.empty l1 in let t2 = add_list GSet.empty l2 in let t = GSet.union t1 t2 in let t' = add_list GSet.empty (l1 @ l2) in GSet.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(GSet) let desc = "[Set] Intersection is commutative" let law (t1,t2) = let t = GSet.inter t1 t2 in let t' = GSet.inter t2 t1 in GSet.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GenList(A))(GenList(A)) let desc = "[Set] Intersection follows list find_all" let law (l1,l2) = let t1 = add_list GSet.empty l1 in let t2 = add_list GSet.empty l2 in let t = GSet.inter t1 t2 in let ilst = List.find_all (fun x -> List.mem x l1) l2 in let t' = add_list GSet.empty ilst in GSet.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GSet let desc = "[Set] diff x x is empty" let law t = let t' = GSet.diff t t in GSet.is_empty t' end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GenList(A))(GenList(A)) let desc = "[Set] diff follows list filter" let law (l1,l2) = let t1 = add_list GSet.empty l1 in let t2 = add_list GSet.empty l2 in let t = GSet.diff t1 t2 in let dlist = List.filter (fun x -> not (List.mem x l2)) l1 in let t' = add_list GSet.empty dlist in GSet.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(GSet) let desc = "[Set] A intersected with B is B - (B - A)" let law (t1,t2) = let t = GSet.inter t1 t2 in let t' = GSet.diff t2 (GSet.diff t2 t1) in GSet.compare t t' = 0 end) in (T.desc, T.test)); (* Well formedness tests *) (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GSet) let desc = "[Set] GSet Well-Formed after add" let law (i,t) = assert(GSet.well_formed t); GSet.well_formed (GSet.add i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GSet) let desc = "[Set] GSet Well-Formed after remove" let law (i,t) = assert(GSet.well_formed t); GSet.well_formed (GSet.add i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(GSet) let desc = "[Set] GSet Well-Formed after union" let law (t1,t2) = assert(GSet.well_formed t1); assert(GSet.well_formed t2); GSet.well_formed (GSet.union t1 t2) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(GSet) let desc = "[Set] GSet Well-Formed after diff" let law (t1,t2) = assert(GSet.well_formed t1); assert(GSet.well_formed t2); GSet.well_formed (GSet.diff t1 t2) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(GSet) let desc = "[Set] GSet Well-Formed after inter" let law (t1,t2) = assert(GSet.well_formed t1); assert(GSet.well_formed t2); GSet.well_formed (GSet.inter t1 t2) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GSet let desc = "[Set] Iter visits nodes in increasing order" let law t = if GSet.is_empty t then true else let acc = ref (GSet.of_result (GSet.min_elt t)) in GSet.iter (fun x -> if A.compare x !acc < 0 then failwith "Failed!" else acc := x ) t; true end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GSet let desc = "[Set] fold visits nodes in increasing order" let law t = if GSet.is_empty t then true else let min = GSet.of_result (GSet.min_elt t) in let _ = GSet.fold (fun acc x -> if A.compare x acc < 0 then failwith "Failed!" else x ) min t in true end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GSet let desc = "[Set] fold finds max_elt" let law t = if GSet.is_empty t then raise Quickcheck.Trivial; let mk = GSet.fold (fun acc k -> if A.compare acc k < 0 then k else acc) (GSet.of_result (GSet.min_elt t)) t in A.compare mk (GSet.of_result (GSet.max_elt t)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GSet let desc = "[Set] fold finds min_elt" let law t = if GSet.is_empty t then raise Quickcheck.Trivial; let mk = GSet.fold (fun acc k -> if A.compare acc k > 0 then k else acc) (GSet.of_result (GSet.max_elt t)) t in A.compare mk (GSet.of_result (GSet.min_elt t)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GSet)(A) let desc = "[Set] removing a non-existent element is no-op" let law (t,x) = if GSet.of_result (GSet.mem x t) then raise Quickcheck.Trivial else GSet.compare t (GSet.remove x t) = 0 end) in (T.desc, T.test)); ] let unit_suite = CmpTests.unit_suite @ [ ("min_elt empty raises Not_found" >:: fun () -> assert_raises ~msg:"(min_elt empty) should raise Not_found" Not_found (fun () -> (GSet.min_elt GSet.empty)) ); ("max_elt empty raises Not_found" >:: fun () -> assert_raises ~msg:"(max_elt empty) should raise Not_found" Not_found (fun () -> (GSet.max_elt GSet.empty)) ); ("choose empty raises Not_found" >:: fun () -> assert_raises ~msg:"(choose empty) should raise Not_found" Not_found (fun () -> (GSet.choose GSet.empty)) ); ("the cardinal of empty is 0" >:: fun () -> assert_equal ~printer:string_of_int 0 (GSet.cardinal GSet.empty) ); ("the cardinal of a singleton is 1" >:: fun () -> let rs = Random.State.make_self_init () in let t = GSet.singleton (A.gen rs) in assert_equal ~printer:string_of_int 1 (GSet.cardinal t) ); ("move_up from the top raises Failure 'move up'" >:: fun () -> assert_raises ~msg:"move_up should raise Failure" (Failure "move_up") (fun () -> (GSet.move_up (GSet.to_cursor GSet.empty))) ); ("move_down_left raises Failure 'move_down_left'" >:: fun () -> assert_raises ~msg:"move_down_left should raise Failure" (Failure "move_down_left") (fun () -> (GSet.move_down_left (GSet.to_cursor GSet.empty))) ); ("move_down_right top raises Failure 'move down_right'" >:: fun () -> assert_raises ~msg:"move_down_right should raise Failure" (Failure "move_down_right") (fun () -> (GSet.move_down_right (GSet.to_cursor GSet.empty))) ); ("empty is well formed" >:: fun () -> assert_bool "empty should be well-formed" (GSet.well_formed GSet.empty) ); ] end ocaml-reins-0.1a/test/unit/set/patriciaSetTest.ml0000644000175000017500000000172510676520540021201 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins open Types let desc = "Patricia Sets" module SetTests = GenericSetTest.RandomSetTests(PatriciaSet.GenSet)(Int) module IterTests = TreeSetIteratorTest.RandomTests(PatriciaSet.GenSet)(Int) let random_suite = [ ] @ SetTests.random_suite @ IterTests.random_suite let unit_suite = [ ] @ SetTests.unit_suite @ IterTests.unit_suite ocaml-reins-0.1a/test/unit/set/aVLSetTest.ml0000644000175000017500000000270110676520540020062 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types open Quickcheck open Printf let desc = "AVL" module SetTests1 = GenericSetTest.RandomSetTests(AVLSet.GenSet1(Int))(Int) module SetTests2 = GenericSetTest.RandomSetTests(AVLSet.GenSet2(Int))(Int) module SetTests3 = GenericSetTest.RandomSetTests(AVLSet.GenSet3(Int))(Int) module Iter1 = TreeSetIteratorTest.RandomTests(AVLSet.GenSet1(Int))(Int) module Iter2 = TreeSetIteratorTest.RandomTests(AVLSet.GenSet2(Int))(Int) module Iter3 = TreeSetIteratorTest.RandomTests(AVLSet.GenSet3(Int))(Int) let random_suite = [ ] @ SetTests1.random_suite @ SetTests2.random_suite @ SetTests3.random_suite @ Iter1.random_suite @ Iter2.random_suite @ Iter3.random_suite let unit_suite = [ ] @ SetTests1.unit_suite @ SetTests2.unit_suite @ SetTests3.unit_suite @ Iter1.unit_suite @ Iter2.unit_suite @ Iter3.unit_suite ocaml-reins-0.1a/test/unit/set/rBSetTest.ml0000644000175000017500000000172610676520540017751 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types let desc = "RedBlack" module SetTests = GenericSetTest.RandomSetTests(RBSet.GenSet(Int))(Int) module IterTests = TreeSetIteratorTest.RandomTests(RBSet.GenSet(Int))(Int) let random_suite = [ ] @ SetTests.random_suite @ IterTests.random_suite let unit_suite = [ ] @ SetTests.unit_suite @ IterTests.unit_suite ocaml-reins-0.1a/test/unit/set/splaySetTest.ml0000644000175000017500000000276010676520540020535 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open OUnit open Reins open Test_helper open Types let desc = "Splay" module M = SplaySet.GenSet(Int) let top_node t = let c = M.to_cursor t in M.get_value c let mem_at_top i t = let m,t = M.mem i t in assert_bool (sprintf "mem failed for %d" i) (m = true); assert_equal i (top_node t); t let (++) f g = g f let add_mem_test = "add/mem sequential" >:: fun () -> let t = M.add 1 M.empty ++ M.add 2 ++ M.add 3 ++ M.add 4 ++ M.add 5 in ignore(mem_at_top 1 t ++ mem_at_top 2 ++ mem_at_top 3 ++ mem_at_top 4 ++ mem_at_top 5) module SetTests = GenericSetTest.RandomSetTests(M)(Int) module IterTests = TreeSetIteratorTest.RandomTests(M)(Int) let random_suite = [ ] @ SetTests.random_suite @ IterTests.random_suite let unit_suite = [ add_mem_test ] @ SetTests.unit_suite @ IterTests.unit_suite ocaml-reins-0.1a/test/unit/set/OMakefile0000644000175000017500000000022510676104001017276 0ustar furrmfurrm OCAMLINCLUDES += .. FILES[] += set/aVLSetTest set/patriciaSetTest set/splaySetTest set/genericSetTest set/rBSetTest set/treeSetIteratorTest ocaml-reins-0.1a/test/unit/set/treeSetIteratorTest.ml0000644000175000017500000001125710676520540022057 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open OUnit open Test_helper open Reins open Types let desc = "TreeSet Iterator" module RandomTests (Tree : Sets.GenSetSig) (Elt : Mono.ArbitraryComparable with type t = Tree.elt) = struct module Iter = TreeSetIterator.Make(Tree) let tree_of_list lst = List.fold_left (fun x y -> Tree.add y x) Tree.empty lst let list_of_iter it = List.rev (Iter.fold (fun acc x -> x::acc) [] it) let assert_equal_ilist l1 l2 = let module M = Mono.ComposeComparable(SList)(Int) in assert_equal ~cmp:(fun x y -> M.compare x y = 0) ~printer:M.to_string l1 l2 let unit_suite = [ ("while false traverse" >:: fun () -> let rs = Random.State.make_self_init () in let trav = Iter.Traverse_While (fun _ -> false) in let s = Tree.singleton (Elt.gen rs) in let _ = Iter.create (Iter.Ascending Iter.InOrder) trav s in () ); ] let random_suite = [ (let module T = RandCheck(struct module Arg = Mono.ComposeGen(SList)(Elt) let desc = "asc inorder is follows List.sort" let law lst = let sorted_lst = SList.sort Elt.compare lst in let t = tree_of_list lst in let dir = Iter.Ascending Iter.InOrder in let it = Iter.create dir Iter.Traverse_All t in let iter_lst = list_of_iter it in if SList.compare Elt.compare sorted_lst iter_lst = 0 then true else begin let msg = Printf.sprintf "sorted: %s iter: %s\n" (SList.to_string Elt.to_string sorted_lst) (SList.to_string Elt.to_string iter_lst) in failwith msg end end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.ComposeGen(SList)(Elt) let desc = "desc inorder is follows reversed List.sort" let law lst = let sorted_lst = SList.sort (fun x y -> -(Elt.compare x y)) lst in let t = tree_of_list lst in let dir = Iter.Descending Iter.InOrder in let it = Iter.create dir Iter.Traverse_All t in let iter_lst = list_of_iter it in SList.compare Elt.compare sorted_lst iter_lst = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Tree let desc = "asc inorder is reverse of desc inorder" let law t = let module I = TreeSetIterator.Make(Arg) in let it1 = I.create (I.Ascending I.InOrder) I.Traverse_All t in let it2 = I.create (I.Descending I.InOrder) I.Traverse_All t in let lst1 = I.fold (fun acc x -> x::acc) [] it1 in let lst2 = I.fold (fun acc x -> x::acc) [] it2 in let module L = Mono.ComposeComparable(SList)(Elt) in (L.compare lst1 (List.rev lst2)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Tree let desc = "asc preorder is reverse of desc preorder" let law t = let module I = TreeSetIterator.Make(Arg) in let it1 = I.create (I.Ascending I.PreOrder) I.Traverse_All t in let it2 = I.create (I.Descending I.PreOrder) I.Traverse_All t in let lst1 = I.fold (fun acc x -> x::acc) [] it1 in let lst2 = I.fold (fun acc x -> x::acc) [] it2 in let module L = Mono.ComposeComparable(SList)(Elt) in (L.compare lst1 (List.rev lst2)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Tree let desc = "asc postorder is reverse of desc postorder" let law t = let module I = TreeSetIterator.Make(Arg) in let it1 = I.create (I.Ascending I.PostOrder) I.Traverse_All t in let it2 = I.create (I.Descending I.PostOrder) I.Traverse_All t in let lst1 = I.fold (fun acc x -> x::acc) [] it1 in let lst2 = I.fold (fun acc x -> x::acc) [] it2 in let module L = Mono.ComposeComparable(SList)(Elt) in (L.compare lst1 (List.rev lst2)) = 0 end) in (T.desc, T.test)); (* (let module T = RandCheck(struct module Arg = Tree let desc = "folding asc preorder follows Tree.fold" let law t = let module ISet = AVL.GenSet(Int) in let module I = TreeSetIterator.MonoIterator(ISet) in let s = ISet.add 3 ISet.empty in let it = I.create (I.Ascending I.PreOrder) I.Traverse_All s in let it_ans = I.fold (+) 0 it in let std_ans = 3 in assert_equal ~printer:Int.to_string std_ans it_ans end) in (T.desc, T.test)); *) ] end ocaml-reins-0.1a/test/unit/OMakefile0000644000175000017500000000073510675630623016526 0ustar furrmfurrm TESTDIRS = list heap set map OCAMLINCLUDES += \ $(shell $(OCAMLFIND) query oUnit) \ $(ROOT)/src FILES[] = test_helper genericTest test_runner .SUBDIRS: $(TESTDIRS) include OMakefile export FILES OCAMLINCLUDES += $(TESTDIRS) OCAML_LIBS = $(ROOT)/src/reins OCAML_OTHER_LIBS += str nums unix oUnit TEST_PROGRAM = $(OCamlProgram run_unit_tests, $(FILES)) unit_tests.results: $(TEST_PROGRAM) ./run_unit_tests |& tee $@ .DEFAULT: $(TEST_PROGRAM) unit_tests.results ocaml-reins-0.1a/test/unit/heap/0002755000175000017500000000000010676540774015671 5ustar furrmfurrmocaml-reins-0.1a/test/unit/heap/binomialHeapTest.ml0000644000175000017500000000147010676520540021440 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins open Types let desc = "Binomial" module ITest = GenericHeapTest.RandomTests(BinomialHeap.GenHeap)(Int) let random_suite = [ ] @ ITest.random_suite let unit_suite = [] @ ITest.unit_suite ocaml-reins-0.1a/test/unit/heap/genericHeapTest.ml0000644000175000017500000000362210676520540021263 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins open Types open Test_helper module GenList = Mono.ComposeGenComparable(SList) module type HOHeap = functor(C : Mono.ArbitraryComparable) -> Heaps.GenHeapSig with type elt = C.t module RandomTests(H : HOHeap)(A : Mono.ArbitraryComparable) = struct module Heap = H(A) let unit_suite = [] let random_suite = [ (let module T = RandCheck(struct module Arg = A let desc = "ins/find 1 element" let law i = let t = Heap.insert i Heap.empty in let i' = Heap.find_min t in A.compare i i' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = A let desc = "ins/del is empty" let law i = let t = Heap.insert i Heap.empty in let t = Heap.delete_min t in Heap.is_empty t end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GenList(A) let desc = "insert list then find_min/del_min each gives sorted output" let law l = let t = List.fold_left (fun acc x -> Heap.insert x acc) Heap.empty l in let lst' = let rec loop acc t = if Heap.is_empty t then acc else loop ((Heap.find_min t)::acc) (Heap.delete_min t) in loop [] t in let lst' = List.rev lst' in let sortlst = List.sort A.compare l in lst' = sortlst end) in (T.desc, T.test)); ] end ocaml-reins-0.1a/test/unit/heap/skewBinomialHeapTest.ml0000644000175000017500000000150110676520540022265 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins open Types let desc = "Skew Binomial" module ITest = GenericHeapTest.RandomTests(SkewBinomialHeap.GenHeap)(Int) let random_suite = [ ] @ ITest.random_suite let unit_suite = [] @ ITest.unit_suite ocaml-reins-0.1a/test/unit/heap/OMakefile0000644000175000017500000000015010675310525017426 0ustar furrmfurrm OCAMLINCLUDES += .. FILES[] += heap/genericHeapTest heap/binomialHeapTest heap/skewBinomialHeapTestocaml-reins-0.1a/test/unit/map/0002755000175000017500000000000010676540774015531 5ustar furrmfurrmocaml-reins-0.1a/test/unit/map/genericMapTest.ml0000644000175000017500000002711610676520540020767 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types open Test_helper module GenList = Mono.ComposeGenComparable(SList) module RandomMapTests (A : Mono.ArbitraryComparable) (GMap : Maps.GenMapSig with type key = A.t and type elt = A.t) = struct module CmpTests = GenericTest.ComparableTests(GMap) module KV = Mono.ComparablePair(A)(A) let add_list t l = List.fold_left (fun t e -> GMap.add e e t) t l let join_max k v1 v2 = max v1 v2 let diff_true _ _ _ = true let random_suite = CmpTests.random_suite @ [ (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenList(A)) let desc = "[Map] Add first element" let law (i,lst) = let t = GMap.add i i GMap.empty in let t = add_list t lst in GMap.of_result (GMap.mem i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.Gen3Tuple(GMap)(A)(GenList(A)) let desc = "[Map] Add middle element" let law (t,i,lst) = let t = GMap.add i i t in let t = add_list t lst in GMap.of_result (GMap.mem i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GMap) let desc = "[Map] Add last element" let law (i,t) = GMap.of_result (GMap.mem i (GMap.add i i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GenList(A)) let desc = "[Map] Remove first element" let law (i,lst) = let t = GMap.add i i GMap.empty in let t = add_list t lst in let t = GMap.remove i t in not (GMap.of_result (GMap.mem i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.Gen3Tuple(GMap)(A)(GenList(A)) let desc = "[Map] Remove middle element" let law (t,i,lst) = let t = GMap.add i i t in let t = add_list t lst in let t = GMap.remove i t in not (GMap.of_result (GMap.mem i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(A) let desc = "[Map] Remove last element" let law (t,i) = let t = GMap.add i i t in let t = GMap.remove i t in not (GMap.of_result (GMap.mem i t)) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(GMap) let desc = "[Map] Union is commutative" let law (t1,t2) = (* Note: the join function must also be commutative *) let t = GMap.union join_max t1 t2 in let t' = GMap.union join_max t2 t1 in GMap.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GenList(A))(GenList(A)) let desc = "[Map] Union follows list concatenation" let law (l1,l2) = let t1 = add_list GMap.empty l1 in let t2 = add_list GMap.empty l2 in let t = GMap.union join_max t1 t2 in let t' = add_list GMap.empty (l1 @ l2) in GMap.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(GMap) let desc = "[Map] Intersection is commutative" let law (t1,t2) = let t = GMap.inter join_max t1 t2 in let t' = GMap.inter join_max t2 t1 in GMap.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GenList(A))(GenList(A)) let desc = "[Map] Intersection follows list find_all" let law (l1,l2) = let t1 = add_list GMap.empty l1 in let t2 = add_list GMap.empty l2 in let t = GMap.inter join_max t1 t2 in let ilst = List.find_all (fun x -> List.mem x l1) l2 in let t' = add_list GMap.empty ilst in GMap.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] diff x x is empty" let law t = let t' = GMap.diff diff_true t t in GMap.is_empty t' end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GenList(A))(GenList(A)) let desc = "[Map] diff follows list filter" let law (l1,l2) = let t1 = add_list GMap.empty l1 in let t2 = add_list GMap.empty l2 in let t = GMap.diff diff_true t1 t2 in let dlist = List.filter (fun x -> not (List.mem x l2)) l1 in let t' = add_list GMap.empty dlist in GMap.compare t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(GMap) let desc = "[Map] A intersected with B has same keys as B - (B - A)" let law (t1,t2) = let t = GMap.inter join_max t1 t2 in let t' = GMap.diff diff_true t2 (GMap.diff diff_true t2 t1) in GMap.compare_keys t t' = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] map id produces equivalent Map" let law t = let t' = GMap.map (fun x -> x) t in (GMap.compare t t') = 0 end) in (T.desc, T.test)); (* Well formedness tests *) (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GMap) let desc = "[Map] GMap Well-Formed after add" let law (i,t) = assert(GMap.well_formed t); GMap.well_formed (GMap.add i i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(A)(GMap) let desc = "[Map] GMap Well-Formed after remove" let law (i,t) = assert(GMap.well_formed t); GMap.well_formed (GMap.add i i t) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(GMap) let desc = "[Map] GMap Well-Formed after union" let law (t1,t2) = assert(GMap.well_formed t1); assert(GMap.well_formed t2); GMap.well_formed (GMap.union join_max t1 t2) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(GMap) let desc = "[Map] GMap Well-Formed after diff" let law (t1,t2) = assert(GMap.well_formed t1); assert(GMap.well_formed t2); GMap.well_formed (GMap.diff diff_true t1 t2) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(GMap) let desc = "[Map] GMap Well-Formed after inter" let law (t1,t2) = assert(GMap.well_formed t1); assert(GMap.well_formed t2); GMap.well_formed (GMap.inter join_max t1 t2) end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] Iter visits nodes in increasing order" let law t = if GMap.is_empty t then true else let acc = ref (GMap.of_result (GMap.min_key t)) in GMap.iter (fun x _ -> if A.compare x !acc < 0 then failwith "Failed!" else acc := x ) t; true end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] fold visits nodes in increasing order" let law t = if GMap.is_empty t then true else let min = GMap.of_result (GMap.min_key t) in let _ = GMap.fold (fun acc x _ -> if A.compare x acc < 0 then failwith "Failed!" else x ) min t in true end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] fold (+1) equals the cardinality" let law t = let c = GMap.fold (fun acc _ _ -> acc+1) 0 t in (GMap.cardinal t) = c end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] fold finds max_key" let law t = if GMap.is_empty t then raise Quickcheck.Trivial; let mk = GMap.fold (fun acc k _ -> if A.compare acc k < 0 then k else acc) (GMap.of_result (GMap.min_key t)) t in A.compare mk (GMap.of_result (GMap.max_key t)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] fold finds min_key" let law t = if GMap.is_empty t then raise Quickcheck.Trivial; let mk = GMap.fold (fun acc k _ -> if A.compare acc k > 0 then k else acc) (GMap.of_result (GMap.max_key t)) t in A.compare mk (GMap.of_result (GMap.min_key t)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] fold finds max_keyval" let law t = if GMap.is_empty t then raise Quickcheck.Trivial; let mkv = GMap.fold (fun (kacc,vacc) k v -> if A.compare kacc k < 0 then (k,v) else (kacc,vacc)) (GMap.of_result (GMap.min_keyval t)) t in KV.compare mkv (GMap.of_result (GMap.max_keyval t)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = GMap let desc = "[Map] fold finds min_keyval" let law t = if GMap.is_empty t then raise Quickcheck.Trivial; let mkv = GMap.fold (fun (kacc,vacc) k v -> if A.compare kacc k > 0 then (k,v) else (kacc,vacc)) (GMap.of_result (GMap.max_keyval t)) t in KV.compare mkv (GMap.of_result (GMap.min_keyval t)) = 0 end) in (T.desc, T.test)); (let module T = RandCheck(struct module Arg = Mono.GenPair(GMap)(A) let desc = "[Map] removing a non-existent element is no-op" let law (t,x) = if GMap.of_result (GMap.mem x t) then raise Quickcheck.Trivial else GMap.compare t (GMap.remove x t) = 0 end) in (T.desc, T.test)); ] let unit_suite = CmpTests.unit_suite @ [ ("min_key empty raises Not_found" >:: fun () -> assert_raises ~msg:"(min_key empty) should raise Not_found" Not_found (fun () -> (GMap.min_key GMap.empty)) ); ("max_key empty raises Not_found" >:: fun () -> assert_raises ~msg:"(max_key empty) should raise Not_found" Not_found (fun () -> (GMap.max_key GMap.empty)) ); ("min_keyval empty raises Not_found" >:: fun () -> assert_raises ~msg:"(min_keyval empty) should raise Not_found" Not_found (fun () -> (GMap.min_keyval GMap.empty)) ); ("max_keyval empty raises Not_found" >:: fun () -> assert_raises ~msg:"(max_keyval empty) should raise Not_found" Not_found (fun () -> (GMap.max_keyval GMap.empty)) ); ("the cardinal of empty is 0" >:: fun () -> assert_equal ~printer:string_of_int 0 (GMap.cardinal GMap.empty) ); ("the cardinal of a singleton is 1" >:: fun () -> let rs = Random.State.make_self_init () in let t = GMap.singleton (A.gen rs) (A.gen rs) in assert_equal ~printer:string_of_int 1 (GMap.cardinal t) ); ("move_up from the top raises Failure 'move up'" >:: fun () -> assert_raises ~msg:"move_up should raise Failure" (Failure "move_up") (fun () -> (GMap.move_up (GMap.to_cursor GMap.empty))) ); ("move_down_left raises Failure 'move_down_left'" >:: fun () -> assert_raises ~msg:"move_down_left should raise Failure" (Failure "move_down_left") (fun () -> (GMap.move_down_left (GMap.to_cursor GMap.empty))) ); ("move_down_right top raises Failure 'move down_right'" >:: fun () -> assert_raises ~msg:"move_down_right should raise Failure" (Failure "move_down_right") (fun () -> (GMap.move_down_right (GMap.to_cursor GMap.empty))) ); ("empty is well formed" >:: fun () -> assert_bool "empty should be well-formed" (GMap.well_formed GMap.empty) ); ] end ocaml-reins-0.1a/test/unit/map/patriciaMapTest.ml0000644000175000017500000000153010676520540021137 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins open Types let desc = "Patricia Sets" module MapTests = GenericMapTest.RandomMapTests(Int)(PatriciaMap.GenMap(Int)) let random_suite = [ ] @ MapTests.random_suite let unit_suite = [ ] @ MapTests.unit_suite ocaml-reins-0.1a/test/unit/map/aVLMapTest.ml0000644000175000017500000000215510676520540020031 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types open Quickcheck open Printf let desc = "AVL" module MapTests1 = GenericMapTest.RandomMapTests(Int)(AVLMap.Gen1(Int)(Int)) module MapTests2 = GenericMapTest.RandomMapTests(Int)(AVLMap.Gen2(Int)(Int)) module MapTests3 = GenericMapTest.RandomMapTests(Int)(AVLMap.Gen3(Int)(Int)) let random_suite = [ ] @ MapTests1.random_suite @ MapTests2.random_suite @ MapTests3.random_suite let unit_suite = [ ] @ MapTests1.unit_suite @ MapTests2.unit_suite @ MapTests3.unit_suite ocaml-reins-0.1a/test/unit/map/rBMapTest.ml0000644000175000017500000000153410676520540017712 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open OUnit open Reins open Types let desc = "RedBlack" module MapTests = GenericMapTest.RandomMapTests(Int)(RBMap.GenMap(Int)(Int)) let random_suite = [ ] @ MapTests.random_suite let unit_suite = [ ] @ MapTests.unit_suite ocaml-reins-0.1a/test/unit/map/OMakefile0000644000175000017500000000017410672112566017276 0ustar furrmfurrm OCAMLINCLUDES += .. FILES[] += map/aVLMapTest map/patriciaMapTest map/splayMapTest map/genericMapTest map/rBMapTest ocaml-reins-0.1a/test/unit/map/splayMapTest.ml0000644000175000017500000000262410676520540020500 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open OUnit open Reins open Test_helper open Types let desc = "Splay" module M = SplayMap.GenMap(Int)(Int) let top_key t = let c = M.to_cursor t in fst (M.get_value c) let mem_at_top i t = let m,t = M.mem i t in assert_bool (sprintf "mem failed for %d" i) (m = true); assert_equal i (top_key t); t let (++) f g = g f let add_mem_test = "add/mem sequential" >:: fun () -> let t = M.add 1 1 M.empty ++ M.add 2 2 ++ M.add 3 3 ++ M.add 4 4 ++ M.add 5 5 in ignore(mem_at_top 1 t ++ mem_at_top 2 ++ mem_at_top 3 ++ mem_at_top 4 ++ mem_at_top 5) module MapTests = GenericMapTest.RandomMapTests(Int)(M) let random_suite = [ ] @ MapTests.random_suite let unit_suite = [ add_mem_test ] @ MapTests.unit_suite ocaml-reins-0.1a/test/OMakefile0000644000175000017500000000002510672112566015535 0ustar furrmfurrm .SUBDIRS: perf unit ocaml-reins-0.1a/test/perf/0002755000175000017500000000000010676540774014731 5ustar furrmfurrmocaml-reins-0.1a/test/perf/bench_driver.ml0000644000175000017500000000211310676520540017675 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (*open Benchmark*) open Bench_helper (* let all_suites = [ Set_bench.suites; ] *) (* let rec run_bench = function | BenchGroup lst -> let res = latencyN ~style:Nil 500 lst in print_newline(); tabulate res | BenchList lst -> List.iter run_bench lst | BenchLabel (label,bench) -> Printf.printf "start group: %s\n%!" label; run_bench bench let _ = List.iter run_bench all_suites *) ocaml-reins-0.1a/test/perf/list_bench.ml0000644000175000017500000000752210676520540017366 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open Reins open Bench open Types type ('elt,'list) dict = { empty : 'list; is_empty : 'list -> bool; length : 'list -> int; rev : 'list -> 'list; cons : 'elt -> 'list -> 'list; snoc : 'elt -> 'list -> 'list; hd : 'list -> 'elt; tl : 'list -> 'list; pop : 'list -> 'elt * 'list; append : 'list -> 'list -> 'list; (* flatten *) from_list : 'elt list -> 'list; to_list : 'list -> 'elt list; iter : ('elt -> unit) -> 'list -> unit; fold : 'a. ('a -> 'elt -> 'a) -> 'a -> 'list -> 'a; (* rev_map : ('a -> 'b) -> 'a t -> 'b t; map : ('a -> 'b) -> 'a t -> 'b t; *) to_string : ('elt -> string) -> 'list -> string; compare : ('elt -> 'elt -> int) -> 'list -> 'list -> int; gen : (?size:int -> Random.State.t -> 'elt) -> ?size:int -> Random.State.t -> 'list; } module ListDict(L : Lists.ListSig) = struct let dict = { empty = L.empty; is_empty = L.is_empty; length = L.length; rev = L.rev; cons = L.cons; snoc = L.snoc; hd = L.hd; tl = L.tl; pop = L.pop; append = L.append; from_list = L.from_list; to_list = L.to_list; iter = L.iter; fold = L.fold; to_string = L.to_string; compare = L.compare; gen = L.gen; } end (* A type for abstractly working with a lists. Using a polymorphic record field allows the same 'f' to simultaneously apply to lists of arbitrary type. *) type ('elt, 'arg, 'res) polyf = { f : 'list. ('elt,'list) dict -> 'arg -> 'res } let modules_map f = [ (let module D = ListDict(CatenableList) in "CatenableList", f.f D.dict); (let module D = ListDict(DoubleList.Make(SList)) in "DoubleList(SList)", f.f D.dict); (let module D = ListDict(DoubleQueue) in "DoubleQueue", f.f D.dict); (let module D = ListDict(SkewBinaryList) in "SkewBinaryList", f.f D.dict); (let module D = ListDict(SList) in "SList", f.f D.dict); ] module SF = Mono.ComposeComparable(SList)(Mono.ComparablePair(String)(Float)) let bench_all polyf arg = let flist = modules_map polyf in let times = List.map (fun (s,f) -> s, time f arg) flist in printf "%s\n" (SF.to_string times) let cons_random () = let f dict rs = ignore(loop 100000 (fun l -> dict.cons (Int.gen rs) l) dict.empty); in let rs = Random.State.make_self_init () in bench_all {f=f} rs let snoc_random () = let f dict rs = ignore(loop 6000 (fun l -> dict.snoc (Int.gen rs) l) dict.empty); in let rs = Random.State.make_self_init () in bench_all {f=f} rs let append1_random () = let f dict rs = ignore(loop 6000 (fun l -> let single = dict.cons (Int.gen rs) dict.empty in dict.append l single ) dict.empty); in let rs = Random.State.make_self_init () in bench_all {f=f} rs let prepend1_random () = let f dict rs = ignore(loop 10000 (fun l -> let single = dict.cons (Int.gen rs) dict.empty in dict.append single l ) dict.empty); in let rs = Random.State.make_self_init () in bench_all {f=f} rs let run () = printf "cons: \n%!"; cons_random (); printf "snoc: \n%!"; snoc_random (); printf "append1: \n%!"; append1_random (); printf "prepend1: \n%!"; prepend1_random (); () ocaml-reins-0.1a/test/perf/dug_set_tests.ml0000644000175000017500000001226210676520540020125 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open Reins open Types module ISet = AVLSet.GenSet(Int) module ExSet = OracleSet.Extractor(Int) module BenchSet = OracleSet.Benchmark(ISet) module SetProf = DugProfile.Make(OracleSet) let pure_acc iters = Bench.loop iters (ExSet.add 10) ExSet.empty module B1(S : Sets.GenSetSig with type elt = int) = struct let bench iters = let rs = Random.State.make_self_init () in let t0 = S.singleton 50 in let rec helper n acc = if n <= 0 then acc else let _ = S.add 60 t0 in let t' = S.add (Int.gen rs) acc in let t'' = S.add (Int.gen rs) acc in let acc = S.union t' t'' in ignore(S.is_empty acc); ignore(S.is_empty t0); helper (n-1) acc in helper iters S.empty end let inst_bench iters = let rs = Random.State.make_self_init () in let t0 = ExSet.singleton 50 in let rec helper n acc = if n <= 0 then acc else let _ = ExSet.add 60 t0 in let t' = ExSet.add (Int.gen rs) acc in let t'' = ExSet.add (Int.gen rs) acc in let acc = ExSet.union t' t'' in ignore(ExSet.is_empty acc); ignore(ExSet.is_empty t0); helper (n-1) acc in helper iters ExSet.empty let real_bench iters = let rs = Random.State.make_self_init () in let t0 = ISet.singleton 50 in let rec helper n acc = if n <= 0 then acc else let _ = ISet.add 60 t0 in let t' = ISet.add (Int.gen rs) acc in let t'' = ISet.add (Int.gen rs) acc in let acc = ISet.union t' t'' in ignore(ISet.is_empty acc); ignore(ISet.is_empty t0); helper (n-1) acc in helper iters ISet.empty let test () = let iters = 10000 in let start = Unix.gettimeofday () in let _ = inst_bench iters in let mid = Unix.gettimeofday () in let _ = real_bench iters in let fin = Unix.gettimeofday () in printf "wrapped: %f\n" (mid -. start); printf "actual: %f\n" (fin -. mid); let dug = ExSet.get_dug () in let prof = SetProf.profile dug in let s = SetProf.to_string prof in printf "profile: %s\n" s let test_profile () = let v0 = ExSet.singleton 10 in let v1 = ExSet.add 10 v0 in let v2 = ExSet.empty in let v3 = ExSet.add 20 v2 in let v4 = ExSet.choose v3 in let v5 = ExSet.union v1 v3 in let v6 = ExSet.remove 20 v5 in let v7 = ExSet.union v1 v6 in let v8 = ExSet.remove 10 v7 in let v9 = ExSet.mem 15 v7 in let v10 = ExSet.is_empty v8 in ignore(v4,v9,v10) let test2 () = let () = test_profile () in let dug = ExSet.get_dug () in let prof = SetProf.profile dug in printf "profile: %s\n" (SetProf.to_string prof); List.iter (fun (op,c) -> printf " %f : %s\n" c (OracleSet.op_to_string (OracleSet.coerce_mut op)) ) prof.SetProf.mut_cdf; prof module SetGen = DugGenerator.Make(OracleSet)(Int) let test_gen () = (*let _ = inst_bench 100 in*) let _ = Bench.loop 500 test_profile () in let dug1 = ExSet.get_dug () in let prof1 = SetProf.profile dug1 in let _ = printf "profile: %s\n" (SetProf.to_string prof1) in let dug2 = SetGen.generate prof1 (Dug.Id.to_int (Dug.size dug1)) in let prof2 = SetProf.profile dug2 in let _ = printf "generated: %s\n" (SetProf.to_string prof2) in let tim = BenchSet.benchmark dug2 in printf "got time: %f\n" tim; (* let dug3 = SetGen.generate prof2 (Dug.Id.to_int (Dug.size dug2)) in let prof3 = SetProf.profile dug3 in let _ = printf "regenerated: %s\n" (SetProf.to_string prof3) in *) () module ASet = AVLSet.GenSet(Int) module RBSet = RBSet.GenSet(Int) module PatSet = PatriciaSet.GenSet module ABench = OracleSet.Benchmark(ASet) module RBBench = OracleSet.Benchmark(RBSet) module PatBench = OracleSet.Benchmark(PatSet) module A_B1 = B1(ASet) module RB_B1 = B1(RBSet) module Pat_B1 = B1(PatSet) module Inst_B1 = B1(OracleSet.Extractor(Int)) let _ = let () = Gc.compact () in let avl_real = Bench.time A_B1.bench 1000 in let () = Gc.compact () in let rb_real = Bench.time RB_B1.bench 1000 in let () = Gc.compact () in let pat_real = Bench.time Pat_B1.bench 1000 in let () = Gc.compact () in let inst = Bench.time inst_bench 1000 in let () = Gc.compact () in let dug = ExSet.get_dug () in let () = Gc.compact () in let avl = Bench.time BenchSet.benchmark dug in let () = Gc.compact () in let pat = Bench.time PatBench.benchmark dug in let () = Gc.compact () in let rb = Bench.time RBBench.benchmark dug in printf "avl actual: %f\n" avl_real; printf "r/b actual: %f\n" rb_real; printf "patricia actual: %f\n" pat_real; printf "instrumented: %f\n" inst; printf "AVL replay: %f\n" avl; printf "R/B replay: %f\n" rb; printf "Patricia replay: %f\n" pat ocaml-reins-0.1a/test/perf/bench_helper.ml0000644000175000017500000000177010676520540017671 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins.Types type ('a,'b) bench_func = { setup : 'a -> 'b; run : 'b -> 'b; teardown : 'b -> unit; } type ('a,'b) benchmark = | BenchGroup of (string * ('a,'b) bench_func * 'a) list | BenchList of ('a,'b) benchmark list | BenchLabel of string * ('a,'b)benchmark (* let random_int_list n = let rs = Random.State.make_self_init ()in loop n (fun y -> (Int.gen rs)::y) [] *) ocaml-reins-0.1a/test/perf/bench.ml0000644000175000017500000000166610676520540016336 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Reins open Types let time f arg = let prev = Unix.gettimeofday () in let _ = f arg in let aft = Unix.gettimeofday () in aft -. prev let rec loop n f acc = if n <= 0 then acc else loop (n-1) f (f acc) let random_int_list n = let rs = Random.State.make_self_init ()in loop n (fun y -> (Int.gen rs)::y) [] ocaml-reins-0.1a/test/perf/set/0002755000175000017500000000000010676540774015524 5ustar furrmfurrmocaml-reins-0.1a/test/perf/set/set_bench.ml0000644000175000017500000001501210676520540017772 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open Bench open Reins.Types (* (** This is a first class representation of a tree which includes all of a tree's operations packed into a record. This can be useful when treating trees as first class objects, such as to benchmark them *) type ('set,'elt,'bool_result,'elt_result,'cursor) treeSetDict = { empty : 'set; is_empty : 'set -> bool; mem : 'elt -> 'set -> 'bool_result; add : 'elt -> 'set -> 'set; singleton : 'elt -> 'set; remove : 'elt -> 'set -> 'set; well_formed : 'set -> bool; compare : 'set -> 'set -> int; equal : 'set -> 'set -> bool; iter : ('elt -> unit) -> 'set -> unit; fold : 'a. ('a -> 'elt -> 'a) -> 'a -> 'set -> 'a; min_elt : 'set -> 'elt_result; max_elt : 'set -> 'elt_result; choose : 'set -> 'elt_result; cardinal : 'set -> int; union : 'set -> 'set -> 'set; inter : 'set -> 'set -> 'set; diff : 'set -> 'set -> 'set; to_cursor : 'set -> 'cursor; from_cursor : 'cursor -> 'set; at_top : 'cursor -> bool; at_left : 'cursor -> bool; at_right : 'cursor -> bool; move_up : 'cursor -> 'cursor; move_down_left : 'cursor -> 'cursor; move_down_right : 'cursor -> 'cursor; went_left : 'cursor -> bool; went_right : 'cursor -> bool; has_value : 'cursor -> bool; get_value : 'cursor -> 'elt; of_result : 'bool_result -> bool; elt_of_elt_result : 'elt_result -> 'elt; gen1 : (?size:int -> Random.State.t -> 'elt) -> ?size:int -> Random.State.t -> 'set (* for_all : ('elt -> bool) -> 'set -> bool exists : ('elt -> bool) -> 'set -> bool elements : 'set -> 'elt list subset : 'set -> 'set -> bool filter : ('elt -> bool) -> 'set -> 'set partition : ('elt -> bool) -> 'set -> 'set * 'set split : 'elt -> 'set -> 'set * bool * 'set add_at : 'elt -> cursor -> cursor mem_at : 'elt -> cursor -> bool remove_at : 'elt -> cursor -> cursor *) } module MonoTreeSetToDict(Set : Sets.MonoSet) = struct let dict = { empty = Set.empty; is_empty = Set.is_empty; mem = Set.mem; add = Set.add; singleton = Set.singleton; remove = Set.remove; well_formed = Set.well_formed; compare = Set.compare; equal = Set.equal; iter = Set.iter; fold = Set.fold; min_elt = Set.min_elt; max_elt = Set.max_elt; choose = Set.choose; cardinal = Set.cardinal; union = Set.union; inter = Set.inter; diff = Set.diff; to_cursor = Set.to_cursor; from_cursor = Set.from_cursor; at_top = Set.at_top; at_left = Set.at_left; at_right = Set.at_right; move_up = Set.move_up; move_down_left = Set.move_down_left; move_down_right = Set.move_down_right; went_left = Set.went_left; went_right = Set.went_right; has_value = Set.has_value; get_value = Set.get_value; of_result = Set.of_result; gen1 = Set.gen1; } end module INRIA_Set (C : MonoComparable) = struct include Set.Make(C) type 'a set = t type 'a elt_ = elt type elt_result = elt type 'a elt_result_ = elt_result type bool_result = bool type 'a bool_result_ = bool_result let fold f acc t = fold (fun x y -> f y x) t acc let elt_of_elt_result x = x let bool_of_bool_result x = x let well_formed t = true let to_string t = "[" ^ (fold (fun acc x -> acc ^ ", " ^ (C.to_string x)) "" t) ^ "]" let gen1 (agen : (?size:int -> Random.State.t -> elt)) ?(size=50) rs = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else loop (n-1) (add (agen ~size:size rs) t) in loop num empty type cursor type 'a cursor_ = cursor let get_value _ = assert false let has_value _ = assert false let went_right _ = assert false let went_left _ = assert false let move_down_right _ = assert false let move_down_left _ = assert false let move_up _ = assert false let at_right _ = assert false let at_left _ = assert false let at_top _ = assert false let from_cursor _ = assert false let to_cursor _ = assert false end (* A type for abstractly working with a sets. Using a polymorphic record field allows the same 'f' to simultaneously apply to sets of arbitrary type. *) type ('elt, 'arg,'res) polyf = { f : 'set 'br 'er 'cur. ('set,'elt, 'br,'er,'cur) treeSetDict -> 'arg -> 'res } let modules_map f = [ (let module D = MonoTreeSetToDict(AVL.Set1(Int)) in f.f D.dict); (let module D = MonoTreeSetToDict(AVL.Set2(Int)) in f.f D.dict); (let module D = MonoTreeSetToDict(AVL.Set3(Int)) in f.f D.dict); (let module D = MonoTreeSetToDict(Patricia.Set) in f.f D.dict); (let module D = MonoTreeSetToDict(RedBlack.Set(Int)) in f.f D.dict); (let module D = MonoTreeSetToDict(Splay.Set(Int)) in f.f D.dict); (let module D = MonoTreeSetToDict(INRIA_Set(Int)) in f.f D.dict); ] let time_f f arg = let prev = Unix.gettimeofday () in let _ = f arg in let aft = Unix.gettimeofday () in aft -. prev let average n f = let rec loop n acc = if n <= 0 then acc else let acc = List.map2 (+.) acc (f ()) in loop (n-1) acc in let lst = loop (n-1) (f()) in List.map (fun x -> x /. (float n)) lst let time_rand_union n oc = let rs = Random.State.make_self_init () in let f d x = time_f (d.union (d.gen1 ~size:n Int.gen rs)) (d.gen1 ~size:n Int.gen rs) in let all_bench = modules_map {f=f} in let bench () = List.map (fun x -> x ()) all_bench in let results = average 20 bench in List.iter (fprintf oc "%f ") results let time_rand_insert n oc = let f d i = ignore(List.fold_left (fun acc x -> d.add x acc) d.empty i) in let all_bench = modules_map {f=f} in let bench () = let input = random_int_list n in List.map (fun x -> time_f x input) all_bench in let results = average 15 bench in List.iter (fprintf oc "%f ") results (* let _ = let oc = open_out "data.1" in for i = 1 to 100 do eprintf "at %d\n%!" i; let size = i * 50 in fprintf oc "%d " size; time_rand_union size oc; fprintf oc "\n%!" done; close_out oc *) *) ocaml-reins-0.1a/test/perf/set/OMakefile0000644000175000017500000000006010672112566017263 0ustar furrmfurrm OCAMLINCLUDES += .. FILES[] += set/set_bench ocaml-reins-0.1a/test/perf/OMakefile0000644000175000017500000000067110675630623016502 0ustar furrmfurrm OCAMLINCLUDES += $(ROOT)/src #+benchmark FILES[] = bench_driver bench list_bench dug_set_tests TESTDIRS = set .SUBDIRS: $(TESTDIRS) include OMakefile export FILES OCAMLINCLUDES += $(TESTDIRS) OCAML_OTHER_LIBS = nums unix #benchmark OCAML_LIBS = $(ROOT)/src/reins PERF_DRIVER = $(OCamlProgram run_benchmarks,$(FILES)) perf_tests.results: $(PERF_DRIVER) $(PERF_DRIVER) |& tee $@ .DEFAULT: $(PERF_DRIVER) #perf_tests.results ocaml-reins-0.1a/OMakeroot0000644000175000017500000000033710675630623014632 0ustar furrmfurrm open build/OCaml open configure/Configure # # The command-line variables are defined *after* the # standard configuration has been loaded. # DefineCommandVars() # # Include the OMakefile in this directory. # .SUBDIRS: . ocaml-reins-0.1a/config.omake0000644000175000017500000000060710676537716015304 0ustar furrmfurrm static. = BYTE_ENABLED = true USE_OCAMLFIND=true if $(not $(OCAMLFIND_EXISTS)) eprintln(ocaml-findlib is required to build this project) exit 1 OCAMLDEP_MODULES_ENABLED = $(OCAMLDEP_MODULES_AVAILABLE) OCAMLDEP=$(OCAMLDEP_MODULES) PREFIX=$(shell ocamlc -where) VERSION=0.1a ConfMsgChecking(oUnit) OUNIT_DIR=$(shell ocamlfind query oUnit) ConfMsgResult($(OUNIT_DIR)) export ocaml-reins-0.1a/AUTHORS0000644000175000017500000000003510676104001014035 0ustar furrmfurrm Mike Furr ocaml-reins-0.1a/doc/0002755000175000017500000000000010676540774013563 5ustar furrmfurrmocaml-reins-0.1a/doc/html/0002755000175000017500000000000010676540774014527 5ustar furrmfurrmocaml-reins-0.1a/doc/html/api/0002755000175000017500000000000010676540774015300 5ustar furrmfurrmocaml-reins-0.1a/doc/html/index.html0000644000175000017500000001100510676244667016521 0ustar furrmfurrm O'Caml Reins Data Structure Library

O'Caml Reins

Welcome to the home page for the O'Caml Reins persistent data structure library. This project began as an OCaml Summer Project sponsored by Jane St. Capital and is now continuing on here at sourceforge. Since it is my goal to include as many data structures as possible in this library, I am always looking for contributions from others. Even if you don't have time to contribute code, but know of a data structure that you would like to see included, please let us know by sending a message to the mailing list. In addition to providing a large collection of data structures, the O'Caml Reins project also includes several features that I hope will make developing O'Caml applications easier such as a random testing framework and a collection of "standard" modules.

Current features

  • List data types:
    • Single linked lists (compatible with the standard library type)
    • O(1) catenable lists
    • Acyclic double linked lists
    • Random access lists with O(1) hd/cons/tl and O(log i) lookup/update for i'th element
  • Double ended queues
  • Sets/Maps:
    • AVL
    • Red/Black
    • Big-endian Patricia
    • Splay
  • Heaps:
    • Binomial
    • Skew Binomial
  • Zipper style cursor interfaces
  • Persistent, bi-directional cursor based iterators (currently only for lists and sets)
  • All standard types hoisted into the module level (Int, Bool, etc...)
  • A collection of functor combinators to minimize boilerplate (e.g., constructing compare or to_string functions)
  • Quickcheck testing framework
    • Each structure provides a gen function that can generate a random instance of itself
  • Completely safe code. No -unsafe or references to Obj.*
  • Consistent function signatures. For instance, all fold functions take the accumulator in the same position.
  • All operations use no more than O(log n) stack space (except for a few operations on splay trees which currently have O(log n) expected time, but O(n) worst case)

Coming features

There are several features that were not quite ready for this release but are in the works:
  • Space and time asymptotic bounds on all functions
  • Automatic benchmarking of all included data structures (based on Graeme Moss's PhD thesis)
    • Including a set of Oracle data structures which recommend a specific implementation based on observed executions
  • Fill in missing functionality. For instance sets and maps need a {to,from}_list function and many list functions are still missing.
  • More data structures:
    • weight balanced trees
    • persistent arrays
    • more heap implementations
  • Iterators for maps and heaps
  • 100% code coverage from the test suite
  • Web based manual / tutorial for using some of the less intuitive features

More Information

Check out the sourceforce project page for access to svn, bug tracker, etc...
There is also a mailing list setup.
You can also browse the ocamldoc API pages available here

This page is hosted by: SourceForge.net Logo

Valid XHTML 1.0!

ocaml-reins-0.1a/doc/OMakefile0000644000175000017500000000000210676104001015303 0ustar furrmfurrm ocaml-reins-0.1a/INSTALL0000644000175000017500000000110610676121507014030 0ustar furrmfurrm The following software is required to build OCaml Reins * OCaml versions >= 3.09.2; earlier versions have not been tested. * OCaml findlib (http://www.ocaml-programming.de/programming/findlib.html) * OMake (http://omake.metaprl.org) version >= 0.9.8.5 * OUnit (http://www.xs4all.nl/~mmzeeman/ocaml/) version >= 1.0.1. To build the library simply type: $ omake To install it (using ocaml-findlib) type: $ omake install To build the api documentation type: $ omake doc The documentation can then be installed by copying it from doc/html/api to the desired location.ocaml-reins-0.1a/src/0002755000175000017500000000000010676540775013606 5ustar furrmfurrmocaml-reins-0.1a/src/oracle/0002755000175000017500000000000010676540774015052 5ustar furrmfurrmocaml-reins-0.1a/src/oracle/dugADT.ml0000644000175000017500000000302510676520540016477 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type S = sig type ('v,'t) generator (** functions that return a container and none of its arguments are containers *) type ('v,'t) mutator (** functions that return a container and at least one arg is a container *) type ('v,'t) observer (** functions that do not return a container, but takes one as an argument *) type ('v,'t) op (** One of {generator,mutator,observer} *) val op_to_string : ('v,'t) op -> string val coerce_gen : ('v,'t) generator -> ('v,'t) op val coerce_mut : ('v,'t) mutator -> ('v,'t) op val coerce_obs : ('v,'t) observer -> ('v,'t) op val classify : ('v,'t) op -> (('v,'t) generator,('v,'t) mutator,('v,'t) observer) Dug.kind val strip : ('v,'t) op -> (unit,unit) op val op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list val create_op : (unit,unit) op -> Dug.Id.t -> (unit -> 'a) -> (int -> Dug.Id.t) -> ('a,Dug.Id.t) op end ocaml-reins-0.1a/src/oracle/dugProfile.mli0000644000175000017500000000311210676520540017635 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Charactericists of a DUG *) module Make : functor(DS : DugADT.S) -> sig type t = private { (* CDF for the different node types (not operation weights) i.e., union counts as 1, not 2 *) gen_cdf : ((unit,unit) DS.generator * float) list; mut_cdf : ((unit,unit) DS.mutator * float) list; obs_cdf : ((unit,unit) DS.observer * float) list; (* ratio of generator nodes to total nodes *) gen_ratio : float; (* ratio of observations / mutations *) obs_mut_ratio : float; (* fraction of version nodes (gen or mut) that are never mutated *) mortality : float; (* fraction of mutations that are persisent *) pmf : float; (* fraction of observations that are persisent *) pof : float; } val random_op : ('a * float) list -> 'a val to_string : t -> string val profile : (('a,'b) DS.generator, ('a,'b) DS.mutator, ('a,'b) DS.observer) Dug.t -> t end ocaml-reins-0.1a/src/oracle/oracleList.mli0000644000175000017500000000215310676520540017642 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** List ADT which captures a DUG as a side effect *) include DugADT.S (* module Extractor : functor(A : Types.ArbitraryComparable) -> sig include Lists.S val get_dug : unit -> ((unit,unit) generator, (unit,unit) mutator, (unit,unit) observer) Dug.t val clear_profile : unit -> unit end module Benchmark : functor(L : Lists.S) -> sig val benchmark : (('a,Dug.Id.t) generator, ('a,Dug.Id.t) mutator, ('a,Dug.Id.t) observer) Dug.t -> float end *) ocaml-reins-0.1a/src/oracle/dugExtractor.ml0000644000175000017500000000350010676520540020040 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Dug type 'a wrap = { data : 'a; id : Id.t; } let mutate t op f wrap = let data = f wrap.data in let id = fresh_id t in let kop = Mutator (op id) in let e = {target = id;op = kop; pos = 0} in Hashtbl.add t.nodes id kop; Hashtbl.add t.edges wrap.id e; {data=data; id=id} let mutate2 t op f w1 w2 = let id = fresh_id t in let kop = Mutator (op id) in let e1 = {target = id; op = kop; pos = 0} in let e2 = {e1 with pos = 1} in Hashtbl.add t.nodes id kop; Hashtbl.add t.edges w1.id e1; Hashtbl.add t.edges w2.id e2; {data = f w1.data w2.data; id=id} let observe t op f w = let kop = Observer op in let id' = fresh_id t in let e = {target = id'; op = kop; pos = 0} in Hashtbl.add t.nodes id' kop; Hashtbl.add t.edges w.id e; f w.data let observe2 t op f w1 w2 = let kop = Observer op in let id' = fresh_id t in let e1 = {target = id'; op = kop; pos = 0} in let e2 = {e1 with pos = 1} in Hashtbl.add t.nodes id' kop; Hashtbl.add t.edges w1.id e1; Hashtbl.add t.edges w2.id e2; f w1.data w2.data let generate t op data = let id = fresh_id t in Hashtbl.add t.nodes id (Generator (op id)); {data = data; id=id} ocaml-reins-0.1a/src/oracle/oracle.mli0000644000175000017500000000175310676520540017013 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Frontend to automatic benchmarking of data structures (work in progress) *) module type RestrictedSet = Sets.GenSetSig with type 'a result = 'a module type ProfiledSet = sig include RestrictedSet include DugADT.S end (* module Set : functor(S : RestrictedSet) -> functor(A : Types.ArbitraryComparable with type t = S.elt) -> ProfiledSet with type elt = A.t *) ocaml-reins-0.1a/src/oracle/dug.ml0000644000175000017500000000305210676520540016146 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module Id = Types.Int64 type ('a,'b,'c) kind = | Generator of 'a | Mutator of 'b | Observer of 'c type ('a,'b,'c) edge = { target : Id.t; op : ('a,'b,'c) kind; pos : int; } type ('a,'b,'c) t = { mutable current_id : Id.t; nodes : (Id.t,('a,'b,'c) kind) Hashtbl.t; edges : (Id.t,('a,'b,'c) edge) Hashtbl.t; } let fresh_id t = t.current_id <- Id.succ t.current_id; t.current_id let create () = {current_id = Int64.zero; nodes = Hashtbl.create 127; edges = Hashtbl.create 229} let clear t = t.current_id <- Int64.zero; Hashtbl.clear t.nodes; Hashtbl.clear t.edges let size t = t.current_id let is_mutator = function | Mutator _ -> true | Generator _ | Observer _ -> false let is_generator = function | Generator _ -> true | Mutator _ | Observer _ -> false let is_observer = function | Observer _ -> true | Generator _ | Mutator _ -> false let _ = Random.self_init () ocaml-reins-0.1a/src/oracle/oracleSet.ml0000644000175000017500000002373410676520540017321 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types open Dug type nodeid = Dug.Id.t type ('v,'t) generator = [ | `Empty of 't | `Singleton of 't * 'v | `Gen1 of 't | `Gen of 't | `From_cursor of 't ] type ('v,'t) mutator = [ | `Add of 't * 'v * 't | `Remove of 't * 'v * 't | `Union of 't * 't * 't | `Inter of 't * 't * 't | `Diff of 't * 't * 't ] type ('v,'t) observer = [ | `Min_elt of 't | `Max_elt of 't | `Choose of 't | `Is_empty of 't | `Mem of 'v * 't | `Equal of 't * 't | `Well_formed of 't | `Cardinal of 't | `Compare of 't * 't | `To_string of 't | `Fold of 't | `Iter of 't ] (* the type of all set operations *) type ('v,'t) op = [ ('v,'t) generator | ('v,'t) mutator | ('v,'t) observer ] let op_to_string = function | `Min_elt _ -> "min_elt" | `Max_elt _ -> "max_elt" | `Choose _ -> "choose" | `Is_empty _ -> "is_empty" | `Mem _ -> "mem" | `Equal _ -> "equal" | `Well_formed _ -> "well_formed" | `Cardinal _ -> "cardinal" | `Compare _ -> "compare" | `Empty _ -> "empty" | `Singleton _ -> "singleton" | `Add _ -> "add" | `Remove _ -> "remove" | `Union _ -> "union" | `Inter _ -> "inter" | `Diff _ -> "diff" | `Gen1 _ -> "gen1" | `Gen _ -> "gen" | `From_cursor _ -> "from_cursor" | `To_string _ -> "to_string" | `Iter _ -> "iter" | `Fold _ -> "fold" let classify = function | #generator as o -> Dug.Generator o | #mutator as o -> Dug.Mutator o | #observer as o -> Dug.Observer o let op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list = function | #generator -> [] | `Min_elt t | `Max_elt t | `Choose t | `Is_empty t | `Mem(_,t) | `Well_formed t | `Cardinal t | `Add(_,_,t) | `Remove(_,_,t) | `Iter t | `Fold t | `To_string t -> [t] | `Equal(t1,t2) | `Compare(t1,t2) | `Union(_,t1,t2) | `Inter(_,t1,t2) | `Diff(_,t1,t2) -> [t1;t2] let coerce_gen x = (x :> ('a,'b) op) let coerce_mut x = (x :> ('a,'b) op) let coerce_obs x = (x :> ('a,'b) op) let create_op uop id elt_f t_f = match uop with | `Min_elt _ -> `Min_elt (t_f 0) | `Max_elt _ -> `Max_elt (t_f 0) | `Choose _ -> `Choose (t_f 0) | `Is_empty _ -> `Is_empty (t_f 0) | `Mem _ -> `Mem(elt_f (), t_f 0) | `Equal _ -> `Equal(t_f 0,t_f 1) | `Well_formed _ -> `Well_formed(t_f 0) | `Cardinal _ -> `Cardinal(t_f 0) | `Compare _ -> `Compare(t_f 0,t_f 1) | `Empty _ -> `Empty(id) | `Singleton _ -> `Singleton(id,elt_f ()) | `Add _ -> `Add(id,elt_f (),t_f 0) | `Remove _ -> `Remove(id,elt_f (), t_f 0) | `Union _ -> `Union(id,t_f 0,t_f 1) | `Inter _ -> `Inter(id,t_f 0,t_f 1) | `Diff _ -> `Diff(id,t_f 0,t_f 1) | `Gen1 _ -> `Gen1(id) | `Gen _ -> `Gen(id) | `From_cursor _ -> `From_cursor(id) | `Iter _ -> `Iter(t_f 0) | `Fold _ -> `Fold(t_f 0) | `To_string _ -> `To_string(t_f 0) let strip (op : ('a,'b) op) : (unit,unit) op = create_op op () (fun () -> ()) (fun _ -> ()) (**********************************************************) module Extractor(A : Mono.ArbitraryComparable) : sig include Sets.GenSetSig with type 'a result = 'a and type elt = A.t val get_dug : unit -> ((elt,Dug.Id.t) generator, (elt,Dug.Id.t) mutator, (elt,Dug.Id.t) observer) Dug.t val clear_profile : unit -> unit end = struct module S = AVLSet.MonoSet(A) let graph = Dug.create () let clear_profile () = Dug.clear graph type 'a result = 'a S.result type t = S.t DugExtractor.wrap type 'a set = t type cursor = S.cursor type 'a cursor_ = 'a S.cursor_ type elt = S.elt type 'a elt_ = 'a S.elt_ type ('a,'b) result_ = ('a,'b) S.result_ (* since we are storing the element and set types as a side effect of these operations, OCaml is unable to generalize the polymorphic form of these types, so we need to provide explicit specializations (we don't actually use the parameter anyway) *) type uelt = unit S.elt_ type uset = unit S.set type 'a ures = ('a,unit) S.result_ type ut = uset DugExtractor.wrap module DE = DugExtractor let empty : t = DE.generate graph (fun t -> `Empty t) S.empty let singleton (x:uelt) : ut = DE.generate graph (fun t -> `Singleton(t,x)) (S.singleton x) let is_empty t = DE.observe graph (`Is_empty t.DE.id) S.is_empty t let mem (x:uelt) (t:ut) : bool ures = DE.observe graph (`Mem(x,t.DE.id)) (S.mem x) t let add (x:uelt) (t:ut) : ut = DE.mutate graph (fun r -> `Add(r,x,t.DE.id)) (S.add x) t let remove (x:uelt) (t:ut) : ut = DE.mutate graph (fun r -> `Remove(r,x,t.DE.id)) (S.remove x) t let min_elt t = DE.observe graph (`Min_elt t.DE.id) S.min_elt t let max_elt t = DE.observe graph (`Max_elt t.DE.id) S.max_elt t let choose t = DE.observe graph (`Choose t.DE.id) S.choose t let cardinal t = DE.observe graph (`Cardinal t.DE.id) S.cardinal t let compare t1 t2 = DE.observe2 graph (`Compare(t1.DE.id,t2.DE.id)) S.compare t1 t2 let equal t1 t2 = DE.observe2 graph (`Equal(t1.DE.id, t2.DE.id)) S.equal t1 t2 let iter f t = DE.observe graph (`Iter t.DE.id) (S.iter f) t let fold f acc t = DE.observe graph (`Fold t.DE.id) (S.fold f acc) t let union t1 t2 = DE.mutate2 graph (fun r -> `Union(r,t1.DE.id,t2.DE.id)) S.union t1 t2 let inter t1 t2 = DE.mutate2 graph (fun r -> `Inter(r,t1.DE.id,t2.DE.id)) S.inter t1 t2 let diff t1 t2 = DE.mutate2 graph (fun r -> `Diff (r,t1.DE.id,t2.DE.id)) S.diff t1 t2 (* OCaml can't generalize the return type of f ('a elt_) even though 'a isn't used. It doesn't seem to notice if I annotate it and explicitly instantiate the variable either... so we'll just always generate an empty container for now. (at least until I address adding HOF's to this framework in a more general way) *) let gen1 f ?size rs : unit S.set DE.wrap = empty (*DE.generate graph (`Gen1(f,rs)) (S.gen1 f ?size rs)*) let gen ?size rs : unit S.set DE.wrap = empty (*DE.generate graph (`Gen1(f,rs)) (S.gen1 f ?size rs)*) let well_formed t = DE.observe graph (`Well_formed t.DE.id) S.well_formed t let of_result = S.of_result let to_cursor t = S.to_cursor t.DE.data (* let from_cursor (c : unit S.cursor_) : unit S.set DE.wrap = DE.generate graph (fun i -> `From_cursor(i,c)) (S.from_cursor c) *) let from_cursor c = empty (* these don't invole type t at all *) let at_top = S.at_top let at_left = S.at_left let at_right = S.at_right let move_up = S.move_up let move_down_left = S.move_down_left let move_down_right = S.move_down_right let went_left = S.went_left let went_right = S.went_right let has_value = S.has_value let get_value = S.get_value let to_string t = DE.observe graph ( `To_string t.DE.id) S.to_string t let get_dug () : ((S.elt,Dug.Id.t) generator, (S.elt,Dug.Id.t) mutator, (S.elt,Dug.Id.t) observer) Dug.t = graph end (**********************************************************) module Benchmark(S : Sets.GenSetSig with type 'a result = 'a) = struct module VarMap = Map.Make(Dug.Id) type env = S.t VarMap.t let empty_env = VarMap.empty let eval_rs = Random.State.make_self_init () let eval_t env op = let id,t = match op with | `Empty id -> id,S.empty | `Singleton(id,x) -> id,S.singleton x | `Add(id,x,t) -> id,S.add x (VarMap.find t env) | `Remove(id,x,t) -> id,S.remove x (VarMap.find t env) | `Union(id,t1,t2) -> id,S.union (VarMap.find t1 env) (VarMap.find t2 env) | `Inter(id,t1,t2) -> id,S.inter (VarMap.find t1 env) (VarMap.find t2 env) | `Diff(id,t1,t2) -> id,S.diff (VarMap.find t1 env) (VarMap.find t2 env) | `Gen1(id) -> id, S.empty (*(S.gen1 A.gen eval_rs)*) | `Gen(id) -> id, (S.gen eval_rs) | `From_cursor(id) -> id,S.empty in VarMap.add id t env let rec eval_obs env = function | `Min_elt t -> ignore(S.min_elt (VarMap.find t env)) | `Max_elt t -> ignore(S.max_elt (VarMap.find t env)) | `Choose t -> ignore(S.choose (VarMap.find t env)) | `Is_empty t -> ignore(S.is_empty (VarMap.find t env)) | `Mem(x,t) -> ignore(S.mem x (VarMap.find t env)) | `Equal(t1,t2) -> ignore(S.equal (VarMap.find t1 env) (VarMap.find t2 env)) | `Well_formed t -> ignore(S.well_formed (VarMap.find t env)) | `Cardinal t -> ignore(S.cardinal (VarMap.find t env)) | `Compare(t1,t2) -> ignore(S.compare (VarMap.find t1 env) (VarMap.find t2 env)) | `To_string t -> ignore(S.to_string (VarMap.find t env)) | `Iter t -> ignore(S.iter (fun _ -> ()) (VarMap.find t env)) | `Fold t -> ignore(S.fold (fun _ _ -> ()) () (VarMap.find t env)) let eval_op env op = match op with | #generator as o -> eval_t env o | #mutator as o -> eval_t env o | #observer as o -> eval_obs env o; env let dug_to_list dug = let rec helper id acc = if Dug.Id.compare id Dug.Id.zero <= 0 then acc else let op = match Hashtbl.find dug.nodes id with | Generator o -> coerce_gen o | Mutator o -> coerce_mut o | Observer o -> coerce_obs o in helper (Dug.Id.pred id) (op :: acc) in helper dug.current_id [] let benchmark dug = let lst = dug_to_list dug in let start = Unix.gettimeofday () in let _ = List.fold_left eval_op empty_env lst in let fin = Unix.gettimeofday() in fin -. start end (* module type ResS = Sets.GenSet with type 'a result = 'a module Make_Is_Set (S : ResS) (A : ArbitraryComparable with type t = S.elt) : ResS = Make(S)(A) Dug_set: module Profile(A) module Benchmark(HOSet)(A) *) ocaml-reins-0.1a/src/oracle/dugADT.mli0000644000175000017500000000451510676520540016655 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Abstract signature for ADTs => DUG extraction *) module type S = sig type ('v,'t) generator (** functions that return a container and none of its arguments are containers *) type ('v,'t) mutator (** functions that return a container and at least one arg is a container *) type ('v,'t) observer (** functions that do not return a container, but takes one as an argument *) type ('v,'t) op (** One of {generator,mutator,observer} *) val op_to_string : ('v,'t) op -> string val coerce_gen : ('v,'t) generator -> ('v,'t) op val coerce_mut : ('v,'t) mutator -> ('v,'t) op val coerce_obs : ('v,'t) observer -> ('v,'t) op val classify : ('v,'t) op -> (('v,'t) generator,('v,'t) mutator,('v,'t) observer) Dug.kind val strip : ('v,'t) op -> (unit,unit) op val op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list val create_op : (unit,unit) op -> Dug.Id.t -> (unit -> 'a) -> (int -> Dug.Id.t) -> ('a,Dug.Id.t) op end (* module type S = sig type 'a generator type 'a mutator type 'a observer type 'a op val op_to_string : 'a op -> string val coerce_gen : 'a generator -> 'a op val coerce_mut : 'a mutator -> 'a op val coerce_obs : 'a observer -> 'a op val classify : 'a op -> ('a generator, 'a mutator, 'a observer) Dug.kind val strip : 'a op -> unit op val op_dependencies : Dug.Id.t op -> Dug.Id.t list val create_op : unit op -> Dug.Id.t -> (int -> Dug.Id.t) -> Dug.Id.t op end *) (* module Impl : sig val benchmark : (Dug.Id.t generator, Dug.Id.t mutator, Dug.Id.t observer) Dug.t -> float val get_dug : unit -> (unit generator, unit mutator, unit observer) Dug.t val clear_profile : unit -> unit end *) ocaml-reins-0.1a/src/oracle/dugExtractor.mli0000644000175000017500000000231010676520540020207 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Helper module for extracting a DUG from a specific program execution *) type 'a wrap = private { data : 'a; id : Dug.Id.t; } val mutate : ('gen,'mut,'obs) Dug.t -> (Dug.Id.t -> 'mut) -> ('a -> 'a) -> 'a wrap -> 'a wrap val mutate2 : ('gen,'mut,'obs) Dug.t -> (Dug.Id.t -> 'mut) -> ('a -> 'a -> 'a) -> 'a wrap -> 'a wrap -> 'a wrap val observe : ('gen,'mut,'obs) Dug.t -> 'obs -> ('a -> 'b) -> 'a wrap -> 'b val observe2 : ('gen,'mut,'obs) Dug.t -> 'obs -> ('a -> 'a -> 'b) -> 'a wrap -> 'a wrap -> 'b val generate : ('gen,'mut,'obs) Dug.t -> (Dug.Id.t -> 'gen) -> 'a -> 'a wrap ocaml-reins-0.1a/src/oracle/OMakefile0000644000175000017500000000036710675307617016631 0ustar furrmfurrm OCAMLINCLUDES[] += ../base ../list ../set ../map ../heap FILES[] += oracle/oracle oracle/oracleSet oracle/oracleList oracle/dug oracle/dugADT oracle/dugProfile oracle/dugExtractor oracle/dugGenerator oracle/randomBag oracle/replayList ocaml-reins-0.1a/src/oracle/dugGenerator.ml0000644000175000017500000001664210676520540020026 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module Make(DS : DugADT.S)(A : Types.Mono.ArbitraryComparable) = struct module DP = DugProfile.Make(DS) type t = { dug : ((A.t,Dug.Id.t) DS.generator, (A.t,Dug.Id.t) DS.mutator, (A.t,Dug.Id.t) DS.observer) Dug.t; frontier : (Dug.Id.t * (unit,unit) DS.op list) RandomBag.t; planned_size : Dug.Id.t; profile : DP.t; max_id : Dug.Id.t; } let frontier_min = 2 let frontier_max = 10000 let rec factf n = if n <= 1. then 1. else n *. (factf (n -. 1.)) (* The regular poisson function *) let poisson' lambda k = (exp ~-.lambda) *. (lambda ** (float k)) /. (factf (float k)) (* simple brute force inversion of the poisson function. *) let rec find_poisson l guess p cump = let cump' = cump +. (poisson' l guess) in if cump' > p then guess else find_poisson l (guess+1) p cump' (* Randomally select an integer K whose valule is taken from the poisson distribution with mean l. That is, P(K=x) = poisson(l,x). *) let poisson l = let p = Random.float 1.0 in match classify_float l with | FP_nan | FP_infinite -> 0 | _ -> find_poisson l 0 p 0. let fresh_id t = Dug.fresh_id t.dug let expected_mutations t = let p = t.profile in (1. -. p.DP.mortality) *. p.DP.pmf /. (1. -. p.DP.pmf) let chance p = (Random.float 1.0) < p let num_mutations t = let p = t.profile in if chance p.DP.mortality then 0 else 1 + (poisson (p.DP.pmf /. (1. -. p.DP.pmf))) let rec loop n f acc = if n <= 0 then acc else loop (n-1) f (f acc) (* Combine two lists of length m and n respectively by choosing an element from lst1 with probability m/(m+n) and from lst2 with probability n/(m+n) *) let mix_lists lst1 lst2 = let rec helper lst1 len1 lst2 len2 acc = match len1,len2 with | 0,0 -> acc | 0,_ -> List.rev_append lst2 acc | _,0 -> List.rev_append lst1 acc | _ -> let tot = len1 + len2 in (* random will be 0..tot-1, so >= len1 is *) if (Random.int tot) < len1 then match lst1 with [] -> assert false | hd::tl -> helper tl (len1-1) lst2 len2 (hd::acc) else match lst2 with [] -> assert false | hd::tl -> helper lst1 len1 tl (len2-1) (hd::acc) in helper lst1 (List.length lst1) lst2 (List.length lst2) [] let num_observations num_muts t = num_muts *. (t.profile.DP.obs_mut_ratio) let exec_plan num coerce cdf = loop num (fun acc -> (coerce (DP.random_op cdf))::acc) [] let tot_muts = ref 0 let mut_times = ref 0 let max_muts = ref 0 let tot_obs = ref 0 let obs_times = ref 0 (* let _ = at_exit (fun () -> Printf.printf "avg mutations: %f (%d)\n" ((float !tot_muts) /. (float !mut_times)) !max_muts; Printf.printf "avg observers: %f\n" ((float !tot_obs) /. (float !obs_times)) ) *) let plan t : (unit,unit) DS.op list = let p = t.profile in let num_muts = num_mutations t in let muts = exec_plan num_muts DS.coerce_mut p.DP.mut_cdf in incr mut_times; tot_muts := !tot_muts + num_muts; max_muts := max !max_muts num_muts; let numf_obs = num_observations (*(expected_mutations t)*) (float num_muts) t in let num_p_obs = poisson (numf_obs *. p.DP.pof) in let pers_obs = exec_plan num_p_obs DS.coerce_obs p.DP.obs_cdf in let num_e_obs = poisson (numf_obs *. (1. -. p.DP.pof)) in let emph_obs = exec_plan num_e_obs DS.coerce_obs p.DP.obs_cdf in incr obs_times; tot_obs := !tot_obs + num_p_obs + num_e_obs; (* Printf.printf "muts: %d(exp: %f) obs: %f\n" num_muts (expected_mutations t) numf_obs;*) match muts with | [] -> emph_obs @ pers_obs (* force the persistent operations, to be persisten by placing a mutation first *) | hd::tl -> emph_obs @ (hd :: (mix_lists tl pers_obs)) let update_frontier id future frontier = match future with | [] -> frontier | _ -> RandomBag.add (id,future) frontier let create_node id op future t = Hashtbl.replace t.dug.Dug.nodes id (DS.classify op); let frontier = update_frontier id future t.frontier in {t with frontier = frontier} let rs = Random.State.make_self_init() let expand_frontier t = (* Printf.printf "expand!!!!!!!!!!!!!!!!!!!!!\n";*) let id = fresh_id t in let gen = DP.random_op t.profile.DP.gen_cdf in let d_op = DS.coerce_gen gen in let op = DS.create_op d_op id (fun () -> A.gen rs) (fun _ -> assert false) in create_node id op (plan t) t let shrink_frontier t = (* Printf.printf "shrink---------------------\n";*) let n = RandomBag.choose t.frontier in {t with frontier = RandomBag.remove n t.frontier} let create_random_node t = let ((pred_id,future) as idf) = RandomBag.choose t.frontier in let t = {t with frontier = RandomBag.remove idf t.frontier} in let next_op = List.hd future in let id = fresh_id t in (* create a temp table to store what objects where taken from the frontier and placed in which position. We do this so we can later add then to the edge table of the dug. We can't do it here, since we need a (Id.t op), not a (unit op) [which next_op is] *) let tbl = Hashtbl.create 11 in let get_pos i = let arg_id = if i = 0 then pred_id else fst(RandomBag.choose t.frontier) in Hashtbl.add tbl i arg_id; arg_id in let op = DS.create_op next_op id (fun () -> A.gen rs) get_pos in let () = Hashtbl.iter (fun pos src_id -> let e = {Dug.target = id; op = DS.classify op; pos = pos} in Hashtbl.add t.dug.Dug.edges src_id e; ) tbl in (* Don't plan a future for an observer node *) let new_plan = if Dug.is_observer (DS.classify op) then [] else plan t in let t = create_node id op new_plan t in let frontier = update_frontier pred_id (List.tl future) t.frontier in {t with frontier = frontier} (* TODO: alternatively, produce all of the generator nodes first, then build up dug until the sum of the futures + current size is the target size, then just run out the futures. *) let rec generate_nodes t = let front_size = (RandomBag.length t.frontier) in if Dug.Id.compare t.dug.Dug.current_id t.max_id >= 0 then t else if front_size < frontier_min then generate_nodes (expand_frontier t) else if front_size > frontier_max then generate_nodes (shrink_frontier t) else if chance t.profile.DP.gen_ratio then generate_nodes (expand_frontier t) (* add a gen *) else generate_nodes (create_random_node t) (* add a mut or obs *) let generate p size = let t = {frontier = RandomBag.empty; dug = Dug.create (); profile = p; max_id = Dug.Id.of_int size; planned_size = Dug.Id.zero; } in let t = generate_nodes t in Printf.eprintf "%d nodes left in frontier\n" (RandomBag.length t.frontier); t.dug end ocaml-reins-0.1a/src/oracle/dug.mli0000644000175000017500000000250710676520540016323 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Datatype Usage Graphs *) module Id : Types.Integral type ('gen,'mut,'obs) kind = | Generator of 'gen | Mutator of 'mut | Observer of 'obs type ('gen,'mut,'obs) edge = { target : Id.t; op : ('gen,'mut,'obs) kind; pos : int; } type ('gen,'mut,'obs) t = { mutable current_id : Id.t; nodes : (Id.t,('gen,'mut,'obs) kind) Hashtbl.t; edges : (Id.t,('gen,'mut,'obs) edge) Hashtbl.t; } val create : unit -> ('gen,'mut,'obs) t val clear : ('gen,'mut,'obs) t -> unit val size : ('eng,'mut,'obs) t -> Id.t val fresh_id : ('gen,'mut,'obs) t -> Id.t val is_mutator : ('gen,'mut,'obs) kind -> bool val is_generator : ('gen,'mut,'obs) kind -> bool val is_observer : ('gen,'mut,'obs) kind -> bool ocaml-reins-0.1a/src/oracle/replayList.ml0000644000175000017500000000731510676520540017525 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) type ('arg,'list,'listlist,'slist) op = [ | `Is_empty of 'list | `Length of 'list | `Rev of 'list | `Cons of 'arg * 'list | `Snoc of 'arg * 'list | `Hd of 'list | `Tl of 'list | `Pop of 'list | `Append of 'list * 'list | `Flatten of 'listlist | `From_list of 'slist | `To_list of 'list | `Iter of 'list | `Fold of 'list | `Rev_map of 'list | `Map of 'list | `To_string of ('arg -> string) * 'list | `Compare of ('arg -> 'arg -> int) * 'list * 'list | `Gen of (?size:int -> Random.State.t -> 'arg) * int option * Random.State.t ] module Replay(L : Lists.ListSig) = struct let eval = function | `Is_empty t -> ignore(L.is_empty t) | `Length t -> ignore(L.length t) | `Rev t -> ignore(L.rev t) | `Cons(x,t) -> ignore(L.cons x t) | `Snoc(x,t) -> ignore(L.snoc x t) | `Hd t -> ignore(L.hd t) | `Tl t -> ignore(L.tl t) | `Pop t -> ignore(L.pop t) | `Append(t1, t2) -> ignore(L.append t1 t2) | `Flatten t -> ignore(L.flatten t) | `From_list l -> ignore(L.from_list l) | `To_list t -> ignore(L.to_list t) | `Iter t -> ignore(L.iter (fun _ -> ()) t) | `Fold t -> ignore(L.fold (fun () _ -> ()) () t) | `Rev_map t -> ignore(L.rev_map (fun x -> x) t) | `Map t -> ignore(L.map (fun x -> x) t) | `To_string(to_s, t) -> ignore(L.to_string to_s t) | `Compare(f, t1, t2) -> ignore(L.compare f t1 t2) | `Gen(f, size, rs) -> ignore(L.gen f ~size:size rs) end let replay history = match history with | [] -> () | _ -> let lst = List.rev history in let module RL = Replay(SList) in List.iter RL.eval lst module Make(L : Lists.ListSig)(A : sig type t end) = struct let __history : (A.t,A.t L.t, A.t L.t L.t, A.t list) op list ref = ref [] let __save x = __history := x :: !__history (* let _ = at_exit (fun () -> replay !__history)*) type t = A.t L.t let empty = L.empty let is_empty (t:t) = __save (`Is_empty t);L.is_empty t let length (t:t) = __save (`Length t); L.length t let rev (t:t) = __save (`Rev t);L.rev t let cons x (t:t) = __save (`Cons(x,t)); L.cons x t let snoc x (t:t) = __save (`Snoc(x,t)); L.snoc x t let hd (t:t) = __save (`Hd t); L.hd t let tl (t:t) = __save (`Tl t); L.tl t let pop (t:t) = __save (`Pop t); L.pop t let append (t1:t) (t2:t) = __save (`Append(t1,t2)); L.append t1 t2 let flatten (t:t L.t) = __save (`Flatten t); L.flatten t let from_list (l:A.t list) = __save (`From_list l); L.from_list l let to_list (t:t) = __save (`To_list t); L.to_list t let iter f (t:t) = __save (`Iter t); L.iter f t let fold f acc (t:t) = __save (`Fold t); L.fold f acc t let rev_map f (t:t) = __save (`Rev_map t); L.rev_map f t let map (f:A.t->'a) (t:t) = __save (`Map t); L.map f t let to_string to_s (t:t) = __save (`To_string(to_s,t)); L.to_string to_s t let compare (f:A.t->A.t->int) t1 t2 = __save (`Compare(f,t1,t2)); L.compare f t1 t2 let gen f ?size rs : t = __save (`Gen(f,size,Random.State.copy rs)); L.gen f ?size rs end ocaml-reins-0.1a/src/oracle/oracleSet.mli0000644000175000017500000000232710676520540017465 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Set ADT which captures a DUG as a side effect *) include DugADT.S module Extractor : functor(A : Types.Mono.ArbitraryComparable) -> sig include Sets.GenSetSig with type 'a result = 'a and type elt = A.t val get_dug : unit -> ((elt,Dug.Id.t) generator, (elt,Dug.Id.t) mutator, (elt,Dug.Id.t) observer) Dug.t val clear_profile : unit -> unit end module Benchmark : functor(S : Sets.GenSetSig with type 'a result = 'a) -> sig val benchmark : ((S.elt,Dug.Id.t) generator, (S.elt,Dug.Id.t) mutator, (S.elt,Dug.Id.t) observer) Dug.t -> float end ocaml-reins-0.1a/src/oracle/randomBag.ml0000644000175000017500000000231310676520540017260 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) include SkewBinaryList module RCurs = ListCursor.Make(SkewBinaryList) let add = cons let remove x t = let rec helper c = if RCurs.at_back c then failwith "remove"; match RCurs.value c with | None -> helper (RCurs.move_next c) | Some y -> if x = y then let l = RCurs.list c in let c = RCurs.replace_list (SkewBinaryList.tl l) c in RCurs.from_cursor c else helper (RCurs.move_next c) in helper (RCurs.to_cursor t) let choose t = if is_empty t then failwith "choose"; let l = SkewBinaryList.length t in let idx = Random.int l in lookup idx t ocaml-reins-0.1a/src/oracle/dugGenerator.mli0000644000175000017500000000163510676520540020173 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Module to generate a random dug from a profile *) module Make : functor (DS : DugADT.S) -> functor(A : Types.Mono.ArbitraryComparable) -> sig val generate : DugProfile.Make(DS).t -> int -> ((A.t,Dug.Id.t) DS.generator, (A.t,Dug.Id.t) DS.mutator, (A.t,Dug.Id.t) DS.observer) Dug.t end ocaml-reins-0.1a/src/oracle/dugProfile.ml0000644000175000017500000001615510676520540017477 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open Dug module Make(DS : DugADT.S) = struct type t = { gen_cdf : ((unit,unit) DS.generator * float) list; mut_cdf : ((unit,unit) DS.mutator * float) list; obs_cdf : ((unit,unit) DS.observer * float) list; gen_ratio : float; obs_mut_ratio : float; mortality : float; pmf : float; pof : float; } let random_op cdf = let prob = Random.float 1.0 in let rec helper = function | [] -> assert false | (op,_)::[] -> op | (op,c)::tl -> if c >= prob then op else helper tl in let res = helper cdf in (* Printf.eprintf "random: %f -> %d\n" prob (pv_tag res);*) res let to_string t = let gen_s x = DS.op_to_string (DS.coerce_gen x) in let mut_s x = DS.op_to_string (DS.coerce_mut x) in let obs_s x = DS.op_to_string (DS.coerce_obs x) in let buf = Buffer.create 127 in let f to_s (op,weight) = Buffer.add_string buf (sprintf " %s %f\n" (to_s op) weight) in Buffer.add_string buf "{\n"; Buffer.add_string buf " gen cdf:\n"; List.iter (f gen_s) t.gen_cdf; Buffer.add_string buf " mut cdf:\n"; List.iter (f mut_s) t.mut_cdf; Buffer.add_string buf " obs cdf:\n"; List.iter (f obs_s) t.obs_cdf; Buffer.add_string buf (sprintf " gen_ratio: %f\n obs/mut: %f\n mort: %f\n pmf: %f\n pof: %f\n}" t.gen_ratio t.obs_mut_ratio t.mortality t.pmf t.pof); Buffer.contents buf type ('a,'b,'c) profile_data = { gen_nodes : ('a,Int64.t) Hashtbl.t; mut_nodes : ('b,Int64.t) Hashtbl.t; obs_nodes : ('c,Int64.t) Hashtbl.t; gen_weights : ('a,Int64.t) Hashtbl.t; mut_weights : ('b,Int64.t) Hashtbl.t; obs_weights : ('c,Int64.t) Hashtbl.t; (* nodes that are never mutated (only non-observer nodes apply) *) mutable mortality_count : Int64.t; mutable pmf_count : Int64.t; mutable pof_count : Int64.t; } let empty_profile () = { gen_nodes = Hashtbl.create 127; mut_nodes = Hashtbl.create 127; obs_nodes = Hashtbl.create 127; gen_weights = Hashtbl.create 127; mut_weights = Hashtbl.create 127; obs_weights = Hashtbl.create 127; mortality_count = Int64.zero; pmf_count = Int64.zero; pof_count = Int64.zero; } let incr_tbl tbl op = let old = try match Hashtbl.find_all tbl op with | [] -> Int64.zero | [x] -> x | _ -> assert false with Not_found -> Int64.zero in Hashtbl.replace tbl op (Int64.succ old) let rec after_true f = function | [] -> [] | hd::tl -> if f hd then tl else after_true f tl let count_persistent f edges = let after_mut = after_true (fun x -> is_mutator x.op) edges in List.fold_left (fun acc x -> if f x.op then Int64.succ acc else acc) Int64.zero after_mut let rec update_weights t pd edges = match edges with | [] -> () | e::tl -> begin match e.op with | Generator _ -> assert false | Mutator op -> let op = match DS.classify (DS.strip (DS.coerce_mut op)) with | Mutator o -> o | _ -> assert false in incr_tbl pd.mut_weights op | Observer op -> let op = match DS.classify (DS.strip (DS.coerce_obs op)) with | Observer o -> o | _ -> assert false in incr_tbl pd.obs_weights op end; update_weights t pd tl let rec profile_node t pd id = if Id.compare id t.current_id > 0 then () else let kind = Hashtbl.find t.nodes id in let edges = Hashtbl.find_all t.edges id in let edges = List.rev edges (* fifo order the edges *) in let update_mortality () = if not (List.exists (fun x -> is_mutator x.op) edges) then pd.mortality_count <- Int64.succ pd.mortality_count in let update_persistents () = let ocount = count_persistent is_observer edges in let mcount = count_persistent is_mutator edges in pd.pof_count <- Int64.add pd.pof_count ocount; pd.pmf_count <- Int64.add pd.pmf_count mcount in update_weights t pd edges; update_persistents (); (* TODO: clean this up! *) begin match kind with | Generator op -> let op = match DS.classify (DS.strip (DS.coerce_gen op)) with | Generator o -> o | _ -> assert false in incr_tbl pd.gen_weights op; update_mortality (); incr_tbl pd.gen_nodes op; | Mutator op -> let op = match DS.classify (DS.strip (DS.coerce_mut op)) with | Mutator o -> o | _ -> assert false in update_mortality (); incr_tbl pd.mut_nodes op; | Observer op -> let op = match DS.classify (DS.strip (DS.coerce_obs op)) with | Observer o -> o | _ -> assert false in assert (List.length edges = 0); incr_tbl pd.obs_nodes op; end; profile_node t pd (Dug.Id.succ id) let sum_tbl tbl = Hashtbl.fold (fun k v acc -> Int64.add v acc) tbl Int64.zero let build_weights totf tbl = let tbl' = Hashtbl.create (Hashtbl.length tbl) in Hashtbl.iter (fun k v -> Hashtbl.add tbl' k ((Int64.to_float v) /. totf)) tbl; Hashtbl.find tbl' let build_cdf pdf tbl = let lst = Hashtbl.fold (fun op _ acc -> op::acc) tbl [] in (* forace a deterministic (but arbitrary) ordering *) let lst = List.sort Pervasives.compare lst in let _,l = List.fold_left (fun (c,acc) op -> let c' = c +. (pdf op) in c', ((op,c') :: acc) ) (0.0,[]) lst in List.rev l let build_profile pd = (* let tot_gen_weights = Int64.to_float (sum_tbl pd.gen_weights) in*) let tot_mut_weights = Int64.to_float (sum_tbl pd.mut_weights) in let tot_obs_weights = Int64.to_float (sum_tbl pd.obs_weights) in let tot_gen_nodes = Int64.to_float (sum_tbl pd.gen_nodes) in let tot_mut_nodes = Int64.to_float (sum_tbl pd.mut_nodes) in let tot_obs_nodes = Int64.to_float (sum_tbl pd.obs_nodes) in let gen_f = build_weights tot_gen_nodes pd.gen_nodes in let mut_f = build_weights tot_mut_nodes pd.mut_nodes in let obs_f = build_weights tot_obs_nodes pd.obs_nodes in { gen_cdf = build_cdf gen_f pd.gen_nodes; mut_cdf = build_cdf mut_f pd.mut_nodes; obs_cdf = build_cdf obs_f pd.obs_nodes; gen_ratio = tot_gen_nodes /. (tot_gen_nodes +. tot_mut_nodes +. tot_obs_nodes); obs_mut_ratio = tot_obs_nodes /. tot_mut_nodes; mortality = (Int64.to_float pd.mortality_count) /. (tot_gen_nodes +. tot_mut_nodes); pmf = (Int64.to_float pd.pmf_count) /. tot_mut_weights; pof = (Int64.to_float pd.pof_count) /. tot_obs_weights; } let profile t = let pd = empty_profile () in profile_node t pd Dug.Id.one; build_profile pd end ocaml-reins-0.1a/src/oracle/oracleList.ml0000644000175000017500000001074310676520540017475 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) type ('v,'t) generator = [ | `Empty of 't | `Gen of 't | `From_list of 't * 'v list ] type ('v,'t) mutator = [ | `Rev of 't * 't | `Cons of 't * 'v * 't | `Snoc of 't * 'v * 't | `Tl of 't * 't | `Append of 't * 't * 't | `Rev_map of 't * 't | `Map of 't * 't ] type ('v,'t) observer = [ | `Is_empty of 't | `Length of 't | `Hd of 't | `To_string of 't | `To_list of 't | `Compare of 't * 't | `Iter of 't | `Fold of 't ] (* val pop : 'a t -> 'a * 'a t val flatten : 'a t t -> 'a t val rev_map : ('a -> 'b) -> 'a t -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t *) type ('v,'t) op = [ | ('v,'t) generator | ('v,'t) mutator | ('v,'t) observer ] let coerce_gen x = (x :> ('v,'t) op) let coerce_mut x = (x :> ('v,'t) op) let coerce_obs x = (x :> ('v,'t) op) let classify = function | #generator as o -> Dug.Generator o | #mutator as o -> Dug.Mutator o | #observer as o -> Dug.Observer o let op_to_string : ('v,'t) op -> string = function | `Empty _ -> "empty" | `Gen _ -> "gen" | `From_list _ -> "from_list" | `Rev _ -> "rev" | `Cons _ -> "cons" | `Snoc _ -> "snoc" | `Tl _ -> "tl" | `Append _ -> "append" | `Is_empty _ -> "is_empty" | `Length _ -> "length" | `Hd _ -> "hd" | `To_string _ -> "to_string" | `To_list _ -> "to_list" | `Compare _ -> "compare" | `Iter _ -> "iter" | `Fold _ -> "fold" | `Rev_map _ -> "rev_map" | `Map _ -> "map" let op_dependencies : ('a,Dug.Id.t) op -> Dug.Id.t list = function | `Empty _ | `Gen _ | `From_list _ -> [] | `Rev(_,t) | `Cons(_,_,t) | `Snoc(_,_,t) | `Tl(_,t) | `Is_empty t | `Length t | `Hd t | `Rev_map(_,t) | `Map(_,t) | `Iter t | `Fold t | `To_list t | `To_string t -> [t] | `Append(_,t1,t2) | `Compare(t1,t2) -> [t1;t2] let create_op uop id elt_f t_f = match uop with | `Empty _ -> `Empty (id) | `Gen _ -> `Gen(id) | `From_list _ -> assert false | `Rev _ -> `Rev(id,t_f 0) | `Cons _ -> `Cons(id,elt_f(),t_f 0) | `Snoc _ -> `Snoc(id,elt_f(),t_f 0) | `Tl _ -> `Tl(id,t_f 0) | `Append _ -> `Append(id,t_f 0, t_f 1) | `Is_empty _ -> `Is_empty(t_f 0) | `Length _ -> `Length(t_f 0) | `Hd _ -> `Hd(t_f 0) | `Iter _ -> `Iter(t_f 0) | `Fold _ -> `Fold(t_f 0) | `To_list _ -> `To_list(t_f 0) | `To_string _ -> `To_string(t_f 0) | `Compare _ -> `Compare(t_f 0,t_f 1) | `Rev_map _ -> `Rev_map(id,t_f 0) | `Map _ -> `Map(id,t_f 0) let strip op = assert false (*create_op op () (fun () -> ()) (fun _ -> ())*) (* module Extractor(A : MonoTypes.ArbitraryComparable) = struct let graph = Dug.create () let clear_profile () = Dug.clear graph let get_dug () = graph module L = SList type 'a t = 'a L.t Dug_extractor.wrap module DE = Dug_extractor let empty = DE.generate graph (`Empty ()) L.empty let gen rs = DE.generate graph (`Empty ()) L.empty (*FIXME*) let is_empty t = DE.observe graph (`Is_empty ()) L.is_empty t let length t = DE.observe graph (`Length ()) L.length t let hd t = DE.observe graph (`Hd ()) L.hd t (** TODO *) let from_list l = empty let flatten t = empty let pop t = assert false let iter f t = DE.observe graph (`Iter ()) (L.iter f) t let fold f acc t = DE.observe graph (`Fold ()) (L.fold f acc) t let to_list t = DE.observe graph (`To_list ()) L.to_list t let to_string t = DE.observe graph (`To_string ()) L.to_string t let compare f t1 t2 = DE.observe2 graph (`Compare((),())) (L.compare f) t1 t2 let rev t = DE.mutate graph (`Rev((),())) L.rev t let cons x t= DE.mutate graph (`Cons((),(),())) (L.cons x) t let snoc x t = DE.mutate graph (`Snoc((),(),())) (L.snoc x) t let tl t = DE.mutate graph (`Tl((),())) L.tl t let append t1 t2 = DE.mutate2 graph (`Append((),(),())) L.append t1 t2 let rev_map f t = DE.mutate graph (`Rev_map((),())) (L.rev_map f) t let map f t = DE.mutate graph (`Map((),())) (L.map f) t end module Benchmark = struct end *) ocaml-reins-0.1a/src/oracle/oracle.ml0000644000175000017500000000232210676520540016633 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type RestrictedSet = Sets.GenSetSig with type 'a result = 'a module type ProfiledSet = sig include RestrictedSet include DugADT.S end module type OSet = sig include DugADT.S module Extractor : functor(A : Types.Mono.ArbitraryComparable) -> Sets.GenSetSig module BenchMark : functor(S : Sets.GenSetSig) -> sig val benchmark : ((S.elt,Dug.Id.t) generator, (S.elt,Dug.Id.t) mutator, (S.elt,Dug.Id.t) observer) Dug.t -> float end end (* module ExtractSet(A : MonoTypes.ArbitraryComparable) = struct module M = OracleSet.Make(A) include M.Extractor end *) ocaml-reins-0.1a/src/version.mli0000644000175000017500000000125310676520540015761 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) val version : string (** Current version of the Reins library *) ocaml-reins-0.1a/src/iterator/0002755000175000017500000000000010676540774015436 5ustar furrmfurrmocaml-reins-0.1a/src/iterator/iterator.ml0000644000175000017500000000262710676520540017613 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type S = sig type 'a t type 'a elt type 'a cursor type 'a collection type direction type 'a traversal = | Traverse_All | Traverse_If of ('a -> bool) | Traverse_While of ('a -> bool) val create : direction -> 'a elt traversal -> 'a collection -> 'a t val from_cursor : direction -> 'a elt traversal -> 'a cursor -> 'a t val value : 'a t -> 'a elt option val get_value : 'a t -> 'a elt val at_end : 'a t -> bool val at_beg : 'a t -> bool val has_next : 'a t -> bool val next : 'a t -> 'a t val has_prev : 'a t -> bool val prev : 'a t -> 'a t val goto_beg : 'a t -> 'a t val goto_end : 'a t -> 'a t val flip : 'a t -> 'a t val iter : ('a elt -> unit) -> 'a t -> unit val fold : ('a -> 'b elt -> 'a) -> 'a -> 'b t -> 'a end ocaml-reins-0.1a/src/iterator/iteratorMixin.ml0000644000175000017500000001120110676520540020604 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type PartIterator = sig type 'a elt type 'a cursor type direction val has_curs_value : 'a cursor -> bool val get_curs_value : 'a cursor -> 'a elt val has_more_elements : direction -> 'a cursor -> bool val move_cursor_next_element : direction -> 'a cursor -> 'a cursor val flip_dir : direction -> direction end module Mixin(IT : PartIterator) (* CR SW: add result signature *) = struct type 'a traversal = | Traverse_All | Traverse_If of ('a -> bool) | Traverse_While of ('a -> bool) type 'a t = { curs : 'a IT.cursor; dir : IT.direction; trav : 'a IT.elt traversal; next : 'a t option Lazy.t; prev : 'a t option Lazy.t; } (* This is the main work horse of the module. It serves to simultaneously check if the iterator has reached the end (returns [None]) and move the iterator to the next element (retruns [Some it]). This is to minimize duplicated work between calls to [at_end] and [next] (and [at_beg]/[prev]). This is also the thunk that is stored in the [next] and [prev] fields of the iterator record, so it must not (recursively) force those values. *) let rec goto_next it = (* Check if the underlying collection has more elements *) if not (IT.has_more_elements it.dir it.curs) then None else match it.trav with | Traverse_All -> Some (move_one it) | Traverse_If f -> (* We are at the end only if f returns false for every element in the remainder of the collection. *) let it' = move_one it in if f (IT.get_curs_value it'.curs) then Some it' (* found an element where f is true *) else goto_next it' (* check the next element *) | Traverse_While f -> (* We are at the end as soon as the condition returns false on any element. We don't have to scan to the end of the list in this case. *) if not (IT.has_curs_value it.curs) then goto_next (move_one it) else if f (IT.get_curs_value it.curs) then Some (move_one it) else None and move_one it = let curs' = IT.move_cursor_next_element it.dir it.curs in set_curs curs' it and reset_next it = let rec t = {it with next = lazy (goto_next t); prev = lazy (goto_next {t with dir=IT.flip_dir it.dir});} in t and set_dir d it = reset_next {it with dir=d} and set_curs c it = reset_next {it with curs=c} let flip t = set_dir (IT.flip_dir t.dir) t let has_next it = match Lazy.force it.next with | None -> false | _ -> true let has_prev it = match Lazy.force it.prev with | None -> false | _ -> true let rec next it = match Lazy.force it.next with | None -> failwith "next" | Some it' -> it' let rec prev it = match Lazy.force it.next with | None -> failwith "prev" | Some it' -> it' let at_end t = not (has_next t) && not (IT.has_curs_value t.curs) let at_beg = has_prev let rec goto_beg t = if at_beg t then t else goto_beg (prev t) let rec goto_end t = if at_end t then t else goto_end (next t) let from_cursor dir trav curs = let t = reset_next {dir = dir; trav = trav; curs = curs; prev = lazy None; next = lazy None; } in match trav with | Traverse_While f -> (* Check to see if f is false for the first element and if so return an iterator that is always at_end. *) if IT.has_curs_value curs && not (f (IT.get_curs_value curs)) then {dir = dir; trav = trav; curs = curs; prev = lazy None; next = lazy None} else t | _ -> if IT.has_curs_value curs then t else if at_end t then t else next t (* move the cursor to the first value *) let rec fold f acc it = let acc = if at_end it then acc else f acc (IT.get_curs_value it.curs) in if has_next it then fold f acc (next it) else acc let iter f it = fold (fun () -> f) () it let get_value t = try IT.get_curs_value t.curs with _ -> failwith "get_value" let value t = try Some (get_value t) with _ -> None end ocaml-reins-0.1a/src/iterator/listIterator.mli0000644000175000017500000000310210676520540020605 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** The signature for an iterator over a List. *) module type S = sig (** List iterators support only two directions. [Left_Right] iterates through the list in the forward direction, visiting the head of the list before the tail. [Right_Left] is the opposite. It iterates through all elements in the tail before visiting the head. *) type direction_ = | Left_Right | Right_Left include Iterator.S with type direction = direction_ end (** Create a list iterator from an arbitrary cursor type *) module Make : functor (I : ListCursor.S) -> S with type 'a collection = 'a I.list_ and type 'a cursor = 'a I.cursor and type 'a elt = 'a (** Create a list iterator for the list [L] using the standard List_Cursor interface for the cursor. *) module From_List : functor (L : Lists.ListSig) -> S with type 'a collection = 'a L.t and type 'a elt = 'a and type 'a cursor = 'a ListCursor.Make(L).cursor ocaml-reins-0.1a/src/iterator/treeSetIterator.mli0000644000175000017500000000321610676520540021253 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** The signature for an iterator over a tree impelementing a set. *) module type S = sig type ordering = PreOrder | InOrder | PostOrder (** A [PreOrder] traversal always visits the root of the tree before its children. An [InOrder] traversal visits one subtree, then the root, then the other subtree (which subtree is chosen by the [direction_] type below). Finally, a [PostOrder] traversal visits the subtrees before visiting the root. *) type direction_ = Ascending of ordering | Descending of ordering (** An ascending direction traversal always visits the elements in increasing order of the keys. Similarly, the descending direction traversal visits elements in decreasing key order. *) include Iterator.S with type direction = direction_ end (** Create an iterator for a Set (note that this implicitly supports both MonoSets and PolySets). *) module Make : functor (T : Sets.Set_) -> S with type 'a elt = 'a T.elt_ and type 'a cursor = 'a T.cursor_ and type 'a collection = 'a T.set ocaml-reins-0.1a/src/iterator/iterator.mli0000644000175000017500000001152110676520540017755 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (* CR SW: It seems pointless to have both and ml and an mli for a definition of a module type. I'd just have the ml. *) (** The signature for an iterator over an arbitrary collection *) module type S = sig type 'a t (** The type of iterators. An iterator serves as a pointer into the middle of a collection. When possible, it always points to a valid element in the collection (skipping over any intermediate nodes that hold no value. *) type 'a elt (** The type of elements in the collection. *) type 'a cursor (** The type of the cursor that points into the collection *) type 'a collection (** The type of the collection *) type direction (** A type which guides the order of the traversal. Different collections may support different directions. *) type 'a traversal = | Traverse_All (** [Traverse_All] will visit every element in the collection. *) | Traverse_If of ('a -> bool) (** [Traverse_If f] will traverse only those elements for which [f] returns true. *) | Traverse_While of ('a -> bool) (** [Traverse_While f] will traverse elements as long as [f] is true. *) (** This type defines the traversal strategy. It determines which elements will be visited by the iterator.*) val create : direction -> 'a elt traversal -> 'a collection -> 'a t (** [create dir trav col] Create an iterator for the collection [col] using the direction and traversal given. *) val from_cursor : direction -> 'a elt traversal -> 'a cursor -> 'a t (** [from_cursor dir trav curs] Create an iterator for the collection starting at the cursor [curs]. The cursor need not point to the beginning of the collection. If it does point to an element, then this element will be the first element visited by the iterator. *) val value : 'a t -> 'a elt option (** Return the element currently pointed to by the iterator. This will return [None] only when the iterator has reached the end of the collection. *) val get_value : 'a t -> 'a elt (** Similar to {!Iterator.S.value} except it throws the exception [Failure "get_value"] if the iterator has reached the end of the collection . *) val at_end : 'a t -> bool (** Returns true if the iterator has reached the end of the collection as governed by the current traversal strategy. *) val at_beg : 'a t -> bool (** Returns true if the iterator is at the beginning of the collection as governed by the current traversal strategy. This is equivalent to {!Iterator.S.has_prev}. *) val has_next : 'a t -> bool (** Returns true if there is another element in the traversal after the current element. *) val next : 'a t -> 'a t (** Advances the iterator to the next element in the collection. If the iterator is at the end of the collection, it raises [Failure "next"]. *) val has_prev : 'a t -> bool (** Returns true if there is another element that occurs before the current element. Equivalent to {!Iterator.S.at_beg}. *) val prev : 'a t -> 'a t (** Advances the iterator to the previous element in the collection. If the iterator is at the beginning of the collection, it raises [Failure "prev"]. *) val goto_beg : 'a t -> 'a t (** Advance the iterator to the beginning of the collection as governed by the traversal strategy *) val goto_end : 'a t -> 'a t (** Advance the iterator to the end of the collection as governed by the traversal strategy *) val flip : 'a t -> 'a t (** Reverse the direction of the iterator. All elements that were previously reachable by [next] are now reachable by [prev] and vice versa. *) val iter : ('a elt -> unit) -> 'a t -> unit (** [iter f t] Apply [f] to each element in the collection that satisfies the traversal strategy. If the iterator is not at the beginning of the collection, the elements reachable by {!Iterator.S.prev} will not be visited. *) val fold : ('a -> 'b elt -> 'a) -> 'a -> 'b t -> 'a (** [fold f acc t] Accumulates the result [acc] by applying [f acc x] for each element [x] in the collection that satisfies the traversal strategy. If the iterator is not at the beginning of the collection, the elements reachable by {!Iterator.S.prev} will not be visited. *) end ocaml-reins-0.1a/src/iterator/OMakefile0000644000175000017500000000023110672112566017175 0ustar furrmfurrm OCAMLINCLUDES += ../base ../set ../map ../list FILES[] += iterator/listIterator iterator/treeSetIterator iterator/iterator iterator/iteratorMixin ocaml-reins-0.1a/src/iterator/listIterator.ml0000644000175000017500000000430510676520540020442 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type S = sig type direction_ = | Left_Right | Right_Left include Iterator.S with type direction = direction_ end module Base(I : ListCursor.S) = struct type 'a elt = 'a type 'a cursor = 'a I.cursor type 'a collection = 'a I.list_ type direction_ = | Left_Right | Right_Left type direction = direction_ let flip_dir = function | Right_Left -> Left_Right | Left_Right -> Right_Left let has_curs_value curs = match I.value curs with | None -> false | Some _ -> true let get_curs_value curs = match I.value curs with | None -> assert false | Some x -> x let has_more_elements dir curs = match dir with | Right_Left -> not (I.at_front curs) | Left_Right -> not (I.at_back curs) let move_cursor_next_element dir curs = match dir with | Right_Left -> I.move_prev curs | Left_Right -> I.move_next curs end module Make(I : ListCursor.S) : S with type 'a collection = 'a I.list_ and type 'a cursor = 'a I.cursor and type 'a elt = 'a = struct (* Can't include the Base code in this module (and make it a module rec) since the type checker does not support instantiating recursive functors. It gives "Cannot safely evaluate the definition of the recursively-defined module" *) include Base(I) include IteratorMixin.Mixin(Base(I)) let create dir trav l = from_cursor dir trav (I.to_cursor l) end module From_List(L : Lists.ListSig) : S with type 'a elt = 'a and type 'a cursor = 'a ListCursor.Make(L).cursor and type 'a collection = 'a L.t = Make(ListCursor.Make(L)) ocaml-reins-0.1a/src/iterator/treeSetIterator.ml0000644000175000017500000001175310676520540021107 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (* CR SW: again, the capitalization of the filename seems weird. Why is "tree" lowercase but "Iterator" uppercase? *) module type S = sig type ordering = | PreOrder | InOrder | PostOrder type direction_ = | Ascending of ordering | Descending of ordering include Iterator.S with type direction = direction_ end module Base(T : Sets.Set_) = struct type 'a elt = 'a T.elt_ type 'a cursor = 'a T.cursor_ type 'a collection = 'a T.set type ordering = | PreOrder (* root, left, right *) | InOrder (* left, root, right *) | PostOrder (* left, right, root *) type direction_ = | Ascending of ordering | Descending of ordering type direction = direction_ (* move to the bottom, left most node in the tree*) let rec move_bottom_left curs = if T.at_left curs then curs else move_bottom_left (T.move_down_left curs) (* move to the bottom, right most node in the tree*) let rec move_bottom_right curs = if T.at_right curs then curs else move_bottom_right (T.move_down_right curs) (* walk up the tree looking for the last branch where we went left *) let rec find_left curs = if T.at_top curs then raise Exit else if T.went_left curs then curs else find_left (T.move_up curs) (* walk up the tree looking for the last branch where we went right *) let rec find_right curs = if T.at_top curs then raise Exit else if T.went_right curs then curs else find_right (T.move_up curs) let rec move_inorder curs = (* left root right *) if T.at_right curs then T.move_up (find_left curs) else move_bottom_left (T.move_down_right curs) let rec move_inorder_rev curs = (* right root left *) if T.at_left curs then T.move_up (find_right curs) else move_bottom_right (T.move_down_left curs) let rec move_preorder curs = (* root left right *) if T.at_left curs then T.move_down_right (T.move_up (find_left curs)) else T.move_down_left curs let rec move_preorder_rev curs = (* right left root *) if T.went_right curs then move_bottom_right (T.move_down_left (T.move_up curs)) else if T.went_left curs then T.move_up curs else raise Exit let rec move_postorder curs = (* left right root *) if T.went_left curs then move_bottom_left (T.move_down_right (T.move_up curs)) else if T.went_right curs then T.move_up curs else raise Exit let rec move_postorder_rev curs = (* root right left *) if T.at_right curs then T.move_down_left (T.move_up (find_right curs)) else T.move_down_right curs let rec move_cursor_next_element dir curs = let curs = match dir with | Ascending PreOrder -> move_preorder curs | Ascending InOrder -> move_inorder curs | Ascending PostOrder -> move_postorder curs | Descending PreOrder -> move_preorder_rev curs | Descending InOrder -> move_inorder_rev curs | Descending PostOrder -> move_postorder_rev curs in if T.has_value curs then curs else move_cursor_next_element dir curs let has_more_elements dir curs = try ignore(move_cursor_next_element dir curs); true with Exit -> false let flip_dir = function | Ascending PreOrder -> Descending PostOrder | Ascending InOrder -> Descending InOrder | Ascending PostOrder -> Descending PreOrder | Descending PreOrder -> Ascending PostOrder | Descending InOrder -> Ascending InOrder | Descending PostOrder -> Ascending PreOrder let has_curs_value = T.has_value let get_curs_value = T.get_value end module Make(T : Sets.Set_) : S with type 'a elt = 'a T.elt_ and type 'a cursor = 'a T.cursor_ and type 'a collection = 'a T.set = struct include Base(T) include IteratorMixin.Mixin(Base(T)) let has_value t = has_curs_value t.curs let get_value t = get_curs_value t.curs let create dir trav t = (* create the cursor at the top of the tree *) let curs = T.to_cursor t in (* Move the cursor to the starting location for the traversal *) let curs = match dir with | Ascending PreOrder -> curs | Ascending InOrder -> move_bottom_left curs | Ascending PostOrder -> move_bottom_left curs | Descending PreOrder -> move_bottom_right curs | Descending InOrder -> move_bottom_right curs | Descending PostOrder -> curs in from_cursor dir trav curs end ocaml-reins-0.1a/src/base/0002755000175000017500000000000010676540774014517 5ustar furrmfurrmocaml-reins-0.1a/src/base/quickcheck.ml0000644000175000017500000000414710676520540017154 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Printf open Types module type Law = sig module Arg : Types.Mono.Arbitrary val desc : string val law : Arg.t -> bool end module type Config = sig val num_iterations : int val size_arg : int option val max_trivial_percentage : float end exception Trivial module Check(Conf : Config)(L : Law) = struct let max_trivs = int_of_float ((float Conf.num_iterations) *. Conf.max_trivial_percentage) let fail_exn iter e arg = let msg = sprintf "Test <%s> raised exception after %d tries.\nInput was %s\n Exception was %s\n" L.desc iter (L.Arg.to_string arg) (Printexc.to_string e) in failwith msg let fail_test iter arg = let msg = sprintf "Test <%s> failed after %d tries.\nInput was %s\n" L.desc iter (L.Arg.to_string arg) in failwith msg let fail_trivial trivs n = let msg = sprintf "Test <%s> could not be tested due to excessive trivial input. %d trivial inputs and %d non-trivial inputs were tried\n" L.desc trivs n in failwith msg let test rs = let rec loop trivs n : unit = if trivs >= max_trivs then fail_trivial trivs n else if n >= Conf.num_iterations then () else let arg = match Conf.size_arg with | None -> L.Arg.gen rs | Some s -> L.Arg.gen ~size:s rs in try let res = try L.law arg with Trivial -> raise Trivial | e -> fail_exn n e arg in if res then loop trivs (n+1) else fail_test n arg with Trivial -> loop (trivs+1) n in loop 0 1 let desc = L.desc end ocaml-reins-0.1a/src/base/types.mli0000644000175000017500000005072210676520540016357 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Various modules and functors used by Reins *) (** Signatures/functors for modules with parameterized (polymorphic) types. *) module Poly : sig module type Equatable = sig type 'a t val equal : 'a t -> 'a t -> bool end module type Comparable = sig type 'a t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val to_string : ('a -> string) -> 'a t -> string end module type Hashable = sig include Equatable val hash : 'a t -> int end module type Arbitrary = sig type 'a t val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t val to_string : ('a -> string) -> 'a t -> string end module type ArbitraryComparable = sig include Arbitrary val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int end module ComposeComparable : functor (A : Comparable) -> functor (B : Comparable) -> sig type 'a t = 'a B.t A.t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val to_string : ('a -> string) -> 'a t -> string end module ComposeGen : functor (A : Arbitrary) -> functor (B : Arbitrary) -> sig type 'a t = 'a B.t A.t val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t val to_string : ('a -> string) -> 'a t -> string end module ComposeGenComparable : functor (A : ArbitraryComparable) -> functor (B : ArbitraryComparable) -> sig type 'a t = 'a B.t A.t val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t val to_string : ('a -> string) -> 'a t -> string val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int end (** This module can be used to "close" a series of functors to produce a module with a parameterized type. For example, [module CC = ComposeComparable module L = CC(CC(List)(Option))(Close)] creates a module with type [type 'a t = 'a list option] *) module Close : sig type 'a t = 'a val to_string : ('a -> 'b) -> 'a -> 'b val compare : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c end end (** Signatures/functors for modules with unparameterized (monomorphic) types *) module Mono : sig module type Equatable = sig type t val equal : t -> t -> bool end module type Comparable = sig type t val compare : t -> t -> int val to_string : t -> string end module type Hashable = sig include Equatable val hash : t -> int end module type Arbitrary = sig type t val gen : ?size:int -> Random.State.t -> t val to_string : t -> string end module type ArbitraryComparable = sig include Arbitrary val compare : t -> t -> int end module ComposeComparable : functor (P : Poly.Comparable) -> functor (M : Comparable) -> sig type t = M.t P.t val compare : t -> t -> int val to_string : t -> string end module ComposeGen : functor (P : Poly.Arbitrary) -> functor (M : Arbitrary) -> sig type t = M.t P.t val gen : ?size:int -> Random.State.t -> t val to_string : t -> string end module ComposeGenComparable : functor (P : Poly.ArbitraryComparable) -> functor (M : ArbitraryComparable) -> sig type t = M.t P.t val gen : ?size:int -> Random.State.t -> t val to_string : t -> string val compare : t -> t -> int end module ComparablePair : functor (M1 : Comparable) -> functor (M2 : Comparable) -> sig type t = M1.t * M2.t val compare : t -> t -> int val to_string : t -> string end module Comparable3Tuple : functor (M1 : Comparable) -> functor (M2 : Comparable) -> functor (M3 : Comparable) -> sig type t = M1.t * M2.t * M3.t val compare : t -> t -> int val to_string : t -> string end module GenPair : functor (A : Arbitrary) -> functor (B : Arbitrary) -> sig type t = A.t * B.t val gen : ?size:int -> Random.State.t -> t val to_string : t -> string end module Gen3Tuple : functor (A : Arbitrary) -> functor (B : Arbitrary) -> functor (C : Arbitrary) -> sig type t = A.t * B.t * C.t val gen : ?size:int -> Random.State.t -> t val to_string : t -> string end end module type Integral = sig type t val zero : t val one : t val minus_one : t val abs : t -> t val neg : t -> t val succ : t -> t val pred : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t val logand : t -> t -> t val lognot : t -> t val logor : t -> t -> t val logxor : t -> t -> t val shift_left : t -> int -> t val shift_right : t -> int -> t val shift_right_logical : t -> int -> t val compare : t -> t -> int val of_int : int -> t val to_int : t -> int val of_float : float -> t val to_float : t -> float val to_string : t -> string val of_string : string -> t end module Int : sig type t = int val zero : int val one : int val minus_one : int val abs : int -> int val neg : int -> int val succ : int -> int val pred : int -> int val add : int -> int -> int val sub : int -> int -> int val mul : int -> int -> int val div : int -> int -> int val rem : int -> int -> int val logxor : int -> int -> int val logand : int -> int -> int val lognot : int -> int val logor : int -> int -> int val shift_left : int -> int -> int val shift_right : int -> int -> int val shift_right_logical : int -> int -> int val of_int : 'a -> 'a val to_int : 'a -> 'a val of_float : float -> int val to_float : int -> float val of_string : string -> int val compare : int -> int -> int val equal : int -> int -> bool val hash : 'a -> 'a val to_string : int -> string val gen : ?size:int -> Random.State.t -> int end module Float : sig type t = float val compare : float -> float -> int val equal : float -> float -> bool val hash : 'a -> int val gen : ?size:int -> Random.State.t -> float val to_string : float -> string end module Bool : sig type t = bool val compare : bool -> bool -> int val equal : bool -> bool -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> bool val to_string : bool -> string end module Char : sig type t = char val compare : char -> char -> int val equal : char -> char -> bool val hash : 'a -> int val gen : ?size:int -> Random.State.t -> char val to_string : char -> string end module Int32 : sig val zero : int32 val one : int32 val minus_one : int32 external neg : int32 -> int32 = "%int32_neg" external add : int32 -> int32 -> int32 = "%int32_add" external sub : int32 -> int32 -> int32 = "%int32_sub" external mul : int32 -> int32 -> int32 = "%int32_mul" external div : int32 -> int32 -> int32 = "%int32_div" external rem : int32 -> int32 -> int32 = "%int32_mod" val succ : int32 -> int32 val pred : int32 -> int32 val abs : int32 -> int32 val max_int : int32 val min_int : int32 external logand : int32 -> int32 -> int32 = "%int32_and" external logor : int32 -> int32 -> int32 = "%int32_or" external logxor : int32 -> int32 -> int32 = "%int32_xor" val lognot : int32 -> int32 external shift_left : int32 -> int -> int32 = "%int32_lsl" external shift_right : int32 -> int -> int32 = "%int32_asr" external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" external of_int : int -> int32 = "%int32_of_int" external to_int : int32 -> int = "%int32_to_int" external of_float : float -> int32 = "caml_int32_of_float" external to_float : int32 -> float = "caml_int32_to_float" external of_string : string -> int32 = "caml_int32_of_string" val to_string : int32 -> string external bits_of_float : float -> int32 = "caml_int32_bits_of_float" external float_of_bits : int32 -> float = "caml_int32_float_of_bits" type t = int32 val compare : t -> t -> int external format : string -> int32 -> string = "caml_int32_format" val equal : t -> t -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Int32.t end module Int64 : sig val zero : int64 val one : int64 val minus_one : int64 external neg : int64 -> int64 = "%int64_neg" external add : int64 -> int64 -> int64 = "%int64_add" external sub : int64 -> int64 -> int64 = "%int64_sub" external mul : int64 -> int64 -> int64 = "%int64_mul" external div : int64 -> int64 -> int64 = "%int64_div" external rem : int64 -> int64 -> int64 = "%int64_mod" val succ : int64 -> int64 val pred : int64 -> int64 val abs : int64 -> int64 val max_int : int64 val min_int : int64 external logand : int64 -> int64 -> int64 = "%int64_and" external logor : int64 -> int64 -> int64 = "%int64_or" external logxor : int64 -> int64 -> int64 = "%int64_xor" val lognot : int64 -> int64 external shift_left : int64 -> int -> int64 = "%int64_lsl" external shift_right : int64 -> int -> int64 = "%int64_asr" external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" external of_int : int -> int64 = "%int64_of_int" external to_int : int64 -> int = "%int64_to_int" external of_float : float -> int64 = "caml_int64_of_float" external to_float : int64 -> float = "caml_int64_to_float" external of_int32 : int32 -> int64 = "%int64_of_int32" external to_int32 : int64 -> int32 = "%int64_to_int32" external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" external of_string : string -> int64 = "caml_int64_of_string" val to_string : int64 -> string external bits_of_float : float -> int64 = "caml_int64_bits_of_float" external float_of_bits : int64 -> float = "caml_int64_float_of_bits" type t = int64 val compare : t -> t -> int external format : string -> int64 -> string = "caml_int64_format" val equal : t -> t -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Int64.t end module Nativeint : sig val zero : nativeint val one : nativeint val minus_one : nativeint external neg : nativeint -> nativeint = "%nativeint_neg" external add : nativeint -> nativeint -> nativeint = "%nativeint_add" external sub : nativeint -> nativeint -> nativeint = "%nativeint_sub" external mul : nativeint -> nativeint -> nativeint = "%nativeint_mul" external div : nativeint -> nativeint -> nativeint = "%nativeint_div" external rem : nativeint -> nativeint -> nativeint = "%nativeint_mod" val succ : nativeint -> nativeint val pred : nativeint -> nativeint val abs : nativeint -> nativeint val size : int val max_int : nativeint val min_int : nativeint external logand : nativeint -> nativeint -> nativeint = "%nativeint_and" external logor : nativeint -> nativeint -> nativeint = "%nativeint_or" external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor" val lognot : nativeint -> nativeint external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl" external shift_right : nativeint -> int -> nativeint = "%nativeint_asr" external shift_right_logical : nativeint -> int -> nativeint = "%nativeint_lsr" external of_int : int -> nativeint = "%nativeint_of_int" external to_int : nativeint -> int = "%nativeint_to_int" external of_float : float -> nativeint = "caml_nativeint_of_float" external to_float : nativeint -> float = "caml_nativeint_to_float" external of_int32 : int32 -> nativeint = "%nativeint_of_int32" external to_int32 : nativeint -> int32 = "%nativeint_to_int32" external of_string : string -> nativeint = "caml_nativeint_of_string" val to_string : nativeint -> string type t = nativeint val compare : t -> t -> int external format : string -> nativeint -> string = "caml_nativeint_format" val equal : t -> t -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Nativeint.t end module Big_int : sig type big_int = Big_int.big_int val zero_big_int : big_int val unit_big_int : big_int val minus_big_int : big_int -> big_int val abs_big_int : big_int -> big_int val add_big_int : big_int -> big_int -> big_int val succ_big_int : big_int -> big_int val add_int_big_int : int -> big_int -> big_int val sub_big_int : big_int -> big_int -> big_int val pred_big_int : big_int -> big_int val mult_big_int : big_int -> big_int -> big_int val mult_int_big_int : int -> big_int -> big_int val square_big_int : big_int -> big_int val sqrt_big_int : big_int -> big_int val quomod_big_int : big_int -> big_int -> big_int * big_int val div_big_int : big_int -> big_int -> big_int val mod_big_int : big_int -> big_int -> big_int val gcd_big_int : big_int -> big_int -> big_int val power_int_positive_int : int -> int -> big_int val power_big_int_positive_int : big_int -> int -> big_int val power_int_positive_big_int : int -> big_int -> big_int val power_big_int_positive_big_int : big_int -> big_int -> big_int val sign_big_int : big_int -> int val compare_big_int : big_int -> big_int -> int val eq_big_int : big_int -> big_int -> bool val le_big_int : big_int -> big_int -> bool val ge_big_int : big_int -> big_int -> bool val lt_big_int : big_int -> big_int -> bool val gt_big_int : big_int -> big_int -> bool val max_big_int : big_int -> big_int -> big_int val min_big_int : big_int -> big_int -> big_int val num_digits_big_int : big_int -> int val string_of_big_int : big_int -> string val big_int_of_string : string -> big_int val big_int_of_int : int -> big_int val is_int_big_int : big_int -> bool val int_of_big_int : big_int -> int val float_of_big_int : big_int -> float val nat_of_big_int : big_int -> Nat.nat val big_int_of_nat : Nat.nat -> big_int val base_power_big_int : int -> int -> big_int -> big_int val sys_big_int_of_string : string -> int -> int -> big_int val round_futur_last_digit : string -> int -> int -> bool val approx_big_int : int -> big_int -> string type t = big_int val equal : big_int -> big_int -> bool val compare : big_int -> big_int -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Big_int.big_int val zero : big_int val one : big_int val minus_one : big_int val abs : big_int -> big_int val neg : big_int -> big_int val succ : big_int -> big_int val pred : big_int -> big_int val add : big_int -> big_int -> big_int val sub : big_int -> big_int -> big_int val mul : big_int -> big_int -> big_int val div : big_int -> big_int -> big_int val rem : big_int -> big_int -> big_int val of_int : 'a -> int -> big_int val to_int : 'a -> big_int -> int val of_float : float -> big_int val to_float : big_int -> float val to_string : big_int -> string val of_string : string -> big_int end module Ratio : sig type ratio = Ratio.ratio val null_denominator : ratio -> bool val numerator_ratio : ratio -> Big_int.big_int val denominator_ratio : ratio -> Big_int.big_int val sign_ratio : ratio -> int val normalize_ratio : ratio -> ratio val cautious_normalize_ratio : ratio -> ratio val cautious_normalize_ratio_when_printing : ratio -> ratio val create_ratio : Big_int.big_int -> Big_int.big_int -> ratio val create_normalized_ratio : Big_int.big_int -> Big_int.big_int -> ratio val is_normalized_ratio : ratio -> bool val report_sign_ratio : ratio -> Big_int.big_int -> Big_int.big_int val abs_ratio : ratio -> ratio val is_integer_ratio : ratio -> bool val add_ratio : ratio -> ratio -> ratio val minus_ratio : ratio -> ratio val add_int_ratio : int -> ratio -> ratio val add_big_int_ratio : Big_int.big_int -> ratio -> ratio val sub_ratio : ratio -> ratio -> ratio val mult_ratio : ratio -> ratio -> ratio val mult_int_ratio : int -> ratio -> ratio val mult_big_int_ratio : Big_int.big_int -> ratio -> ratio val square_ratio : ratio -> ratio val inverse_ratio : ratio -> ratio val div_ratio : ratio -> ratio -> ratio val integer_ratio : ratio -> Big_int.big_int val floor_ratio : ratio -> Big_int.big_int val round_ratio : ratio -> Big_int.big_int val ceiling_ratio : ratio -> Big_int.big_int val eq_ratio : ratio -> ratio -> bool val compare_ratio : ratio -> ratio -> int val lt_ratio : ratio -> ratio -> bool val le_ratio : ratio -> ratio -> bool val gt_ratio : ratio -> ratio -> bool val ge_ratio : ratio -> ratio -> bool val max_ratio : ratio -> ratio -> ratio val min_ratio : ratio -> ratio -> ratio val eq_big_int_ratio : Big_int.big_int -> ratio -> bool val compare_big_int_ratio : Big_int.big_int -> ratio -> int val lt_big_int_ratio : Big_int.big_int -> ratio -> bool val le_big_int_ratio : Big_int.big_int -> ratio -> bool val gt_big_int_ratio : Big_int.big_int -> ratio -> bool val ge_big_int_ratio : Big_int.big_int -> ratio -> bool val int_of_ratio : ratio -> int val ratio_of_int : int -> ratio val ratio_of_nat : Nat.nat -> ratio val nat_of_ratio : ratio -> Nat.nat val ratio_of_big_int : Big_int.big_int -> ratio val big_int_of_ratio : ratio -> Big_int.big_int val div_int_ratio : int -> ratio -> ratio val div_ratio_int : ratio -> int -> ratio val div_big_int_ratio : Big_int.big_int -> ratio -> ratio val div_ratio_big_int : ratio -> Big_int.big_int -> ratio val approx_ratio_fix : int -> ratio -> string val approx_ratio_exp : int -> ratio -> string val float_of_rational_string : ratio -> string val string_of_ratio : ratio -> string val ratio_of_string : string -> ratio val float_of_ratio : ratio -> float val power_ratio_positive_int : ratio -> int -> ratio val power_ratio_positive_big_int : ratio -> Big_int.big_int -> ratio val equal : 'a -> 'a -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Ratio.ratio end module Complex : sig type t = Complex.t = { re : float; im : float; } val zero : t val one : t val i : t val neg : t -> t val conj : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val inv : t -> t val div : t -> t -> t val sqrt : t -> t val norm2 : t -> float val norm : t -> float val arg : t -> float val polar : float -> float -> t val exp : t -> t val log : t -> t val pow : t -> t -> t val equal : 'a -> 'a -> bool val hash : 'a -> int val gen : ?size:'a -> Random.State.t -> Complex.t end module String : sig external length : string -> int = "%string_length" external get : string -> int -> char = "%string_safe_get" external set : string -> int -> char -> unit = "%string_safe_set" external create : int -> string = "caml_create_string" val make : int -> char -> string val copy : string -> string val sub : string -> int -> int -> string val fill : string -> int -> int -> char -> unit val blit : string -> int -> string -> int -> int -> unit val concat : string -> string list -> string val iter : (char -> unit) -> string -> unit val escaped : string -> string val index : string -> char -> int val rindex : string -> char -> int val index_from : string -> int -> char -> int val rindex_from : string -> int -> char -> int val contains : string -> char -> bool val contains_from : string -> int -> char -> bool val rcontains_from : string -> int -> char -> bool val uppercase : string -> string val lowercase : string -> string val capitalize : string -> string val uncapitalize : string -> string type t = string val compare : t -> t -> int external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : string -> int -> int -> char -> unit = "caml_fill_string" "noalloc" val equal : t -> t -> bool val hash : 'a -> int val gen : ?size:int -> Random.State.t -> string val to_string : 'a -> 'a end module Option : sig type 'a t = 'a option val compare : ('a -> 'b -> int) -> 'a option -> 'b option -> int val equal : 'a option -> 'a option -> bool val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a option val to_string : ('a -> string) -> 'a option -> string end ocaml-reins-0.1a/src/base/quickcheck.mli0000644000175000017500000000450210676520540017320 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Random Testing Framework This module implements a random testing framework based on Claessen and Hughes's QuickCheck library for Haskell. *) exception Trivial module type Law = sig module Arg : Types.Mono.Arbitrary (** A value of type Arg.t will be randomly generated and passed to the law function below. *) val desc : string (** Description of the test. This value is simply stored in the result of the Check functor below for easy access by a test driver. *) val law : Arg.t -> bool (** The function that implements the law. The function should return [true] when the law holds for the input and [false] if the law does not hold. It may also raise the exception {!Trivial} if the law only trivially applies to the input, in which case a new input will be attempted. *) end module type Config = sig val num_iterations : int (** This value determines how many inputs will be passed to the {!Law.law} function. Values that are signaled to be trivial are not counted. *) val size_arg : int option (** This value is passed as the option size paramter to the function {!Types.Mono.Arbitrary.gen} when generating input for a law. *) val max_trivial_percentage : float (** This value determines how many inputs are allowed to be classified as trivial before giving up and classifying the law as failed. The value should be in the range \[0\.0,1\.0) *) end module Check : functor (Conf : Config) -> functor (L : Law) -> sig val desc : string (** A copy of the test description supplied by the Law module *) val test : Random.State.t -> unit (** The function which executes the series random tests on law [L] *) end ocaml-reins-0.1a/src/base/types.ml0000644000175000017500000002664610676520540016216 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (* combinator for composing compare functions *) let cmp2 c1 f a1 a2 = match c1 with | 0 -> f a1 a2 | _ -> c1 module Poly = struct module type Equatable = sig type 'a t val equal : 'a t -> 'a t -> bool end module type Comparable = sig type 'a t val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val to_string : ('a -> string) -> 'a t -> string end module type Hashable = sig include Equatable val hash : 'a t -> int end module type Arbitrary = sig type 'a t val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t val to_string : ('a -> string) -> 'a t -> string end module type ArbitraryComparable = sig include Arbitrary val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int end module ComposeComparable (A : Comparable) (B : Comparable) : Comparable with type 'a t = 'a B.t A.t = struct type 'a t = 'a B.t A.t let compare f = A.compare (B.compare f) let to_string f = A.to_string (B.to_string f) end module ComposeGen (A : Arbitrary) (B : Arbitrary) : Arbitrary with type 'a t = 'a B.t A.t = struct type 'a t = 'a B.t A.t let to_string to_s t = A.to_string (B.to_string to_s) t let gen (gen1: ?size:int -> Random.State.t -> 'a) ?size rs = A.gen (B.gen gen1) ?size rs end module ComposeGenComparable (A : ArbitraryComparable) (B : ArbitraryComparable) : ArbitraryComparable with type 'a t = 'a B.t A.t = struct include ComposeGen(A)(B) let compare f x y = A.compare (B.compare f) x y end (* This module allows you to close the Compose* functors. *) module Close = struct type 'a t = 'a let to_string to_s t = to_s t let compare cmp t1 t2 = cmp t1 t2 end end module Mono = struct module type Equatable = sig type t val equal : t -> t -> bool end module type Comparable = sig type t val compare : t -> t -> int val to_string : t -> string end module type Hashable = sig include Equatable val hash : t -> int end module type Arbitrary = sig type t val gen : ?size:int -> Random.State.t -> t val to_string : t -> string end module type ArbitraryComparable = sig include Arbitrary val compare : t -> t -> int end module ComposeComparable (P : Poly.Comparable) (M : Comparable) : Comparable with type t = M.t P.t = struct type t = M.t P.t let compare x y = P.compare M.compare x y let to_string t = P.to_string M.to_string t end module ComposeGen (P : Poly.Arbitrary) (M : Arbitrary) : Arbitrary with type t = M.t P.t = struct type t = M.t P.t let to_string t = P.to_string M.to_string t let gen ?size rs = P.gen M.gen ?size rs end module ComposeGenComparable (P : Poly.ArbitraryComparable) (M : ArbitraryComparable) : ArbitraryComparable with type t = M.t P.t = struct include ComposeGen(P)(M) let compare x y = P.compare M.compare x y end module ComparablePair(M1 : Comparable)(M2 : Comparable) : Comparable with type t = M1.t * M2.t = struct type t = M1.t * M2.t let compare (x1,x2) (y1,y2) = cmp2 (M1.compare x1 y1) M2.compare x2 y2 let to_string (a,b) = Printf.sprintf "(%s, %s)" (M1.to_string a) (M2.to_string b) end module Comparable3Tuple(M1 : Comparable)(M2 : Comparable)(M3 : Comparable) : Comparable with type t = M1.t * M2.t * M3.t = struct type t = M1.t * M2.t * M3.t let compare (x1,x2,x3) (y1,y2,y3) = cmp2 (cmp2 (M1.compare x1 y1) M2.compare x2 y2) M3.compare x3 y3 let to_string (a,b,c) = Printf.sprintf "(%s, %s, %s)" (M1.to_string a) (M2.to_string b) (M3.to_string c) end module GenPair(A : Arbitrary)(B : Arbitrary) : Arbitrary with type t = A.t * B.t = struct type t = A.t * B.t let gen ?size r = A.gen ?size r, B.gen ?size r let to_string (a,b) = Printf.sprintf "(%s, %s)" (A.to_string a) (B.to_string b) end module Gen3Tuple(A : Arbitrary)(B : Arbitrary)(C : Arbitrary) : Arbitrary with type t = A.t * B.t * C.t = struct type t = (A.t * B.t * C.t) let gen ?size r = A.gen ?size r, B.gen ?size r, C.gen ?size r let to_string (a,b,c) = Printf.sprintf "(%s, %s, %s)" (A.to_string a) (B.to_string b) (C.to_string c) end end (** Base Types *) module type Integral = sig type t val zero : t val one : t val minus_one : t val abs : t -> t val neg : t -> t val succ : t -> t val pred : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t val logand : t -> t -> t val lognot : t -> t val logor : t -> t -> t val logxor : t -> t -> t val shift_left : t -> int -> t val shift_right : t -> int -> t val shift_right_logical : t -> int -> t val compare : t -> t -> int val of_int : int -> t val to_int : t -> int val of_float : float -> t val to_float : t -> float val to_string : t -> string val of_string : string -> t end module Int = struct type t = int let zero = 0 let one = 1 let minus_one = -1 let abs = Pervasives.abs let neg = ( ~- ) let succ = Pervasives.succ let pred = Pervasives.pred let add = (+) let sub = (-) let mul = ( * ) let div = ( / ) let rem x y = x mod y let logxor x y = x lxor y let logand x y = x land y let lognot x = lnot x let logor x y = x lor y let shift_left x y = x lsl y let shift_right x y = x asr y let shift_right_logical x y = x lsr y let of_int x = x let to_int x = x let of_float = Pervasives.int_of_float let to_float = Pervasives.float_of_int let to_string = Pervasives.string_of_int let of_string = Pervasives.int_of_string let compare (x:int) (y:int) = Pervasives.compare x y let equal x y = (compare x y) = 0 let hash x = x let to_string x = string_of_int x let gen ?(size=max_int) r = let nsize = Nativeint.of_int size in let rand = Random.State.nativeint r nsize in Nativeint.to_int rand end module Float = struct type t = float let compare (x:float) (y:float) = compare x y let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?(size=max_int) r = Random.State.float r (float size) let to_string = string_of_float end module Bool = struct type t = bool let compare (x:bool) (y:bool) = compare x y let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?size r = Random.State.bool r let to_string = string_of_bool end module Char = struct type t = char let compare (x:char) (y:char) = compare x y let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?(size=256) r = Char.chr (Random.State.int r (size mod 256)) let to_string c = String.make 1 c end module Int32 = struct include Int32 let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?size r = Random.State.int32 r Int32.max_int end module Int64 = struct include Int64 let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?size r = Random.State.int64 r Int64.max_int end module Nativeint = struct include Nativeint let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?size r = Random.State.nativeint r Nativeint.max_int end module Big_int = struct include Big_int type t = big_int let equal x y = (compare_big_int x y) = 0 let compare = eq_big_int let hash x = Hashtbl.hash x let gen ?size r = Big_int.big_int_of_string (Int64.to_string (Random.State.int64 r Int64.max_int)) let zero = zero_big_int let one = unit_big_int let minus_one = minus_big_int one let abs = abs_big_int let neg = minus_big_int let succ = succ_big_int let pred = pred_big_int let add = add_big_int let sub = sub_big_int let mul = mult_big_int let div = div_big_int let rem = mod_big_int (* let logxor = ( lxor ) let logand = ( land ) let lognot = ( lnot ) let logor = ( lor ) let shift_left = ( lsl ) let shift_right = ( asr ) let shift_right_logical = ( lsr ) *) let of_int x = big_int_of_int let to_int x = int_of_big_int let of_float f = big_int_of_string (string_of_float (floor f)) let to_float = float_of_big_int let to_string = string_of_big_int let of_string = big_int_of_string end module Ratio = struct include Ratio let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?size r = Ratio.create_ratio (Big_int.gen r) (Big_int.gen r) end module Complex = struct include Complex let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?size r = {Complex.re = Float.gen r; im = Float.gen r} end module String = struct include String let equal x y = (compare x y) = 0 let hash x = Hashtbl.hash x let gen ?(size=100) rs = let len = (Random.State.int rs size) mod Sys.max_string_length in let s = String.create len in for i = 0 to (len-1) do s.[i] <- Char.gen ~size:size rs done; s let to_string x = x end let _ = let module Test1 = (Int : Integral) in let module Test2 = (Int32 : Integral) in let module Test3 = (Int64 : Integral) in let module Test4 = (Nativeint : Integral) in (* let module Test5 = (Big_int : Integral) in missing logical ops... :-( *) () module Option = struct type 'a t = 'a option let compare cmp x y = match x,y with | None, None -> 0 | None, Some _ -> -1 | Some _, None -> 1 | Some a, Some b -> cmp a b let equal x y = (compare Pervasives.compare x y) = 0 let gen (gen:?size:int -> Random.State.t -> 'a) ?size r : 'a option = if Random.State.bool r then None else Some (gen ?size r) let to_string to_s = function | None -> "None" | Some x -> "Some " ^ (to_s x) end (* CR SW: There's some room for code sharing, both at the module type level and at the functor level. First, there is a technique by which one can get multiple interface inheritance. This would allow you to mix and match all of the various signatures (comparable, hashable, equality, ...) to write down an explicit signature that describes a module that meets some subset of them. The trick is to *not* use "t" when defining "abstract" signatures (characterizing some aspect of behavior), and instead to use the name of the of the behavior as the name of the type. For example, one could do: module type MonoEquatable = sig type equatable val equal : equatable -> equatable -> bool end module type MonoHashable = sig type hashable val hash : hashable -> int end Then, whenever you have a type t in some signature that you want to have a particaular behavior, you do "include Behavior with type behavior = t". For example, for a monotype that supports equal and hash, you could do. module type Z = sig type t include MonoEquatable with type equatable = t include MonoHashable with type hashable = t end *) ocaml-reins-0.1a/src/base/OMakefile0000644000175000017500000000005410672112566016261 0ustar furrmfurrm FILES[] += base/types base/quickcheck ocaml-reins-0.1a/src/META.in0000644000175000017500000000010410675630623014644 0ustar furrmfurrmversion="0.1" archive(byte)="reins.cma" archive(native)="reins.cmxa"ocaml-reins-0.1a/src/list/0002755000175000017500000000000010676540774014560 5ustar furrmfurrmocaml-reins-0.1a/src/list/listCursor.ml0000644000175000017500000000420410676520540017246 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type S = sig type 'a list_ type 'a cursor val to_cursor : 'a list_ -> 'a cursor val from_cursor : 'a cursor -> 'a list_ val at_front : 'a cursor -> bool val at_back : 'a cursor -> bool val move_next : 'a cursor -> 'a cursor val move_prev : 'a cursor -> 'a cursor val goto_front : 'a cursor -> 'a cursor val goto_back : 'a cursor -> 'a cursor val value : 'a cursor -> 'a option val list : 'a cursor -> 'a list_ val replace_list : 'a list_ -> 'a cursor -> 'a cursor end module Make(L : Lists.ListSig) : S with type 'a list_ = 'a L.t = struct type 'a list_ = 'a L.t (* Note that this type is same as the standard list type with the arguments of the 2nd constructor reversed. *) type 'a path = | Top | Path of 'a path * 'a type 'a cursor = 'a path * 'a L.t let to_cursor t = Top, t let at_front = function Top,_ -> true | _ -> false let at_back (p,t) = L.is_empty t let value (_,t) = if L.is_empty t then None else Some (L.hd t) let list (_,t) = t let replace_list t (p,_) = (p,t) let move_next (p,t) = if L.is_empty t then failwith "move_next" else let x,xs = L.pop t in Path(p,x), xs let move_prev (p,t) = match p with | Top -> failwith "move_prev" | Path(p, x) -> p, (L.cons x t) let rec goto_front c = if at_front c then c else goto_front (move_prev c) let rec goto_back c = if at_back c then c else goto_back (move_next c) let rec from_cursor = function | Top,t -> t | c -> from_cursor (move_prev c) end ocaml-reins-0.1a/src/list/skewBinaryList.ml0000644000175000017500000002043710676520540020055 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (* The type RList.t is based on skew binary numbers. A skew binary number is comprised of a sequence of the digits 0,1, or 2 where the weight of the ith digit is 2^{i+1}-1 instead of the typical 2^i with traditional binary numbers. Furthermore, all skew binary numbers can be written where only the lowest non-zero digit is 2 (canonical form). To increment a skew binary number in canoncical form, we simply reset the (single) 2 to 0 and increment the next digit (which can't be a 2). If there are no 2's, we can simply increment the lowest digit. Here are the first 10 skew binary numbers to illustrate: 0 1 2 10 11 12 20 100 # increment the 2, not the 0 101 102 Decrementing is simply the reverse of this operation (decrement the 2, if it exists, otherwise decrement the lowest non-zero digit, possibly carrying a result one plce). *) (* The type elt is a complete binary tree. *) type 'a elt = | Leaf of 'a | Node of 'a * 'a elt * 'a elt (* A random access list is a list of complete binary trees paired with their size. These trees each have size 2^i-1 making them ideal for representing digits in this number system. We represent a '2' digit by a pair of adjacent trees with the same weight. Otherwise, each tree represents a '1' digit while '0' digits are omitted from the list. The list is kept in increasing order of size so that a '2' digit exists iff the first two elements have the same height. *) type 'a t = (int * 'a elt) list let empty = [] let is_empty = function [] -> true | _ -> false (* The cons operation adds a new element to the list. Therefore we must "increment" the skew binary number. To do so, we look at the bottom two digits and compare their weights. If they have the same weight, this is a '2' digit and therefore we reset it to 0 and propogate the bit. We do this by creating a new tree combining the two previous trees with an incremented weight (thus there is no tree with the original weight, creating the 0 digit). If the bottom digit is not a '2', then we can simply add 'x' as a leaf to the beginning of the list, incrementing the lowest digit (to either '1' or '2'). *) let cons x ts = match ts with | (w1,t1)::(w2,t2)::ts' when w1=w2 -> (1+w1+w2, Node(x,t1,t2)) :: ts' | _ -> (1,Leaf x) :: ts let hd = function | [] -> failwith "hd" | (w,Leaf x) :: ts -> assert(w=1);x | (w,Node(x,t1,t2)) :: ts -> x (* The tl operation must remove an element from the list and therefore we must decrement the skew binary number. To do this we simply remove the root of the first tree and add its children back as a new '2' digit (which has smaller weight than any other tree, preserving canonical form). *) let tl = function | [] -> failwith "tl" | (w,Leaf x) :: ts -> assert(w=1); ts | (w,Node(x,t1,t2))::ts -> (w / 2, t1) :: (w / 2, t2) :: ts let pop = function | [] -> failwith "pop" | (w,Leaf x) :: ts -> assert(w=1); x,ts | (w,Node(x,t1,t2))::ts -> x, ((w / 2, t1) :: (w / 2, t2) :: ts) (* Returns the i'th element in the complete tree 't'. Raises Not_found if i is greater than the cardinality of the tree. *) let rec lookup_tree i = function | 1, Leaf x -> if i = 0 then x else raise Not_found | _, Leaf _ -> assert false | w, Node(x,t1,t2) -> if i = 0 then x (* The tree is pre-ordered, so the first element is at the root. *) else if i <= w/2 then lookup_tree (i-1) (w/2,t1) (* Decrement i, since we skip over the first element *) else lookup_tree (i-(1+(w/2))) (w/2,t2) (* Subtract 1+w/2 since we skip over the first element and all of the elements in t1. *) (* Return the i'th element (0-indexed) in the list. We first find the tree which contains i'th element, and then call loookup_tree to extract the proper element from that tree. Raises Not_found if the list does not have at least i+1 elements (+1 because of 0-index). *) let rec lookup i = function | [] -> raise Not_found | ((w,t) as elt)::ts -> if i < w then lookup_tree i elt else lookup (i-w) ts (* Returns the tree 't' with the i'th element replaced by 'y'. Raises Not_found if i is greater than the cardinality of the tree. *) let rec update_tree i y = function | (1, Leaf x) -> if i = 0 then Leaf y else raise Not_found | (_, Leaf _) -> assert false | (w, Node(x,t1,t2)) -> if i = 0 then Node(y,t1,t2) (* The tree is pre-ordered, so the first element is at the root. *) else if i <= w / 2 then Node(x, update_tree (i-1) y (w/2,t1), t2) (* Decrement i, since we skip over the first element *) else Node(x,t1,update_tree (i-1-(w/2)) y (w/2,t2)) (* Subtract 1+w/2 since we skip over the first element and all of the elements in t1. *) (* Return the list with the i'th element (0-indexed) in the list replaced by v. We first find the tree which contains i'th element, and then call update_tree to update the proper element from that tree. Raises Not_found if the list does not have at least i+1 elements (+1 because of 0-index). *) let rec update i v = function | [] -> raise Not_found | ((w,t) as l)::ts -> if i < w then (w, update_tree i v l)::ts else (w,t)::(update (i-w) v ts) (* fold over a single tree *) let rec fold_elt f acc = function | Leaf x -> f acc x | Node(x,t1,t2) -> fold_elt f (fold_elt f (f acc x) t1) t2 let fold_left f acc t = List.fold_left (fun acc (_,e) -> fold_elt f acc e) acc t let fold = fold_left let rec iter_elt f = function | Leaf x -> f x | Node(x,t1,t2) -> f x; iter_elt f t1; iter_elt f t2 let iter f t = List.iter (fun (_,e) -> iter_elt f e) t let length t = List.fold_left (fun acc (w,_) -> acc + w) 0 t let from_list lst = List.fold_left (fun acc x -> cons x acc) empty (List.rev lst) let to_list t = List.rev (fold_left (fun acc x -> x::acc) [] t) let rev t = fold_left (fun acc x -> cons x acc) empty t (* This could be made more efficient if we were smarter about keeping existing trees and performing skew binary addition. The worst case would still be O(n), but some cases would reduce to O(log n). TODO *) let append t1 t2 = fold_left (fun acc x -> cons x acc) t2 (rev t1) (* Since this will cause all of the trees to shift by one, this operation is the worst case scenario of append. *) let snoc x t = append t (cons x empty) let rec last_tree = function | Leaf x -> x | Node(_,_,r) -> last_tree r let rec last = function | [] -> failwith "last" | (w,t)::[] -> last_tree t | _::tl -> last tl let rev_map f t = fold_left (fun acc t -> cons (f t) acc) empty t let rec map_tree f = function | Leaf x -> Leaf (f x) | Node(x,t1,t2) -> Node(f x, map_tree f t1, map_tree f t2) let map f t = (* List.map is not tail recursive, but the list we are mapping is only (log n) long, so it will only use log n stack. *) List.map (fun (w,t) -> w, map_tree f t) t (* We can't use append since it is O(n). Instead we do two linear passes over the list of lists. First we convert the list of type ('a t t) into a list of type ('a list list), but keep both the individual and aggregate lists in reverse order. Then we simply fold over this collection accumulating the result using cons. *) let flatten t = let rlsts = fold_left (fun acc lst -> (fold_left (fun acc x -> x::acc) [] lst)::acc) [] t in List.fold_left (List.fold_left (fun acc x -> cons x acc)) empty rlsts (* TODO: replace with more efficient version *) let rec compare c t1 t2 = SList.compare c (to_list t1) (to_list t2) let to_string to_s t = ListCommon.to_string iter pop to_s t let gen genA ?(size=50) rs = let t = SList.gen genA ~size:size rs in from_list t ocaml-reins-0.1a/src/list/catenableList.ml0000644000175000017500000000662510676520540017660 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Lists with fast concatenation. Based on Okasaki's implementation *) type 'a t = | Empty | Cat of 'a * 'a t Lazy.t DoubleQueue.t let empty = Empty let is_empty = function Empty -> true | _ -> false let link (t: 'a t) (s: 'a t Lazy.t) = match t with | Empty -> assert false | Cat(x,q) -> Cat(x, DoubleQueue.enqueue s q) let rec link_all q = let t = Lazy.force (DoubleQueue.hd q) in let q' = DoubleQueue.tl q in if DoubleQueue.is_empty q' then t else link t (lazy (link_all q')) let append t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | _ -> link t1 (lazy t2) let cons x xs = append (Cat(x,DoubleQueue.empty)) xs let snoc x xs = append xs (Cat(x,DoubleQueue.empty)) let rec last = function | Empty -> failwith "last" | Cat(x,q) -> if DoubleQueue.is_empty q then x else let t' = Lazy.force (DoubleQueue.last q) in last t' let hd = function | Empty -> failwith "hd" | Cat(x,_) -> x let pop = function | Empty -> failwith "pop" | Cat(x,q) -> x, (if DoubleQueue.is_empty q then Empty else link_all q) let tl = function | Empty -> failwith "tl" | Cat(x,q) -> if DoubleQueue.is_empty q then Empty else link_all q let rec iter f = function | Empty -> () | t -> let hd,tl = pop t in f hd; iter f tl let rec fold_left f acc = function | Empty -> acc | t -> let hd,tl = pop t in fold_left f (f acc hd) tl (* let rec fold_right f t acc = match t with | Empty -> acc | Cat(x,q) -> if DoubleQueue.is_empty q then f x acc else let rest,last = DoubleQueue.pop_back q in fold_right f rest (f acc last) *) let fold = fold_left let rev t = fold (fun acc x -> cons x acc) empty t let rev_map f t = let rec helper acc = function | Empty -> acc | t -> let hd,tl = pop t in helper (cons (f hd) acc) tl in helper Empty t let map f t = let rec helper acc = function | Empty -> acc | t -> let hd,tl = pop t in helper (snoc (f hd) acc) tl in helper Empty t let length t = fold (fun acc _ -> acc+1) 0 t let to_list t = List.rev (fold (fun acc x -> x::acc) [] t) let from_list lst = List.fold_left (fun acc x -> snoc x acc) Empty lst let rec flatten t = let rec helper acc t = if is_empty t then acc else let x,xs = pop t in helper (append acc x) xs in helper Empty t let to_string to_s t = ListCommon.to_string iter pop to_s t let rec compare cmp t1 t2 = match t1,t2 with | Empty, Empty -> 0 | Empty, t -> -1 | t, Empty -> 1 | Cat(x,q1),Cat(y,q2) -> match cmp x y with | 0 -> compare cmp (tl t1) (tl t2) | v -> v let rec gen (agen : ?size:int -> Random.State.t -> 'a) ?(size=50) rs : 'a t = let rec helper acc s = let s = max s 1 in let i = Random.State.int rs s in if i <= 1 then acc else helper (cons (agen ~size:size rs) acc) (s-1) in helper Empty size ocaml-reins-0.1a/src/list/doubleQueue.ml0000644000175000017500000000616210676520540017361 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) type 'a t = 'a list * 'a list let empty = [], [] let is_empty (f,r) = match f with [] -> true | _ -> false (* smart construct to enforce that the first list is only empty when the entire queue is empty *) let dqueue f r = match f with | [] -> (List.rev r), [] | _ -> f,r let cons x (f,r) = x::f, r let snoc x (f,r) = dqueue f (x::r) let cons_back = snoc let enqueue = snoc let hd = function | [],_ -> failwith "hd" | x::_,_ -> x let tl = function | [],_ -> failwith "tl" | x::tl,r -> dqueue tl r let pop = function | [],_ -> failwith "pop" | x::tl,r -> x, (dqueue tl r) let dequeue = pop let last = function | _, r::_ -> r | [],[] -> failwith "last" | hd::[], [] -> hd | f::fs, [] -> List.hd (List.rev fs) let hd_back t = try last t with Failure "last" -> failwith "hd_back" let tl_back = function | f, (r::rs) -> (f,rs) | [], [] -> failwith "tl_back" | hd::[], [] -> empty | f::fs, [] -> match List.rev fs with | [] -> assert false | r::rs -> [f], rs let pop_back = function | f, (r::rs) -> (f,rs), r | [], [] -> failwith "pop_back" | hd::[], [] -> empty, hd | f::fs, [] -> match List.rev fs with | [] -> assert false | r::rs -> ([f], rs), r let length (f,r) = (List.length f) + (List.length r) let append (f1,r1) (f2,r2) = let r = List.rev_append f2 r1 in let r = List.append r2 r in f1, r let rev (f,r) = dqueue r f let iter func (f,r) = List.iter func f; List.iter func (List.rev r) let fold func acc (f,r) = List.fold_left func (List.fold_left func acc f) (List.rev r) let rev_map func l = fold (fun acc x -> cons (func x) acc) empty l let map func l = fold (fun acc x -> snoc (func x) acc) empty l let to_list (f,r) = List.rev_append (List.rev f) (List.rev r) let from_list l = (l,[]) (* This is probably not the fastest implementation due to the intermediate list reversals, however its at least O(n). Feel free to submit patches with a faster version if you actually use this function. *) let flatten (f,r) = let f' = List.rev (List.fold_left (fold (fun acc x -> x::acc)) [] f) in let r' = List.rev (List.fold_left (fold (fun acc x -> x::acc)) [] r) in (f',r') let compare c ((f1,r1) as l1) ((f2,r2) as l2) = match r1,r2 with | [],[] -> SList.compare c f1 f2 | _ -> SList.compare c (to_list l1) (to_list l2) let to_string to_s l = ListCommon.to_string iter pop to_s l let gen (gena: ?size:int -> Random.State.t -> 'a) ?size rs : 'a t = (SList.gen ?size gena rs), (SList.gen ?size gena rs) ocaml-reins-0.1a/src/list/doubleList.mli0000644000175000017500000002320110676520540017352 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Acyclic doubly linked lists This module implements acyclic doubly linked lists that support O(1) navigation. The running time of the rest of the operations depend on the argument [L]. All operations are explained assuming the list is visually laid out from left to right. That is, the front of the list is on the left and the end of the list is on the right. *) module Make(L : Lists.ListSig) : sig type 'a t (** The type of doubly linked lists. This type can be thought of as a cursor pointing into the middle of a [L.t] list. Elements to the right of [t] can be reached with [hd], [tl], [pop], and [next]. Elements to the left of [t] can be reached with [prev_hd], [prev_tl], [prev_pop], and [prev]. *) val empty : 'a t (** The empty list *) val is_empty : 'a t -> bool (** Returns true if the list is empty. That is, there are no elements to the left or right of [t]. Runs in the same time and stack space as [L.is_empty]. *) val at_front : 'a t -> bool (** [at_front t] Retruns true if there are no elements to the left of [t]. Runs in the same time and stack space as [L.is_empty]. *) val at_back : 'a t -> bool (** [at_front t] Retruns true if there are no elements to the right of [t]. Runs in the same time and stack space as [L.is_empty]. *) val length : 'a t -> int (** [length t] Returns the length of the entire list. Runs in the same time and stack space as [L.length]. *) val next_length : 'a t -> int (** [next_length t] Returns the number of elements to the right of [t]. Runs in the same time and stack space as [L.length]. *) val prev_length : 'a t -> int (** [prev_length t] Returns the number of elements in front of [t]. Runs in the same time and stack space as [L.length]. *) val rev : 'a t -> 'a t (** [rev t] Reverse the list [t]. All elements that were in front of [t] are now to the right of it and vice versa. Runs in O(1) time and stack space. *) val hd : 'a t -> 'a (** [hd t] Returns the element to the immediate right of [t]. Runs in the same time and stack space as [L.hd]. If there are no elements to the right of [t], it raises [Failure "hd"]. *) val tl : 'a t -> 'a t (** [tl t] Return the list with the first element to the right of [t] removed. Runs in the same time and stack space as [L.tl]. If there are no elements to the right of [t], it raises [Failure "tl"]. *) val pop : 'a t -> 'a * 'a t (** [pop t] Equivalent to [(hd t), (tl t)] but is slightly more efficient. Runs in the same time and stack space as [L.pop]. If there are no elements to the right of [t], it raises [Failure "pop"]. *) val last : 'a t -> 'a (** [last t] Returns the last element the right of [t]. Runs in the same time and stack space as [L.last]. If there are no elements to the right of [t], it raises [Failure "last"]. *) val next : 'a t -> 'a t (** [next t] Advance [t] to the next element in the list. The element to the right of [t] is now to the left of the result. Runs in the same time and stack space as the maximum of [L.hd] and [L.cons]. If there are no elements to the right of [t], it raises [Failure "next"]. *) val prev_hd : 'a t -> 'a (** [prev_hd t] Returns the element to the left of [t]. Runs in the same time and space as [L.hd]. If there are no element to the left of [t], it raises [Failure "prev_hd"]. *) val prev_tl : 'a t -> 'a t (** [prev_tl t] Return the list with the first element to the left of [t] removed. Runs in the same time and stack space as [L.tl]. If there are no elements to the left of [t], it raises [Failure "prev_tl"]. *) val prev_pop : 'a t -> 'a * 'a t (** [prev_pop t] Equivalent to [(prev_hd t), (prev_tl t)] but is slightly more efficient. Runs in the same time and stack space as [L.pop]. If there are no elements to the left of [t], it raises [Failure "prev_pop"]. *) val prev : 'a t -> 'a t (** [prev t] Advance [t] to the previous element in the list. The element to the left of [t] is now to the right of the result. Runs in the same time and stack space as the maximum of [L.hd] and [L.cons]. If there are no elements to the left of [t], it raises [Failure "prev"]. *) val cons : 'a -> 'a t -> 'a t (** [cons x t] Adds [x] as the first element to the right of [t]. Runs in the same time and stack space as [L.cons]. *) val prev_cons : 'a -> 'a t -> 'a t (** [prev_cons x t] Adds [x] as the first element to the left of [t]. Runs in the same time and stack space as [L.cons]. *) val snoc : 'a -> 'a t -> 'a t (** [snoc x t] Adds [x] as the last element to the right of [t] (i.e., the last element in the entire list). The resulting list otherwise has the same elements to the left of it and to the right of it as [t] (i.e., the position has not changed). Runs in the same time and stack space as [L.snoc]. *) val prev_snoc : 'a -> 'a t -> 'a t (** [snoc x t] Adds [x] as the last element to the left of t [t] (i.e., the first element in the entire list). The resulting list otherwise has the same elements to the left of it and to the right of it as [t] (i.e., the position has not changed). Runs in the same time and stack space as [L.snoc]. *) val append : 'a t -> 'a t -> 'a t (** [append t1 t2] Append the list [t2] onto the back of [t1]. The resulting list has the same position as [t1]. Runs in the O(|t2| + LA) time where LA is the running time of [L.append]. It uses O(1 + LS) stack space where LS is the stack space required by [L.append]. *) val splice : 'a t -> 'a t -> 'a t (** [splice t1 t2] Splices the elements of [t1] into [t2]. The resulting list has the shape: prev_l2 @ prev_l1 @ next_l1 @ next_l2 Runs in the same time and stack space as [L.append]. *) val flatten : 'a t t -> 'a t (** [flatten l] Appends all of the elements of [l] into a new list. Currently ineffeciently implemented and has greater than O(n) running time. *) val from_list : 'a list -> 'a t (** [from_list l] Convert the standard list [l] into a {!DList.t}. Runs in the same time and stack space as [L.from_list]. The resulting cursor points to the front of the list. *) val to_list : 'a t -> 'a list (** [to_list t] Convert the DList [t] into a standard list. Runs in O(|t|) time and O(1) stack space. The position of [t] does not affect the order of the resulting list. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f t] Iterates over each element in the list [t] and applies [f] to that element. The elements to the right of [t] are visited first in order, following by the elements to the left of [t] in reverse order. Runs in the same time and stack space as [L.iter]. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold f acc t] Accumulates the result [acc] by applying [f acc x] for each element [x] in [t]. The elements to the right of [t] are visited first in order, following by the elements to the left of [t] in reverse order. Runs in the same time and stack space as [L.fold]. *) val rev_map : ('a -> 'b) -> 'a t -> 'b t (** [rev_map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in reverse order of [t] and the cursor of the resulting list points to the same location as [t] whith the next and previous elements reversed. e.g., if [e == hd t], then [f(e) == prev_hd (rev_map f t)] Runs in the same time and stack space as [L.map]. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in the same order as [t] and the cursor points to the same location as [t]. e.g., if [e == hd t], then [f(e) == hd (map f t)]. Runs in the same time and stack space as [L.map]. *) val to_string : ('a -> string) -> 'a t -> string (** [to_string to_s t] Convert the list [t] into a string using [to_s] to individually convert each element into a string. Runs in O(|t|*st) where st is the running time of [to_s] and uses O(ss) stack space where ss is the amount of stack required by [to_s]. *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to compare individual elements. Returns 0 if [t1] and [t2] are equal (under f). Returns [<0] if [t1] is less than [t2] and returns [>0] otherwise. Runs in O(min(|t1|, |t2|)) time and O(1) stack space. *) val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t (** [gen f ?size rs] Generates a random list whose length is bounded by [size]. Each element in the list is computed by calling [f ?size rs]. Runs in time O([size] * ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space of [f]. The location of the cursor is not defined. *) include ListCursor.S with type 'a list_ = 'a t and type 'a cursor = 'a t (** Note that the type [cursor] is the same as [t]. Therefore all {!List_Cursor.S} operations can be applied directly to values of type DList.t *) end ocaml-reins-0.1a/src/list/listCursor.mli0000644000175000017500000000661410676520540017426 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Cursor interface for Lists *) module type S = sig type 'a list_ (** The underlying list type the cursor points to. *) type 'a cursor (** The type of list cursors. A cursor can be thought of a pointer into the middle of a list. More specifically, cursors point to edges between list elements, not elements directly. A cursor can be move to the left (towards the front of the list) or to the right (towards the back of the list) and supports updating the list at the current position efficiently. *) val to_cursor : 'a list_ -> 'a cursor (** [to_cursor t] Create a cursor that points to the beginning of list [t]. Runs in O(1) time and space. *) val from_cursor : 'a cursor -> 'a list_ (** [from_cursor curs] Return the list that is pointed to by [curs]. Runs in O(n) time and O(1) stack space where n is the number of elements to the left of [curs]. *) val at_front : 'a cursor -> bool (** [at_front curs] Returns true if there are no elements to the left of [curs]. Runs in O(1) time and stack space. *) val at_back : 'a cursor -> bool (** [at_end curs] Returns true if there are no elements to the right of [curs]. Runs in O(1) time and stack space. *) val move_next : 'a cursor -> 'a cursor (** [move_left curs] Moves the cursor one element to the left. If there are no elements to the left of [curs] (i.e., [curs] points to the front of the list), it raises [Failure "move_left"]. Runs in O(1) time and stack space. *) val move_prev : 'a cursor -> 'a cursor (** [move_right curs] Moves the cursor one element to the right. If there are no elements to the right of [curs] (i.e., [curs] points to the end of the list), it raises [Failure "move_right"]. Runs in O(1) time and stack space. *) val goto_front : 'a cursor -> 'a cursor (** [goto_front curs] Moves the cursor to the front of the list. Runs in O(n) time and O(1) stack space where n is the number of elements to the left of [curs]. *) val goto_back : 'a cursor -> 'a cursor (** [goto_back curs] Moves the cursor to the back of the list. Runs in O(n) time and O(1) stack space where n is the number of elements to the right of [curs]. *) val value : 'a cursor -> 'a option (** If the cursor currently points to an element [x], return that element as [Some x], otherwise return [None]. *) val list : 'a cursor -> 'a list_ (** [list curs] Returns all of the elements to the right of [curs] as a ['a list_]. Runs in O(1) time and stack space. *) val replace_list : 'a list_ -> 'a cursor -> 'a cursor (** [replace_list l curs] Replaces the list of elements to the right of [curs] with [l]. Runs in O(1) time and stack space. *) end module Make : functor (L : Lists.ListSig) -> S with type 'a list_ = 'a L.t ocaml-reins-0.1a/src/list/skewBinaryList.mli0000644000175000017500000001445510676520540020231 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Random access lists based on skew binary numbers This module implements random access lists with O(1) [hd] and [tl] operations and O(log n) [lookup] and [update] operations. *) type 'a t (** The type of random access lists *) val empty : 'a t (** The empty list *) val is_empty : 'a t -> bool (** Returns tree if the list is emtpy. *) val length : 'a t -> int (** [length t] returns the lenth of the list [t]. Runs in O(log n) time and O(1) stack space where n is the number of elements in the list. *) val rev : 'a t -> 'a t (** [rev t] Reverse the list [t]. Runs in O(n) run and O(1) stack space where n is the number of elements in the list. *) val cons : 'a -> 'a t -> 'a t (** [cons x t] Adds the element [x] to the front of the list [t]. Runs in O(1) time and stack space. *) val snoc : 'a -> 'a t -> 'a t (** [snoc x t] Adds the element [x] to the back of the list [t]. Runs in O(n) time and O(1) stack space where n is the length of the list. *) val last : 'a t -> 'a (** [last t] Returns the element at the back of the list. If the list is empty, it raises [Failure "last"]. Runs in O(1) stack and O(log n) time. *) val hd : 'a t -> 'a (** [hd t] Returns the element at the front of the list [t]. Runs in O(1) time and stack space. Raises [Failure "hd"] if the list is empty. *) val tl : 'a t -> 'a t (** [tl t] Returns the list [t] with the first element removed. Runs in O(1) time and stack space. Raises [Failure "tl"] if the list is empty. *) val pop : 'a t -> 'a * 'a t (** [pop t] Equivalent to [(hd t), (tl t)] but is more efficient. Runs in amortized O(1) time and stack space. If the list is empty, it raises [Failure "pop"]. *) val append : 'a t -> 'a t -> 'a t (** [append t1 t2] Appends the list [t2] onto the back of list [t1]. Runs in O(n) time and O(1) stack space where n is the number of elements in [t1]. *) val flatten : 'a t t -> 'a t (** [flatten t] Appends all of the elements of [t] into a new list. Runs in O(n) time and O(1) stack space where n is the sum of each of the lists in [t]. *) val from_list : 'a list -> 'a t (** [from_list l] Convert the standard list l into a SkewBinaryList. Runs in O(n) time and O(1) stack space where n is the number of elements in [l]. *) val to_list : 'a t -> 'a list (** [to_list t] Convert the SkewBinaryList [t] into a standard list. Runs in O(n) time and O(1) stack space where n is the number of elements in [t]. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f t] Iterates over each element in the list [t] in order and applies [f] to that element. Runs in O(n*ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space required by [f]. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold f acc t] Accumulates the result [acc] by applying [f acc x] for each element [x] in [t]. Runs in O(n*ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space required by [f]. *) val rev_map : ('a -> 'b) -> 'a t -> 'b t (** [rev_map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in reverse order of [t]. Runs in O(n*ft) time where n is the number of elements in [t] and ft is the running time of [f]. It uses O(fs) stack space where fs is the stack space required by [f]. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in the same order as [t]. Runs in O(n*ft) time where n is the number of elements in [t] and ft is the running time of [f]. It uses O((fs * log n) stack space where fs is the stack space required by [f]. This function is slightly more efficient than {!SkewBinaryList.rev_map} (yielding a different ordering) and significantly more efficient (by a constant factor) than [SkewBinaryList.rev (SkewBinaryList.rev_map t)]. *) val to_string : ('a -> string) -> 'a t -> string (** [to_string to_s t] Convert the list [t] into a string using [to_s] to individually convert each element into a string. Runs in O(n*st) where st is the running time of [to_s] and uses O(ss) stack space where ss is the amount of stack required by [to_s]. *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to compare individual elements. Returns 0 if [t1] and [t2] are equal (under f). Returns [<0] if [t1] is less than [t2] and returns [>0] otherwise. *) val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t (** [gen f ?size rs] Generates a random list whose length is bounded by [size]. Each element in the list is computed by calling [f ?size rs]. Runs in time O([size] * ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space of [f]. *) val lookup : int -> 'a t -> 'a (** [lookup i t] Returns the element at position [i] (O-indexed) in the list [t]. Raises [Not_found] if the list contains fewer than [i-1] elements. Runs in O(min(i,log n)) time and O(1) stack space where n is the number of elements in [t]. *) val update : int -> 'a -> 'a t -> 'a t (** [update i v t] Returns a new list where the element in position [i] (0-indexed) has been replaced by [v]. Raises [Not_found] if the list contains fewer than [i-1] elements. Runs in O(min(i,log n)) time and O(1) stack space where n is the number of elements in [t]. *) ocaml-reins-0.1a/src/list/catenableList.mli0000644000175000017500000001274410676520540020030 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Lists with fast concatenation. This module implements lists with amortized O(1) [hd], [tl], and [append] operations. *) type 'a t val empty : 'a t (** The empty list *) val is_empty : 'a t -> bool (** returns true if the list is empty *) val length : 'a t -> int (** [length t] Returns the length of the list [t]. Runs in O(n) time and O(1) stack space *) val rev : 'a t -> 'a t (** [rev t] Returns the list [t] in reversed order. Runs in O(n) time and O(1) stack space. *) val hd : 'a t -> 'a (** [hd t] Return the element at the front of the list. O(1) time and stack space. If the list is empty, it raises [Failure "hd"]. *) val tl : 'a t -> 'a t (** [tl t] Return the tail of the list (the list with the first element removed). This operation runs in amortized O(1) time and stack space. If the list is empty, it raises [Failure "tl"]. *) val pop : 'a t -> 'a * 'a t (** [pop t] Equivalent to [(hd t), (tl t)] but is more efficient. Runs in amortized O(1) time and stack space. If the list is empty, it raises [Failure "pop"]. *) val cons : 'a -> 'a t -> 'a t (** [cons x t] Adds [x] onto the front of the list [t]. Runs in amortized O(1) time and stack space. *) val snoc : 'a -> 'a t -> 'a t (** [snoc t x] Adds [x] onto the back of the list [t]. Runs in amortized O(1) time and stack space. *) val last : 'a t -> 'a (** [last t] Returns the element at the back of the list. If the list is empty, it raises [Failure "last"]. Runs in O(1) stack and O(n) time, but may be more efficient in some circumstances when t has been constructed with several concatenations. *) val append : 'a t -> 'a t -> 'a t (** [append t1 t2] Appends the list [t2] onto the back of list [t1]. Runs in amortized O(1) time and stack space. *) val flatten : 'a t t -> 'a t (** [flatten l] Appends all of the elements of [l] into a new list. Runs in amortized O(n) time and amortized O(1) stack space where n is the length of [l]. *) val from_list : 'a list -> 'a t (** [from_list l] Convert the standard list l into a CatenableList. Runs in O(n) time and O(1) stack space where n is the number of elements in [l]. *) val to_list : 'a t -> 'a list (** [to_list t] Convert the CatenableList [t] into a standard list. Runs in O(n) time and O(1) stack space where n is the number of elements in [t]. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f t] Iterates over each element in the list [t] in order and applies [f] to that element. Runs in O(n*ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space required by [f]. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold f acc t] Accumulates the result [acc] by applying [f acc x] for each element [x] in [t]. Runs in O(n*ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space required by [f]. *) val rev_map : ('a -> 'b) -> 'a t -> 'b t (** [rev_map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in reverse order of [t]. Runs in O(n*ft) time where n is the number of elements in [t] and ft is the running time of [f]. It uses O(fs) stack space where fs is the stack space required by [f]. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in the same order as [t]. Runs in O(n*ft) time where n is the number of elements in [t] and ft is the running time of [f]. It uses O(fs) stack space where fs is the stack space required by [f]. This function is just as efficient as {!CatenableList.rev_map} (yielding a different ordering) and more efficient than [CatenableList.rev (CatenableList.rev_map t)]. *) val to_string : ('a -> string) -> 'a t -> string (** [to_string to_s t] Convert the list [t] into a string using [to_s] to individually convert each element into a string. Runs in O(n*st) where st is the running time of [to_s] and uses O(ss) stack space where ss is the amount of stack required by [to_s]. *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to compare individual elements. Returns 0 if [t1] and [t2] are equal (under f). Returns [<0] if [t1] is less than [t2] and returns [>0] otherwise. *) val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t (** [gen f ?size rs] Generates a random list whose length is bounded by [size]. Each element in the list is computed by calling [f ?size rs]. Runs in time O([size] * ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space of [f]. *) ocaml-reins-0.1a/src/list/listCommon.ml0000644000175000017500000000170410676520540017223 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) let to_string iter pop to_s t = try let buf = Buffer.create 32 in let hd,tl = pop t in Buffer.add_char buf '['; Buffer.add_string buf (to_s hd); iter (fun e -> Buffer.add_string buf "; "; Buffer.add_string buf (to_s e) ) tl; Buffer.add_char buf ']'; Buffer.contents buf with Failure "pop" -> "[]" ocaml-reins-0.1a/src/list/OMakefile0000644000175000017500000000032510676104001016310 0ustar furrmfurrm OCAMLINCLUDES += ../base/ #OCAMLFLAGS = -for-pack Reins.Lists FILES[] += list/sList list/doubleList list/catenableList list/doubleQueue list/skewBinaryList list/lists list/listCursor list/listCommon ocaml-reins-0.1a/src/list/doubleQueue.mli0000644000175000017500000001555310676520540017536 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Double ended queues *) type 'a t (** The type of double ended queues. Access to both the front and the back of the queue take amortized O(1) time. *) val empty : 'a t (** The empty queue *) val is_empty : 'a t -> bool (** Returns true is the queue is empty *) val hd : 'a t -> 'a (** [hd q] Return the element at the front of the queue. If the queue is empty, it raises [Failure "hd"] *) val tl : 'a t -> 'a t (** [tl t] Return the queue [t] with the element at the front of the queue removed. Runs in O(1) time and stack space. If the queue is empty, it raises [Failure "tl"]. *) val pop : 'a t -> 'a * 'a t (** [pop t] Equivalent to [(hd t), (tl t)] but is more efficient. Runs in O(1) time and stack space. If the queue is empty, it raises [Failure "pop"]. *) val cons : 'a -> 'a t -> 'a t (** [cons x t] Adds [x] to the front of queue [t] so that a subsequent call to [hd] returns [x]. Runs in O(1) time and stack space. *) val hd_back : 'a t -> 'a (** [hd_back q] Return the element at the back of the queue. If the queue is empty, it raises [Failure "hd_back"]. Runs in amortized O(1) time and O(1) stack space. *) val tl_back : 'a t -> 'a t (** [tl t] Return the queue [t] with the element at the back of the queue removed. Runs in amortized O(1) time and O(1) stack space. If the queue is empty, it raises [Failure "tl_back"]. *) val pop_back : 'a t -> 'a t * 'a (** [pop_back t] Equivalent to [(hd_back t), (tl_back t)] but is more efficient. Runs in amortized O(1) time and O(1) stack space. If the queue is empty, it raises [Failure "pop_back"]. *) val cons_back : 'a -> 'a t -> 'a t (** [cons_back x t] Adds [x] to the back of queue [t] so that a subsequent call to [hd_back] returns [x]. Runs in O(1) time and stack space. *) val snoc : 'a -> 'a t -> 'a t (** [snoc x t] is an alias for {!DoubleQueue.cons_back} [x t], adding [x] to the back of [t]. *) val last : 'a t -> 'a (** [last q] is an alias for [hd_back q] *) val enqueue : 'a -> 'a t -> 'a t (** [enqueue x t] is an alias for {!DoubleQueue.cons_back} [x t], adding [x] to the back of [t]. *) val dequeue : 'a t -> 'a * 'a t (** [dequeue x t] is an alias for {!DoubleQueue.hd} [x t], removing the first element from the front of [t]. *) val length : 'a t -> int (** [length t] Returns the number of elements in the queue [t] *) val rev : 'a t -> 'a t (** [rev t] Reverses the order of the queue [t]. e.g., [hd t == hd_back (rev t)] *) val append : 'a t -> 'a t -> 'a t (** [append t1 t2] Appends all of the elements in queue [t2] onto the back of [t1]. That is, in the resulting queue, {!DoubleQueue.hd} returns the first element of [t1] and {!DoubleQueue.hd_back} returns the last element of [t2]. Runs in O(n+m) time where n and m are the number of elements in [t1] and [t2] respectively. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f t] Iterates over each element in the queue [t] in order and applies [f] to that element. Runs in O(n*ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space required by [f]. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold f acc t] Accumulates the result [acc] by applying [f acc x] for each element [x] in [t]. Runs in O(n*ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space required by [f]. *) val rev_map : ('a -> 'b) -> 'a t -> 'b t (** [rev_map f t] Creates a new queue by applying [f] to each element of [t]. The resulting queue is in reverse order of [t]. Runs in O(n*ft) time where n is the number of elements in [t] and ft is the running time of [f]. It uses O(fs) stack space where fs is the stack space required by [f]. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f t] Creates a new queue by applying [f] to each element of [t]. The resulting queue is in the same order as [t]. Runs in O(n*ft) time where n is the number of elements in [t] and ft is the running time of [f]. It uses O(fs) stack space where fs is the stack space required by [f]. This function is just as efficient as {!DoubleQueue.rev_map} (yielding a different ordering) and more efficient than [DoubleQueue.rev (DoubleQueue.rev_map t)]. *) val to_list : 'a t -> 'a list (** [to_list t] Convert the DoubleQueue [t] into a standard list. Runs in O(n) time and O(1) stack space where n is the number of elements in [t]. The resulting list has the same ordering as [t]. That is, [DoubleQueue.hd t == List.hd (DoubleQueue.to_list t)]. *) val from_list : 'a list -> 'a t (** [from_list l] Convert the standard list l into a DoubleQueue.t. Runs in O(n) time and O(1) stack space where n is the number of elements in [l]. The resulting queue has the same order as the original list. That is [List.hd l == DoubleQueue.hd (DoubleQueue.from_list l)]. *) val flatten : 'a t t -> 'a t (** [flatten l] Appends all of the elements of [l] into a new queue. The current implementation is not very efficient and runs in greater than O(n) time uses a O(n) stack space. *) val to_string : ('a -> string) -> 'a t -> string (** [to_string to_s t] Convert the queue [t] into a string using [to_s] to individually convert each element into a string. Runs in O(n*st) where st is the running time of [to_s] and uses O(ss) stack space where ss is the amount of stack required by [to_s]. *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int (** [compare f t1 t2] Compares the queues [t1] and [t2] using [f] to compare individual elements. Returns 0 if [t1] and [t2] are equal (under f). Returns [<0] if [t1] is less than [t2] and returns [>0] otherwise. *) val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t (** [gen f ?size rs] Generates a random queue whose length is bounded by [size]. Each element in the queue is computed by calling [f ?size rs]. Runs in time O([size] * ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space of [f]. *) ocaml-reins-0.1a/src/list/sList.ml0000644000175000017500000000276710676520540016207 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) include List type 'a t = 'a list let empty = [] let is_empty = function [] -> true | _ -> false let pop = function | [] -> failwith "pop" | hd::tl -> hd,tl let fold = fold_left let cons x t = x::t let snoc x t = rev (x::(rev t)) let rec last = function | [] -> failwith "last" | x::[] -> x | _::xs -> last xs let to_list x = x let from_list x = x let rec compare cmp x y = match x,y with | [],[] -> 0 | _::_, [] -> 1 | [], _::_ -> -1 | hx::xs, hy::ys -> match cmp hx hy with | 0 -> compare cmp xs ys | c -> c let rec gen (f : ?size:int -> Random.State.t -> 'a) ?(size=100) (r : Random.State.t) : 'a list = let size = abs size in if (Random.State.int r size) = 0 then [] else (f r) :: (gen ~size:(size-1) f r) let to_string to_s t = ListCommon.to_string iter pop to_s t let fold = fold_left (*let equal x y = (compare Pervasives.compare x y) = 0*) ocaml-reins-0.1a/src/list/lists.ml0000644000175000017500000000263710676520540016243 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type ListSig = sig type 'a t val empty : 'a t val is_empty : 'a t -> bool val length : 'a t -> int val rev : 'a t -> 'a t val cons : 'a -> 'a t -> 'a t val snoc : 'a -> 'a t -> 'a t val hd : 'a t -> 'a val tl : 'a t -> 'a t val pop : 'a t -> 'a * 'a t val last : 'a t -> 'a val append : 'a t -> 'a t -> 'a t val flatten : 'a t t -> 'a t val from_list : 'a list -> 'a t val to_list : 'a t -> 'a list val iter : ('a -> unit) -> 'a t -> unit val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val rev_map : ('a -> 'b) -> 'a t -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t val to_string : ('a -> string) -> 'a t -> string val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t end ocaml-reins-0.1a/src/list/doubleList.ml0000644000175000017500000000777610676520540017224 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module Make(L : Lists.ListSig) = struct type 'a dlist = 'a L.t * 'a L.t type 'a t = 'a dlist let empty = L.empty, L.empty let at_front (p,_) = L.is_empty p let at_back (_,n) = L.is_empty n let is_empty l = at_front l && at_back l let next_length (_,n) = L.length n let prev_length (p,_) = L.length p let length (p,n) = (L.length p) + (L.length n) let rev (p,n) = (n,p) (* [splice l1 l2] prev_l2 :: prev_l1 :: next_l1 :: next_l2 *) let splice (sp,sn) (p,n) = (L.append sp p), (L.append sn n) let rec next (p,n) = if L.is_empty n then failwith "next" else let x,n' = L.pop n in (L.cons x p),n' let rec prev (p,n) = if L.is_empty p then failwith "prev" else let x,p' = L.pop p in p',(L.cons x n) let cons x (p,n) = p, (L.cons x n) let prev_cons x (p,n) =(L.cons x p), n let hd (_,n) = try fst (L.pop n) with Failure "pop" -> failwith "hd" let value (_,n) = if L.is_empty n then None else Some (L.hd n) let prev_hd (p,_) = try fst (L.pop p) with Failure "pop" -> failwith "prev_hd" let tl (p,n) = try let tl = snd (L.pop n) in (p,tl) with Failure "pop" -> failwith "tl" let prev_tl (p,n) = try let tl = snd (L.pop p) in (tl,n) with Failure "pop" -> failwith "prev_tl" let pop (p,n) = let h,tl = L.pop n in h, (p,tl) let prev_pop (p,n) = try let h,tl = L.pop p in h, (tl,n) with Failure "pop" -> failwith "prev_pop" let rec goto_front l = if at_front l then l else goto_front (prev l) let rec goto_back l = if at_back l then l else goto_back (next l) (* stay at same position in l1 and tack l2 onto the end *) let append l1 l2 = splice l1 (goto_front l2) let snoc x (p,n) = p, (L.snoc x n) let last (p,n) = (L.last n) let prev_snoc x (p,n) =(L.snoc x p), n let rec fold1 f acc l = if L.is_empty l then acc else let x,tl = L.pop l in fold1 f (f acc x) tl let fold f acc (p,n) = fold1 f (fold1 f acc n) p let iter f l = fold (fun () -> f) () l let map f (p,n) = let n' = L.map f n in let p' = L.map f p in (p',n') (* If we applied rev_map to the front and back list, we would still have to reverse them again. So we might as well just use this simple version (since our rev is O(1)) in the hopes that L provides an efficient 'map' (and no worse the L.rev L.rev_map)*) let rev_map f l = rev (map f l) let flatten ll = let dl = fold (fun acc l -> splice l (goto_back acc)) empty (goto_front ll) in goto_back dl let from_list l = L.empty, (L.from_list l) let to_list dl = let dl' = goto_back dl in fold (fun acc x -> x::acc) [] dl' let rec to_string to_s t = ListCommon.to_string iter pop to_s (goto_front t) let rec compare c x y = let x = goto_front x in let y = goto_front y in match at_back x, at_back y with | true,true -> 0 | false,true -> 1 | true,false -> -1 | false,false -> let hx,tx = pop x in let hy,ty = pop y in match c hx hy with | 0 -> compare c tx ty | v -> v let gen agen ?(size=50) rs = (L.gen agen ~size:(size/2) rs), (L.gen agen ~size:(size/2) rs) type 'a list_ = 'a t type 'a cursor = 'a dlist let to_cursor x = x let from_cursor x = x let current = hd let move_prev = prev let move_next = next let list x = x let replace_list (p1,n1) (p2,_) = let n2 = L.append p1 n1 in (p2,n2) end ocaml-reins-0.1a/src/list/sList.mli0000644000175000017500000001163710676520540016354 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) type 'a t = 'a list val empty : 'a list (** The empty list. aka [] *) val is_empty : 'a list -> bool (** Returns true if the list is empty *) val cons : 'a -> 'a list -> 'a list (** [cons x t] Adds [x] onto the front of the list [t]. Runs in O(1) time and stack space. *) val pop : 'a list -> 'a * 'a list (** [pop t] equivalent to [(hd t), (tl t)] but is more efficient. Runs in amortized O(1) time and stack space. If the list is empty, it raises [Failure "pop"]. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a (** [fold f acc l] Equivalent to [fold_left f acc l] *) val snoc : 'a -> 'a list -> 'a list (** [snoc x t] Adds the element [x] to the back of the list [t]. Runs in O(n) time and O(1) stack space where n is the length of the list. *) val last : 'a t -> 'a (** [last t] Returns the element at the back of the list. If the list is empty, it raises [Failure "last"]. Runs in O(1) stack and O(n) time. *) val to_list : 'a -> 'a (** [to_list t] Included for compatibility with the common ListSig signature. This function does not perform any computation. *) val from_list : 'a -> 'a (** [from_list t] Included for compatibility with the common ListSig signature. This function does not perform any computation. *) val to_string : ('a -> string) -> 'a list -> string (** [to_string to_s t] Convert the list [t] into a string using [to_s] to individually convert each element into a string. Runs in O(n*st) where st is the running time of [to_s] and uses O(ss) stack space where ss is the amount of stack required by [to_s]. *) val compare : ('a -> 'b -> int) -> 'a list -> 'b list -> int (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to compare individual elements. Returns 0 if [t1] and [t2] are equal (under f). Returns [<0] if [t1] is less than [t2] and returns [>0] otherwise. *) val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a list (** [gen f ?size rs] Generates a random list whose length is bounded by [size]. Each element in the list is computed by calling [f ?size rs]. Runs in time O([size] * ft) where ft is the running time of [f] and uses O(fs) stack space where fs is the stack space of [f]. *) (** The following are all implemented in the standard library *) val length : 'a list -> int val hd : 'a list -> 'a val tl : 'a list -> 'a list val nth : 'a list -> int -> 'a val rev : 'a list -> 'a list val append : 'a list -> 'a list -> 'a list val rev_append : 'a list -> 'a list -> 'a list val concat : 'a list list -> 'a list val flatten : 'a list list -> 'a list val iter : ('a -> unit) -> 'a list -> unit val map : ('a -> 'b) -> 'a list -> 'b list val rev_map : ('a -> 'b) -> 'a list -> 'b list val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c val for_all : ('a -> bool) -> 'a list -> bool val exists : ('a -> bool) -> 'a list -> bool val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val mem : 'a -> 'a list -> bool val memq : 'a -> 'a list -> bool val find : ('a -> bool) -> 'a list -> 'a val filter : ('a -> bool) -> 'a list -> 'a list val find_all : ('a -> bool) -> 'a list -> 'a list val partition : ('a -> bool) -> 'a list -> 'a list * 'a list val assoc : 'a -> ('a * 'b) list -> 'b val assq : 'a -> ('a * 'b) list -> 'b val mem_assoc : 'a -> ('a * 'b) list -> bool val mem_assq : 'a -> ('a * 'b) list -> bool val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list val split : ('a * 'b) list -> 'a list * 'b list val combine : 'a list -> 'b list -> ('a * 'b) list val sort : ('a -> 'a -> int) -> 'a list -> 'a list val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list ocaml-reins-0.1a/src/list/lists.mli0000644000175000017500000000726310676520540016414 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** The signature that all lists must minimally conform to. *) module type ListSig = sig type 'a t (** The type of the list *) val empty : 'a t (** The empty list *) val is_empty : 'a t -> bool (** Returns true if the list is empty *) val length : 'a t -> int (** Returns the length of the list *) val rev : 'a t -> 'a t (** Reverse the list *) val cons : 'a -> 'a t -> 'a t (** [cons x t] Add the element [x] to the front of list [t] *) val snoc : 'a -> 'a t -> 'a t (** [snoc x t] Add the element [x] to the end of list [t] *) val hd : 'a t -> 'a (** [hd t] Return the first element at the front of the list. All lists in the Reins library raise [Failure "hd"] when applied to an empty list. *) val tl : 'a t -> 'a t (** [tl t] Return the list with the first element removed. All lists in the Reins library raise [Failure "tl"] when applied to an empty list. *) val pop : 'a t -> 'a * 'a t (** Returns both the first element of the list and the remaining tail of the list. All lists in the Reins library raise [Failure "pop"] when applied to an empty list. *) val last : 'a t -> 'a (** [last t] Returns the element at the back of the list. All lists in the Reins library raise [Failure "last"] when applied to an empty list. *) val append : 'a t -> 'a t -> 'a t (** [append t1 t2] Append the list [t2] onto the end of list [t1]. *) val flatten : 'a t t -> 'a t (** Flatten a list of lists into a single list *) val from_list : 'a list -> 'a t (** Create a list from a builtin list type *) val to_list : 'a t -> 'a list (** Convert the list into a builtin list type *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f t] Apply [f] to each element in list [t]. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [fold f acc t] Accumulates the result [acc] by applying [f acc x] for each element [x] in [t]. *) val rev_map : ('a -> 'b) -> 'a t -> 'b t (** [rev_map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in reverse order of [t]. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f t] Creates a new list by applying [f] to each element of [t]. The resulting list is in the same order as [t]. *) val to_string : ('a -> string) -> 'a t -> string (** [to_string to_s t] Convert the list [t] into a string using [to_s] to individually convert each element into a string. All lists in the Reins library format the list following OCaml syntax. e.g., "[x1; x2; x3]" *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int (** [compare f t1 t2] Compares the lists [t1] and [t2] using [f] to compare individual elements. Returns 0 if [t1] and [t2] are equal (under f). Returns [<0] if [t1] is less than [t2] and returns [>0] otherwise. *) val gen : (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t (** [gen f ?size rs] Generates a random list whose length is bounded by [size]. Each element in the list is computed by calling [f ?size rs]. *) end ocaml-reins-0.1a/src/set/0002755000175000017500000000000010676540775014401 5ustar furrmfurrmocaml-reins-0.1a/src/set/patriciaSet.ml0000644000175000017500000001664710676520540017203 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module MonoSet = struct type elt = int type t = | Empty | Leaf of int | Branch of int * int * t * t (* (prefix * branchbit * l * r) *) type 'a elt_ = elt type 'a set = t type 'a result = 'a type ('a,'b) result_ = 'a let of_result x = x let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton x = Leaf x let zero_bit k m = (k land m) = 0 let mask k m = (k lor (m-1)) land (lnot m) let match_prefix k p m = (mask k m) = p let lowest_bit x = x land (-x) let highest_bit x m = let x' = x land (lnot (m-1)) in let rec highb x = let m = lowest_bit x in if x = m then m else highb (x-m) in highb x' let branching_bit p0 m0 p1 m1 = highest_bit (p0 lxor p1) (max 1 (2*(max m0 m1))) let rec mem x = function | Empty -> false | Leaf k -> x = k | Branch(p,m,t0,t1) -> if not (match_prefix x p m) then false else if zero_bit x m then mem x t0 else mem x t1 let branch p m t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | _ -> Branch(p,m,t1,t2) let get_branch_bit = function | Empty | Leaf _ -> 0 | Branch(_,b,_,_) -> b let join p0 t0 p1 t1 = let m = branching_bit p0 (get_branch_bit t0) p1 (get_branch_bit t1) in if zero_bit p0 m then Branch(mask p0 m, m, t0, t1) else Branch(mask p0 m, m, t1, t0) let add x t = let rec ins = function | Empty -> Leaf x | (Leaf y) as t -> if x = y then t else join x (Leaf x) y t | Branch(p,m,t0,t1) as t -> if match_prefix x p m then if zero_bit x m then Branch(p,m,ins t0, t1) else Branch(p,m,t0,ins t1) else join x (Leaf x) p t in ins t let rec merge s t = match s,t with | Empty,t | t,Empty -> t | Leaf(x), t | t, Leaf x -> add x t | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> if m = n && match_prefix q p m then (* same prefix, just recurse *) Branch(p,m,merge s0 t0, merge s1 t1) else if m > n && match_prefix q p m then (* q contains p*) if zero_bit q m then Branch(p,m,merge s0 t,s1) else Branch(p,m,s0,merge s1 t) else if m < n && match_prefix p q n then (* p contains q*) if zero_bit p n then Branch(q,n,merge s t0,t1) else Branch(q,n,t0,merge s t1) else (* different prefixes *) join p s q t let rec remove x t = match t with | Empty -> Empty | Leaf y -> if x = y then Empty else t | Branch (p,m,t0,t1) -> if match_prefix x p m then if zero_bit x m then branch p m (remove x t0) t1 else branch p m t0 (remove x t1) else t let rec min_elt = function | Empty -> raise Not_found | Leaf x -> x | Branch(_,_,t0,_) -> min_elt t0 let rec max_elt = function | Empty -> raise Not_found | Leaf x -> x | Branch(_,_,_,t1) -> max_elt t1 let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Branch (_,_,t0,t1) -> (cardinal t0) + (cardinal t1) let rec choose = function | Empty -> raise Not_found | Leaf k -> k | Branch (_, _,t0,_) -> choose t0 let rec iter f = function | Empty -> () | Leaf x -> f x | Branch(_,_,t0,t1) -> iter f t0; iter f t1 let rec fold f acc t = match t with | Empty -> acc | Leaf x -> f acc x | Branch (_,_,t0,t1) -> fold f (fold f acc t0) t1 let rec no_empty_under_branch = function | Empty -> true | Leaf _ -> true | Branch(_,_,Empty,_) | Branch(_,_,_,Empty) -> false | Branch(_,_,t0,t1) -> (no_empty_under_branch t0) && (no_empty_under_branch t1) let well_formed t = no_empty_under_branch t let to_string t = let rec h = function | Empty -> "" | Leaf x -> string_of_int x | Branch(_,_,Empty,Empty) -> "" | Branch(_,_,subt,Empty) | Branch(_,_,Empty,subt) -> h subt | Branch(_,_,t0,t1) -> Printf.sprintf "%s, %s" (h t0) (h t1) in "{" ^ (h t) ^ "}" let rec compare s t = match s,t with | Empty, Empty -> 0 | Empty, _ -> -1 | _, Empty -> 1 | Leaf x, Leaf y -> Pervasives.compare x y | Leaf _, Branch _ -> -1 | Branch _, Leaf _ -> 1 | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> if p < q then -1 else if p > q then 1 else if m < n then -1 else if m > n then 1 else match compare s0 t0 with | 0 -> compare s1 t1 | c -> c let equal s t = compare s t = 0 let union = merge let rec diff s t = match s,t with | Empty,t -> Empty | s,Empty -> s | Leaf(x), t -> if mem x t then Empty else s | s, Leaf x -> remove x s | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> if m = n && match_prefix q p m (* same prefix, just recurse *) then merge (diff s0 t0) (diff s1 t1) else if m > n && match_prefix q p m then (* q contains p*) if zero_bit q m then merge (diff s0 t) s1 else merge s0 (diff s1 t) else if m < n && match_prefix p q n then (* p contains q*) if zero_bit p n then diff s t0 else diff s t1 else (* different prefixes *) s let rec inter s t = match s,t with | Empty,_ -> Empty | _,Empty -> Empty | (Leaf x as lf), t -> if mem x t then lf else Empty | t, (Leaf x as lf) -> if mem x t then lf else Empty | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> if m = n && match_prefix q p m (* same prefix, just recurse *) then merge (inter s0 t0) (inter s1 t1) else if m > n && match_prefix q p m then (* q contains p *) if zero_bit q m then inter s0 t else inter s1 t else if m < n && match_prefix p q n then (* p contains q *) if zero_bit p n then inter s t0 else inter s t1 else (* different prefixes *) Empty let gen1 (agen : (?size:int -> Random.State.t -> int)) ?(size=50) rs = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else loop (n-1) (add (agen ~size:size rs) t) in loop num empty let gen ?size rs = gen1 Types.Int.gen ?size rs type path = | Top | PathL of path * t | PathR of t * path type cursor = path * t type 'a cursor_ = cursor let to_cursor t = Top,t let at_top = function | Top,_ -> true | _ -> false let at_right = function | _, Empty | _,Leaf _ -> true | _ -> false let at_left = at_right let went_left = function PathL _,_ -> true | _ -> false let went_right = function PathR _,_ -> true | _ -> false let move_up = function | Top, _ -> failwith "move_up" | PathL(p,r),l | PathR(l,p),r -> p, (merge l r) let move_down_right (p,t) = match t with | Empty | Leaf _ -> failwith "move_down_right" | Branch(_,_,_,r) -> PathR(t,p),r let move_down_left (p,t) = match t with | Empty | Leaf _ -> failwith "move_down_left" | Branch(_,_,l,_) -> PathL(p,t),l let has_value = function _,Leaf _ -> true | _ -> false let get_value = function | _,Leaf v -> v | _,_ -> failwith "get_value" let rec from_cursor curs = if at_top curs then snd curs else from_cursor (move_up curs) end module GenSet = MonoSet ocaml-reins-0.1a/src/set/rBSet.mli0000644000175000017500000000370310676520540016110 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Balanaced binary search tree with small memory footprint Redblack trees are balanced binary search trees that provide O(log n) [mem], [add], and [remove] tree operations and O(n) [union], [inter], and [diff] set operations. They can also be more memory efficient than AVL trees since they only need to store 1 bit of information to maintain their internal invariants. In the current implementation, this bit is encoded in the type constructor, meaning that each internal node of the tree uses one less word of memory than AVL trees. *) (** This module provides an implementation of RedBlack trees with a polymorphic element type. The implementation uses the standard library's polymorphic [compare] function internally and may not be as efficient as the {!RBSet.MonoSet} module which allows the use of a more efficient comparison function. *) module PolySet : Sets.PolySetSigStd (** This functor provides an implementation of RedBlack trees that are parameterized by a specific monomorphic element type. *) module MonoSet : Sets.MonoSetSigFnStd (** This functor is similar to the {!RBSet.MonoSet} functor except it is parameterized by a module that also supports the [gen] operation. Therefore, the resulting module is also able to generate number sets. *) module GenSet : Sets.GenSetSigFnStd ocaml-reins-0.1a/src/set/splaySet.mli0000644000175000017500000000476710676520540016710 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Sets with excellent non-uniform access performance Splay trees are binary search trees that are balanced based on recently accessed elements. They provide amortized O(log n) performance for tree operations ([mem], [add], [remove]), and O(n) amortized time for set operations. Splay trees do not maintain any invariant information and are therefore very memory efficient. To achieve their amortized bounds, splay trees re-balance themselves on every tree access (e.g., [mem]). Re-balancing always leaves the most recently accessed element at the root of the tree. Therefore repeated access to recent elements can be very efficient. However, this also means that tree operations may take O(n) for degenerate cases. *) (** This module provides an implementation of Splay trees with a polymorphic element type. The implementation uses the standard library's polymorphic [compare] function internally and may not be as efficient as the {!SplaySet.MonoSet} module which allows the use of a more efficient comparison function. *) module rec PolySet : Sets.PolySetSig with type ('a,'b) result = 'a * 'b PolySet.t (** This functor provides an implementation of Splay trees that are parameterized by a specific monomorphic element type. The resulting module may be more efficient than its polymorphic counterpart, {!SplaySet.PolySet}. *) module rec MonoSet : functor(C: Types.Mono.Comparable) -> Sets.MonoSetSig with type elt = C.t and type 'a result = 'a * MonoSet(C).t (** This functor is similar to the {!SplaySet.MonoSet} functor except it is parameterized by a module that also supports the [gen] operation. Therefore, the resulting module is also able to generate number sets. *) module rec GenSet : functor(C: Types.Mono.ArbitraryComparable) -> Sets.GenSetSig with type elt = C.t and type 'a result = 'a * GenSet(C).t ocaml-reins-0.1a/src/set/aVLSet.ml0000644000175000017500000003463210676520540016063 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types (** The main functor for implementing sets. The paramater field HeightDiff.v specifies the maximum difference between the heights of two subtrees joined at a node. *) module BaseSet (HeightDiff : sig val v : int end) = struct (** The types of AVL trees. An element can be either stored in a Leaf if it has no children, or in a Node if it has at least 1 child. The constructor Node(l,v,r,h) also contains the left branch 'l' (all elements are smaller than v), the right branch 'r' (all elements greater than v) and the heigh of the tree at that point. *) type 'a tree = | Empty | Leaf of 'a | Node of 'a tree * 'a * 'a tree * int let of_result x = x let empty = Empty let singleton x = Leaf x let is_empty = function | Empty -> true | _ -> false let rec mem cmp x = function | Empty -> false | Leaf y -> (cmp x y) = 0 | Node(l,y,r,_) -> match cmp x y with | 0 -> true | c when c < 0 -> mem cmp x l | _ -> mem cmp x r let rec fold f acc t = match t with | Empty -> acc | Leaf x -> f acc x | Node(l,v,r,_) -> fold f (f (fold f acc l) v) r let rec iter f t = match t with | Empty -> () | Leaf x -> f x | Node(l,v,r,_) -> iter f l; f v; iter f r let rec min_elt = function | Empty -> raise Not_found | Leaf x -> x | Node(Empty,v,_,_) -> v | Node(l,_,_,_) -> min_elt l let rec max_elt = function | Empty -> raise Not_found | Leaf x -> x | Node(_,v,Empty,_) -> v | Node(_,_,r,_) -> max_elt r let height = function | Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,h) -> h (** N-"smart" constructor (a la Stephen Adams). This function chooses the right constructor based on the number of children and ensures that the Node constructor is well formed. *) let node l v r = match height l, height r with | 0,0 -> Leaf v | hl,hr -> Node(l,v,r, (max hl hr)+1) let pivot ll lv c rv rr = match c with | Node(cl,cv,cr,_) -> node (node ll lv cl) cv (node cr rv rr) | Leaf cv -> node (node ll lv Empty) cv (node Empty rv rr) | Empty -> assert false (** This function will fix the tree if the left subtree has a height at most HeightDiff.v +1 more than that of the right subtree. *) let rebal_left ll lv lr v r = if height ll >= height lr then node ll lv (node lr v r) else pivot ll lv lr v r (** This function will fix the tree if the right subtree has a height at most HeightDiff.v +1 more than that of the left subtree. *) let rebal_right l v rl rv rr = if height rr >= height rl then node (node l v rl) rv rr else pivot l v rl rv rr (** T'-"smart" constructor: fixes trees by performing at most 1 rotation. *) let rotate l v r = match l,r with (* Height 1 tree *) | Empty, Empty -> Leaf v (* Height 2 tree *) | Empty, Leaf _ | Leaf _, Empty | Leaf _, Leaf _ -> Node(l,v,r,2) (* General Height 'h' *) | Node(ll,lv,lr,h), Empty -> if h > HeightDiff.v then rebal_left ll lv lr v r else Node(l,v,r,h+1) | Empty, Node(rl,rv,rr,h) -> if h > HeightDiff.v then rebal_right l v rl rv rr else Node(l,v,r,h+1) | Leaf _, Node(_,_,_,h) (* 1 + for Leaf _ *) | Node(_,_,_,h), Leaf _ when h <= (1 + HeightDiff.v) -> Node(l,v,r,h+1) | Leaf _, Node(rl,rv,rr,h) -> rebal_right l v rl rv rr | Node(ll,lv,lr,h), Leaf _ -> rebal_left ll lv lr v r | Node(ll,lv,lr,lh), Node(rl,rv,rr,rh) -> if lh > rh + HeightDiff.v then rebal_left ll lv lr v r else if rh > lh + HeightDiff.v then rebal_right l v rl rv rr else node l v r let rec add cmp newe t = match t with | Empty -> Leaf newe | Leaf elt -> begin match cmp newe elt with | 0 -> t | c when c < 0 -> Node(Empty,newe,t,2) | _ -> Node(t, newe, Empty,2) end | Node(l,elt,r,_) -> match cmp newe elt with | 0 -> t | c when c < 0 -> rotate (add cmp newe l) elt r | _ -> rotate l elt (add cmp newe r) let rec get_and_remove_min = function | Empty -> raise (Invalid_argument "get_and_remove_min") | Leaf elt -> elt, Empty | Node(Empty,elt,r,h) -> elt, r | Node(l,elt,r,h) -> let d,newl = get_and_remove_min l in d, rotate newl elt r let rec get_and_remove_max = function | Empty -> raise (Invalid_argument "get_and_remove_max") | Leaf elt -> elt, Empty | Node(l,elt,Empty,h) -> elt, l | Node(l,elt,r,h) -> let d,newr = get_and_remove_max r in d, rotate l elt newr let rec remove cmp dele t = match t with | Empty -> Empty | Leaf elt | Node(Empty,elt,Empty,_) -> if (cmp dele elt) = 0 then Empty else Leaf elt | Node(l,elt,r,_) -> match cmp dele elt with | 0 -> if r = Empty then l else if l = Empty then r else let d,newr = get_and_remove_min r in rotate l d newr | c when c < 0 -> rotate (remove cmp dele l) elt r | _ -> rotate l elt (remove cmp dele r) (** join trees of arbitrary size *) let rec concat3 cmp l v r = match l,r with | Empty, r -> add cmp v r | l, Empty -> add cmp v l | Leaf x, Leaf y -> node l v r | Leaf x, Node(l2,v2,r2,h) -> if h > (1 + HeightDiff.v) then rotate (concat3 cmp l v l2) v2 r2 else node l v r | Node(l1,v1,r1,h), Leaf x -> if h > (1 + HeightDiff.v) then rotate l1 v1 (concat3 cmp r1 v r) else node l v r | Node(l1,v1,r1,h1),Node(l2,v2,r2,h2) -> if h2 > h1 + HeightDiff.v then rotate (concat3 cmp l v l2) v2 r2 else if h1 > h2 + HeightDiff.v then rotate l1 v1 (concat3 cmp r1 v r) else node l v r (* equivalent to (split_lt v t), (split_gt v t) *) let rec split cmp v t = match t with | Empty -> Empty, Empty | Leaf elt -> begin match cmp v elt with | 0 -> Empty,Empty | c when c < 0 -> Empty,t | _ -> t,Empty end | Node(l1,elt,r1,_) -> match cmp v elt with | 0 -> l1,r1 | c when c < 0 -> let l2,r2 = split cmp v l1 in (l2,concat3 cmp r2 elt r1) | _ -> let l2,r2 = split cmp v r1 in (concat3 cmp l1 elt l2), r2 let rec union cmp t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | Leaf x,r -> add cmp x r | l,Leaf x -> add cmp x l | t1, Node(l,v,r,_) -> let l',r' = split cmp v t1 in concat3 cmp (union cmp l' l) v (union cmp r' r) let rec concat t1 t2 = match t1,t2 with | Empty, _ -> t2 | _, Empty -> t1 | Leaf x, Leaf y -> Node(t1,y,Empty,2) | Leaf x, Node(l2,v2,r2,h) -> if h > 1+HeightDiff.v then rotate (concat t1 l2) v2 r2 else let m,t2' = get_and_remove_min t2 in rotate t1 m t2' | Node(l1,v1,r1,h), Leaf x -> if h > 1+HeightDiff.v then rotate l1 v1 (concat r1 t2) else rotate t1 x Empty (* inline get_*_min for Leaf *) | Node(l1,v1,r1,h1), Node(l2,v2,r2,h2) -> if h2 > h1 + HeightDiff.v then rotate (concat t1 l2) v2 r2 else if h1 > h2 + HeightDiff.v then rotate l1 v1 (concat r1 t2) else let m,t2' = get_and_remove_min t2 in rotate t1 m t2' let rec diff cmp t1 t2 = match t1,t2 with | Empty, _ -> Empty | _, Empty -> t1 | _, Leaf y -> remove cmp y t1 | _, Node(l,v,r,_) -> let l',r' = split cmp v t1 in concat (diff cmp l' l) (diff cmp r' r) let rec inter cmp t1 t2 = match t1,t2 with | Empty,_ | _,Empty -> Empty | t1, Leaf x -> if mem cmp x t1 then t2 else Empty | t1, Node(l,v,r,_) -> let l',r' = split cmp v t1 in if mem cmp v t1 then concat3 cmp (inter cmp l' l) v (inter cmp r' r) else concat (inter cmp l' l) (inter cmp r' r) let choose = function | Empty -> raise Not_found | Leaf x -> x | Node(_,x,_,_) -> x let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Node(l,_,r,_) -> 1 + (cardinal l) + (cardinal r) let rec cmp c x y = match (is_empty x), (is_empty y) with | true, true -> 0 | true, false -> -1 | false, true -> 1 | false, false -> let xm = min_elt x in let ym = min_elt y in match c xm ym with | 0 -> cmp c (remove c xm x) (remove c ym y) | v -> v let rec well_ordered cmp = function | Empty -> true | Leaf _ -> true | Node(Empty,_,Empty,_) -> true | Node(((Leaf x)|Node(_,x,_,_) as l),elt,Empty,_) -> (well_ordered cmp l) && (cmp x elt < 0) | Node(Empty,elt,((Leaf x)|Node(_,x,_,_) as r),_) -> (well_ordered cmp r) && (cmp x elt > 0) | Node(((Leaf lx)|Node(_,lx,_,_) as l) ,elt, ((Leaf rx)|Node(_,rx,_,_) as r), _) -> (well_ordered cmp l) && (well_ordered cmp r) && (cmp lx elt < 0) && (cmp rx elt > 0) let well_formed_height = function | Empty | Leaf _ -> true | Node(l,v,r,h) -> let hl = height l in let hr = height r in (h = (max hl hr) + 1) && (abs (hl - hr) <= HeightDiff.v) let rec well_formed cmp t = (well_ordered cmp t) && (well_formed_height t) type 'a path = | Top | PathL of 'a path * 'a * 'a tree | PathR of 'a tree * 'a * 'a path type 'a curs = 'a path * 'a tree let to_cursor t = Top,t let at_top (p,t) = (p = Top) let at_left (p,t) = match t with | Empty | Leaf _ -> true | _ -> false let at_right (p,t) = match t with | Empty | Leaf _ -> true | _ -> false let went_left (p,t) = match p with | PathL _ -> true | _ -> false let went_right (p,t) = match p with | PathR _ -> true | _ -> false let move_up = function | Top, _ -> failwith "move_up" | PathL(p,x,r),l | PathR(l,x,p),r -> p, (node l x r) let move_down_left = function | _,Empty | _, Leaf _ -> failwith "move_down_left" | p, Node(l,v,r,h) -> PathL(p,v,r),l let move_down_right = function | _,Empty | _, Leaf _ -> failwith "move_down_right" | p,Node(l,v,r,h) -> PathR(l,v,p),r let rec from_cursor ((p,t) as curs) = if at_top curs then t else from_cursor (move_up curs) let has_value (p,t) = match t with Empty -> false | _ -> true let get_value = function | _,Empty -> failwith "get_value" | _,Leaf x | _,Node(_,x,_,_) -> x let rec move_to_ancestor cmp x ((p,t) as curs) = match p with | Top -> curs | PathL(p', v, r) -> if cmp x v < 0 then curs else move_to_ancestor cmp x (move_up curs) | PathR(_,v,_) -> if cmp x v > 0 then curs else move_to_ancestor cmp x (move_up curs) let rec move_to cmp x curs = let (p,t) as curs = move_to_ancestor cmp x curs in match t with | Empty -> raise Not_found | Leaf v -> if (cmp x v) = 0 then curs else raise Not_found | Node(l,v,r,_) -> match cmp x v with | 0 -> curs | c when c < 0 -> move_to cmp x (move_down_left curs) | _ -> move_to cmp x (move_down_right curs) let rec to_string to_s t = let rec h = function | Empty -> "" | Leaf x -> to_s x | Node(Empty,v,Empty,_) -> to_s v | Node(l,v,Empty,_) -> Printf.sprintf "%s, %s" (h l) (to_s v) | Node(Empty,v,r,_) -> Printf.sprintf "%s, %s" (to_s v) (h r) | Node(l,v,r,_) -> Printf.sprintf "%s, %s, %s" (h l) (to_s v) (h r) in "{" ^ (h t) ^ "}" let gen_ cmp (agen: ?size:int -> Random.State.t -> 'a) ?(size=50) rs : 'a tree = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else loop (n-1) (add cmp (agen ~size:size rs) t) in loop num empty end module AVL_PolySet (HeightDiff : sig val v : int end) = struct module BH = BaseSet(HeightDiff) include BH (* include Cursor.Mixin(BH)*) type 'a t = 'a tree type 'a set = 'a t type 'a elt_ = 'a type 'a cursor = 'a curs type 'a cursor_ = 'a cursor type ('a,'b) result = 'a type ('a,'b) result_ = 'a let add x t = add Pervasives.compare x t let mem x t = mem Pervasives.compare x t let remove x t = remove Pervasives.compare x t let split v t = split Pervasives.compare v t let union t1 t2 = union Pervasives.compare t1 t2 let diff t1 t2 = diff Pervasives.compare t1 t2 let inter t1 t2 = inter Pervasives.compare t1 t2 let well_formed t = well_formed Pervasives.compare t let move_to_ancestor cmp x c = move_to_ancestor Pervasives.compare x c let compare x y = cmp Pervasives.compare x y let equal x y = compare x y = 0 let gen1 agen ?size rs = gen_ Pervasives.compare agen ?size rs (*include Merge_mixin.Make(B)*) end module PolySet1 = AVL_PolySet(struct let v = 1 end) module PolySet2 = AVL_PolySet(struct let v = 2 end) module PolySet3 = AVL_PolySet(struct let v = 3 end) module PolySet = PolySet2 module AVL_MonoSet (HeightDiff : sig val v : int end) (C : Mono.Comparable) = struct module BH = BaseSet(HeightDiff) include BH (* include Cursor.Mixin(BH)*) type elt = C.t type t = C.t tree type cursor = C.t curs type 'a elt_ = elt type 'a set = t type 'a cursor_ = cursor type 'a result = 'a type ('a,'b) result_ = 'a let add x t = add C.compare x t let mem x t = mem C.compare x t let remove x t = remove C.compare x t let split v t = split C.compare v t let union t1 t2 = union C.compare t1 t2 let diff t1 t2 = diff C.compare t1 t2 let inter t1 t2 = inter C.compare t1 t2 let well_formed t = well_formed C.compare t let move_to_ancestor cmp x c = move_to_ancestor C.compare x c let compare x y = cmp C.compare x y let equal x y = compare x y = 0 let to_string t = to_string C.to_string t (*include Merge_mixin.Make(B)*) let gen1 agen ?size rs = gen_ C.compare agen ?size rs end module MonoSet1 = AVL_MonoSet(struct let v = 1 end) module MonoSet2 = AVL_MonoSet(struct let v = 2 end) module MonoSet3 = AVL_MonoSet(struct let v = 3 end) module MonoSet = MonoSet2 module AVL_GenSet (HeightDiff : sig val v : int end) (C : Types.Mono.ArbitraryComparable) = struct include AVL_MonoSet(HeightDiff)(C) let gen ?size rs = gen1 C.gen ?size rs end module GenSet1 = AVL_GenSet(struct let v = 1 end) module GenSet2 = AVL_GenSet(struct let v = 2 end) module GenSet3 = AVL_GenSet(struct let v = 3 end) module GenSet = GenSet2 ocaml-reins-0.1a/src/set/sets.ml0000644000175000017500000000733110676520540015677 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types module type Set_ = sig type 'a elt_ type 'a set type ('a,'b) result_ val empty : 'a set val is_empty : 'a set -> bool val mem : 'a elt_ -> 'a set -> (bool,'a) result_ val add : 'a elt_ -> 'a set -> 'a set val singleton : 'a elt_ -> 'a set val remove : 'a elt_ -> 'a set -> 'a set val min_elt : 'a set -> ('a elt_, 'a) result_ val max_elt : 'a set -> ('a elt_, 'a) result_ val choose : 'a set -> ('a elt_, 'a) result_ val cardinal : 'a set -> int val compare : 'a set -> 'a set -> int val equal : 'a set -> 'a set -> bool val iter : ('a elt_ -> unit) -> 'a set -> unit val fold : ('b -> 'a elt_ -> 'b) -> 'b -> 'a set -> 'b val union : 'a set -> 'a set -> 'a set val inter : 'a set -> 'a set -> 'a set val diff : 'a set -> 'a set -> 'a set val gen1 : (?size:int -> Random.State.t -> 'a elt_) -> ?size:int -> Random.State.t -> 'a set val well_formed : 'a set -> bool val of_result : ('a,'b) result_ -> 'a type 'a cursor_ val to_cursor : 'a set -> 'a cursor_ val from_cursor : 'a cursor_ -> 'a set val at_top : 'a cursor_ -> bool val at_left : 'a cursor_ -> bool val at_right : 'a cursor_ -> bool val move_up : 'a cursor_ -> 'a cursor_ val move_down_left : 'a cursor_ -> 'a cursor_ val move_down_right : 'a cursor_ -> 'a cursor_ val went_left : 'a cursor_ -> bool val went_right : 'a cursor_ -> bool val has_value : 'a cursor_ -> bool val get_value : 'a cursor_ -> 'a elt_ (* val for_all : ('a elt_ -> bool) -> 'a set -> bool val exists : ('a elt_ -> bool) -> 'a set -> bool val elements : 'a set -> 'a elt_ list val subset : 'a set -> 'a set -> bool val filter : ('a elt_ -> bool) -> 'a set -> 'a set val partition : ('a elt_ -> bool) -> 'a set -> 'a set * 'a set val split : 'a elt_ -> 'a set -> 'a set * bool * 'a set val add_at : 'a elt_ -> cursor -> cursor val mem_at : 'a elt_ -> cursor -> bool val remove_at : 'a elt_ -> cursor -> cursor *) end module type MonoSetSig = sig type t type elt type cursor type 'a result include Set_ with type 'a elt_ = elt and type 'a set = t and type 'a cursor_ = cursor and type ('a,'b) result_ = 'a result val to_string : 'a set -> string end module type MonoSetSigFn = functor(C : Types.Mono.Comparable) -> MonoSetSig with type elt = C.t module type MonoSetSigFnStd = functor(C : Types.Mono.Comparable) -> MonoSetSig with type elt = C.t and type 'a result = 'a module type GenSetSig = sig include MonoSetSig val gen : ?size:int -> Random.State.t -> t end module type GenSetSigFn = functor(C : Types.Mono.ArbitraryComparable) -> GenSetSig with type elt = C.t module type GenSetSigFnStd = functor(C : Types.Mono.ArbitraryComparable) -> GenSetSig with type elt = C.t and type 'a result = 'a module type PolySetSig = sig type 'a t type 'a cursor type ('a,'b) result include Set_ with type 'a elt_ = 'a and type 'a set = 'a t and type 'a cursor_ = 'a cursor and type ('a,'b) result_ = ('a,'b) result val to_string : ('a -> string) -> 'a set -> string end module type PolySetSigStd = PolySetSig with type ('a,'b) result = 'a ocaml-reins-0.1a/src/set/rBSet.ml0000644000175000017500000004333310676520540015742 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module BaseSet = struct (* Red/Black Trees follow: 1) all nodes are Red or Black 2) The root is black 3) Empty Trees (i.e. leafs) are black 4) Both children of a red node are black 5) Every path from a leaf to the root has the same "black height" *) (* save a cell by encoding the color in the constructor *) type 'a tree = | Empty | RNode of 'a tree * 'a * 'a tree | BNode of 'a tree * 'a * 'a tree let of_result x = x let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton x = BNode(Empty,x,Empty) let is_black = function | Empty -> true | BNode _ -> true | RNode _ -> false let rec black_height t = let rec bh acc = function | Empty -> 1+acc | RNode(l,_,r) -> bh acc l | BNode(l,_,r) -> bh (acc+1) l in bh 0 t (* true if the top of sub is lt x *) let sub_lt cmp x sub = match sub with | RNode(_,y,_) | BNode(_,y,_) -> cmp y x < 0 | _ -> assert false let sub_gt cmp x sub = match sub with | RNode(_,y,_) | BNode(_,y,_) -> cmp y x > 0 | _ -> assert false let rec well_ordered cmp = function | Empty -> true | RNode(Empty,e,Empty) | BNode(Empty,e,Empty) -> true | BNode(Empty,e,r) | RNode(Empty,e,r) -> sub_gt cmp e r && well_ordered cmp r | BNode(l,e,Empty) | RNode(l,e,Empty) -> sub_lt cmp e l && well_ordered cmp l | RNode(l,e,r) | BNode(l,e,r) -> sub_lt cmp e l && sub_gt cmp e r && well_ordered cmp l && well_ordered cmp r let rec check_red_children = function | Empty -> true | BNode(l,_,r) -> check_red_children l && check_red_children r | RNode(l,_,r) -> is_black l && is_black r && check_red_children l && check_red_children r let rec check_black_height = function | Empty -> true | RNode(l,_,r) | BNode(l,_,r) -> if ((black_height l) = (black_height r)) then (check_black_height l) && (check_black_height r) else failwith "black height is off" let well_formed_not1 cmp t = well_ordered cmp t && check_red_children t && (* prop 4 *) check_black_height t (* prop 5 *) let well_formed cmp t = well_ordered cmp t && is_black t && (* prop 2 *) check_red_children t && (* prop 4 *) check_black_height t (* prop 5 *) let rec to_string to_s t = let rec h = function | Empty -> "" | RNode(Empty,v,Empty) | BNode(Empty,v,Empty) -> to_s v | RNode(l,v,Empty) | BNode(l,v,Empty) -> Printf.sprintf "%s, %s" (h l) (to_s v) | RNode(Empty,v,r) | BNode(Empty,v,r) -> Printf.sprintf "%s, %s" (to_s v) (h r) | RNode(l,v,r) | BNode(l,v,r) -> Printf.sprintf "%s, %s, %s" (h l) (to_s v) (h r) in "{" ^ (h t) ^ "}" let rec min_elt t = match t with | Empty -> raise Not_found | RNode(Empty,elt,_) | BNode(Empty,elt,_) -> elt | RNode(l,_,_) | BNode(l,_,_) -> min_elt l let rec max_elt t = match t with | Empty -> raise Not_found | RNode(_,elt,Empty) | BNode(_,elt,Empty) -> elt | RNode(_,_,r) | BNode(_,_,r) -> max_elt r let rec mem cmp x t = match t with | Empty -> false | RNode(l,elt,r) | BNode(l,elt,r) -> match cmp x elt with | 0 -> true | c when c < 0 -> mem cmp x l | _ -> mem cmp x r (* Okasaki's rebalancing constructor *) let bal_l l elt r = match l with | RNode(RNode(t1,a1,t2),a2,t3) | RNode(t1,a1,RNode(t2,a2,t3)) -> RNode(BNode(t1,a1,t2),a2,BNode(t3,elt,r)) | _ -> BNode(l,elt,r) let bal_r l elt r = match r with | RNode(RNode(t2,a2,t3),a3,t4) | RNode(t2,a2,RNode(t3,a3,t4)) -> RNode(BNode(l,elt,t2),a2,BNode(t3,a3,t4)) | _ -> BNode(l,elt,r) let rec ins cmp x t = match t with | Empty -> RNode(Empty,x,Empty) | RNode(l,elt,r) -> begin match cmp x elt with | 0 -> t (* impossible to violate black height property with a red node here, so no need to rebalance *) | c when c < 0 -> RNode(ins cmp x l,elt,r) | _ -> RNode(l,elt,ins cmp x r) end | BNode(l,elt,r) -> begin match cmp x elt with | 0 -> t | c when c < 0 -> bal_l (ins cmp x l) elt r | _ -> bal_r l elt (ins cmp x r) end let blackify = function | RNode(l,elt,r) -> BNode(l,elt,r) | t -> t let add cmp x t = blackify (ins cmp x t) let redify = function | BNode(l,e,r) -> RNode(l,e,r) | _ -> assert false let balance l v r = match l,v,r with (* TODO: investigate this first constructor proposed by Kahrs. Is it better to move Red nodes up?*) | RNode(a,x,b),y,RNode(c,z,d) | RNode(RNode(a,x,b),y,c),z,d | RNode(a,x,RNode(b,y,c)),z,d | a,x,RNode(b,y,RNode(c,z,d)) | a,x,RNode(RNode(b,y,c),z,d) -> RNode(BNode(a,x,b),y,BNode(c,z,d)) | a,x,b -> BNode(a,x,b) let balleft l elt r = match l with | RNode(ll,lv,lr) -> RNode(BNode(ll,lv,lr),elt,r) | _ -> match r with | BNode(rl,rv,rr) -> balance l elt (RNode(rl,rv,rr)) | RNode(BNode(a,y,b),z,c) -> RNode(BNode(l,elt,a), y, (balance b z (redify c))) | _ -> assert false let balright l elt r = match r with | RNode(b,y,c) -> RNode(l,elt,BNode(b,y,c)) | _ -> match l with | BNode(a,x,b) -> balance (RNode(a,x,b)) elt r | RNode(a,x,BNode(b,y,c)) -> RNode(balance (redify a) x b, y, (BNode(c,elt,l))) | _ -> assert false let rec app l r = match l,r with | Empty,_ -> r | _,Empty -> l | RNode(a,x,b), RNode(c,y,d) -> begin match app b c with | RNode(b',z,c') -> RNode(RNode(a,x,b'),z,RNode(c',y,d)) | bc -> RNode(a,x,RNode(bc,y,d)) end | BNode(a,x,b), BNode(c,y,d) -> begin match app b c with | RNode(b',z,c') -> RNode(BNode(a,x,b'),z,BNode(c',y,d)) | bc -> balleft a x (BNode(bc, y, d)) end | a, RNode(b,x,c) -> RNode(app a b, x, c) | RNode(a,x,b), c -> RNode(a,x,app b c) (* based on Stefan Kahrs work on RB trees *) let rec del cmp x t = match t with | Empty -> Empty | BNode(l,elt,r) | RNode(l,elt,r) -> match cmp x elt with | 0 -> app l r | c when c < 0 -> del_left cmp x l elt r | _ -> del_right cmp x l elt r and del_left cmp x l elt r = match l with | BNode _ -> balleft (del cmp x l) elt r | _ -> RNode(del cmp x l, elt, r) and del_right cmp x l elt r = match r with | BNode _ -> balright l elt (del cmp x r) | _ -> RNode(l,elt,del cmp x r) let remove cmp x t = blackify (del cmp x t) (* join trees of arbitrary size *) (* This is still really inefficient since it keeps calling black_height which O(log n) raising this to O(n log n). Should only call these once in union/diff/inter and then keep track of local differences. *) let rec concat3h cmp l v r hl hr = match hl - hr with | 0 -> begin match l,r with | BNode _, BNode _ -> RNode(l,v,r) | _ -> BNode(l,v,r) end | -1 -> (* r has at exactly 1 extra black node *) begin match l,r with | _, Empty -> assert false (* r must have at least 2 black nodes *) | RNode(ll,lv,lr),_ -> (* if l is red, just color it black to match r *) BNode(BNode(ll,lv,lr),v,r) | _,RNode(rl,rv,rr) -> (* rl and rr must be black by (4) *) (* recurse to force l=blk rl=blk *) balance (concat3h cmp l v rl hl hr) rv rr | _,BNode(rl,rv,rr) -> begin match rl,rr with | (BNode _|Empty), (BNode _|Empty) -> (*both black, so color their parent red to drop BH, then use bnode as parent to restore height *) BNode(l,v,RNode(rl,rv,rr)) | RNode _, RNode _ -> (* push black down to rr and connect rl with l *) RNode(BNode(l,v,rl),rv, blackify(rr)) | (BNode _|Empty), RNode _ -> (* RNode(l,v,rl) will have same height as rr *) BNode(RNode(l,v,rl),rv,rr) | RNode(rll,rlv,rlr), (BNode _|Empty) -> (* rll and rlr are black, and all of l,rll,rlr,rr have same BH *) RNode(BNode(l,v,rll), rlv, BNode(rlr,rv,rr)); end end | 1 -> (* l has at exactly 1 extra black node *) begin match l,r with | Empty,_ -> assert false (* l must have at least 2 black nodes *) | _,RNode(rl,rv,rr) -> (* if r is red, just color it black to match l *) BNode(l,v,BNode(rl,rv,rr)) | RNode(ll,lv,lr),_ -> (* ll and lr must be black by (4) *) (* recurse to force l=blk rl=blk *) balance ll lv (concat3h cmp lr v r hl hr) | BNode(ll,lv,lr),_ -> begin match ll,lr with | (BNode _|Empty), (BNode _|Empty) -> (*both black, so color their parent red to drop BH, then use bnode as parent to restore height *) BNode(RNode(ll,lv,lr),v,r) | RNode _, RNode _ -> (* push black down to ll and connect lr with r *) RNode(blackify(ll),lv,BNode(lr,v,r)) | (BNode _|Empty), RNode(lrl,lrv,lrr) -> (* lrl and lrr are black, and all of l,rll,rlr,rr have same BH *) RNode(BNode(ll,lv,lrl), lrv, BNode(lrr,v,r)) | RNode _, (BNode _|Empty) -> (* RNode(lr,v,r) will have same height as ll *) BNode(ll,lv,RNode(lr,v,r)) end end | c when c < -1 -> (* r has at least 2 more black nodes *) begin match r with | Empty -> assert false | RNode(rl,rv,rr) -> let t1 = concat3h cmp l v rl hl hr in let hl = black_height t1 in let t2 = concat3h cmp t1 rv rr hl hr in t2 | BNode(rl,rv,rr) -> let t1 = concat3h cmp l v rl hl (hr-1) in let hl = black_height t1 in let t2 = concat3h cmp t1 rv rr hl (hr-1)in t2 end | _ -> match l with (* l has at least 2 more black nodes *) | Empty -> assert false | RNode(ll,lv,lr) -> let t1 = concat3h cmp lr v r hl hr in let hr = black_height t1 in let t' = concat3h cmp ll lv t1 hl hr in t' | BNode(ll,lv,lr) -> let t1 = concat3h cmp lr v r (hl-1) hr in let hr = black_height t1 in let t' = concat3h cmp ll lv t1 (hl-1) hr in t' and concat3 cmp l v r = let hl = black_height l in let hr = black_height r in concat3h cmp l v r hl hr let rec split cmp v t = match t with | Empty -> Empty, Empty | BNode(l1,elt,r1) | RNode(l1,elt,r1) -> match cmp v elt with | 0 -> l1,r1 | c when c < 0 -> let l2,r2 = split cmp v l1 in let t' = concat3 cmp r2 elt r1 in (*assert(well_formed_not1 cmp t');*) (l2,t') | _ -> let l2,r2 = split cmp v r1 in let t' = concat3 cmp l1 elt l2 in (*assert(well_formed_not1 cmp t');*) (t'), r2 let union cmp t1 t2 = let rec u t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | t1, (BNode(l,v,r) | RNode(l,v,r)) -> let l',r' = split cmp v t1 in let t' = concat3 cmp (u l' l) v (u r' r) in (*assert(well_formed_not1 cmp t');*) t' in blackify (u t1 t2) (* Inefficient, easy version for now *) let get_and_remove_min cmp t = let m = min_elt t in m, (remove cmp m t) (* Inefficient, easy version for now *) let concat cmp t1 t2 = if is_empty t2 then t1 else let rm,t2 = get_and_remove_min cmp t2 in concat3 cmp t1 rm t2 let rec diff cmp t1 t2 = let rec helper t1 t2 = match t1,t2 with | Empty, _ -> Empty | _, Empty -> t1 | _, (BNode(l,v,r)|RNode(l,v,r)) -> let l',r' = split cmp v t1 in concat cmp (helper l' l) (helper r' r) in blackify (helper t1 t2) let rec inter cmp t1 t2 = match t1,t2 with | Empty,_ | _,Empty -> Empty | t1, (BNode(l,v,r)|RNode(l,v,r)) -> let l',r' = split cmp v t1 in let t = if mem cmp v t1 then concat3 cmp (inter cmp l' l) v (inter cmp r' r) else concat cmp (inter cmp l' l) (inter cmp r' r) in blackify t let rec cardinal = function | Empty -> 0 | BNode(l,_,r) | RNode(l,_,r) -> 1 + (cardinal l) + (cardinal r) let choose = function | Empty -> raise Not_found | BNode(_,v,_) | RNode(_,v,_) -> v let rec iter f = function | Empty -> () | RNode(l,v,r) | BNode(l,v,r) -> iter f l; f v; iter f r let rec fold f acc t = match t with | Empty -> acc | RNode(l,v,r) | BNode(l,v,r) -> fold f (f (fold f acc l) v) r type 'a digit = | One of 'a * 'a tree | Two of 'a * 'a tree * 'a * 'a tree let rec incr a1 t1 ds = match ds with | [] -> [One(a1,t1)] | One(a2,t2)::tl -> Two(a1,t1,a2,t2) :: tl | Two(a2,t2,a3,t3)::tl -> One(a1,t1) :: (incr a2 (BNode(t2,a3,t3)) tl) let link l = function | One(a,t) -> BNode(l,a,t) | Two(a1,t1,a2,t2) -> BNode(RNode(l,a1,t1),a2,t2) let linkall lst = List.fold_right (fun dig t -> link t dig) lst Empty (* let add a lst = incr a Empty lst let bottom_up lst = linkall (List.fold_right add lst [])*) type 'a path = | Top | PathL of 'a path * 'a * 'a tree * bool (* is_black *) | PathR of 'a tree * 'a * 'a path * bool (* is_black *) type 'a curs = 'a path * 'a tree let to_cursor c = Top, c let has_value = function | _,Empty -> false | _ -> true let get_value = function | _,Empty -> failwith "get_value" | _,RNode(_,v,_) | _,BNode(_,v,_) -> v let at_top = function (Top,_) -> true | _ -> false let at_left (_,t) = match t with | Empty -> true | _ -> false let at_right (_,t) = match t with | Empty -> true | _ -> false let went_left = function PathL _,_ -> true | _ -> false let went_right = function PathR _,_ -> true | _ -> false let try_color blk t = if blk then blackify t else match t with (* try to color t red *) | Empty -> t (* can't *) | RNode _ -> t (* already *) | BNode(l', v', r') -> if is_black l' && is_black r' then RNode(l',v',r') (* can change to red and still satisfy (4) *) else t (* have to leave it black *) let move_up cmp = function | Top, _ -> failwith "move_up" | PathL(p,x,r,blk),l | PathR(l,x,p,blk),r -> let t = concat3 cmp l x r in (* We try and keep the same color as the original tree if possible so that we don't do any unnecessary rotations when rebuilding the tree. Besides being more efficient, this is also required to make traversals work properly (otherwise the tree might rotate in the middle of the traversal, giving incorrect results *) let t = try_color blk t in p, t let move_down_left = function | _,Empty -> failwith "move_down_left" | p, RNode(l,v,r) -> PathL(p,v,r,false),l | p, BNode(l,v,r) -> PathL(p,v,r,true),l let move_down_right = function | _,Empty -> failwith "move_down_right" | p,RNode(l,v,r) -> PathR(l,v,p,false),r | p,BNode(l,v,r) -> PathR(l,v,p,true),r let rec from_cursor cmp curs = if at_top curs then blackify (snd curs) else from_cursor cmp (move_up cmp curs) (** Step the cursor one position "in-order". Does not keep any state *) let rec step_io = function | Top, Empty -> raise Exit | PathL(p,x,r,_),Empty -> x,(p,r) | p, RNode(l,x,r) -> step_io (PathL(p,x,r,false),l) | p, BNode(l,x,r) -> step_io (PathL(p,x,r,true),l) | PathR _, Empty -> assert false let can_step = function Top, Empty -> false | _ -> true let cmp kcmp t1 t2 = let rec helper c1 c2 = match (can_step c1), (can_step c2) with | false, false -> 0 | true, false -> -1 | false, true -> 1 | true, true -> let x1,c1 = step_io c1 in let x2,c2 = step_io c2 in match kcmp x1 x2 with | 0 -> helper c1 c2 | c -> c in helper (to_cursor t1) (to_cursor t2) let gen_ cmp (agen:?size:int -> Random.State.t -> 'a) ?(size=50) rs = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else loop (n-1) (add cmp (agen ~size:size rs) t) in loop num empty end module PolySet (*: Tree.PolyTreeSet*) = struct include BaseSet type 'a t = 'a tree type 'a set = 'a t type 'a elt_ = 'a type ('a,'b) result = 'a type ('a,'b) result_ = 'a let add x t = add Pervasives.compare x t let mem x t = mem Pervasives.compare x t let remove x t = remove Pervasives.compare x t let union t1 t2 = union Pervasives.compare t1 t2 let diff t1 t2 = diff Pervasives.compare t1 t2 let inter t1 t2 = inter Pervasives.compare t1 t2 let compare x y = cmp Pervasives.compare x y let equal x y = compare x y = 0 let well_formed t = well_formed Pervasives.compare t type 'a cursor = 'a curs type 'a cursor_ = 'a cursor let move_up c = move_up Pervasives.compare c let from_cursor c = from_cursor Pervasives.compare c let gen1 (agen:?size:int -> Random.State.t -> 'a) ?size rs = gen_ Pervasives.compare agen ?size rs end module MonoSet (C : Types.Mono.Comparable) = struct include BaseSet type elt = C.t type 'a elt_ = elt type t = C.t tree type 'a set = t type 'a result = 'a type ('a,'b) result_ = 'a let add x t = add C.compare x t let mem x t = mem C.compare x t let remove x t = remove C.compare x t let union t1 t2 = union C.compare t1 t2 let diff t1 t2 = diff C.compare t1 t2 let inter t1 t2 = inter C.compare t1 t2 let compare x y = cmp C.compare x y let equal x y = compare x y = 0 let well_formed t = well_formed C.compare t let to_string t = to_string C.to_string t type cursor = C.t curs type 'a cursor_ = cursor let move_up c = move_up C.compare c let from_cursor c = from_cursor C.compare c let gen1 (agen:?size:int -> Random.State.t -> 'a) ?size rs = gen_ C.compare agen ?size rs end module GenSet (C : Types.Mono.ArbitraryComparable) = struct include MonoSet(C) let gen ?size rs = gen1 C.gen ?size rs end ocaml-reins-0.1a/src/set/patriciaSet.mli0000644000175000017500000000301610676520540017336 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Efficient sets of integers Patricia trees are balanced binary search trees whose elements are integers. These trees can be very efficient since navigating the each tree uses only specific bits of the elements value. They have O(w) worst case running time for the [mem], [add], [remove] where w is the number of bits in an integer, but typically run in O(log n) time for most inputs. Because, Patricia trees never need to be re-balanced, [union], [inter], and [diff] can be much faster than ordinary balanced trees, but still may take O(n+m) in the worst case. *) (** This module implements sets with integer keys *) module MonoSet : Sets.MonoSetSig with type elt = int and type 'a result = 'a (** Same as the {!PatriciaSet.MonoSet} module, except it also provides the [gen] function. *) module GenSet : Sets.GenSetSig with type elt = int and type 'a result = 'a ocaml-reins-0.1a/src/set/splaySet.ml0000644000175000017500000002517510676520540016533 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types module BaseSet = struct type 'elt tree = | Empty | Node of 'elt tree * 'elt * 'elt tree type 'a path = | Top | PathL of 'a path * 'a tree | PathR of 'a path * 'a tree type 'a curs = 'a path * 'a tree let of_result (x,_) = x let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton x = Node(Empty,x,Empty) let node l e r = Node(l,e,r) let to_cursor t = (Top,t) let rec from_cursor (p,t) = match p with | Top -> t | PathL(p',Node(_,v,r)) -> from_cursor (p', Node(t,v,r)) | PathR(p',Node(l,v,_)) -> from_cursor (p', Node(l,v,t)) | _ -> assert false let at_top (p,t) = (p = Top) let has_left (p,t) = match t with | Node(Empty,_,_) -> false | Node _ -> true | _ -> false let has_right (p,t) = match t with | Node(_,_,Empty) -> false | Node _ -> true | _ -> false let went_left = function PathL _,_ -> true | _ -> false let went_right = function PathR _,_ -> true | _ -> false let move_up (p,t) = match p with | Top -> failwith "move_up" | PathL(p',Node(_,v,r)) -> p', Node(t,v,r) | PathR(p',Node(l,v,_)) -> p', Node(l,v,t) | _ -> assert false (* parent can't be emptytree *) let move_down_left (p,t) = match t with | Empty -> failwith "move_down_left" | Node(l,v,r) -> PathL(p,t),l let move_down_right (p,t) = match t with | Empty -> failwith "move_down_right" | Node(l,v,r) -> PathR(p,t),r let rec move_to_ancestor cmp x ((p,t) as curs) = match p with | Top -> curs | PathL(p', Node(_,v,_)) -> if cmp x v < 0 then curs else move_to_ancestor cmp x (move_up curs) | PathR(p', Node(_,v,_)) -> if cmp x v > 0 then curs else move_to_ancestor cmp x (move_up curs) | _ -> assert false let rec splay curs = match curs with | Top,_ -> curs | _, Empty -> splay (move_up curs) (* no grand-parent, so just zig one level *) | PathL(Top,Node(_,v,r)), Node(ll,lv,lr) -> Top,Node(ll,lv,Node(lr,v,r)) | PathR(Top,Node(l,v,_)),Node(rl,rv,rr) -> Top,Node(Node(l,v,rl),rv,rr) (* has grand-parent *) (* zig-zig *) | PathL(PathL(gp_p,Node(_,v,r)),Node(_,lv,lr)), Node(lll,llv,llr) -> let br = Node(lr,v,r) in let mr = Node(llr,lv,br) in splay (gp_p, Node(lll,llv,mr)) (* zig-zig *) | PathR(PathR(gp_p,Node(l,v,_)),Node(ll,lv,_)), Node(rrl,rrv,rrr) -> let bl = Node(l,v,ll) in let ml = Node(bl,lv,rrl) in splay (gp_p,Node(ml,rrv,rrr)) (* zig-zag *) | PathL(PathR(gp_p,Node(l,v,_)),Node(_,rv,rr)), Node(rll,rlv,rlr) -> let newl = Node(l,v,rll) in let newr = Node(rlr,rv,rr) in splay (gp_p,Node(newl, rlv, newr)) (* zig-zag *) | PathR(PathL(gp_p,Node(_,v,r)),Node(ll,lv,_)), Node(lrl,lrv,lrr) -> let newl = Node(ll,lv,lrl) in let newr = Node(lrr,v,r) in splay(gp_p, Node(newl, lrv, newr)) (* all of remaining cases are impossible. e.g., the grandparent tree being Empty *) | _ -> assert false let rec add_at cmp x ((p,t) as curs) = match t with | Empty -> p,Node(Empty,x,Empty) | Node(l,v,r) -> match cmp x v with | 0 -> curs | c when c < 0 -> add_at cmp x (PathL(p,t),l) | _ -> add_at cmp x (PathR(p,t),r) let add cmp x t = let curs = add_at cmp x (to_cursor t) in from_cursor (splay curs) let rec closest_to cmp x ((p,t) as curs) = match t with | Empty -> if at_top curs then curs else move_up curs | Node(l,v,r) -> match cmp x v with | 0 -> curs | c when c < 0 -> closest_to cmp x (PathL(p,t),l) | _ -> closest_to cmp x (PathR(p,t),r) let top_node = function | Empty -> raise (Invalid_argument "splay:top_node") | Node(_,v,_) -> v let rec goto_min ((p,t) as curs) = match t with | Empty -> curs | Node(Empty,_,_) -> curs | Node(l,_,_) -> goto_min ((PathL(p,t)),l) let rec goto_max ((p,t) as curs) = match t with | Empty -> curs | Node(_,_,Empty) -> curs | Node(_,_,r) -> goto_max ((PathR(p,t)),r) let rec min_elt t = if is_empty t then raise Not_found else let c = goto_min (to_cursor t) in let t = from_cursor (splay c) in top_node t, t let max_elt t = if is_empty t then raise Not_found else let c = goto_max (to_cursor t) in let t = from_cursor (splay c) in top_node t, t let mem cmp x t = let curs = closest_to cmp x (to_cursor t) in let t = from_cursor (splay curs) in match t with | Empty -> false,t | Node(_,v,_) -> if cmp x v = 0 then true,t else false,t (* TODO: fix this to be better than O(n) stack *) let rec iter f = function | Empty -> () | Node(l,v,r) -> iter f l; f v; iter f r let rec get_and_remove_min = function | Empty -> raise (Invalid_argument "remove_min") | Node(Empty,v,r) -> v,r | Node(l,v,r) -> let d,newl = get_and_remove_min l in d, Node(newl,v,r) let remove cmp x t = let (p,t) = closest_to cmp x (to_cursor t) in let t = match t with | Empty -> t | Node(Empty,v,r) -> if (cmp v x) = 0 then r else t | Node(l,v,Empty) -> if (cmp v x) = 0 then l else t | Node(l,v,r) -> if (cmp v x) = 0 then let d,newl = get_and_remove_min l in Node(newl,d,r) else t in from_cursor (splay (p,t)) let rec split cmp v t = match t with | Empty -> Empty, Empty | Node(l1,elt,r1) -> match cmp v elt with | 0 -> l1,r1 | c when c < 0 -> let l2,r2 = split cmp v l1 in l2,Node(r2,elt,r1) | _ -> let l2,r2 = split cmp v r1 in Node(l1,elt,l2), r2 let rec union cmp t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | t1, Node(l,v,r) -> let l',r' = split cmp v t1 in Node((union cmp l' l),v,(union cmp r' r)) let rec concat t1 t2 = match t1,t2 with | Empty, _ -> t2 | _, Empty -> t1 | Node(l1,v1,r1), Node(l2,v2,r2) -> let m,t2' = get_and_remove_min t2 in Node(t1,m,t2') let rec diff cmp t1 t2 = match t1,t2 with | Empty, _ -> Empty | _, Empty -> t1 | _, Node(l,v,r) -> let l',r' = split cmp v t1 in concat (diff cmp l' l) (diff cmp r' r) let rec inter cmp t1 t2 = match t1,t2 with | Empty,_ | _,Empty -> Empty | t1, Node(l,v,r) -> let l',r' = split cmp v t1 in if fst (mem cmp v t1) then Node((inter cmp l' l),v,(inter cmp r' r)) else concat (inter cmp l' l) (inter cmp r' r) let at_right = function | _,Empty -> true | _,Node _ -> false let at_left = at_right let has_value = function _,Node _ -> true | _ -> false let get_value = function | _,Empty -> failwith "get_value" | _,Node(_,v,_) -> v let rec cardinal = function | Empty -> 0 | Node(l,_,r) -> 1 + (cardinal l) + (cardinal r) let choose t = match t with | Empty -> raise Not_found | Node(l,v,r) -> v, t (* TODO: fix this to be better than O(n) stack *) let rec fold f acc t = match t with | Empty -> acc | Node(l,v,r) -> fold f (f (fold f acc l) v) r let rec well_ordered cmp = function | Empty -> true | Node(Empty,e,Empty) -> true | Node(Node(_,le,_) as l,e,Empty) -> ((cmp le e) < 0) && well_ordered cmp l | Node(Empty,e,(Node(_,re,_) as r)) -> ((cmp re e) > 0) && well_ordered cmp r | Node(Node(_,le,_) as l,e,(Node(_,re,_) as r)) -> ((cmp le e) < 0) &&((cmp re e) > 0) && well_ordered cmp l && well_ordered cmp r let well_formed t = well_ordered t let rec compare_ kcmp t1 t2 = match t1,t2 with | Empty, Empty -> 0 | Empty, Node _ -> -1 | Node _, Empty -> 1 | _ -> (* This actually may be one of the most efficient ways to implement this since we will always be removing near the top thanks to the splay property. *) let xk,t1' = get_and_remove_min t1 in let yk,t2' = get_and_remove_min t2 in match kcmp xk yk with | 0 -> compare_ kcmp t1' t2' | v -> v let rec to_string to_s t = let rec h = function | Empty -> "" | Node(Empty,v,Empty) -> to_s v | Node(l,v,Empty) -> Printf.sprintf "%s, %s" (h l) (to_s v) | Node(Empty,v,r) -> Printf.sprintf "%s, %s" (to_s v) (h r) | Node(l,v,r) -> Printf.sprintf "%s, %s, %s" (h l) (to_s v) (h r) in "{" ^ (h t) ^ "}" let gen_ cmp (agen : ?size:int -> Random.State.t -> 'a) ?(size=50) rs : 'a tree = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else let t = from_cursor (add_at cmp (agen rs) (to_cursor t)) in loop (n-1) t in loop num empty end module PolySet = struct include BaseSet type 'a t = 'a tree type 'a set = 'a t type ('a,'b) result = 'a * 'b t type ('a,'b) result_ = ('a,'b) result type 'a elt_ = 'a type 'a cursor = 'a curs type 'a cursor_ = 'a cursor let add x t = add Pervasives.compare x t let add_at x t = add_at Pervasives.compare x t let compare x y = compare_ Pervasives.compare x y let equal x y = compare x y = 0 let mem x t = mem Pervasives.compare x t let remove x t = remove Pervasives.compare x t let union t1 t2 = union Pervasives.compare t1 t2 let diff t1 t2 = diff Pervasives.compare t1 t2 let inter t1 t2 = inter Pervasives.compare t1 t2 let well_formed t = well_formed Pervasives.compare t let gen1 (agen : ?size:int -> Random.State.t -> 'a) ?size rs : 'a t = gen_ Pervasives.compare agen ?size rs end module MonoSet(C : Mono.Comparable) = struct include BaseSet type elt = C.t type 'a elt_ = elt type t = elt tree type 'a set = t type 'a result = 'a * t type ('a,'b) result_ = 'a result type cursor = elt curs type 'a cursor_ = cursor let add x t = add C.compare x t let mem x t = mem C.compare x t let remove x t = remove C.compare x t let union t1 t2 = union C.compare t1 t2 let diff t1 t2 = diff C.compare t1 t2 let inter t1 t2 = inter C.compare t1 t2 let add_at x t = add_at C.compare x t let compare t1 t2 = compare_ C.compare t1 t2 let equal t1 t2 = compare t1 t2 = 0 let well_formed t = well_formed C.compare t let to_string s = to_string C.to_string s let gen1 (agen : ?size:int -> Random.State.t -> elt) ?size rs : t = gen_ C.compare agen ?size rs end module GenSet(C : Types.Mono.ArbitraryComparable) = struct include MonoSet(C) let gen ?size rs = gen1 C.gen ?size rs end ocaml-reins-0.1a/src/set/OMakefile0000644000175000017500000000022610672112566016143 0ustar furrmfurrm OCAMLINCLUDES += ../base ../iterator FILES[] += set/sets set/aVLSet set/splaySet set/rBSet set/patriciaSet ocaml-reins-0.1a/src/set/aVLSet.mli0000644000175000017500000001250210676520540016224 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Height balanced binary search trees implementing sets AVL trees are balanced binary search trees with O(log n) lookup, add, and remove operations. The set operations [union], [inter], and [diff] all take O(n) time. However, some inputs to these functions will take significantly less time to process (e.g. when one tree is significantly smaller than the other, or when the trees have large number consecutive elements that do not overlap). *) (** This module provides an implementation of AVL trees with a polymorphic element type. The implementation uses the standard library's polymorphic [compare] function internally and may not be as efficient as the {!AVLSet.MonoSet} module which allows the use of a more efficient comparison function. *) module PolySet : Sets.PolySetSigStd (** This functor provides an implementation of AVL trees that are parameterized by a specific monomorphic element type. *) module MonoSet : Sets.MonoSetSigFnStd (** This functor is similar to the {!AVLSet.MonoSet} functor except it is parameterized by a module that also supports the [gen] operation. Therefore, the resulting module is also able to generate number sets. *) module GenSet : Sets.GenSetSigFnStd (** All of the module below are variations of the above modules that allow client code to control the performance of the AVL tree. Note that in most cases, the modules defined above will perform the best. *) (** This functor is similar to the {!AVLSet.PolySet} module above, except it allows the user to specify the maximum difference between the heights of two subtrees at a node with [HeightDiff.v]. The choice of this value affects the amount of effort spent rebalancing the tree after it has been modified in exchange for the cost of locating a particular element in the tree. The modules {!AVLSet.PolySet1}, {!AVLSet.PolySet2}, and {!AVLSet.PolySet3} below instantiate this functor with the values 1, 2, and 3 respectively. Those modules are also defined in the same compilation unit as the implementation code, so the value of HeightDiff.v is inlined, increasing performance. *) module AVL_PolySet: functor(HeightDiff : sig val v : int end) -> Sets.PolySetSigStd (** {!AVLSet.AVL_PolySet} instanced with HeightDiff.v = 1 *) module PolySet1 : Sets.PolySetSigStd (** {!AVLSet.AVL_PolySet} instanced with HeightDiff.v = 2 *) module PolySet2 : Sets.PolySetSigStd (** {!AVLSet.AVL_PolySet} instanced with HeightDiff.v = 3 *) module PolySet3 : Sets.PolySetSigStd (** This functor is similar to the {!AVLSet.MonoSet} module above, except it allows the user to specify the maximum difference between the heights of two subtrees at a node with [HeightDiff.v]. The choice of this value affects the amount of effort spent rebalancing the tree after it has been modified in exchange for the cost of locating a particular element in the tree. The modules {!AVLSet.MonoSet1}, {!AVLSet.MonoSet2}, and {!AVLSet.MonoSet3} below instantiate this functor with the values 1, 2, and 3 respectively. Those modules are also defined in the same compilation unit as the implementation code, so the value of HeightDiff.v is inlined, increasing performance. *) module AVL_MonoSet: functor(HeightDiff : sig val v : int end) -> Sets.MonoSetSigFnStd (** {!AVLSet.AVL_MonoSet} instanced with HeightDiff.v = 1 *) module MonoSet1: Sets.MonoSetSigFnStd (** {!AVLSet.AVL_MonoSet} instanced with HeightDiff.v = 2 *) module MonoSet2: Sets.MonoSetSigFnStd (** {!AVLSet.AVL_MonoSet} instanced with HeightDiff.v = 3 *) module MonoSet3: Sets.MonoSetSigFnStd (** This functor is similar to the {!AVLSet.GenSet} module above, except it allows the user to specify the maximum difference between the heights of two subtrees at a node with [HeightDiff.v]. The choice of this value affects the amount of effort spent rebalancing the tree after it has been modified in exchange for the cost of locating a particular element in the tree. The modules {!AVLSet.GenSet1}, {!AVLSet.GenSet2}, and {!AVLSet.GenSet3} below instantiate this functor with the values 1, 2, and 3 respectively. Those modules are also defined in the same compilation unit as the implementation code, so the value of HeightDiff.v is inlined, increasing performance. *) module AVL_GenSet : functor(HeightDiff : sig val v : int end) -> Sets.GenSetSigFnStd (** {!AVLSet.AVL_GenSet} instanced with HeightDiff.v = 1 *) module GenSet1 : Sets.GenSetSigFnStd (** {!AVLSet.AVL_GenSet} instanced with HeightDiff.v = 2 *) module GenSet2 : Sets.GenSetSigFnStd (** {!AVLSet.AVL_GenSet} instanced with HeightDiff.v = 3 *) module GenSet3 : Sets.GenSetSigFnStd ocaml-reins-0.1a/src/set/sets.mli0000644000175000017500000002110110676520540016037 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Signatures for set ADTs. *) (** This module represents the core functionality of Sets. It defines a few extra types to abstract over exact implement details of its operations. Also, it defines the elements and the set type to be polymorphic, although this can later be refined to a monomorphic type (as is done bye {!Sets.MonoSetSig}. *) module type Set_ = sig type 'a elt_ (** The type of elements in the set *) type 'a set (** The type of sets *) type ('a,'b) result_ (** The [result_] type is used for operations that may either return just a result or a result a something else. Most trees conform to the former, while splay trees use the latter (e.g. the mem function may modify the tree) *) val empty : 'a set (** The empty set *) val is_empty : 'a set -> bool (** Returns true if the set is empty *) val mem : 'a elt_ -> 'a set -> (bool,'a) result_ (** [mem x t] Returns true if [x] is contained in the set [t]. More precisely, there exists an element [y] in [t] such that [compare x y = 0]. *) val add : 'a elt_ -> 'a set -> 'a set (** [add x t] Return the set [t] with the element [x]. *) val singleton : 'a elt_ -> 'a set (** [singleton x] Return the set consisting of only the element [x] *) val remove : 'a elt_ -> 'a set -> 'a set (** [remove x t] Return the set [t] with the element [x] removed. Does {b not} raise an exception if [t] does not contain [x]. *) val min_elt : 'a set -> ('a elt_,'a) result_ (** Return the smallest element in the set. If the set is empty, raises [Not_found] *) val max_elt : 'a set -> ('a elt_,'a) result_ (** Return the largest element in the set. If the set is empty, raises [Not_found] *) val choose : 'a set -> ('a elt_,'a) result_ (** Choose an arbitrary element from the set. It is implementation dependent whether or not the same element is chosen for equal sets. If the set is empty, it raises [Not_found]. *) val cardinal : 'a set -> int (** Returns the number of elements in the set. *) val compare : 'a set -> 'a set -> int (** [compare t1 t2] Compares the sets [t1] and [t2] and returns [0] if they are equal. Returns [<0] if [t1] is less than [t2] and [>0] otherwise. *) val equal : 'a set -> 'a set -> bool (** [equal t1 t2] Returns true if [t1] and [t2] contain the same elements. *) val iter : ('a elt_ -> unit) -> 'a set -> unit (** [iter f t] Apply [f] to each element in list [t]. The elements are always visited in increasing order. *) val fold : ('b -> 'a elt_ -> 'b) -> 'b -> 'a set -> 'b (** [fold f acc t] Accumulates the result [acc] by applying [f acc x] for each element [x] in [t]. The elements are always visited in increasing order. Note that this is a slightly different signature than the fold from the standard library, however, it is the same signature as the lists modules use. *) val union : 'a set -> 'a set -> 'a set (** [union t1 t2] Returns a set containing all of the elements in [t1] and [t2] *) val inter : 'a set -> 'a set -> 'a set (** [inter t1 t2] Returns a set containing only the elements contained in both [t1] and [t2] *) val diff : 'a set -> 'a set -> 'a set (** [diff t1 t2] Returns a set containing only the elements contained in [t1] and not [t2] *) val gen1 : (?size:int -> Random.State.t -> 'a elt_) -> ?size:int -> Random.State.t -> 'a set (** [gen1 f ?size rs] Generates a random set whose size is bounded by [size]. Each element in the set is computed by calling [f ?size rs]. *) val well_formed : 'a set -> bool (** A predicate to test if the set is well-formed. All sets exposed by this API should always be well-formed. This is only useful for debugging an implementation. *) val of_result : ('a,'b) result_ -> 'a (** Returns the result part of a [result_] value. This is only useful when treating a collection of sets abstractly, as most clients should deconstruct the values of type [result_] for maximal efficiency *) (** The cursor interface to sets *) type 'a cursor_ (** The type of Set cursors. A cursor can be thought of a pointer to a node in the middle of a tree. Cursors support navigating the tree in arbitrary ways. Depending on the implementation, not every node in the tree may have a value associated with it. *) val to_cursor : 'a set -> 'a cursor_ (** Create a cursor from a tree. The cursor initially points to the top of the tree. *) val from_cursor : 'a cursor_ -> 'a set (** Return the tree pointed to by the cursor. This operation may require re-balancing the tree depending on the implementation. *) val at_top : 'a cursor_ -> bool (** Returns true if the cursor is at the top of the tree. The {!Sets.Set_.move_up} operation only succeeds when this returns [false]. *) val at_left : 'a cursor_ -> bool (** Returns true if the cursor is at the left most element in the current subtree. The {!Sets.Set_.move_down_left} operation only succeeds when this returns [false]. *) val at_right : 'a cursor_ -> bool (** Returns true if the cursor is at the right most element in the current subtree. The {!Sets.Set_.move_down_right} operation only succeeds when this returns [false]. *) val move_up : 'a cursor_ -> 'a cursor_ (** Move the cursor up the tree from a sibling to a parent. If the cursor is already at the top of the tree (as determined by {!Sets.Set_.at_top}), it raises [Failure "move_up"]. *) val move_down_left : 'a cursor_ -> 'a cursor_ (** Move the cursor down the tree to the left child. If the cursor is already at the bottom left of the tree (as determined by {!Sets.Set_.at_left}), it raises [Failure "move_down_left"]. *) val move_down_right : 'a cursor_ -> 'a cursor_ (** Move the cursor down the tree to the right child. If the cursor is already at the bottom right of the tree (as determined by {!Sets.Set_.at_right}), it raises [Failure "move_down_right"]. *) val went_left : 'a cursor_ -> bool (** Returns true if the cursor points to an element that is the left sibling of its parent. *) val went_right : 'a cursor_ -> bool (** Returns true if the cursor points to an element that is the right sibling of its parent. *) val has_value : 'a cursor_ -> bool (** Returns true if the cursor points to a node that contains a value. *) val get_value : 'a cursor_ -> 'a elt_ (** Extracts the value from the current node. If the node does not contain a value (as determined by {!Sets.Set_.has_value}, then it raises [Failure "get_value"]. *) end (** A {!Sets.Set_} whose elements are monomorphic (possibly using a custom comparison function *) module type MonoSetSig = sig type t type elt type cursor type 'a result include Set_ with type 'a elt_ = elt and type 'a set = t and type 'a cursor_ = cursor and type ('a,'b) result_ = 'a result val to_string : 'a set -> string end module type MonoSetSigFn = functor(C : Types.Mono.Comparable) -> MonoSetSig with type elt = C.t module type MonoSetSigFnStd = functor(C : Types.Mono.Comparable) -> MonoSetSig with type elt = C.t and type 'a result = 'a (** The same as {!Sets.MonoSetSig} except includes a [gen] function *) module type GenSetSig = sig include MonoSetSig val gen : ?size:int -> Random.State.t -> t end module type GenSetSigFn = functor(C : Types.Mono.ArbitraryComparable) -> GenSetSig with type elt = C.t module type GenSetSigFnStd = functor(C : Types.Mono.ArbitraryComparable) -> GenSetSig with type elt = C.t and type 'a result = 'a (** A {!Sets.Set_} whose elements are polymorphic. *) module type PolySetSig = sig type 'a t type 'a cursor type ('a,'b) result include Set_ with type 'a elt_ = 'a and type 'a set = 'a t and type 'a cursor_ = 'a cursor and type ('a,'b) result_ = ('a,'b) result val to_string : ('a -> string) -> 'a set -> string end module type PolySetSigStd = PolySetSig with type ('a,'b) result = 'a ocaml-reins-0.1a/src/OMakefile0000644000175000017500000000250610676104001015340 0ustar furrmfurrm FILES[] = version OCAMLFLAGS += -for-pack Reins DIRS = base list iterator set map heap oracle .SUBDIRS: $(DIRS) include OMakefile export FILES version.ml: echo "let version = \"$(VERSION)\"" > version.ml META: META.in sed "s/@version/$(VERSION)/" META.in > META reins.mli: $(addsuffix .cmi, $(FILES)) :optional: $(addsuffix .mli, $(FILES)) rm -f $@ echo "(** The OCaml Reins library *)" > $@ foreach(name, \ $(filter-exists \ $(replacesuffixes .cmi, .mli, \ $(file-sort .BUILDORDER, \ $(filter %.cmi, \ $^))))) mod = $(capitalize $(removesuffix $(basename $(name)))) echo "module $(mod) : sig" >> $@ cat $(name) >> $@ echo "end" >> $@ section # hack for pre 3.10 -pack behavior OCAMLFLAGS = $(mapprefix -I,$(DIRS)) REINS_PKG = $(OCamlPackage reins, $(FILES)) REINS_LIB = $(OCamlLibrary reins, reins) export REINS_LIB REINS_TOP = reins $(REINS_TOP) : libreins.cma $(OCAMLMKTOP) -o $(REINS_TOP) nums.cma unix.cma libreins.cma .PHONY: doc doc: reins.mli ocamldoc -v -sort -warn-error -html -d $(ROOT)/doc/html/api reins.mli .DEFAULT: $(REINS_LIB) #$(REINS_TOP) .PHONY: install REINS_CMX=$(if $(NATIVE_ENABLED), reins.cmx) install: META $(REINS_LIB) mkdir -p $(PREFIX)/reins ocamlfind install reins META $(REINS_LIB) $(REINS_CMX) \ $(filter-exists $(addsuffix .mli, $(FILES))) ocaml-reins-0.1a/src/heap/0002755000175000017500000000000010676540775014523 5ustar furrmfurrmocaml-reins-0.1a/src/heap/binomialHeap.ml0000644000175000017500000000646210676520540017437 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types module Base = struct type 'a tree = Node of int * 'a * 'a tree list (* An element of type 'a tree is a binomial tree where the children are kept in a pre-order traversal with respect to their comparison function. *) type 'a binheap = 'a tree list (* A heap is a sparse collection of trees kept in increasing order of rank. *) let empty = [] let is_empty = function [] -> true | _ -> false let singleton x = [Node(0,x,[])] let link cmp t1 t2 = match t1,t2 with | Node(r,x1,c1), Node(_,x2,c2) -> if cmp x1 x2 <= 0 then Node(r+1,x1,t2::c1) else Node(r+1,x2,t1::c2) let rank = function | Node(r,_,_) -> r (* find a tree with the same rank and link them *) let rec insTree cmp t1 h = match h with | [] -> [t1] | t2::rest as ts -> if rank t1 < rank t2 then t1::ts else insTree cmp (link cmp t1 t2) rest let insert cmp x h = insTree cmp (Node(0,x,[])) h let rec merge cmp h1 h2 = match h1,h2 with | [], h | h, [] -> h | t1::t1s, t2::t2s -> if rank t1 < rank t2 then t1::(merge cmp t1s (t2::t2s)) else if rank t2 < rank t1 then t2::(merge cmp (t1::t1s) t2s) else insTree cmp (link cmp t1 t2) (merge cmp t1s t2s) let root = function Node(_,v,_) -> v let rec find_min cmp = function | [] -> raise Not_found | t::[] -> root t | t::ts -> let x = root t in let y = find_min cmp ts in if cmp x y <= 0 then x else y let delete_min cmp = function | [] -> raise Not_found | ts -> let rec get_min = function | [] -> assert false | t::[] -> t, [] | t::ts -> let t',ts' = get_min ts in if cmp (root t) (root t') <= 0 then (t,ts) else (t', t::ts') in let Node(_,t,ts1),ts2 = get_min ts in merge cmp (List.rev ts1) ts2 let to_string cmp t = "" end module MonoHeap(C : Types.Mono.Comparable) = struct include Base type elt = C.t type 'a elt_ = elt type t = C.t binheap type 'a heap = t let insert x t = insert C.compare x t let merge t1 t2 = merge C.compare t1 t2 let find_min t = find_min C.compare t let delete_min t = delete_min C.compare t let to_string t = to_string C.compare t end module GenHeap(C : Types.Mono.ArbitraryComparable) = struct include MonoHeap(C) let gen ?(size=50) rs = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else loop (n-1) (insert (C.gen rs) t) in loop num empty end module PolyHeap = struct include Base type 'a elt_ = 'a type 'a t = 'a binheap type 'a heap = 'a t let insert x t = insert Pervasives.compare x t let merge t1 t2 = merge Pervasives.compare t1 t2 let find_min t = find_min Pervasives.compare t let delete_min t = delete_min Pervasives.compare t end ocaml-reins-0.1a/src/heap/heaps.mli0000644000175000017500000000314710676520540016315 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Abstract signature for Heaps *) module type Heap_ = sig type 'a elt_ type 'a heap val empty : 'a heap val is_empty : 'a heap -> bool val singleton : 'a elt_ -> 'a heap val insert : 'a elt_ -> 'a heap -> 'a heap val merge : 'a heap -> 'a heap -> 'a heap val find_min : 'a heap -> 'a elt_ val delete_min : 'a heap -> 'a heap end module type MonoHeapSig = sig type t type elt include Heap_ with type 'a elt_ = elt and type 'a heap = t val to_string : 'a heap -> string end module type MonoHeapSigFn = functor(C : Types.Mono.Comparable) -> MonoHeapSig with type elt = C.t module type GenHeapSig = sig include MonoHeapSig val gen : ?size:int -> Random.State.t -> t end module type GenHeapSigFn = functor(C : Types.Mono.ArbitraryComparable) -> GenHeapSig with type elt = C.t module type PolyHeapSig = sig type 'a t include Heap_ with type 'a elt_ = 'a and type 'a heap = 'a t val to_string : ('a -> string) -> 'a heap -> string end ocaml-reins-0.1a/src/heap/skewBinomialHeap.mli0000644000175000017500000000142210676520540020431 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Skew Binomial Heap. O(1) insert, O(log n) rest *) module MonoHeap : Heaps.MonoHeapSigFn module GenHeap : Heaps.GenHeapSigFn module PolyHeap : Heaps.PolyHeapSig ocaml-reins-0.1a/src/heap/heaps.ml0000644000175000017500000000310110676520540016132 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module type Heap_ = sig type 'a elt_ type 'a heap val empty : 'a heap val is_empty : 'a heap -> bool val singleton : 'a elt_ -> 'a heap val insert : 'a elt_ -> 'a heap -> 'a heap val merge : 'a heap -> 'a heap -> 'a heap val find_min : 'a heap -> 'a elt_ val delete_min : 'a heap -> 'a heap end module type MonoHeapSig = sig type t type elt include Heap_ with type 'a elt_ = elt and type 'a heap = t val to_string : 'a heap -> string end module type MonoHeapSigFn = functor(C : Types.Mono.Comparable) -> MonoHeapSig with type elt = C.t module type GenHeapSig = sig include MonoHeapSig val gen : ?size:int -> Random.State.t -> t end module type GenHeapSigFn = functor(C : Types.Mono.ArbitraryComparable) -> GenHeapSig with type elt = C.t module type PolyHeapSig = sig type 'a t include Heap_ with type 'a elt_ = 'a and type 'a heap = 'a t val to_string : ('a -> string) -> 'a heap -> string end ocaml-reins-0.1a/src/heap/binomialHeap.mli0000644000175000017500000000142410676520540017601 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Binomial Heap. All operations are O(log n) time. *) module MonoHeap : Heaps.MonoHeapSigFn module GenHeap : Heaps.GenHeapSigFn module PolyHeap : Heaps.PolyHeapSig ocaml-reins-0.1a/src/heap/skewBinomialHeap.ml0000644000175000017500000000724410676520540020270 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types module Base = struct type 'a tree = Node of int * 'a * 'a list * 'a tree list type 'a skewheap = 'a tree list let empty = [] let is_empty = function [] -> true | _ -> false let rank (Node(r,x,xs,c)) = r let root (Node(r,x,xs,c)) = x let link cmp (Node(r,x1,xs1,c1) as t1) (Node(_,x2,xs2,c2) as t2) = if cmp x1 x2 <= 0 then Node(r+1,x1,xs1,t2::c1) else Node(r+1,x2,xs2,t1::c2) let skew_link cmp x t1 t2 = let Node(r,y,ys,c) = link cmp t1 t2 in if cmp x y <= 0 then Node(r,x,y::ys,c) else Node(r,y,x::ys,c) let rec insTree cmp t1 t = match t with | [] -> [t1] | t2::ts -> if rank t1 < rank t2 then t1::t2::ts else insTree cmp (link cmp t1 t2) ts let rec mergeTrees cmp tl1 tl2 = match tl1,tl2 with | _,[] -> tl1 | [],_ -> tl2 | t1::ts1, t2::ts2 -> if rank t1 < rank t2 then t1::(mergeTrees cmp ts1 (t2::ts2)) else if rank t2 < rank t1 then t2::(mergeTrees cmp (t1::ts1) ts2) else insTree cmp (link cmp t1 t2) (mergeTrees cmp ts1 ts2) let normalize cmp = function | [] -> [] | t::ts -> insTree cmp t ts let insert cmp x ts = match ts with | t1::t2::rest -> if rank t1 = rank t2 then (skew_link cmp x t1 t2) :: rest else Node(0,x,[],[])::ts | _ -> Node(0,x,[],[])::ts let singleton x = [Node(0,x,[],[])] let merge cmp ts1 ts2 = mergeTrees cmp (normalize cmp ts1) (normalize cmp ts2) let rec find_min cmp = function | [] -> raise Not_found | [t] -> root t | t::ts -> let x = root t in let y = find_min cmp ts in if cmp x y <= 0 then x else y let delete_min cmp = function | [] -> failwith "SkewBinomial:delete_min" | ts -> let rec get_min = function | [] -> assert false | [t] -> t,[] | t::ts -> let t',ts' = get_min ts in if cmp (root t) (root t') <= 0 then t,ts else t', (t::ts') in let Node(_,x,xs,c),ts' = get_min ts in let rec insert_all t1 t2 = match t1 with | [] -> t2 | x::xs -> insert_all xs (insert cmp x t2) in insert_all xs (mergeTrees cmp (List.rev c) (normalize cmp ts')) let to_string cmp t = "" end module MonoHeap (C : Types.Mono.Comparable) = struct include Base type elt = C.t type 'a elt_ = elt type t = C.t skewheap type 'a heap = t let insert x t = insert C.compare x t let merge t1 t2 = merge C.compare t1 t2 let find_min t = find_min C.compare t let delete_min t = delete_min C.compare t let to_string t = to_string C.compare t end module GenHeap (C : Types.Mono.ArbitraryComparable) = struct include MonoHeap(C) let gen ?(size=50) rs = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else loop (n-1) (insert (C.gen rs) t) in loop num empty end module PolyHeap = struct include Base type 'a elt_ = 'a type 'a t = 'a skewheap type 'a heap = 'a skewheap let insert x t = insert Pervasives.compare x t let merge t1 t2 = merge Pervasives.compare t1 t2 let find_min t = find_min Pervasives.compare t let delete_min t = delete_min Pervasives.compare t let to_string t = to_string t end ocaml-reins-0.1a/src/heap/OMakefile0000644000175000017500000000015010675310525016257 0ustar furrmfurrm OCAMLINCLUDES += ../base FILES[] += heap/binomialHeap heap/skewBinomialHeap heap/heaps # heap/soft ocaml-reins-0.1a/src/map/0002755000175000017500000000000010676540775014363 5ustar furrmfurrmocaml-reins-0.1a/src/map/aVLMap.mli0000644000175000017500000000352110676520540016171 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Height balanced binary search trees implementing maps *) module PolyMap : Maps.PolyMapSigStd module MonoKeyMap : Maps.MonoKeyMapSigFnStd module GenKeyMap : Maps.GenKeyMapSigFnStd module MonoMap : Maps.MonoMapSigFnStd module GenMap : Maps.GenMapSigFnStd module AVL_PMap : functor(HeightDiff : sig val v : int end) -> Maps.PolyMapSig module AVL_KeyMap : functor(HeightDiff : sig val v : int end) -> Maps.MonoKeyMapSigFnStd module AVL_GenKeyMap : functor(HeightDiff : sig val v : int end) -> Maps.GenKeyMapSigFnStd module AVL_Map : functor(HeightDiff : sig val v : int end) -> Maps.MonoMapSigFnStd module AVL_GenMap : functor(HeightDiff : sig val v : int end) -> Maps.GenMapSigFnStd module Poly1 : Maps.PolyMapSig module Poly2 : Maps.PolyMapSig module Poly3 : Maps.PolyMapSig module MonoKey1 : Maps.MonoKeyMapSigFnStd module MonoKey2 : Maps.MonoKeyMapSigFnStd module MonoKey3 : Maps.MonoKeyMapSigFnStd module GenKey1 : Maps.GenKeyMapSigFnStd module GenKey2 : Maps.GenKeyMapSigFnStd module GenKey3 : Maps.GenKeyMapSigFnStd module Mono1 : Maps.MonoMapSigFnStd module Mono2 : Maps.MonoMapSigFnStd module Mono3 : Maps.MonoMapSigFnStd module Gen1 : Maps.GenMapSigFnStd module Gen2 : Maps.GenMapSigFnStd module Gen3 : Maps.GenMapSigFnStd ocaml-reins-0.1a/src/map/maps.mli0000644000175000017500000001434610676520540016020 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Signature for Map ADTs *) module type Map_ = sig type 'k key_ type 'e elt_ type ('k,'e) map (* The {bool,key}_result_ types are used for operations that may either return just a bool (key resp.) or a bool and something else (key and something else resp.) . Most trees conform to the former, while splay trees use the latter (e.g. the mem function may modify the tree) *) type ('a,'k,'e) result_ val empty : ('k, 'e) map val is_empty : ('k, 'e) map -> bool val mem : 'k key_ -> ('k, 'e) map -> (bool,'k,'e) result_ val add : 'k key_ -> 'e elt_ -> ('k, 'e) map -> ('k, 'e) map val singleton : 'k key_ -> 'e elt_ -> ('k, 'e) map val remove : 'k key_ -> ('k, 'e) map -> ('k, 'e) map val find : 'k key_ -> ('k,'e) map -> ('e elt_,'k,'e) result_ val min_key : ('k, 'e) map -> ('k key_,'k,'e) result_ val max_key : ('k, 'e) map -> ('k key_,'k,'e) result_ val min_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ val max_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ val cardinal : ('k, 'e) map -> int val iter : ('k key_ -> 'e elt_ -> unit) -> ('k, 'e) map -> unit val fold : ('acc -> 'k key_ -> 'e elt_ -> 'acc) -> 'acc -> ('k, 'e) map -> 'acc val map : ('e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map val mapi : ('k key_ -> 'e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map val union : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map val inter : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map val diff : ('k key_ -> 'e elt_ -> 'e elt_ -> bool) -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map val well_formed : ('k, 'e) map -> bool val of_result : ('a,'k,'e) result_ -> 'a type ('k, 'e) cursor_ val to_cursor : ('k, 'e) map -> ('k, 'e) cursor_ val from_cursor : ('k, 'e) cursor_ -> ('k, 'e) map val at_top : ('k, 'e) cursor_ -> bool val at_left : ('k, 'e) cursor_ -> bool val at_right : ('k, 'e) cursor_ -> bool val move_up : ('k, 'e) cursor_ -> ('k, 'e) cursor_ val move_down_left : ('k, 'e) cursor_ -> ('k, 'e) cursor_ val move_down_right : ('k, 'e) cursor_ -> ('k, 'e) cursor_ val went_left : ('k, 'e) cursor_ -> bool val went_right : ('k, 'e) cursor_ -> bool val has_value : ('k, 'e) cursor_ -> bool val get_value : ('k, 'e) cursor_ -> 'k key_ * 'e elt_ end module type PolyMapSig = sig type ('k,'e) t type 'k key = 'k type 'e elt = 'e type ('k,'e) cursor type ('a,'k,'v) result include Map_ with type 'a key_ = 'a and type 'e elt_ = 'e and type ('k,'e) map = ('k,'e) t and type ('k,'e) cursor_ = ('k, 'e) cursor and type ('a,'k,'v) result_ = ('a,'k,'v) result val gen2 : (?size:int -> Random.State.t -> 'k key_) -> (?size:int -> Random.State.t -> 'e elt_) -> ?size:int -> Random.State.t -> ('k, 'e) map val to_string : ('k -> 'e -> string) -> ('k, 'e) map -> string val compare : ('k -> 'k -> int) -> ('e -> 'e -> int) -> ('k,'e) t -> ('k,'e) t -> int val compare_keys : ('k -> 'k -> int) -> ('k,'e) t -> ('k,'e) t -> int end module type PolyMapSigStd = PolyMapSig with type ('a,'k,'v) result = 'a module type MonoKeyMapSig = sig type 'e t type key type 'e elt = 'e type 'e cursor type ('a,'v) result include Map_ with type 'k key_ = key and type 'e elt_ = 'e and type ('k,'e) map = 'e t and type ('k,'e) cursor_ = 'e cursor and type ('a,'k,'v) result_ = ('a,'v) result val compare_keys : 'e t -> 'e t -> int val compare : ('e -> 'e -> int) -> 'e t -> 'e t -> int val to_string : ('e -> string) -> 'e t -> string val gen2 : (?size:int -> Random.State.t -> key) -> (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t end module type MonoKeyMapSigStd = MonoKeyMapSig with type ('a,'v) result = 'a module type MonoKeyMapSigFnStd = functor(C : Types.Mono.Comparable) -> MonoKeyMapSigStd with type key = C.t module type GenKeyMapSig = sig include MonoKeyMapSig val gen1 : (?size:int -> Random.State.t -> 'e) -> ?size:int -> Random.State.t -> 'e t end module type GenKeyMapSigStd = GenKeyMapSig with type ('a,'v) result = 'a module type GenKeyMapSigFnStd = functor(C : Types.Mono.ArbitraryComparable) -> GenKeyMapSigStd with type key = C.t module type MonoMapSig = sig type t type key type elt type cursor type 'a result include Map_ with type 'k key_ = key and type 'e elt_ = elt and type ('k,'e) map = t and type ('k,'e) cursor_ = cursor and type ('a,'k,'v) result_ = 'a result val compare_keys : t -> t -> int val compare : t -> t -> int val to_string : t -> string val gen2 : (?size:int -> Random.State.t -> key) -> (?size:int -> Random.State.t -> elt) -> ?size:int -> Random.State.t -> t end module type MonoMapSigFn = functor(K : Types.Mono.Comparable) -> functor(V : Types.Mono.Comparable) -> MonoMapSig with type key = K.t and type elt = V.t module type MonoMapSigFnStd = functor(K : Types.Mono.Comparable) -> functor(V : Types.Mono.Comparable) -> MonoMapSig with type key = K.t and type elt = V.t and type 'a result = 'a module type GenMapSig = sig include MonoMapSig val gen : ?size:int -> Random.State.t -> t end module type GenMapSigFn = functor(K : Types.Mono.ArbitraryComparable) -> functor(V : Types.Mono.ArbitraryComparable) -> GenMapSig with type key = K.t and type elt = V.t module type GenMapSigFnStd = functor(K : Types.Mono.ArbitraryComparable) -> functor(V : Types.Mono.ArbitraryComparable) -> GenMapSig with type key = K.t and type elt = V.t and type 'a result = 'a ocaml-reins-0.1a/src/map/patriciaMap.ml0000644000175000017500000002422110676520540017132 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module Map_ = struct type key = int type 'a key_ = key type 'a tree = | Empty | Leaf of int * 'a | Branch of int * int * 'a tree * 'a tree (* (prefix * branchbit * l * r) *) let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton k v = Leaf(k,v) let zero_bit k m = (k land m) = 0 let mask k m = (k lor (m-1)) land (lnot m) let match_prefix k p m = (mask k m) = p let lowest_bit x = x land (-x) let highest_bit x m = let x' = x land (lnot (m-1)) in let rec highb x = let m = lowest_bit x in if x = m then m else highb (x-m) in highb x' let branching_bit p0 m0 p1 m1 = highest_bit (p0 lxor p1) (max 1 (2*(max m0 m1))) let rec find x = function | Empty -> raise Not_found | Leaf(k,v) -> if x = k then v else raise Not_found | Branch(p,m,t0,t1) -> if not (match_prefix x p m) then raise Not_found else if zero_bit x m then find x t0 else find x t1 let mem x t = try ignore(find x t);true with Not_found -> false let branch p m t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | _ -> Branch(p,m,t1,t2) let get_branch_bit = function | Empty | Leaf _ -> 0 | Branch(_,b,_,_) -> b let join p0 t0 p1 t1 = let m = branching_bit p0 (get_branch_bit t0) p1 (get_branch_bit t1) in if zero_bit p0 m then Branch(mask p0 m, m, t0, t1) else Branch(mask p0 m, m, t1, t0) let add k v t = let rec ins = function | Empty -> Leaf(k,v) | Leaf(k',v') as t -> if k = k' then Leaf(k,v) (* repalce binding *) else join k (Leaf(k,v)) k' t | Branch(p,m,t0,t1) as t -> if match_prefix k p m then if zero_bit k m then Branch(p,m,ins t0, t1) else Branch(p,m,t0,ins t1) else join k (Leaf(k,v)) p t in ins t let rec merge f s t = match s,t with | Empty,t | t,Empty -> t | Leaf(k,v), t | t, Leaf(k,v) -> begin try let v' = find k t in if v == v' then add k v t else add k (f k v v') t with Not_found -> add k v t end | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> if m = n && match_prefix q p m then (* same prefix, just recurse *) Branch(p,m,merge f s0 t0, merge f s1 t1) else if m > n && match_prefix q p m then (* q contains p*) if zero_bit q m then Branch(p,m,merge f s0 t,s1) else Branch(p,m,s0,merge f s1 t) else if m < n && match_prefix p q n then (* p contains q*) if zero_bit p n then Branch(q,n,merge f s t0,t1) else Branch(q,n,t0,merge f s t1) else (* different prefixes *) join p s q t let rec remove x t = match t with | Empty -> Empty | Leaf(k,v) -> if x = k then Empty else t | Branch (p,m,t0,t1) -> if match_prefix x p m then if zero_bit x m then branch p m (remove x t0) t1 else branch p m t0 (remove x t1) else t let rec min_key = function | Empty -> raise Not_found | Leaf(k,_) -> k | Branch(_,_,t0,_) -> min_key t0 let rec max_key = function | Empty -> raise Not_found | Leaf(k,_) -> k | Branch(_,_,_,t1) -> max_key t1 let rec min_keyval = function | Empty -> raise Not_found | Leaf(k,v) -> k,v | Branch(_,_,t0,_) -> min_keyval t0 let rec max_keyval = function | Empty -> raise Not_found | Leaf(k,v) -> k,v | Branch(_,_,_,t1) -> max_keyval t1 let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Branch (_,_,t0,t1) -> (cardinal t0) + (cardinal t1) let rec iter f = function | Empty -> () | Leaf(k,v) -> f k v | Branch(_,_,t0,t1) -> iter f t0; iter f t1 let rec fold f acc t = match t with | Empty -> acc | Leaf(k,v) -> f acc k v | Branch (_,_,t0,t1) -> fold f (fold f acc t0) t1 let rec no_empty_under_branch = function | Empty -> true | Leaf _ -> true | Branch(_,_,Empty,_) | Branch(_,_,_,Empty) -> false | Branch(_,_,t0,t1) -> (no_empty_under_branch t0) && (no_empty_under_branch t1) let well_formed t = no_empty_under_branch t let rec to_string to_s t = let rec h = function | Empty -> "" | Leaf(k,v) -> Printf.sprintf "(%d => %s)" k (to_s v) | Branch(_,_,subt,Empty) -> h subt | Branch(_,_,Empty,subt) -> h subt | Branch(_,_,t0,t1) -> Printf.sprintf "%s, %s" (h t0) (h t1) in "{" ^ (h t) ^ "}" let rec compare cmp s t = match s,t with | Empty, Empty -> 0 | Empty, _ -> -1 | _, Empty -> 1 | Leaf(lk,lv), Leaf(rk,rv) -> (** pervasives is ok since keys always have type int *) let res = Pervasives.compare lk rk in if res = 0 then cmp lv rv else res | Leaf _, Branch _ -> -1 | Branch _, Leaf _ -> 1 | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> if p < q then -1 else if p > q then 1 else if m < n then -1 else if m > n then 1 else match compare cmp s0 t0 with | 0 -> compare cmp s1 t1 | c -> c let compare_keys s t = compare (fun _ _ -> 0) s t let rec equal elt_eq s t = match s,t with | Empty, Empty -> true | Empty, _ | _, Empty -> false | Leaf(lk,lv), Leaf(rk,rv) -> (lk = rk) && (elt_eq lv rv) | Leaf _, Branch _ | Branch _, Leaf _ -> false | Branch(p,m,s0,s1),Branch(q,n,t0,t1) -> (p=q) && (m=n) && equal elt_eq s0 t0 && equal elt_eq s1 t1 let union = merge (** if k is not in t then return s. Otherwise if f returns true when applied to the k and the respective values, return s with k removed. Otherwise return s unchanged. *) let remove_if f k v s t = begin try let v' = find k t in if f k v v' (* are they "equal" in the user's eyes? *) then remove k s (* yes, remove the leaf *) else s (* no keep the leaf *) with Not_found -> s end let never_merge k v v = assert false let rec diff f s t = match s,t with | Empty,t -> Empty | s,Empty -> s | Leaf(k,v), t -> remove_if f k v s t | s, Leaf(k,v) -> remove_if f k v s s | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> if m = n && match_prefix q p m (* same prefix, just recurse *) then merge never_merge (diff f s0 t0) (diff f s1 t1) else if m > n && match_prefix q p m then (* q contains p*) if zero_bit q m then merge never_merge (diff f s0 t) s1 else merge never_merge s0 (diff f s1 t) else if m < n && match_prefix p q n then (* p contains q*) if zero_bit p n then diff f s t0 else diff f s t1 else (* different prefixes *) s let rec inter f s t = match s,t with | Empty,_ -> Empty | _,Empty -> Empty | Leaf(k,v), t | t, Leaf(k,v) -> begin try let v' = find k t in Leaf(k,f k v v') with Not_found -> Empty end | Branch(p,m,s0,s1), Branch(q,n,t0,t1) -> if m = n && match_prefix q p m (* same prefix, just recurse *) then merge never_merge (inter f s0 t0) (inter f s1 t1) else if m > n && match_prefix q p m then (* q contains p *) if zero_bit q m then inter f s0 t else inter f s1 t else if m < n && match_prefix p q n then (* p contains q *) if zero_bit p n then inter f s t0 else inter f s t1 else (* different prefixes *) Empty let rec mapi f = function | Empty -> Empty | Leaf(k,v) -> Leaf(k, f k v) | Branch(p,m,l,r) -> Branch(p,m,mapi f l, mapi f r) let map f t = mapi (fun _ v -> f v) t let gen2 (kgen : (?size:int -> Random.State.t -> int)) (vgen : (?size:int -> Random.State.t -> 'v)) ?(size=50) rs : 'v tree = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else let k = kgen ~size:size rs in let v = vgen ~size:size rs in loop (n-1) (add k v t) in loop num empty let gen1 (vgen : (?size:int -> Random.State.t -> 'v)) ?size rs : 'v tree = gen2 Types.Int.gen vgen ?size rs type 'a path = | Top | PathL of 'a path * 'a tree | PathR of 'a tree * 'a path type 'a curs = 'a path * 'a tree let to_cursor t = Top,t let at_top = function | Top,_ -> true | _ -> false let at_right = function | _, Empty | _,Leaf _ -> true | _ -> false let at_left = at_right let went_left = function PathL _,_ -> true | _ -> false let went_right = function PathR _,_ -> true | _ -> false let move_up = function | Top, _ -> failwith "move_up" | PathL(p,r),l -> p, (merge (fun k v1 v2 -> v1) l r) (* we use the join function to choose the binding which was modified in by values in the subtree of the cursor *) | PathR(l,p),r -> p, (merge (fun k v1 v2 -> v2) l r) let move_down_right (p,t) = match t with | Empty | Leaf _ -> failwith "move_down_right" | Branch(_,_,_,r) -> PathR(t,p),r let move_down_left (p,t) = match t with | Empty | Leaf _ -> failwith "move_down_left" | Branch(_,_,l,_) -> PathL(p,t),l let has_value = function _,Leaf _ -> true | _ -> false let get_value = function | _,Leaf(k,v) -> k,v | _,_ -> failwith "get_value" let rec from_cursor curs = if at_top curs then snd curs else from_cursor (move_up curs) let of_result x = x end module MonoKeyMap = struct include Map_ type ('k,'v) map = 'v tree type 'a t = 'a tree type 'e elt = 'e type 'e elt_ = 'e type 'v cursor = 'v curs type ('k,'v) cursor_ = 'v cursor type ('a,'e) result = 'a type ('a,'k,'e) result_ = 'a end module GenKeyMap = MonoKeyMap module MonoMap(C : Types.Mono.Comparable) = struct include Map_ type ('k,'v) map = C.t tree type t = C.t tree type elt = C.t type 'e elt_ = C.t type cursor = C.t curs type ('k,'v) cursor_ = cursor type 'a result = 'a type ('a,'k,'e) result_ = 'a let compare x y = compare C.compare x y let to_string t = to_string C.to_string t end module GenMap(C : Types.Mono.ArbitraryComparable) = struct include MonoMap(C) let gen ?size rs = gen1 C.gen ?size rs end ocaml-reins-0.1a/src/map/rBMap.mli0000644000175000017500000000156010676520540016053 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Balanaced binary search tree with small memory footprint *) module PolyMap : Maps.PolyMapSig module MonoKeyMap : Maps.MonoKeyMapSigFnStd module GenKeyMap : Maps.GenKeyMapSigFnStd module MonoMap : Maps.MonoMapSigFnStd module GenMap : Maps.GenMapSigFnStd ocaml-reins-0.1a/src/map/splayMap.mli0000644000175000017500000000304210676520540016635 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Maps with excellent non-uniform access performance *) module rec PolyMap : Maps.PolyMapSig with type ('a,'k,'v) result = 'a * ('k,'v) PolyMap.t module rec MonoKeyMap : functor(C : Types.Mono.Comparable) -> Maps.MonoKeyMapSig with type key = C.t and type ('a,'v) result = 'a * 'v MonoKeyMap(C).t module rec GenKeyMap : functor(C : Types.Mono.ArbitraryComparable) -> Maps.GenKeyMapSig with type key = C.t and type ('a,'v) result = 'a * 'v GenKeyMap(C).t module rec MonoMap : functor(K : Types.Mono.Comparable) -> functor(V : Types.Mono.Comparable) -> Maps.MonoMapSig with type key = K.t and type elt = V.t and type 'a result = 'a * MonoMap(K)(V).t module rec GenMap : functor(K : Types.Mono.ArbitraryComparable) -> functor(V : Types.Mono.ArbitraryComparable) -> Maps.GenMapSig with type key = K.t and type elt = V.t and type 'a result = 'a * GenMap(K)(V).t ocaml-reins-0.1a/src/map/aVLMap.ml0000644000175000017500000004712510676520540016030 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** The main functor for implementing maps. The paramater field HeightDiff.v specifies the maximum difference between the heights of two subtrees joined at a node. *) module BaseMap (HeightDiff : sig val v : int end) = struct (** The types of AVL trees. An element can be either stored in a Leaf if it has no children, or in a Node if it has at least 1 child. The constructor Node(l,v,r,h) also contains the left branch 'l' (all elements are smaller than v), the right branch 'r' (all elements greater than v) and the heigh of the tree at that point. *) type ('k,'v) tree = | Empty | Leaf of 'k * 'v | Node of ('k,'v) tree * 'k * 'v * ('k,'v) tree * int let of_result x = x let empty = Empty let singleton k v = Leaf(k,v) let is_empty = function | Empty -> true | _ -> false let rec find cmp x = function | Empty -> raise Not_found | Leaf(k,v) -> if (cmp x k) = 0 then v else raise Not_found | Node(l,k,v,r,_) -> match cmp x k with | 0 -> v | c when c < 0 -> find cmp x l | _ -> find cmp x r let mem cmp x t = try ignore(find cmp x t);true with Not_found -> false let rec fold f acc t = match t with | Empty -> acc | Leaf(k,v) -> f acc k v | Node(l,k,v,r,_) -> fold f (f (fold f acc l) k v) r let rec iter f t = match t with | Empty -> () | Leaf(k,v) -> f k v | Node(l,k,v,r,_) -> iter f l; f k v; iter f r let rec min_key = function | Empty -> raise Not_found | Leaf(k,_) -> k | Node(Empty,k,_,_,_) -> k | Node(l,_,_,_,_) -> min_key l let rec max_key = function | Empty -> raise Not_found | Leaf(k,_) -> k | Node(_,k,_,Empty,_) -> k | Node(_,_,_,r,_) -> max_key r let rec min_keyval = function | Empty -> raise Not_found | Leaf(k,v) -> k,v | Node(Empty,k,v,_,_) -> k,v | Node(l,_,_,_,_) -> min_keyval l let rec max_keyval = function | Empty -> raise Not_found | Leaf(k,v) -> k,v | Node(_,k,v,Empty,_) -> k,v | Node(_,_,_,r,_) -> max_keyval r let height = function | Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,_,h) -> h (** N-"smart" constructor (a la Stephen Adams). This function chooses the right constructor based on the number of children and ensures that the Node constructor is well formed. *) let node l (k,v) r = match height l, height r with | 0,0 -> Leaf(k,v) | hl,hr -> Node(l,k,v,r, (max hl hr)+1) let pivot ll lkv c rkv rr = match c with | Node(cl,ck,cv,cr,_) -> node (node ll lkv cl) (ck,cv) (node cr rkv rr) | Leaf(ck,cv) -> node (node ll lkv Empty) (ck,cv) (node Empty rkv rr) | Empty -> assert false (** This function will fix the tree if the left subtree has a height at most HeightDiff.v +1 more than that of the right subtree. *) let rebal_left ll lkv lr kv r = if height ll >= height lr then node ll lkv (node lr kv r) else pivot ll lkv lr kv r (** This function will fix the tree if the right subtree has a height at most HeightDiff.v +1 more than that of the left subtree. *) let rebal_right l kv rl rkv rr = if height rr >= height rl then node (node l kv rl) rkv rr else pivot l kv rl rkv rr (** T'-"smart" constructor: fixes trees by performing at most 1 rotation. *) let rotate l ((k,v) as kv) r = match l,r with (* Height 1 tree *) | Empty, Empty -> Leaf(k,v) (* Height 2 tree *) | Empty, Leaf _ | Leaf _, Empty | Leaf _, Leaf _ -> Node(l,k,v,r,2) (* General Height 'h' *) | Node(ll,lk,lv,lr,h), Empty -> if h > HeightDiff.v then rebal_left ll (lk,lv) lr kv r else Node(l,k,v,r,h+1) | Empty, Node(rl,rk,rv,rr,h) -> if h > HeightDiff.v then rebal_right l kv rl (rk,rv) rr else Node(l,k,v,r,h+1) | Leaf _, Node(_,_,_,_,h) (* 1 + for Leaf _ *) | Node(_,_,_,_,h), Leaf _ when h <= (1 + HeightDiff.v) -> Node(l,k,v,r,h+1) | Leaf _, Node(rl,rk,rv,rr,h) -> rebal_right l kv rl (rk,rv) rr | Node(ll,lk,lv,lr,h), Leaf _ -> rebal_left ll (lk,lv) lr kv r | Node(ll,lk,lv,lr,lh), Node(rl,rk,rv,rr,rh) -> if lh > rh + HeightDiff.v then rebal_left ll (lk,lv) lr kv r else if rh > lh + HeightDiff.v then rebal_right l kv rl (rk,rv) rr else node l kv r let rec add cmp k v t = match t with | Empty -> Leaf(k,v) | Leaf(k',v') -> begin match cmp k k' with | 0 -> Leaf(k,v) (* replace existing binding *) | c when c < 0 -> Node(Empty,k,v,t,2) | _ -> Node(t, k,v, Empty,2) end | Node(l,k',v',r,h) -> match cmp k k' with | 0 -> Node(l,k,v,r,h) (* repalce existing binding *) | c when c < 0 -> rotate (add cmp k v l) (k',v') r | _ -> rotate l (k',v') (add cmp k v r) let rec get_and_remove_min = function | Empty -> raise (Invalid_argument "get_and_remove_min") | Leaf(k,v) -> (k, v), Empty | Node(Empty,k,v,r,h) -> (k, v), r | Node(l,k,v,r,h) -> let kv,newl = get_and_remove_min l in kv, rotate newl (k,v) r let rec remove cmp delk t = match t with | Empty -> Empty | Leaf(k,v) | Node(Empty,k,v,Empty,_) -> if (cmp delk k) = 0 then Empty else t | Node(l,k,v,r,_) -> match cmp delk k with | 0 -> if r = Empty then l else if l = Empty then r else let kv,newr = get_and_remove_min r in rotate l kv newr | c when c < 0 -> rotate (remove cmp delk l) (k,v) r | _ -> rotate l (k,v) (remove cmp delk r) (** join trees of arbitrary size *) let rec concat3 cmp l ((k,v) as kv) r = match l,r with | Empty, r -> add cmp k v r | l, Empty -> add cmp k v l | Leaf _, Leaf _ -> node l kv r | Leaf(lk,lv), Node(rl,rk,rv,rr,h) -> if h > (1 + HeightDiff.v) then rotate (concat3 cmp l kv rl) (rk,rv) rr else node l kv r | Node(ll,lk,lv,lr,h), Leaf(rk,rv) -> if h > (1 + HeightDiff.v) then rotate ll (lk,lv) (concat3 cmp lr kv r) else node l kv r | Node(ll,lk,lv,lr,lh),Node(rl,rk,rv,rr,rh) -> if rh > lh + HeightDiff.v then rotate (concat3 cmp l kv rl) (rk,rv) rr else if lh > rh + HeightDiff.v then rotate ll (lk,lv) (concat3 cmp lr kv r) else node l kv r (* equivalent to (split_lt v t), (split_gt v t) *) let rec split cmp k t = match t with | Empty -> Empty, Empty | Leaf(k',v') -> begin match cmp k k' with | 0 -> Empty,Empty | c when c < 0 -> Empty,t | _ -> t,Empty end | Node(l1,k',v',r1,_) -> match cmp k k' with | 0 -> l1,r1 | c when c < 0 -> let l2,r2 = split cmp k l1 in (l2,concat3 cmp r2 (k',v') r1) | _ -> let l2,r2 = split cmp k r1 in (concat3 cmp l1 (k',v') l2), r2 let rec concat t1 t2 = match t1,t2 with | Empty, _ -> t2 | _, Empty -> t1 | Leaf(lk,lv), Leaf(rk,rv) -> Node(t1,rk,rv,Empty,2) | Leaf(lk,lv), Node(rl,rk,rv,rr,h) -> if h > 1+HeightDiff.v then rotate (concat t1 rl) (rk,rv) rr else let kv,t2' = get_and_remove_min t2 in rotate t1 kv t2' | Node(ll,lk,lv,lr,h), Leaf(rk,rv) -> if h > 1+HeightDiff.v then rotate ll (lk,lv) (concat lr t2) else rotate t1 (rk,rv) Empty (* inline get_*_min for Leaf *) | Node(l1,k1,v1,r1,h1), Node(l2,k2,v2,r2,h2) -> if h2 > h1 + HeightDiff.v then rotate (concat t1 l2) (k2,v2) r2 else if h1 > h2 + HeightDiff.v then rotate l1 (k1,v1) (concat r1 t2) else let kv,t2' = get_and_remove_min t2 in rotate t1 kv t2' let add_join cmp f k v t = try let v' = find cmp k t in (* don't call join if the values are physically equal *) if v' == v then add cmp k v t else add cmp k (f k v v') t with Not_found -> add cmp k v t let rec union cmp f t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | Leaf(k,v),r -> add_join cmp f k v r | l,Leaf(k,v) -> add_join cmp f k v l | t1, Node(l,k,v,r,_) -> let l',r' = split cmp k t1 in (** This is slightly inefficient since we could use concat3 if k \in t1, but probably not worth the refactoring *) let t' = concat (union cmp f l' l) (union cmp f r' r) in try let v' = find cmp k t1 in add cmp k (f k v v') t' with Not_found -> add cmp k v t' let rec diff cmp f t1 t2 = match t1,t2 with | Empty, _ -> Empty | _, Empty -> t1 | _, Leaf(k,v2) -> begin try let v1 = find cmp k t1 in if f k v1 v2 (* does the client consider these equal values? *) then remove cmp k t1 (* yes, so remove the binding *) else t1 (* no, so keep the binding *) with Not_found -> t1 end | _, Node(l,k,v2,r,_) -> let l',r' = split cmp k t1 in try let v1 = find cmp k t1 in if f k v1 v2 (* does v1 = v2? *) then concat (diff cmp f l' l) (diff cmp f r' r) (* note k must already be in t1 since find succeeded *) else concat3 cmp (diff cmp f l' l) (k,v1) (diff cmp f r' r) with Not_found -> (* k's not in t1, so the split will contain all of t1 *) concat (diff cmp f l' l) (diff cmp f r' r) let rec inter cmp f t1 t2 = match t1,t2 with | Empty,_ | _,Empty -> Empty | t1, Leaf(k,v) -> begin try let v' = find cmp k t1 in if v == v' then t2 (* already exists with the same physical value *) else Leaf(k, (f k v v')) (* use value from t1 *) with Not_found -> Empty end | t1, Node(l,k,v,r,_) -> let l',r' = split cmp k t1 in begin try let v1 = find cmp k t1 in let v2 = f k v v1 in concat3 cmp (inter cmp f l' l) (k,v2) (inter cmp f r' r) with Not_found -> concat (inter cmp f l' l) (inter cmp f r' r) end let rec mapi f = function | Empty -> Empty | Leaf(k,v) -> let v' = f k v in Leaf(k,v') | Node(l,k,v,r,h) -> let l' = mapi f l in let v' = f k v in let r' = mapi f r in Node(l',k,v',r',h) let map f t = mapi (fun _ v -> f v) t (* let choose = function | Empty -> raise Not_found | Leaf(k,v) -> x | Node(_,x,_,_) -> x *) let rec cardinal = function | Empty -> 0 | Leaf _ -> 1 | Node(l,_,_,r,_) -> 1 + (cardinal l) + (cardinal r) let rec compare kcmp ecmp x y = match (is_empty x), (is_empty y) with | true, true -> 0 | true, false -> -1 | false, true -> 1 | false, false -> let xk,xe = min_keyval x in let yk,ye = min_keyval y in match kcmp xk yk with | 0 -> begin match ecmp xe ye with | 0 -> compare kcmp ecmp (remove kcmp xk x) (remove kcmp yk y) | v -> v end | v -> v let compare_keys kcmp s t = compare kcmp (fun _ _ -> 0) s t let rec well_ordered cmp = function | Empty -> true | Leaf _ -> true | Node(Empty,_,_,Empty,_) -> assert false | Node(((Leaf(lk,_))|Node(_,lk,_,_,_) as l),k,_,Empty,_) -> (well_ordered cmp l) && (cmp lk k < 0) | Node(Empty,k,_,((Leaf(rk,_))|Node(_,rk,_,_,_) as r),_) -> (well_ordered cmp r) && (cmp rk k > 0) | Node(((Leaf(lk,_))|Node(_,lk,_,_,_) as l) ,k,v, ((Leaf(rk,_))|Node(_,rk,_,_,_) as r), _) -> (well_ordered cmp l) && (well_ordered cmp r) && (cmp lk k < 0) && (cmp rk k > 0) let well_formed_height = function | Empty | Leaf _ -> true | Node(l,k,v,r,h) -> let hl = height l in let hr = height r in (h = (max hl hr) + 1) && (abs (hl - hr) <= HeightDiff.v) let rec well_formed cmp t = (well_ordered cmp t) && (well_formed_height t) type ('k,'v) path = | Top | PathL of ('k,'v) path * 'k * 'v * ('k,'v) tree | PathR of ('k,'v) tree * 'k * 'v * ('k,'v) path type ('k,'v) curs = ('k,'v) path * ('k,'v) tree let to_cursor t = Top,t let at_top (p,t) = (p = Top) let at_left (p,t) = match t with | Empty | Leaf _ -> true | _ -> false let at_right (p,t) = match t with | Empty | Leaf _ -> true | _ -> false let went_left (p,t) = match p with | PathL _ -> true | _ -> false let went_right (p,t) = match p with | PathR _ -> true | _ -> false let move_up = function | Top, _ -> failwith "move_up" | PathL(p,k,v,r),l | PathR(l,k,v,p),r -> p, (node l (k,v) r) let move_down_left = function | _,Empty | _, Leaf _ -> failwith "move_down_left" | p, Node(l,k,v,r,h) -> PathL(p,k,v,r),l let move_down_right = function | _,Empty | _, Leaf _ -> failwith "move_down_right" | p,Node(l,k,v,r,h) -> PathR(l,k,v,p),r let rec from_cursor ((p,t) as curs) = if at_top curs then t else from_cursor (move_up curs) let has_value (p,t) = match t with Empty -> false | _ -> true let get_value = function | _,Empty -> failwith "get_value" | _,Leaf(k,v) | _,Node(_,k,v,_,_) -> k,v let rec move_to_ancestor cmp x ((p,t) as curs) = match p with | Top -> curs | PathL(p', k, v, r) -> if cmp x k < 0 then curs else move_to_ancestor cmp k (move_up curs) | PathR(_,k,v,_) -> if cmp x k > 0 then curs else move_to_ancestor cmp k (move_up curs) let rec move_to cmp x curs = let (p,t) as curs = move_to_ancestor cmp x curs in match t with | Empty -> raise Not_found | Leaf(k,v) -> if (cmp x k) = 0 then curs else raise Not_found | Node(l,k,v,r,_) -> match cmp x k with | 0 -> curs | c when c < 0 -> move_to cmp x (move_down_left curs) | _ -> move_to cmp x (move_down_right curs) let rec to_string to_s t = let rec h = function | Empty -> "" | Leaf(k,v) -> to_s k v | Node(Empty,k,v,Empty,_) -> to_s k v | Node(l,k,v,Empty,_) -> Printf.sprintf "%s, %s" (h l) (to_s k v) | Node(Empty,k,v,r,_) -> Printf.sprintf "%s, %s" (to_s k v) (h r) | Node(l,k,v,r,_) -> Printf.sprintf "%s, %s, %s" (h l) (to_s k v) (h r) in "{" ^ (h t) ^ "}" let gen_ cmp (kgen: ?size:int -> Random.State.t -> 'k) (egen: ?size:int -> Random.State.t -> 'v) ?(size=50) rs : ('k,'v) tree = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else let k = kgen ~size:size rs in let v = egen ~size:size rs in loop (n-1) (add cmp k v t) in loop num empty end module AVL_KeyMap (HeightDiff : sig val v : int end) (C : Types.Mono.Comparable) = struct module BH = BaseMap(HeightDiff) include BH (* include Cursor.Mixin(BH)*) type key = C.t type 'a key_ = key type 'e elt = 'e type 'e elt_ = 'e type 'v t = (key,'v) tree type ('k,'v) map = 'v t type 'v cursor = (C.t,'v) curs type ('k,'v) cursor_ = 'v cursor type ('a,'v) result = 'a type ('a,'k,'v) result_ = 'a let add x t = add C.compare x t let mem x t = mem C.compare x t let remove x t = remove C.compare x t let find x t = find C.compare x t let split v t = split C.compare v t let union f t1 t2 = union C.compare f t1 t2 let diff f t1 t2 = diff C.compare f t1 t2 let inter f t1 t2 = inter C.compare f t1 t2 let well_formed t = well_formed C.compare t let move_to_ancestor cmp x c = move_to_ancestor C.compare x c let compare x y = compare C.compare x y let compare_keys t1 t2 = compare_keys C.compare t1 t2 (* let equal x y = compare x y = 0*) let to_string to_s t = to_string (fun k v -> Printf.sprintf "(%s => %s)" (C.to_string k) (to_s v) ) t (*include Merge_mixin.Make(B)*) (* need to eta expand these to properly generalize the type variables *) let gen2 (kgen: ?size:int -> Random.State.t -> 'k) (egen: ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen_ C.compare kgen egen ?size rs end module MonoKey1 = AVL_KeyMap(struct let v = 1 end) module MonoKey2 = AVL_KeyMap(struct let v = 2 end) module MonoKey3 = AVL_KeyMap(struct let v = 3 end) module MonoKeyMap = MonoKey2 module AVL_GenKeyMap (HeightDiff : sig val v : int end) (C : Types.Mono.ArbitraryComparable) = struct include AVL_KeyMap(HeightDiff)(C) let gen1 (agen : (?size:int -> Random.State.t -> 'a)) ?size rs : 'a t = gen2 C.gen agen ?size rs end module GenKey1 = AVL_GenKeyMap(struct let v = 1 end) module GenKey2 = AVL_GenKeyMap(struct let v = 2 end) module GenKey3 = AVL_GenKeyMap(struct let v = 3 end) module GenKeyMap = GenKey2 module AVL_PMap (HeightDiff : sig val v : int end) = struct module BH = BaseMap(HeightDiff) include BH (* include Cursor.Mixin(BH)*) type 'a key = 'a type 'a key_ = 'a type 'e elt = 'e type 'e elt_ = 'e type ('k,'v) t = ('k,'v) tree type ('k,'v) map = ('k,'v) t type ('k,'v) cursor = ('k,'v) curs type ('k,'v) cursor_ = ('k,'v) cursor type ('a,'k,'v) result = 'a type ('a,'k,'v) result_ = 'a let add x t = add Pervasives.compare x t let mem x t = mem Pervasives.compare x t let remove x t = remove Pervasives.compare x t let find x t = find Pervasives.compare x t let split v t = split Pervasives.compare v t let union f t1 t2 = union Pervasives.compare f t1 t2 let diff f t1 t2 = diff Pervasives.compare f t1 t2 let inter f t1 t2 = inter Pervasives.compare f t1 t2 let well_formed t = well_formed Pervasives.compare t let move_to_ancestor cmp x c = move_to_ancestor Pervasives.compare x c (* let equal x y = compare x y = 0*) let gen2 (kgen: ?size:int -> Random.State.t -> 'k) (egen: ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen_ Pervasives.compare kgen egen ?size rs (*include Merge_mixin.Make(B)*) end module Poly1 = AVL_PMap(struct let v = 1 end) module Poly2 = AVL_PMap(struct let v = 2 end) module Poly3 = AVL_PMap(struct let v = 3 end) module PolyMap = Poly2 module AVL_Map (HeightDiff : sig val v : int end) (K : Types.Mono.Comparable) (E : Types.Mono.Comparable) = struct module BH = BaseMap(HeightDiff) include BH (* include Cursor.Mixin(BH)*) type key = K.t type 'a key_ = key type elt = E.t type 'e elt_ = elt type t = (key,elt) tree type ('k,'v) map = t type cursor = (K.t,E.t) curs type ('k,'v) cursor_ = cursor type 'a result = 'a type ('a,'k,'v) result_ = 'a let add x t = add K.compare x t let mem x t = mem K.compare x t let remove x t = remove K.compare x t let find x t = find K.compare x t let split v t = split K.compare v t let union f t1 t2 = union K.compare f t1 t2 let diff f t1 t2 = diff K.compare f t1 t2 let inter f t1 t2 = inter K.compare f t1 t2 let well_formed t = well_formed K.compare t let move_to_ancestor cmp x c = move_to_ancestor K.compare x c let compare x y = compare K.compare E.compare x y let compare_keys t1 t2 = compare_keys K.compare t1 t2 let to_string t = to_string (fun k v -> Printf.sprintf "(%s => %s)" (K.to_string k) (E.to_string v) ) t (*include Merge_mixin.Make(B)*) let gen2 (kgen: ?size:int -> Random.State.t -> 'k) (egen: ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen_ Pervasives.compare kgen egen ?size rs end module Mono1 = AVL_Map(struct let v = 1 end) module Mono2 = AVL_Map(struct let v = 2 end) module Mono3 = AVL_Map(struct let v = 3 end) module MonoMap = Mono2 module AVL_GenMap (HeightDiff : sig val v : int end) (K : Types.Mono.ArbitraryComparable) (E : Types.Mono.ArbitraryComparable) = struct include AVL_Map(HeightDiff)(K)(E) let gen ?size rs = gen_ K.compare K.gen E.gen ?size rs end module Gen1 = AVL_GenMap(struct let v = 1 end) module Gen2 = AVL_GenMap(struct let v = 2 end) module Gen3 = AVL_GenMap(struct let v = 3 end) module GenMap = Gen2 ocaml-reins-0.1a/src/map/maps.ml0000644000175000017500000001432310676520540015642 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types module type Map_ = sig type 'k key_ type 'e elt_ type ('k,'e) map (* The {bool,key}_result_ types are used for operations that may either return just a bool (key resp.) or a bool and something else (key and something else resp.) . Most trees conform to the former, while splay trees use the latter (e.g. the mem function may modify the tree) *) type ('a,'k,'e) result_ val empty : ('k, 'e) map val is_empty : ('k, 'e) map -> bool val mem : 'k key_ -> ('k, 'e) map -> (bool,'k,'e) result_ val add : 'k key_ -> 'e elt_ -> ('k, 'e) map -> ('k, 'e) map val singleton : 'k key_ -> 'e elt_ -> ('k, 'e) map val remove : 'k key_ -> ('k, 'e) map -> ('k, 'e) map val find : 'k key_ -> ('k,'e) map -> ('e elt_,'k,'e) result_ val min_key : ('k, 'e) map -> ('k key_,'k,'e) result_ val max_key : ('k, 'e) map -> ('k key_,'k,'e) result_ val min_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ val max_keyval : ('k, 'e) map -> ('k key_ * 'e elt_,'k,'e) result_ val cardinal : ('k, 'e) map -> int val iter : ('k key_ -> 'e elt_ -> unit) -> ('k, 'e) map -> unit val fold : ('acc -> 'k key_ -> 'e elt_ -> 'acc) -> 'acc -> ('k, 'e) map -> 'acc val map : ('e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map val mapi : ('k key_ -> 'e elt_ -> 'f elt_) -> ('k, 'e) map -> ('k, 'f) map val union : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map val inter : ('k key_ -> 'e elt_ -> 'e elt_ -> 'e elt_) -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map val diff : ('k key_ -> 'e elt_ -> 'e elt_ -> bool) -> ('k, 'e) map -> ('k, 'e) map -> ('k, 'e) map val well_formed : ('k, 'e) map -> bool val of_result : ('a,'k,'e) result_ -> 'a type ('k, 'e) cursor_ val to_cursor : ('k, 'e) map -> ('k, 'e) cursor_ val from_cursor : ('k, 'e) cursor_ -> ('k, 'e) map val at_top : ('k, 'e) cursor_ -> bool val at_left : ('k, 'e) cursor_ -> bool val at_right : ('k, 'e) cursor_ -> bool val move_up : ('k, 'e) cursor_ -> ('k, 'e) cursor_ val move_down_left : ('k, 'e) cursor_ -> ('k, 'e) cursor_ val move_down_right : ('k, 'e) cursor_ -> ('k, 'e) cursor_ val went_left : ('k, 'e) cursor_ -> bool val went_right : ('k, 'e) cursor_ -> bool val has_value : ('k, 'e) cursor_ -> bool val get_value : ('k, 'e) cursor_ -> 'k key_ * 'e elt_ end module type PolyMapSig = sig type ('k,'e) t type 'k key = 'k type 'e elt = 'e type ('k,'e) cursor type ('a,'k,'v) result include Map_ with type 'a key_ = 'a and type 'e elt_ = 'e and type ('k,'e) map = ('k,'e) t and type ('k,'e) cursor_ = ('k, 'e) cursor and type ('a,'k,'v) result_ = ('a,'k,'v) result val gen2 : (?size:int -> Random.State.t -> 'k key_) -> (?size:int -> Random.State.t -> 'e elt_) -> ?size:int -> Random.State.t -> ('k, 'e) map val to_string : ('k -> 'e -> string) -> ('k, 'e) map -> string val compare : ('k -> 'k -> int) -> ('e -> 'e -> int) -> ('k,'e) t -> ('k,'e) t -> int val compare_keys : ('k -> 'k -> int) -> ('k,'e) t -> ('k,'e) t -> int end module type PolyMapSigStd = PolyMapSig with type ('a,'k,'v) result = 'a module type MonoKeyMapSig = sig type 'e t type key type 'e elt = 'e type 'e cursor type ('a,'v) result include Map_ with type 'k key_ = key and type 'e elt_ = 'e and type ('k,'e) map = 'e t and type ('k,'e) cursor_ = 'e cursor and type ('a,'k,'v) result_ = ('a,'v) result val compare_keys : 'e t -> 'e t -> int val compare : ('e -> 'e -> int) -> 'e t -> 'e t -> int val to_string : ('e -> string) -> 'e t -> string val gen2 : (?size:int -> Random.State.t -> key) -> (?size:int -> Random.State.t -> 'a) -> ?size:int -> Random.State.t -> 'a t end module type MonoKeyMapSigStd = MonoKeyMapSig with type ('a,'v) result = 'a module type MonoKeyMapSigFnStd = functor(C : Types.Mono.Comparable) -> MonoKeyMapSigStd with type key = C.t module type GenKeyMapSig = sig include MonoKeyMapSig val gen1 : (?size:int -> Random.State.t -> 'e) -> ?size:int -> Random.State.t -> 'e t end module type GenKeyMapSigStd = GenKeyMapSig with type ('a,'v) result = 'a module type GenKeyMapSigFnStd = functor(C : Types.Mono.ArbitraryComparable) -> GenKeyMapSigStd with type key = C.t module type MonoMapSig = sig type t type key type elt type cursor type 'a result include Map_ with type 'k key_ = key and type 'e elt_ = elt and type ('k,'e) map = t and type ('k,'e) cursor_ = cursor and type ('a,'k,'v) result_ = 'a result val compare_keys : t -> t -> int val compare : t -> t -> int val to_string : t -> string val gen2 : (?size:int -> Random.State.t -> key) -> (?size:int -> Random.State.t -> elt) -> ?size:int -> Random.State.t -> t end module type MonoMapSigFn = functor(K : Types.Mono.Comparable) -> functor(V : Types.Mono.Comparable) -> MonoMapSig with type key = K.t and type elt = V.t module type MonoMapSigFnStd = functor(K : Types.Mono.Comparable) -> functor(V : Types.Mono.Comparable) -> MonoMapSig with type key = K.t and type elt = V.t and type 'a result = 'a module type GenMapSig = sig include MonoMapSig val gen : ?size:int -> Random.State.t -> t end module type GenMapSigFn = functor(K : Types.Mono.ArbitraryComparable) -> functor(V : Types.Mono.ArbitraryComparable) -> GenMapSig with type key = K.t and type elt = V.t module type GenMapSigFnStd = functor(K : Types.Mono.ArbitraryComparable) -> functor(V : Types.Mono.ArbitraryComparable) -> GenMapSig with type key = K.t and type elt = V.t and type 'a result = 'a ocaml-reins-0.1a/src/map/rBMap.ml0000644000175000017500000005033110676520540015702 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) module BaseMap = struct (* Red/Black Trees follow: 1) all nodes are Red or Black 2) The root is black 3) Empty Trees (i.e. leafs) are black 4) Both children of a red node are black 5) Every path from a leaf to the root has the same "black height" *) (* save a cell by encoding the color in the constructor *) type ('a,'b) tree = | Empty | RNode of ('a,'b) tree * 'a * 'b * ('a,'b) tree | BNode of ('a,'b) tree * 'a * 'b * ('a,'b) tree let of_result x = x let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton k v = BNode(Empty,k,v,Empty) let is_black = function | Empty -> true | BNode _ -> true | RNode _ -> false let rec black_height t = let rec bh acc = function | Empty -> 1+acc | RNode(l,_,_,r) -> bh acc l | BNode(l,_,_,r) -> bh (acc+1) l in bh 0 t (* true if the top of sub is lt x *) let sub_lt cmp x sub = match sub with | RNode(_,k,_,_) | BNode(_,k,_,_) -> cmp k x < 0 | _ -> assert false let sub_gt cmp x sub = match sub with | RNode(_,k,_,_) | BNode(_,k,_,_) -> cmp k x > 0 | _ -> assert false let rec well_ordered cmp = function | Empty -> true | RNode(Empty,_,_,Empty) | BNode(Empty,_,_,Empty) -> true | BNode(Empty,k,_,r) | RNode(Empty,k,_,r) -> sub_gt cmp k r && well_ordered cmp r | BNode(l,k,_,Empty) | RNode(l,k,_,Empty) -> sub_lt cmp k l && well_ordered cmp l | RNode(l,e,_,r) | BNode(l,e,_,r) -> sub_lt cmp e l && sub_gt cmp e r && well_ordered cmp l && well_ordered cmp r let rec check_red_children = function | Empty -> true | BNode(l,_,_,r) -> check_red_children l && check_red_children r | RNode(l,_,_,r) -> is_black l && is_black r && check_red_children l && check_red_children r let rec check_black_height = function | Empty -> true | RNode(l,_,_,r) | BNode(l,_,_,r) -> if ((black_height l) = (black_height r)) then (check_black_height l) && (check_black_height r) else failwith "black height is off" let well_formed cmp t = well_ordered cmp t && is_black t && (* prop 2 *) check_red_children t && (* prop 4 *) check_black_height t (* prop 5 *) let rec to_string to_s t = let rec h = function | Empty -> "" | RNode(Empty,k,v,Empty) | BNode(Empty,k,v,Empty) -> to_s k v | RNode(l,k,v,Empty) | BNode(l,k,v,Empty) -> Printf.sprintf "%s, %s" (h l) (to_s k v) | RNode(Empty,k,v,r) | BNode(Empty,k,v,r) -> Printf.sprintf "%s, %s" (to_s k v) (h r) | RNode(l,k,v,r) | BNode(l,k,v,r) -> Printf.sprintf "%s, %s, %s" (h l) (to_s k v) (h r) in "{" ^ (h t) ^ "}" let rec min_keyval t = match t with | Empty -> raise Not_found | RNode(Empty,k,v,_) | BNode(Empty,k,v,_) -> k,v | RNode(l,_,_,_) | BNode(l,_,_,_) -> min_keyval l let rec max_keyval t = match t with | Empty -> raise Not_found | RNode(_,k,v,Empty) | BNode(_,k,v,Empty) -> k,v | RNode(_,_,_,r) | BNode(_,_,_,r) -> max_keyval r let min_key t = fst (min_keyval t) let max_key t = fst (max_keyval t) let rec find cmp x t = match t with | Empty -> raise Not_found | RNode(l,k,v,r) | BNode(l,k,v,r) -> match cmp x k with | 0 -> v | c when c < 0 -> find cmp x l | _ -> find cmp x r let mem cmp x t = try ignore(find cmp x t);true with Not_found -> false (* Okasaki's rebalancing constructor *) let bal_l l (k,v) r = match l with | RNode(RNode(t1,k1,v1,t2),k2,v2,t3) | RNode(t1,k1,v1,RNode(t2,k2,v2,t3)) -> RNode(BNode(t1,k1,v1,t2),k2,v2,BNode(t3,k,v,r)) | _ -> BNode(l,k,v,r) let bal_r l (k,v) r = match r with | RNode(RNode(t2,k2,v2,t3),k3,v3,t4) | RNode(t2,k2,v2,RNode(t3,k3,v3,t4)) -> RNode(BNode(l,k,v,t2),k2,v2,BNode(t3,k3,v3,t4)) | _ -> BNode(l,k,v,r) let rec ins cmp x y t = match t with | Empty -> RNode(Empty,x,y,Empty) | RNode(l,k,v,r) -> begin match cmp x k with | 0 -> t (* impossible to violate black height property with a red node here, so no need to rebalance *) | c when c < 0 -> RNode(ins cmp x y l,k,v,r) | _ -> RNode(l,k,v,ins cmp x y r) end | BNode(l,k,v,r) -> begin match cmp x k with | 0 -> t | c when c < 0 -> bal_l (ins cmp x y l) (k,v) r | _ -> bal_r l (k,v) (ins cmp x y r) end let blackify = function | RNode(l,k,v,r) -> BNode(l,k,v,r) | t -> t let add cmp x y t = blackify (ins cmp x y t) let redify = function | BNode(l,k,v,r) -> RNode(l,k,v,r) | _ -> assert false let balance l (k,v) r = match l,k,v,r with (* TODO: investigate this first constructor proposed by Kahrs. Is it better to move Red nodes up?*) | RNode(a,xk,xv,b),yk,yv,RNode(c,zk,zv,d) | RNode(RNode(a,xk,xv,b),yk,yv,c),zk,zv,d | RNode(a,xk,xv,RNode(b,yk,yv,c)),zk,zv,d | a,xk,xv,RNode(b,yk,yv,RNode(c,zk,zv,d)) | a,xk,xv,RNode(RNode(b,yk,yv,c),zk,zv,d) -> RNode(BNode(a,xk,xv,b),yk,yv,BNode(c,zk,zv,d)) | a,k,v,b -> BNode(a,k,v,b) let balleft l ((k,v) as elt) r = match l with | RNode(ll,lk,lv,lr) -> RNode(BNode(ll,lk,lv,lr),k,v,r) | _ -> match r with | BNode(rl,rk,rv,rr) -> balance l elt (RNode(rl,rk,rv,rr)) | RNode(BNode(a,yk,yv,b),zk,zv,c) -> RNode(BNode(l,k,v,a), yk, yv, (balance b (zk,zv) (redify c))) | _ -> assert false let balright l ((k,v) as elt) r = match r with | RNode(b,yk,yv,c) -> RNode(l,k,v,BNode(b,yk,yv,c)) | _ -> match l with | BNode(a,xk,xy,b) -> balance (RNode(a,xk,xy,b)) elt r | RNode(a,xk,xv,BNode(b,yk,yv,c)) -> RNode(balance (redify a) (xk,xv) b, yk, yv, (BNode(c,k,v,l))) | _ -> assert false let rec app l r = match l,r with | Empty,_ -> r | _,Empty -> l | RNode(a,xk,xv,b), RNode(c,yk,yv,d) -> begin match app b c with | RNode(b',zk,zv,c') -> RNode(RNode(a,xk,xv,b'),zk,zv,RNode(c',yk,yv,d)) | bc -> RNode(a,xk,xv,RNode(bc,yk,yv,d)) end | BNode(a,xk,xv,b), BNode(c,yk,yv,d) -> begin match app b c with | RNode(b',zk,zv,c') -> RNode(BNode(a,xk,xv,b'),zk,zv,BNode(c',yk,yv,d)) | bc -> balleft a (xk,xv) (BNode(bc, yk, yv, d)) end | a, RNode(b,xk,xv,c) -> RNode(app a b, xk,xv, c) | RNode(a,xk,xv,b), c -> RNode(a,xk,xv,app b c) (* based on Stefan Kahrs work on RB trees *) let rec del cmp x t = match t with | Empty -> Empty | BNode(l,k,v,r) | RNode(l,k,v,r) -> match cmp x k with | 0 -> app l r | c when c < 0 -> del_left cmp x l (k,v) r | _ -> del_right cmp x l (k,v) r and del_left cmp x l ((k,v) as elt) r = match l with | BNode _ -> balleft (del cmp x l) elt r | _ -> RNode(del cmp x l, k,v, r) and del_right cmp x l ((k,v) as elt) r = match r with | BNode _ -> balright l elt (del cmp x r) | _ -> RNode(l,k,v,del cmp x r) let remove cmp x t = blackify (del cmp x t) (* join trees of arbitrary size *) (* This is still really inefficient since it keeps calling black_height which O(log n) raising this to O(n log n). Should only call these once in union/diff/inter and then keep track of local differences. *) let rec concat3h cmp l (k,v) r hl hr = match hl - hr with | 0 -> begin match l,r with | BNode _, BNode _ -> RNode(l,k,v,r) | _ -> BNode(l,k,v,r) end | -1 -> (* r has at exactly 1 extra black node *) begin match l,r with | _, Empty -> assert false (* r must have at least 2 black nodes *) | RNode(ll,lk,lv,lr),_ -> (* if l is red, just color it black to match r *) BNode(BNode(ll,lk,lv,lr),k,v,r) | _,RNode(rl,rk,rv,rr) -> (* rl and rr must be black by (4) *) (* recurse to force l=blk rl=blk *) balance (concat3h cmp l (k,v) rl hl hr) (rk,rv) rr | _,BNode(rl,rk,rv,rr) -> begin match rl,rr with | (BNode _|Empty), (BNode _|Empty) -> (*both black, so color their parent red to drop BH, then use bnode as parent to restore height *) BNode(l,k,v,RNode(rl,rk,rv,rr)) | RNode _, RNode _ -> (* push black down to rr and connect rl with l *) RNode(BNode(l,k,v,rl),rk,rv, blackify(rr)) | (BNode _|Empty), RNode _ -> (* RNode(l,v,rl) will have same height as rr *) BNode(RNode(l,k,v,rl),rk,rv,rr) | RNode(rll,rlk,rlv,rlr), (BNode _|Empty) -> (* rll and rlr are black, and all of l,rll,rlr,rr have same BH *) RNode(BNode(l,k,v,rll), rlk, rlv, BNode(rlr,rk, rv,rr)); end end | 1 -> (* l has at exactly 1 extra black node *) begin match l,r with | Empty,_ -> assert false (* l must have at least 2 black nodes *) | _,RNode(rl,rk,rv,rr) -> (* if r is red, just color it black to match l *) BNode(l,k,v,BNode(rl,rk,rv,rr)) | RNode(ll,lk,lv,lr),_ -> (* ll and lr must be black by (4) *) (* recurse to force l=blk rl=blk *) balance ll (lk,lv) (concat3h cmp lr (k,v) r hl hr) | BNode(ll,lk,lv,lr),_ -> begin match ll,lr with | (BNode _|Empty), (BNode _|Empty) -> (*both black, so color their parent red to drop BH, then use bnode as parent to restore height *) BNode(RNode(ll,lk,lv,lr),k,v,r) | RNode _, RNode _ -> (* push black down to ll and connect lr with r *) RNode(blackify(ll),lk,lv,BNode(lr,k,v,r)) | (BNode _|Empty), RNode(lrl,lrk,lrv,lrr) -> (* lrl and lrr are black, and all of l,rll,rlr,rr have same BH *) RNode(BNode(ll,lk,lv,lrl), lrk, lrv, BNode(lrr,k,v,r)) | RNode _, (BNode _|Empty) -> (* RNode(lr,v,r) will have same height as ll *) BNode(ll,lk,lv,RNode(lr,k,v,r)) end end | c when c < -1 -> (* r has at least 2 more black nodes *) begin match r with | Empty -> assert false | RNode(rl,rk,rv,rr) -> let t1 = concat3h cmp l (k,v) rl hl hr in let hl = black_height t1 in let t2 = concat3h cmp t1 (rk,rv) rr hl hr in t2 | BNode(rl,rk,rv,rr) -> let t1 = concat3h cmp l (k,v) rl hl (hr-1) in let hl = black_height t1 in let t2 = concat3h cmp t1 (rk,rv) rr hl (hr-1)in t2 end | _ -> match l with (* l has at least 2 more black nodes *) | Empty -> assert false | RNode(ll,lk,lv,lr) -> let t1 = concat3h cmp lr (k,v) r hl hr in let hr = black_height t1 in let t' = concat3h cmp ll (lk,lv) t1 hl hr in t' | BNode(ll,lk,lv,lr) -> let t1 = concat3h cmp lr (k,v) r (hl-1) hr in let hr = black_height t1 in let t' = concat3h cmp ll (lk,lv) t1 (hl-1) hr in t' and concat3 cmp l v r = let hl = black_height l in let hr = black_height r in concat3h cmp l v r hl hr let rec split cmp s t = match t with | Empty -> Empty, Empty | BNode(l1,k,v,r1) | RNode(l1,k,v,r1) -> match cmp s k with | 0 -> l1,r1 | c when c < 0 -> let l2,r2 = split cmp s l1 in let t' = concat3 cmp r2 (k,v) r1 in (l2,t') | _ -> let l2,r2 = split cmp s r1 in let t' = concat3 cmp l1 (k,v) l2 in t', r2 (* Inefficient, easy version for now *) let get_and_remove_min cmp t = let (k,v as kv) = min_keyval t in kv, (remove cmp k t) (* Inefficient, easy version for now *) let concat cmp t1 t2 = if is_empty t2 then t1 else let rm,t2 = get_and_remove_min cmp t2 in concat3 cmp t1 rm t2 let union cmp f t1 t2 = let rec u t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | t1, (BNode(l,k,v,r) | RNode(l,k,v,r)) -> let l',r' = split cmp k t1 in let t' = concat cmp (u l' l) (u r' r) in try let v' = find cmp k t1 in add cmp k (f k v v') t' with Not_found -> add cmp k v t' in blackify (u t1 t2) let rec diff cmp f t1 t2 = let rec helper t1 t2 = match t1,t2 with | Empty, _ -> Empty | _, Empty -> t1 | _, (BNode(l,k,v,r)|RNode(l,k,v,r)) -> let l',r' = split cmp k t1 in concat cmp (helper l' l) (helper r' r) in blackify (helper t1 t2) let rec inter cmp f t1 t2 = match t1,t2 with | Empty,_ | _,Empty -> Empty | t1, (BNode(l,k,v,r)|RNode(l,k,v,r)) -> let l',r' = split cmp k t1 in let t = begin try let v1 = find cmp k t1 in let v2 = f k v v1 in concat3 cmp (inter cmp f l' l) (k,v2) (inter cmp f r' r) with Not_found ->concat cmp (inter cmp f l' l) (inter cmp f r' r) end in blackify t let rec mapi f = function | Empty -> Empty | RNode(l,k,v,r) -> RNode(mapi f l, k, f k v, mapi f r) | BNode(l,k,v,r) -> BNode(mapi f l, k, f k v, mapi f r) let map f t = mapi (fun _ v -> f v) t let rec cardinal = function | Empty -> 0 | BNode(l,_,_,r) | RNode(l,_,_,r) -> 1 + (cardinal l) + (cardinal r) let rec iter f = function | Empty -> () | RNode(l,k,v,r) | BNode(l,k,v,r) -> iter f l; f k v; iter f r let rec fold f acc t = match t with | Empty -> acc | RNode(l,k,v,r) | BNode(l,k,v,r) -> fold f (f (fold f acc l) k v) r type ('a,'b) path = | Top | PathL of ('a,'b) path * 'a * 'b * ('a,'b) tree * bool (* is_black *) | PathR of ('a,'b) tree * 'a * 'b * ('a,'b) path * bool (* is_black *) type ('a,'b) curs = ('a,'b) path * ('a,'b) tree let to_cursor c = Top, c let has_value = function | _,Empty -> false | _ -> true let get_value = function | _,Empty -> failwith "get_value" | _,RNode(_,k,v,_) | _,BNode(_,k,v,_) -> k,v let at_top = function (Top,_) -> true | _ -> false let at_left (_,t) = match t with | Empty -> true | _ -> false let at_right (_,t) = match t with | Empty -> true | _ -> false let went_left = function PathL _,_ -> true | _ -> false let went_right = function PathR _,_ -> true | _ -> false let try_color blk t = if blk then blackify t else match t with (* try to color t red *) | Empty -> t (* can't *) | RNode _ -> t (* already *) | BNode(l', k', v', r') -> if is_black l' && is_black r' then RNode(l',k', v',r') (* can change to red and still satisfy (4) *) else t (* have to leave it black *) let move_up cmp = function | Top, _ -> failwith "move_up" | PathL(p,k,v,r,blk),l | PathR(l,k,v,p,blk),r -> let t = concat3 cmp l (k,v) r in (* We try and keep the same color as the original tree if possible so that we don't do any unnecessary rotations when rebuilding the tree. Besides being more efficient, this is also required to make traversals work properly (otherwise the tree might rotate in the middle of the traversal, giving incorrect results *) let t = try_color blk t in p, t let move_down_left = function | _,Empty -> failwith "move_down_left" | p, RNode(l,k,v,r) -> PathL(p,k,v,r,false),l | p, BNode(l,k,v,r) -> PathL(p,k,v,r,true),l let move_down_right = function | _,Empty -> failwith "move_down_right" | p,RNode(l,k,v,r) -> PathR(l,k,v,p,false),r | p,BNode(l,k,v,r) -> PathR(l,k,v,p,true),r let rec from_cursor cmp curs = if at_top curs then blackify (snd curs) else from_cursor cmp (move_up cmp curs) (** Step the cursor one position "in-order". Does not keep any state *) let rec step_io = function | Top, Empty -> raise Exit | PathL(p,k,v,r,_),Empty -> (k,v),(p,r) | p, RNode(l,k,v,r) -> step_io (PathL(p,k,v,r,false),l) | p, BNode(l,k,v,r) -> step_io (PathL(p,k,v,r,true),l) | PathR _, Empty -> assert false let can_step = function Top, Empty -> false | _ -> true let compare kcmp vcmp t1 t2 = let rec helper c1 c2 = match (can_step c1), (can_step c2) with | false, false -> 0 | true, false -> -1 | false, true -> 1 | true, true -> let (k1,v1),c1 = step_io c1 in let (k2,v2),c2 = step_io c2 in match kcmp k1 k2 with | 0 -> let c = vcmp v1 v2 in if c = 0 then helper c1 c2 else c | c -> c in helper (to_cursor t1) (to_cursor t2) let compare_keys kcmp t1 t2 = compare kcmp (fun _ _ -> 0) t1 t2 let gen_ cmp (kgen:?size:int -> Random.State.t -> 'a) (vgen:?size:int -> Random.State.t -> 'b) ?(size=50) rs : ('a,'b) tree = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else let k = kgen ~size:size rs in let v = vgen ~size:size rs in loop (n-1) (add cmp k v t) in loop num empty end module PolyMap = struct include BaseMap type 'a key = 'a type 'a key_ = 'a type 'e elt = 'e type 'e elt_ = 'e type ('k,'v) t = ('k,'v) tree type ('k,'v) map = ('k,'v) t type ('k,'v) cursor = ('k,'v) curs type ('k,'v) cursor_ = ('k,'v) cursor type ('a,'k,'v) result = 'a type ('a,'k,'v) result_ = 'a let add x t = add Pervasives.compare x t let mem x t = mem Pervasives.compare x t let remove x t = remove Pervasives.compare x t let find x t = find Pervasives.compare x t let union f t1 t2 = union Pervasives.compare f t1 t2 let diff f t1 t2 = diff Pervasives.compare f t1 t2 let inter f t1 t2 = inter Pervasives.compare f t1 t2 let well_formed t = well_formed Pervasives.compare t let from_cursor c = from_cursor Pervasives.compare c let move_up c = move_up Pervasives.compare c let gen2 (kgen: ?size:int -> Random.State.t -> 'k) (egen: ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen_ Pervasives.compare kgen egen ?size rs end module MonoKeyMap(C : Types.Mono.Comparable) = struct include BaseMap type key = C.t type 'a key_ = C.t type 'e elt = 'e type 'e elt_ = 'e type 'v t = (C.t,'v) tree type ('k,'v) map = 'v t type 'v cursor = (C.t,'v) curs type ('k,'v) cursor_ = 'v cursor type ('a,'v) result = 'a type ('a,'k,'v) result_ = 'a let add x t = add C.compare x t let mem x t = mem C.compare x t let remove x t = remove C.compare x t let find x t = find C.compare x t let union f t1 t2 = union C.compare f t1 t2 let diff f t1 t2 = diff C.compare f t1 t2 let inter f t1 t2 = inter C.compare f t1 t2 let well_formed t = well_formed C.compare t let from_cursor c = from_cursor C.compare c let move_up c = move_up C.compare c let compare vcmp t1 t2 = compare C.compare vcmp t1 t2 let compare_keys t1 t2 = compare_keys C.compare t1 t2 let to_string to_s t = to_string (fun k v -> Printf.sprintf "(%s => %s)" (C.to_string k) (to_s v) ) t let gen2 (kgen: ?size:int -> Random.State.t -> 'k) (egen: ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen_ C.compare kgen egen ?size rs end module GenKeyMap(C : Types.Mono.ArbitraryComparable) = struct include MonoKeyMap(C) let gen1(egen: ?size:int -> Random.State.t -> 'v) ?size rs : 'v t = gen2 C.gen egen ?size rs end module MonoMap (K : Types.Mono.Comparable) (V : Types.Mono.Comparable) = struct include BaseMap type key = K.t type 'a key_ = K.t type elt = V.t type 'e elt_ = elt type t = (K.t,V.t) tree type ('k,'v) map = t type cursor = (K.t,V.t) curs type ('k,'v) cursor_ = cursor type 'a result = 'a type ('a,'k,'v) result_ = 'a let add x t = add K.compare x t let mem x t = mem K.compare x t let remove x t = remove K.compare x t let find x t = find K.compare x t let union f t1 t2 = union K.compare f t1 t2 let diff f t1 t2 = diff K.compare f t1 t2 let inter f t1 t2 = inter K.compare f t1 t2 let well_formed t = well_formed K.compare t let from_cursor c = from_cursor K.compare c let move_up c = move_up K.compare c let compare t1 t2 = compare K.compare V.compare t1 t2 let compare_keys t1 t2 = compare_keys K.compare t1 t2 let to_string t = to_string (fun k v -> Printf.sprintf "(%s => %s)" (K.to_string k) (V.to_string v) ) t let gen2 (kgen: ?size:int -> Random.State.t -> 'k) (egen: ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen_ K.compare kgen egen ?size rs end module GenMap (K : Types.Mono.ArbitraryComparable) (V : Types.Mono.ArbitraryComparable) = struct include MonoMap(K)(V) let gen ?size rs = gen2 K.gen V.gen ?size rs end ocaml-reins-0.1a/src/map/patriciaMap.mli0000644000175000017500000000211010676520540017274 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) (** Efficient maps over integers *) module MonoKeyMap : Maps.MonoKeyMapSig with type key = int and type 'e elt = 'e module GenKeyMap : Maps.GenKeyMapSig with type key = int and type 'e elt = 'e module MonoMap : functor(C : Types.Mono.Comparable) -> Maps.MonoMapSig with type key = int and type elt = C.t module GenMap : functor(C : Types.Mono.ArbitraryComparable) -> Maps.GenMapSig with type key = int and type elt = C.t ocaml-reins-0.1a/src/map/OMakefile0000644000175000017500000000022610672112566016125 0ustar furrmfurrm OCAMLINCLUDES += ../base ../iterator FILES[] += map/maps map/aVLMap map/splayMap map/rBMap map/patriciaMap ocaml-reins-0.1a/src/map/splayMap.ml0000644000175000017500000003315110676520540016470 0ustar furrmfurrm(**************************************************************************) (* The OCaml Reins Library *) (* *) (* Copyright 2007 Mike Furr. *) (* All rights reserved. This file is distributed under the terms of the *) (* GNU Lesser General Public License version 2.1 with the linking *) (* exception given in the COPYING file. *) (**************************************************************************) open Types module BaseMap = struct type ('k,'v) tree = | Empty | Node of ('k,'v) tree * 'k * 'v * ('k,'v) tree let of_result (x,_) = x type ('k,'v) path = | Top | PathL of ('k,'v) path * ('k,'v) tree | PathR of ('k,'v) path * ('k,'v) tree type ('k,'v) curs = ('k,'v) path * ('k,'v) tree let empty = Empty let is_empty = function Empty -> true | _ -> false let singleton k v = Node(Empty,k,v,Empty) let node l k v r = Node(l,k,v,r) let to_cursor t = (Top,t) let rec from_cursor (p,t) = match p with | Top -> t | PathL(p',Node(_,k,v,r)) -> from_cursor (p', Node(t,k,v,r)) | PathR(p',Node(l,k,v,_)) -> from_cursor (p', Node(l,k,v,t)) | _ -> assert false let at_top (p,t) = (p = Top) let has_left (p,t) = match t with | Node(Empty,_,_,_) -> false | Node _ -> true | _ -> false let has_right (p,t) = match t with | Node(_,_,_,Empty) -> false | Node _ -> true | _ -> false let went_left = function PathL _,_ -> true | _ -> false let went_right = function PathR _,_ -> true | _ -> false let move_up (p,t) = match p with | Top -> failwith "move_up" | PathL(p',Node(_,k,v,r)) -> p', Node(t,k,v,r) | PathR(p',Node(l,k,v,_)) -> p', Node(l,k,v,t) | _ -> assert false (* parent can't be emptytree *) let move_down_left (p,t) = match t with | Empty -> failwith "move_down_left" | Node(l,k,v,r) -> PathL(p,t),l let move_down_right (p,t) = match t with | Empty -> failwith "move_down_right" | Node(l,k,v,r) -> PathR(p,t),r let rec move_to_ancestor cmp x ((p,t) as curs) = match p with | Top -> curs | PathL(p', Node(_,k,v,_)) -> if cmp x k < 0 then curs else move_to_ancestor cmp x (move_up curs) | PathR(p', Node(_,k,_,_)) -> if cmp x k > 0 then curs else move_to_ancestor cmp x (move_up curs) | _ -> assert false let rec splay curs = match curs with | Top,_ -> curs | _, Empty -> splay (move_up curs) (* no grand-parent, so just zig one level *) | PathL(Top,Node(_,k,v,r)), Node(ll,lk,lv,lr) -> Top,Node(ll,lk,lv,Node(lr,k,v,r)) | PathR(Top,Node(l,k,v,_)),Node(rl,rk,rv,rr) -> Top,Node(Node(l,k,v,rl),rk,rv,rr) (* has grand-parent *) (* zig-zig *) | PathL(PathL(gp_p,Node(_,k,v,r)),Node(_,lk,lv,lr)), Node(lll,llk,llv,llr) -> let br = Node(lr,k,v,r) in let mr = Node(llr,lk,lv,br) in splay (gp_p, Node(lll,llk,llv,mr)) (* zig-zig *) | PathR(PathR(gp_p,Node(l,k,v,_)),Node(ll,lk,lv,_)), Node(rrl,rrk,rrv,rrr) -> let bl = Node(l,k,v,ll) in let ml = Node(bl,lk,lv,rrl) in splay (gp_p,Node(ml,rrk,rrv,rrr)) (* zig-zag *) | PathL(PathR(gp_p,Node(l,k,v,_)),Node(_,rk,rv,rr)), Node(rll,rlk,rlv,rlr) -> let newl = Node(l,k,v,rll) in let newr = Node(rlr,rk,rv,rr) in splay (gp_p,Node(newl, rlk, rlv, newr)) (* zig-zag *) | PathR(PathL(gp_p,Node(_,k,v,r)),Node(ll,lk,lv,_)), Node(lrl,lrk,lrv,lrr) -> let newl = Node(ll,lk,lv,lrl) in let newr = Node(lrr,k,v,r) in splay(gp_p, Node(newl, lrk, lrv, newr)) (* all of remaining cases are impossible. e.g., the grandparent tree being Empty *) | _ -> assert false let rec add_at cmp k v (p,t) = match t with | Empty -> p,Node(Empty,k,v,Empty) | Node(l,k',v',r) -> match cmp k k' with | 0 -> p, Node(l,k,v,r) (* replace binding *) | c when c < 0 -> add_at cmp k v (PathL(p,t),l) | _ -> add_at cmp k v (PathR(p,t),r) let add cmp k v t = let curs = add_at cmp k v (to_cursor t) in from_cursor (splay curs) let rec closest_to cmp x ((p,t) as curs) = match t with | Empty -> if at_top curs then curs else move_up curs | Node(l,k,v,r) -> match cmp x k with | 0 -> curs | c when c < 0 -> closest_to cmp x (PathL(p,t),l) | _ -> closest_to cmp x (PathR(p,t),r) let top_node = function | Empty -> raise (Invalid_argument "splay:top_node") | Node(_,k,v,_) -> k,v let rec goto_min ((p,t) as curs) = match t with | Empty -> curs | Node(Empty,_,_,_) -> curs | Node(l,_,_,_) -> goto_min ((PathL(p,t)),l) let rec goto_max ((p,t) as curs) = match t with | Empty -> curs | Node(_,_,_,Empty) -> curs | Node(_,_,_,r) -> goto_max ((PathR(p,t)),r) let min_keyval t = if is_empty t then raise Not_found else let c = goto_min (to_cursor t) in let t = from_cursor (splay c) in top_node t, t let max_keyval t = if is_empty t then raise Not_found else let c = goto_max (to_cursor t) in let t = from_cursor (splay c) in top_node t, t let min_key t = let (k,_),t = min_keyval t in k,t let max_key t = let (k,_),t = max_keyval t in k,t let mem cmp x t = let curs = closest_to cmp x (to_cursor t) in let t = from_cursor (splay curs) in match t with | Empty -> false,t | Node(_,k,_,_) -> if cmp x k = 0 then true,t else false,t let find cmp x t = let ((p,t') as curs) = closest_to cmp x (to_cursor t) in match t' with | Empty -> raise Not_found | Node(l,k,v,r) -> if cmp x k = 0 then v, (from_cursor (splay curs)) else raise Not_found (* TODO: fix this to be better than O(n) stack *) let rec iter f = function | Empty -> () | Node(l,k,v,r) -> iter f l; f k v; iter f r let rec mapi f = function | Empty -> Empty | Node(l,k,v,r) ->Node(mapi f l, k, f k v, mapi f r) let map f t = mapi (fun _ v -> f v) t let rec get_and_remove_min = function | Empty -> raise (Invalid_argument "remove_min") | Node(Empty,k,v,r) -> k,v,r | Node(l,k,v,r) -> let k',v',newl = get_and_remove_min l in k',v', Node(newl,k,v,r) let remove cmp x t = let (p,t) = closest_to cmp x (to_cursor t) in let t = match t with | Empty -> t | Node(Empty,k,v,r) -> if (cmp x k) = 0 then r else t | Node(l,k,v,Empty) -> if (cmp x k) = 0 then l else t | Node(l,k,v,r) -> if (cmp x k) = 0 then let k',v',newl = get_and_remove_min l in Node(newl,k',v',r) else t in from_cursor (splay (p,t)) let rec compare_ kcmp vcmp t1 t2 = match t1,t2 with | Empty, Empty -> 0 | Empty, Node _ -> -1 | Node _, Empty -> 1 | _ -> (* This actually may be one of the most efficient ways to implement this since we will always be removing near the top thanks to the splay property. *) let xk,xv,t1' = get_and_remove_min t1 in let yk,yv,t2' = get_and_remove_min t2 in match kcmp xk yk with | 0 -> begin match vcmp xv yv with | 0 -> compare_ kcmp vcmp t1' t2' | v -> v end | v -> v let compare_keys kcmp t1 t2 = compare_ kcmp (fun _ _ -> 0) t1 t2 let rec split cmp kelt t = match t with | Empty -> Empty, Empty | Node(l1,k,v,r1) -> match cmp kelt k with | 0 -> l1,r1 | c when c < 0 -> let l2,r2 = split cmp kelt l1 in l2,Node(r2,k,v,r1) | _ -> let l2,r2 = split cmp kelt r1 in Node(l1,k,v,l2), r2 let rec union cmp f t1 t2 = match t1,t2 with | Empty, t | t, Empty -> t | t1, Node(l,k,v,r) -> let l',r' = split cmp k t1 in let v' = try let v',_ = find cmp k t1 in f k v v' with Not_found -> v in Node((union cmp f l' l),k,v',(union cmp f r' r)) let rec concat t1 t2 = match t1,t2 with | Empty, _ -> t2 | _, Empty -> t1 | Node(l1,k1,v1,r1), Node(l2,k2,v2,r2) -> let k',v',t2' = get_and_remove_min t2 in Node(t1,k',v',t2') let rec diff cmp f t1 t2 = match t1,t2 with | Empty, _ -> Empty | _, Empty -> t1 | _, Node(l,k,v,r) -> let l',r' = split cmp k t1 in concat (diff cmp f l' l) (diff cmp f r' r) let rec inter cmp f t1 t2 = match t1,t2 with | Empty,_ | _,Empty -> Empty | t1, Node(l,k,v,r) -> let l',r' = split cmp k t1 in try let v',_ = find cmp k t1 in let uv = f k v v' in Node((inter cmp f l' l),k,uv,(inter cmp f r' r)) with Not_found -> concat (inter cmp f l' l) (inter cmp f r' r) let at_right = function | _,Empty -> true | _,Node _ -> false let at_left = at_right let has_value = function _,Node _ -> true | _ -> false let get_value = function | _,Empty -> failwith "get_value" | _,Node(_,k,v,_) -> k,v let rec cardinal = function | Empty -> 0 | Node(l,_,_,r) -> 1 + (cardinal l) + (cardinal r) (* TODO: fix this to be better than O(n) stack *) let rec fold f acc t = match t with | Empty -> acc | Node(l,k,v,r) -> fold f (f (fold f acc l) k v) r let rec well_ordered cmp = function | Empty -> true | Node(Empty,_,_,Empty) -> true | Node(Node(_,lk,lv,_) as l,k,v,Empty) -> ((cmp lk k) < 0) && well_ordered cmp l | Node(Empty,k,v,(Node(_,rk,rv,_) as r)) -> ((cmp rk k) > 0) && well_ordered cmp r | Node(Node(_,lk,_,_) as l,k,_,(Node(_,rk,_,_) as r)) -> ((cmp lk k) < 0) &&((cmp rk k) > 0) && well_ordered cmp l && well_ordered cmp r let well_formed t = well_ordered t let rec to_string to_s t = let rec h = function | Empty -> "" | Node(Empty,k,v,Empty) -> to_s k v | Node(l,k,v,Empty) -> Printf.sprintf "%s, %s" (h l) (to_s k v) | Node(Empty,k,v,r) -> Printf.sprintf "%s, %s" (to_s k v) (h r) | Node(l,k,v,r) -> Printf.sprintf "%s, %s, %s" (h l) (to_s k v) (h r) in "{" ^ (h t) ^ "}" let gen2 cmp (kgen : ?size:int -> Random.State.t -> 'k) (vgen : ?size:int -> Random.State.t -> 'v) ?(size=50) rs : ('k,'v) tree = let num = Random.State.int rs size in let rec loop n t = if n <= 0 then t else let k = kgen ~size:size rs in let v = vgen ~size:size rs in let t = from_cursor (add_at cmp k v (to_cursor t)) in loop (n-1) t in loop num empty end (* CR SW: Is it possible to write a functor that builds a Poly from a BaseMap? *) module PolyMap = struct include BaseMap type 'a key = 'a type 'a key_ = 'a type 'e elt = 'e type 'e elt_ = 'e type ('k,'v) t = ('k,'v) tree type ('k,'v) map = ('k,'v) t type ('k,'v) cursor = ('k,'v) curs type ('k,'v) cursor_ = ('k,'v) cursor type ('a,'k,'v) result = 'a * ('k,'v) tree type ('a,'k,'v) result_ = ('a,'k,'v) result let compare = compare_ let mem k t = mem Pervasives.compare k t let add k v t = add Pervasives.compare k v t let remove k t = remove Pervasives.compare k t let find k t = find Pervasives.compare k t let union f t1 t2 = union Pervasives.compare f t1 t2 let inter f t1 t2 = inter Pervasives.compare f t1 t2 let diff f t1 t2 = diff Pervasives.compare f t1 t2 let well_formed t = well_formed Pervasives.compare t let gen2 (kgen : ?size:int -> Random.State.t -> 'k) (vgen : ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen2 Pervasives.compare kgen vgen ?size rs end module MonoKeyMap(C : Mono.Comparable) = struct include BaseMap type key = C.t type 'a key_ = key type 'e elt = 'e type 'e elt_ = 'e type 'v t = (C.t,'v) tree type ('k,'v) map = 'v t type 'v cursor = (C.t,'v) curs type ('k,'v) cursor_ = 'v cursor type ('a,'v) result = 'a * 'v t type ('a,'k,'v) result_ = ('a,'v) result let compare t1 t2 = compare_ C.compare t1 t2 let compare_keys t1 t2 = compare_keys C.compare t1 t2 let mem k t = mem C.compare k t let add k v t = add C.compare k v t let remove k t = remove C.compare k t let find k t = find C.compare k t let union f t1 t2 = union C.compare f t1 t2 let inter f t1 t2 = inter C.compare f t1 t2 let diff f t1 t2 = diff C.compare f t1 t2 let well_formed t = well_formed C.compare t let to_string to_s t = let f k v = Printf.sprintf "(%s => %s)" (C.to_string k) (to_s v) in to_string f t let gen2 (kgen : ?size:int -> Random.State.t -> 'k) (vgen : ?size:int -> Random.State.t -> 'v) ?size rs : ('k,'v) tree = gen2 C.compare kgen vgen ?size rs end module GenKeyMap (C : Mono.ArbitraryComparable) = struct include MonoKeyMap(C) let gen1 (vgen : ?size:int -> Random.State.t -> 'v) ?size rs : 'v t = gen2 C.gen vgen ?size rs end module MonoMap (K : Mono.Comparable) (V : Mono.Comparable) = struct include BaseMap type key = K.t type 'a key_ = key type elt = V.t type 'e elt_ = elt type t = (key,elt) tree type ('k,'v) map = t type cursor = (key,elt) curs type ('k,'v) cursor_ = cursor type 'a result = 'a * t type ('a,'k,'v) result_ = 'a result let compare t1 t2 = compare_ K.compare V.compare t1 t2 let compare_keys t1 t2 = compare_keys K.compare t1 t2 let mem k t = mem K.compare k t let add k v t = add K.compare k v t let remove k t = remove K.compare k t let find k t = find K.compare k t let union f t1 t2 = union K.compare f t1 t2 let inter f t1 t2 = inter K.compare f t1 t2 let diff f t1 t2 = diff K.compare f t1 t2 let well_formed t = well_formed K.compare t let to_string t = let f k v = Printf.sprintf "(%s => %s)" (K.to_string k) (V.to_string v) in to_string f t let gen2 (kgen : ?size:int -> Random.State.t -> key) (vgen : ?size:int -> Random.State.t -> elt) ?size rs : t = gen2 K.compare kgen vgen ?size rs end module GenMap (K : Types.Mono.ArbitraryComparable) (V : Types.Mono.ArbitraryComparable) = struct include MonoMap(K)(V) let gen ?size rs = gen2 K.gen V.gen ?size rs end ocaml-reins-0.1a/COPYING0000644000175000017500000000205110676540553014040 0ustar furrmfurrm The OCaml Reins library is distributed under the terms of the Lesser General Public License version 2.1 (provided in the file LGPL-2.1) with the following linking exception. As a special exception to the GNU Lesser General Public License, you may link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Lesser General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library as distributed by the official ocaml-reins website (currently ocaml-reins.sourceforge.net), or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Lesser General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Lesser General Public License. ocaml-reins-0.1a/header0000644000175000017500000000033510676520540014155 0ustar furrmfurrmThe OCaml Reins Library Copyright 2007 Mike Furr. All rights reserved. This file is distributed under the terms of the GNU Lesser General Public License version 2.1 with the linking exception given in the COPYING file. ocaml-reins-0.1a/LGPL-2.10000644000175000017500000006363710676104001013765 0ustar furrmfurrm GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! ocaml-reins-0.1a/OMakefile0000644000175000017500000000022210675307617014563 0ustar furrmfurrm include config.omake OCAMLFLAGS += -dtypes .SUBDIRS: src doc .SUBDIRS: test .PHONY: clean clean: rm -f $(filter-proper-targets $(ls R, .))