Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
OCaml in-memory "database" -- I use this for component-based game-objects.
(* Database provides key-generation and table-instantiation,
* so that a key can be associated to various properties.
*)
(* This is for a fully-controlled specification...
*
* module Db = Database.Make (Database.IntKey)
* module Prop = Db.MultiInherit
* module PropHash = Prop.Table(Database.Hash)
* module Size = (val PropHash.create ~default:0 () : Db.Sig with type t = int)
*
* module Size = (val Db.MultiInherit.Hashtbl.create ~default:0 ())
*
* -- or even this, if we don't have any inheritance at all
* module Size = (val Db.Hashtbl.create ~default:0 ())
*
*
*)
(* Signature for database keys, which are commonly integers or GUIDs *)
module type KEY = sig
type t
val zero: t
val hash: 'a -> t
val incr: t ref -> unit
val alt: t -> t (* alt is the mapping to transient-data keys *)
val invalid: t -> bool
val to_string: t -> string
end
module IntKey : KEY = struct
type t = int
let zero = 0
let hash = Hashtbl.hash
let incr = incr
let alt x = x lor 0x40000000
let invalid x = x < 0
let to_string x = string_of_int x
end
(* Abstraction of a "store" -- an associative map from key to data 'a. *)
module type STORE = sig
type 'a t
type key
val create: ?size:int -> unit -> 'a t
val get: 'a t -> key -> 'a
val set: 'a t -> key -> 'a -> unit (* XXX what about immutable sets? *)
val del: 'a t -> key -> unit
val iter: 'a t -> (key -> 'a -> unit) -> unit
val fold: 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
end
(* Functor of Key to Store -- a type passed into the Table functor *)
module type KEYED_STORE = functor (Key:KEY) -> (STORE with type key = Key.t)
(* Adaptation of Hashtbl to the common STORE signature *)
module Hash (Key:KEY) : (STORE with type key = Key.t) = struct
type key = Key.t
type 'a t = (key,'a) Hashtbl.t
let create ?(size=13) () = Hashtbl.create size
let get = Hashtbl.find (* must return found value or raise Not_found *)
let set = Hashtbl.replace
let del = Hashtbl.remove
let iter h f = Hashtbl.iter f h
let fold h f init = Hashtbl.fold f h init
end
module Id (Key:KEY) = struct
(* -- ID Generation -- *)
exception IdOverflow
let uniq_transient = ref Key.zero
let uniq_persistent = ref Key.zero
(* For Key.t = int, persistent IDs are positive integers 0 .. max_int *)
let persistent_id () =
let id = !uniq_persistent in
if Key.invalid id then raise IdOverflow
else Key.incr uniq_persistent;
id
(* For Key.t = int, transient IDs are negative integers min_int .. -1 *)
let transient_id () =
let id = !uniq_transient in
Key.incr uniq_transient;
Key.alt id
(* -- ID/Name Mapping -- *)
(* 'id' maps hash-generated number to an ID *)
let (id:(Key.t,Key.t) Hashtbl.t) = Hashtbl.create 13
(* 'name' maps a string to an ID *)
let (name:(Key.t,string) Hashtbl.t) = Hashtbl.create 13
let find_id_by_name n =
let hashId = Key.hash n in
(* TODO at least verify that namestrings also match in a 'debug' mode *)
Hashtbl.find id hashId
(* Generates a new id if one doesn't already exist for this name *)
let get_id_by_name n =
let hashId = Key.hash n in
try Hashtbl.find id hashId (* should verify that namestrings match *)
with Not_found ->
let nId = persistent_id () in
Hashtbl.replace id hashId nId;
Hashtbl.replace name nId n;
nId
let get_name hashId =
try Hashtbl.find name hashId
with Not_found -> "<unknown>"
let string_of_id id = Key.to_string id
end
module InheritSingle (Key:KEY) = struct
let (parents:(Key.t, Key.t) Hashtbl.t) = Hashtbl.create 13
let get_parent id = Hashtbl.find parents id
let set_parent id parent = Hashtbl.replace parents id parent
let del_parent id = Hashtbl.remove parents id
module Get (Store:STORE with type key = Key.t) = struct
let rec get (s:'a Store.t) (id:Store.key) =
try Store.get s id
with Not_found -> get s (get_parent id)
(* ancestry of component: list of direct and inherited, oldest first *)
let get_all (s:'a Store.t) (id:Store.key) =
let rec aux accum i =
let a =
try (Store.get s i)::accum
with Not_found -> accum
in
try let next = get_parent i in aux a next
with Not_found -> a
in aux [] id
end
end
module InheritMulti (Key:KEY) = struct
let (parents:(Key.t, Key.t list) Hashtbl.t) = Hashtbl.create 13
let get_parents id =
try Hashtbl.find parents id with Not_found -> []
let set_parents id alist =
Hashtbl.replace parents id alist
let add_parents id alist =
set_parents id ((get_parents id) @ alist)
let del_parent id parent =
let existing = get_parents id in
set_parents id (List.filter (fun e -> e <> parent) existing)
module Get (Store:STORE with type key = Key.t) = struct
(* local utility function to return the first successful result of
* 'fn' applied to the input list; otherwise re-raise Not_found *)
let rec first fn = function
| h::t -> (try fn h with Not_found -> first fn t)
| _ -> raise Not_found
let rec get (s:'a Store.t) (id:Store.key) =
try Store.get s id
with Not_found -> first (get s) (get_parents id)
(* ancestry of component: list of direct and inherited, oldest first *)
let get_all (s:'a Store.t) (id:Store.key) =
let rec aux accum i =
let a =
try (Store.get s i)::accum
with Not_found -> accum
in
try let next = get_parents i in List.fold_left aux a next
with Not_found -> a
in aux [] id
end
end
(* specialize on Key, then we can select inheritance... then instantiate
* table... *)
module Make (Key:KEY) = struct
type key = Key.t
(* this would allow a common ID space...
* with separate ancestry heirarchies in whatever divisions we desired...
* and table implementations to further specialize.
* Of course I get the same effect as a database of one inheritance model
* by extracting out a single interface...
*)
(* Exempli Gratis:
* module IntDb = Database.Make (Database.IntKey)
* module Db = IntDb.NoInherit
* module Prop = IntDb.MultiInherit
* module Offset = (val (Prop.Table(Hash).create ~default:0 ~inheritance:false ()))
* module Size = (val (Db.Table(Hash).create ~default:0 ()))
* module Offset = (val (Prop.Hashtbl.create ~default:0 ~inheritance:false ()))
* module Size = (val (Db.Hashtbl.create ~default:0 ()))
*)
include Id(Key)
module type Sig = sig
type t
val get : Key.t -> t (* return property for id *)
val get_personal : Key.t -> t (* will only return a non-inherited property *)
val get_inheritable : Key.t -> t (* uses inheritance even if table defaults to non-inherited *)
val get_all : Key.t -> t list (* list of direct and inherited properties *)
val set : Key.t -> t -> unit
val s : t -> Key.t -> Key.t (* alternative 'set' which is 'pipe'-compatible *)
val del : Key.t -> unit
val iter : (Key.t -> t -> unit) -> unit
val fold : (Key.t -> t -> 'a -> 'a) -> 'a -> 'a
end
(* Parts of Sig which are type-agnostic; common between all tables *)
module type COMMON = sig
val del : Key.t -> unit
end
(* Registration of components at Database level, for id-wise operations
* like a total delete by id... *)
let tables : (module COMMON) list ref = ref []
let register_table m =
tables := m :: !tables
let delete id =
List.iter (fun m -> let module M = (val m:COMMON) in M.del id) !tables
(* -remove id from inheritance? *)
(* -add id to recycle FIFO? *)
let d_size = 13 (* default size for pre-allocated tables *)
module type GET = functor (Store:(STORE with type key = Key.t)) -> sig
val get : 'a Store.t -> Store.key -> 'a
val get_all : 'a Store.t -> Store.key -> 'a list
end
module TableImpl (Get:GET) = struct
module Table (KStore:KEYED_STORE) = struct
module Store = KStore(Key) (* FIXME let module...? *)
let create (type s) ?(size=d_size) ?default ?(nhrt=true) () =
(* Instantiate a table... *)
let h = Store.create ~size () in
(* And a base interface to it... *)
let module T = struct
module G = Get(Store) (* FIXME let module G = ... in? why no worky? *)
type t = s
let get_personal (id:Key.t) = Store.get h id
let get_inheritable (id:Key.t) = G.get h id
let get = get_personal
let get_all (id:Key.t) = G.get_all h id
let set id (v:t) = Store.set h id v
let s (v:t) id = Store.set h id v; id
let del id = Store.del h id
let iter f = Store.iter h f
let fold f init = Store.fold h f init
end in
(* Modify the interface based on optional parameters... *)
match (nhrt,default) with
| (false, Some x) ->
let module Td = struct
(*
include AddDefault(T,struct value=x end)
let get = get_personal
*)
include T
let get_personal (id:Key.t) = try T.get_personal id with Not_found -> x
let get_inheritable (id:Key.t) = try T.get_inheritable id with Not_found -> x
let get = get_personal
end in
register_table (module Td:COMMON);
(module Td : Sig with type t = s)
| (true, Some x) ->
let module Td = struct
include T
let get_personal (id:Key.t) = try T.get_personal id with Not_found -> x
let get_inheritable (id:Key.t) = try T.get_inheritable id with Not_found -> x
let get = get_inheritable
end in
register_table (module Td:COMMON);
(module Td : Sig with type t = s)
| (false, None) ->
register_table (module T:COMMON);
(module T : Sig with type t = s)
| (true, None) ->
let module Td = struct
include T
let get = get_inheritable
end in
register_table (module Td:COMMON);
(module Td : Sig with type t = s)
end
end
(* For no-inheritance ... *)
module Get (Store:STORE with type key = Key.t) = struct
let get (s:'a Store.t) (id:Store.key) = Store.get s id
let get_all s id = try [get s id] with Not_found -> []
end
include TableImpl(Get)
module Hashtbl = Table(Hash)
(*
module NoInherit = struct
(* TODO here, Get is just the normal Store.get *)
include TableImpl(Get)
end
*)
module SingleInherit = struct
include InheritSingle(Key)
include TableImpl(Get)
module Hashtbl = Table(Hash)
end
module MultiInherit = struct
include InheritMulti(Key)
include TableImpl(Get)
module Hashtbl = Table(Hash)
end
end
module type KEY =
sig
type t
val zero : t
val hash : 'a -> t
val incr : t ref -> unit
val alt : t -> t
val invalid : t -> bool
val to_string : t -> string
end
module type STORE =
sig
type 'a t
type key
val create : ?size:int -> unit -> 'a t
val get : 'a t -> key -> 'a
val set : 'a t -> key -> 'a -> unit
val del : 'a t -> key -> unit
val iter : 'a t -> (key -> 'a -> unit) -> unit
val fold : 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
end
module type KEYED_STORE = functor (Key : KEY) -> (STORE with type key = Key.t)
module IntKey : KEY
module Hash : KEYED_STORE
module Make :
functor (Key : KEY) ->
sig
type key = Key.t
exception IdOverflow
val persistent_id : unit -> key
val transient_id : unit -> key
val find_id_by_name : 'a -> key
val get_id_by_name : string -> key
val get_name : key -> string
val string_of_id : key -> string
val delete : key -> unit
module type Sig =
sig
type t
val get : key -> t (* get, obeying table's inheritance setting *)
val get_personal : key -> t (* ignore inheritance *)
val get_inheritable : key -> t (* permit inheritance (overriding default) *)
val get_all : key -> t list (* for a stacked component *)
val set : key -> t -> unit (* set value on key; stacking is possible *)
val s : t -> key -> key (* set, but an alternate calling signature *)
val del : key -> unit (* delete this component from key *)
val iter : (key -> t -> unit) -> unit
val fold : (key -> t -> 'a -> 'a) -> 'a -> 'a
end
module type COMMON =
sig
val del : key -> unit
end
module Table :
functor (KStore : KEYED_STORE) ->
sig
val create :
?size:int ->
?default:'a ->
?nhrt:bool -> unit -> (module Sig with type t = 'a)
end
module Hashtbl :
sig
val create :
?size:int ->
?default:'a ->
?nhrt:bool -> unit -> (module Sig with type t = 'a)
end
module SingleInherit :
sig
val get_parent : key -> key
val set_parent : key -> key -> unit
val del_parent : key -> unit
module Table :
functor (KStore : KEYED_STORE) ->
sig
val create :
?size:int ->
?default:'a ->
?nhrt:bool -> unit -> (module Sig with type t = 'a)
end
module Hashtbl :
sig
val create :
?size:int ->
?default:'a ->
?nhrt:bool -> unit -> (module Sig with type t = 'a)
end
end
module MultiInherit :
sig
val get_parents : key -> key list
val set_parents : key -> key list -> unit
val add_parents : key -> key list -> unit
val del_parent : key -> key -> unit
module Table :
functor (KStore : KEYED_STORE) ->
sig
val create :
?size:int ->
?default:'a ->
?nhrt:bool -> unit -> (module Sig with type t = 'a)
end
module Hashtbl :
sig
val create :
?size:int ->
?default:'a ->
?nhrt:bool -> unit -> (module Sig with type t = 'a)
end
end
end
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment