gistfile1.ml

(** {2 Universal type} *)
module Univ = struct
  (** This is largely inspired by https://ocaml.janestreet.com/?q=node/18 . *)

  type t = { 
    mutable id : unit ref;
    mutable store : unit -> unit;
  } (** The universal type *)

  type 'a embedding = {
    pack : 'a -> t;           (** Pack a 'a into a univ value *)
    unpack : t -> 'a option;  (** Try to unpack the univ value into an 'a *)
    set : t -> 'a -> unit;    (** Change, in-place, the content of the univ value *)
    compatible : t -> bool;   (** Check whether the univ value can be unpacked *)
  } (** Conversion between the universal type and 'a *)

  (** Create a new embedding. Values packed by a given embedding can
      only be unpacked by the same embedding. *)
  let embed () = 
    let id = ref () in  (* unique ID of the embedding *)
    let r = ref None in (* place to store values *)
    let pack a =        (* pack the 'a value into a new univ cell *)
      let o = Some a in
      { id = id; store = (fun () -> r := o); }
    in
    let unpack t =      (* try to extract the content of a univ cell *)
      r := None;
      t.store ();
      let a = !r in
      a
    in
    let set t a =       (* change, in place, the embedding and content of the cell *)
      t.id <- id;
      let o = Some a in
      t.store <- (fun () -> r := o)
    in
    let compatible t =  (* check whether the univ cell is from this embedding *)
      id == t.id
    in
    { pack; unpack; compatible; set; }

  let pack emb x = emb.pack x

  let unpack emb t = emb.unpack t

  let compatible emb t = emb.compatible t

  let set emb t x = emb.set t x
end

class type ['a, 'b] index =
  object
    method embed : ('a, 'b) index Univ.embedding
    method add : 'a -> ('a, 'b) index
    method remove : 'a -> ('a, 'b) index
    method select : 'b -> ('a -> unit) -> unit
    method keys : ('b -> unit) -> unit
  end

let idx_fun (type k) (type e) ~(cmp : k ->  k -> int) (f : (e -> k list)) =
  let embed = Univ.embed () in
  let module M = Map.Make(struct
    type t = k
    let compare = cmp
  end) in
  (* make an index given the current map index -> element list *)
  let rec make map =
    (object
      method embed = embed
      method add e =
        let keys = f e in
        let map' =
          List.fold_left
            (fun map key ->
              let es = try M.find key map with Not_found -> [] in
              M.add key (e::es) map)
            map keys
        in
        (make map' :> (e, k) index)
      method remove e =
        (failwith "not implemented" : (e, k) index)
      method select key f' =
        let es = try M.find key map with Not_found -> [] in
        List.iter f' es
      method keys f' =
        M.iter (fun k _ -> f' k) map
    end : (e, k) index) in
  make M.empty

let idx_set ?(cmp=Pervasives.compare) ~name =
  failwith "not implemented"

module IndexList = struct
  type t = Univ.t list
  let nil = []
  let cons idx l = (Univ.pack idx#embed idx) :: l
end

let mk_set il = il

let rec get_eq set idx key =
  match set with
  | [] -> failwith "bad index for this set"
  | univ :: set' ->
    begin match Univ.unpack idx#embed univ with
    | None -> get_eq set' idx key  (* not the index you are looking for *)
    | Some idx' ->
      let l = ref [] in
      idx'#select key (fun e -> l := e :: !l);
      !l
    end

let rec get_filter set idx p =
  match set with
  | [] -> failwith "bad index for this set"
  | univ :: set' ->
    begin match Univ.unpack idx#embed univ with
    | None -> get_filter set' idx p  (* not the index you are looking for *)
    | Some idx' ->
      let l = ref [] in
      idx'#keys
        (fun k ->
          if p k then idx'#select k (fun e -> l := e :: !l));
      !l
    end

(* TODO

val inter : 'a t -> 'a t -> 'a t
  (** Set intersection *)

val union : 'a t -> 'a t -> 'a t
  (** Set union *)

val add : 'a t -> 'a -> 'a t
  (** Add an element to the set *)

val remove : 'a t -> 'a -> 'a t
  (** Remove an element to the set *)

val group_by : 'a t -> ('a, 'b) index -> ('b * 'a list) list
  (** Group by the given index *)

*)