Commits

Yit Phang Khoo committed 2d389c0

Add SAArrayMappedTrie module.

Comments (0)

Files changed (7)

Source/Adapton.mlpack

 Adapton/MemoN
 Adapton/NonSAEager
 Adapton/NonSALazy
+Adapton/SAArrayMappedTrie
 Adapton/SAList
 Adapton/Signatures
 Adapton/Types

Source/Adapton/All.ml

 let salist_list = List.map begin fun ( name, sa ) ->
     ( "SAList (" ^ name ^ ")", (module SAList.Make ((val sa : Signatures.SAType)) : Signatures.SAListType)  )
 end sa_list
+
+(** List of all names and modules for self-adjusting array mapped trie. *)
+let saamt_list = List.map begin fun ( name, sa ) ->
+    ( "SAArrayMappedTrie (" ^ name ^ ")", (module SAArrayMappedTrie.Make ((val sa : Signatures.SAType)) : Signatures.SAArrayMappedTrieType)  )
+end sa_list

Source/Adapton/SAArrayMappedTrie.ml

+(** Self-adjusting array mapped trie. *)
+
+(**/**) (* helper parameters *)
+let depth = 7
+let bits = LazySparseArray.key_width
+let width = 1 lsl bits
+let mask = width - 1
+let mask' = lnot mask
+let keybits' = bits * (depth - 1)
+let _ = assert (keybits' < Sys.word_size - 3)
+(**/**)
+
+(** Key-width of self-adjusting array mapped tries. *)
+let key_width = bits * depth
+
+(** Size of self-adjusting array mapped tries. *)
+let size = 1 lsl key_width
+
+(** Functor to make self-adjusting array mapped tries, given a particular module for self-adjusting values. *)
+module Make (M : Signatures.SAType)
+        : Signatures.SAArrayMappedTrieType with
+            type sa = M.sa
+            and type 'a thunk = 'a M.thunk
+        = struct
+
+    (** Self-adjusting array mapped tries containing ['a]. *)
+    type 'a saamt = 'a saamt' M.thunk
+
+    (** Constructor tags for self-adjusting array mapped tries containing ['a]. *)
+    and 'a saamt' =
+        | Branches of 'a saamt LazySparseArray.t
+        | Leaves of 'a LazySparseArray.t
+        | Empty
+
+    (** Types and operations common to self-adjusting array mapped tries containing any type. *)
+    module T = struct
+        (** Abstract type identifying the given module for self-adjusting values used to create this module for self-adjusting array mapped tries. *)
+        type sa = M.sa
+
+        (** Self-adjusting values from the given module used to create this module for self-adjusting array mapped tries. *)
+        type 'a thunk = 'a M.thunk
+
+        (** True if this module implements self-adjusting array mapped tries. *)
+        let is_self_adjusting = M.is_self_adjusting
+
+        (** True if this module implements lazy array mapped tries. *)
+        let is_lazy = M.is_lazy
+
+        (** Compute the hash value of a self-adjusting array mapped trie. *)
+        let hash = M.hash
+
+        (** Compute whether two self-adjusting array mapped tries are equal. *)
+        let equal = M.equal
+
+        (** Recompute self-adjusting array mapped tries if necessary. *)
+        let refresh = M.refresh
+
+        (** Return the value at index [k] of a self-adjusting array mapped trie. *)
+        let get xs k =
+            if k < 0 || k >= size then invalid_arg "index out of bounds";
+            let rec get xs s =
+                let k = k lsr s land mask in
+                match M.force xs with
+                    | Branches xs ->
+                        begin match LazySparseArray.get xs k with
+                            | Some xs -> get xs (s - bits)
+                            | None -> None
+                        end
+                    | Leaves xs ->
+                        LazySparseArray.get xs k
+                    | Empty ->
+                        None
+            in
+            get xs keybits'
+    end
+    include T
+
+    (** Output module types of {!SAList.Make}. *)
+    module type S = Signatures.SAArrayMappedTrieType.S
+
+    (** Helper functor to make a constructor for self-adjusting array mapped tries of a specific type. *)
+    module Make (R : Hashtbl.SeededHashedType)
+            : S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t saamt = struct
+        module A = M.Make (struct
+            type t = R.t saamt'
+            let hash seed = function
+                | Branches xs -> LazySparseArray.hash (Hashtbl.seeded_hash seed `Leaves) xs
+                | Leaves xs -> LazySparseArray.hash (Hashtbl.seeded_hash seed `Leaves) xs
+                | Empty -> Hashtbl.seeded_hash seed `Empty
+            let equal xs xs' = xs == xs' || match xs, xs' with
+                | Branches xs, Branches xs' -> LazySparseArray.equal xs xs'
+                | Leaves xs, Leaves xs' -> LazySparseArray.equal xs xs'
+                | _ -> false
+        end)
+
+        (** Value contained by self-adjusting array mapped tries for a specific type. *)
+        type data = R.t
+
+        (** Self-adjusting array mapped tries for a specific type. *)
+        type t = A.t
+
+        include T
+
+        (** An empty self-adjusting array mapped trie. *)
+        let empty = A.const Empty
+
+        (** Create memoizing constructor and updater that adds a binding to an self-adjusting array mapped trie. *)
+        let memo_add =
+            let add, update_add = A.memo4 (module A) (module Types.Int) (module Types.Int) (module R) begin fun add xs s k v ->
+                (* if along k, initialize the next branch/leaf node, else lookup the subtrie under the prior AMT *)
+                if s > 0 then
+                    Branches begin LazySparseArray.make begin fun d ->
+                        if k lsr s land mask == d then
+                            Some (add xs (s - bits) k v)
+                        else
+                            (* perform a partial key lookup for the corresponding subtrie under the prior AMT *)
+                            let rec subtrie xs s' =
+                                match M.force xs with
+                                    | Branches xs ->
+                                        if s' == s then
+                                            LazySparseArray.get xs d
+                                        else
+                                            let k = k lsr s' land mask in
+                                            begin match LazySparseArray.get xs k with
+                                                | Some xs ->
+                                                    subtrie xs (s' - bits)
+                                                | None ->
+                                                    None
+                                            end
+                                    | Empty ->
+                                        None
+                                    | Leaves _ ->
+                                        assert false
+                            in
+                            subtrie xs keybits'
+                    end end
+                else
+                    Leaves begin LazySparseArray.make begin fun d ->
+                        if k land mask == d then
+                            Some v
+                        else
+                            get xs (k land mask' lor d)
+                    end end
+            end in
+            let add xs k v =
+                if k < 0 || k >= size then invalid_arg "index out of bounds";
+                add xs keybits' k v
+            in
+            let update_add m xs k v =
+                if k < 0 || k >= size then invalid_arg "index out of bounds";
+                update_add m xs keybits' k v
+            in
+            ( add, update_add )
+    end
+end

Source/Adapton/Signatures.ml

     module Make (R : Hashtbl.SeededHashedType)
         : S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t salist and type t' = R.t salist'
 end
+
+(** {2 Self-adjusting array mapped tries} *)
+
+(** Module type for self-adjusting lists. *)
+module rec SAArrayMappedTrieType : sig
+    module type S = sig
+        type sa
+        type 'a thunk
+        type data
+        type t
+        val is_self_adjusting : bool
+        val is_lazy : bool
+        val hash : int -> t -> int
+        val equal : t -> t -> bool
+        val refresh : unit -> unit
+        val get : t -> int -> data option
+        val empty : t
+        val memo_add : (t -> int -> data -> t) * (t -> t -> int -> data -> unit)
+    end
+end = SAArrayMappedTrieType
+
+(** Module type for self-adjusting lists. *)
+module type SAArrayMappedTrieType = sig
+    type sa
+    type 'a thunk
+    type 'a saamt
+    val is_self_adjusting : bool
+    val is_lazy : bool
+    val hash : int -> 'a saamt -> int
+    val equal : 'a saamt -> 'a saamt -> bool
+    val refresh : unit -> unit
+    val get : 'a saamt -> int -> 'a option
+    module type S = SAArrayMappedTrieType.S
+    module Make (R : Hashtbl.SeededHashedType)
+        : S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t saamt
+end

Test/TestAdapton.mlpack

 TestAdapton/TestLazySparseArray
 TestAdapton/TestSA
+TestAdapton/TestSAArrayMappedTrie
 TestAdapton/TestSAList

Test/TestAdapton/TestSAArrayMappedTrie.ml

+open TestUtil.MyOUnit
+open Format
+
+let assert_float_option_equal = assert_equal ~printer:(option_printer pp_print_float)
+
+let make_correctness_testsuite (module A : Adapton.Signatures.SAArrayMappedTrieType) =
+    let module F = A.Make (Adapton.Types.Float) in
+
+    "Correctness" >::: [
+        "add" >:: QC.forall (QC.triple QC.float (QC.list (QC.pair QC.int QC.float)) (QC.list QC.int)) begin fun ( fseed, xs, ks ) ->
+            let h x = abs (Hashtbl.seeded_hash (Hashtbl.hash fseed) x) in
+            let add, _ = F.memo_add in
+            let ys = Hashtbl.create 0 in
+            let zs = List.fold_left (fun zs ( k, v ) -> let k = h k in Hashtbl.add ys k v; add zs k v) F.empty xs in
+            List.iter begin fun k ->
+                let k = h k in
+                assert_float_option_equal (try Some (Hashtbl.find ys k) with Not_found -> None) (F.get zs k);
+            end ks
+        end
+    ]
+
+
+let make_testsuite ( name, saamt ) =
+    name >::: [
+        make_correctness_testsuite saamt
+    ]
+
+
+let testsuite = "TestSAArrayMappedTrie" >::: List.map make_testsuite Adapton.All.saamt_list

Test/runtestadapton.ml

     run_test_tt_main begin "TestAdapton" >::: [
         TestAdapton.TestLazySparseArray.testsuite;
         TestAdapton.TestSA.testsuite;
+        TestAdapton.TestSAArrayMappedTrie.testsuite;
         TestAdapton.TestSAList.testsuite;
     ] end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.