(****************************************************************************)
(*                                                                          *)
(*    This file is part of Zephyrus.                                        *)
(*                                                                          *)
(*    Zephyrus is free software: you can redistribute it and/or modify      *)
(*    it under the terms of the GNU General Public License as published by  *)
(*    the Free Software Foundation, either version 3 of the License, or     *)
(*    (at your option) any later version.                                   *)
(*                                                                          *)
(*    Zephyrus 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 General Public License for more details.                          *)
(*                                                                          *)
(*    You should have received a copy of the GNU General Public License     *)
(*    along with Zephyrus.  If not, see <http://www.gnu.org/licenses/>.     *)
(*                                                                          *)
(****************************************************************************)

(* Depends on
    - Data_common_set
    - Data_common_map
    - Data_common_unique_id
    - Data_common_mapping
*)

open Data_common_set
open Data_common_map
open Data_common_unique_id
open Data_common_mapping


(* Module providing a class for storing id and names and creating mappings between names and ids. *)
(* In fact it's general enough to use it for mappings between ids and anything 
   (not only names but also any objects) as long as we can order them. *)
(* A five-functor module is quite heavy, but these functors here are redundant, so it is not as
   complicated as it looks. It could be probably possible to reduce it to three functors, however
   I have no idea if that would type correctly, so I prefer to leave it like this. *)
module Catalog =
  functor (Fresh_id : Fresh)                             -> (* For generating fresh ids. *)
  functor (Id_set   : Set.S with type elt = Fresh_id.id) -> (* Set of ids. Must match with the type of ids generated by Fresh_id. *)
  functor (Obj_set  : Set.S)                             -> (* Set of names. *)
  functor (Id_map   : Map.S with type key = Id_set.elt)  -> (* Map with ids as keys.   Must match with the Id_set  element type. *)
  functor (Obj_map  : Map.S with type key = Obj_set.elt) -> (* Map with names as keys. Must match with the Id_name element type. *)
  struct

    (* Five functors is quite heavy indeed, let's extract the two basic types. *)
    type id  = Id_set.elt
    type obj = Obj_set.elt

    (* A modifiable catalog with id <-> object mapping. *)
    class type obj_catalog_iface = object
      (* Access *)
      method ids             : Id_set.t           (* All the ids. *)
      method objs            : Obj_set.t          (* All the objects. *)
      method obj_of_id       : id  -> obj         (* Get the object corresponding to the given id. May throw Not_found exception. *)
      method id_of_obj       : obj -> id          (* Get the id corresponding to the given object. May throw Not_found exception. *)
      (* Modify *)
      method get_else_add    : obj -> id          (* Get the id corresponding to the given object. If the object does not exist, create a new fresh id for this object, update the data structures and the return the id. *)
      method add             : obj -> unit        (* If the object does not exist, create a new fresh id for this object and update the data structures. *)
      method add_id_obj_pair : id  -> obj -> unit (* Update the data structures with the given (id, object) pair. *)
      (* Lower level manipulation *)
      method set_id_of_obj   : obj -> id  -> unit (* Adds the object to objs and makes it correspond to the given id     (only one way, we have obj -> id, but not id -> obj!). *)
      method set_obj_of_id   : id  -> obj -> unit (* Adds the id     to ids  and makes it correspond to the given object (only one way, we have id -> obj, but not obj -> id!). *)
      method id_to_obj_map   : obj Id_map.t       (* Retrieve directly the id -> object map. *)
      method obj_to_id_map   : id Obj_map.t       (* Retrieve directly the object -> id map. *)
    end

    module Id_to_Obj_mapping = Mapping (Id_set)  (Obj_set) (Id_map)
    module Obj_to_Id_mapping = Mapping (Obj_set) (Id_set)  (Obj_map)

    (* Implementation of the catalog. *)
    class obj_catalog : obj_catalog_iface = object (self)

      (* Data structures. *)
      val id_to_obj_mapping : Id_to_Obj_mapping.mapping_iface = new Id_to_Obj_mapping.mapping
      val obj_to_id_mapping : Obj_to_Id_mapping.mapping_iface = new Obj_to_Id_mapping.mapping

      (* For unique identifier creation. *)
      val current_id = Fresh_id.create ()

      (* Access methods. *)

      (* Domains and data structures access. *)
      method ids           : Id_set.t       = id_to_obj_mapping#domain           (* All the ids. *)
      method objs          : Obj_set.t      = obj_to_id_mapping#domain           (* All the objs. *)
      method id_to_obj_map : (obj Id_map.t) = id_to_obj_mapping#key_to_value_map (* Mapping id -> obj *)
      method obj_to_id_map : (id Obj_map.t) = obj_to_id_mapping#key_to_value_map (* Mapping obj -> id *)
    
      (* Mapping access. May throw Not_found exception. *)
      method obj_of_id (id  : id)  : obj = id_to_obj_mapping#find id
      method id_of_obj (obj : obj) : id  = obj_to_id_mapping#find obj
      
      (* Modify methods. *)

      (* Make the id correspond to a given obj (id -> obj mapping). *)
      method set_obj_of_id id obj =
        id_to_obj_mapping#add id obj;
        Fresh_id.mark_used current_id id
      
      (* Make the obj correspond to a given id (obj -> id mapping). *)
      method set_id_of_obj obj id = 
        obj_to_id_mapping#add obj id
          
      (* Add the relation id <-> obj to both mappings. *)
      method add_id_obj_pair id obj =
        self#set_id_of_obj obj id;
        self#set_obj_of_id id obj

      (* Look for the obj in the maps, if it does not exist create it and give it a fresh id. *)
      method get_else_add obj = 
        try self#id_of_obj obj
        with Not_found -> let id = Fresh_id.next current_id in self#add_id_obj_pair id obj; id

      (* As above, but don't return anything. *)
      method add obj =
        let _ = self#get_else_add obj in ()

    end

    (* Create a new catalog by taking a set of objects and adding them all. *)
    let of_set_of_objs (objs : Obj_set.t) : obj_catalog_iface = 
      let catalog = new obj_catalog in
      Obj_set.iter catalog#add objs;
      catalog

    (* Create a new catalog corresponding to a given id -> object map. *)
    let of_id_to_obj_map (id_to_obj_map : obj Id_map.t) : obj_catalog_iface =
      let catalog = new obj_catalog in
      Id_map.iter catalog#add_id_obj_pair id_to_obj_map;
      catalog



    (* A catalog variation with just one purely syntactic difference - we have names not objects. *)
    type name = obj

    (* A modifiable catalog with name <-> id mapping. *)
    class type catalog_iface = object
      (* Access *)
      method ids              : Id_set.t           (* All the ids. *)
      method names            : Obj_set.t          (* All the names. *)
      method name_of_id       : id   -> name       (* Get the name corresponding to the given id. May throw Not_found exception. *)
      method id_of_name       : name -> id         (* Get the id corresponding to the given name. May throw Not_found exception. *)
      (* Modify *)
      method get_else_add     : name -> id         (* Get the id corresponding to the given name. If the name does not exist, create a new fresh id for this name, update the data structures and the return the id. *)
      method add              : name -> unit       (* If the name does not exist, create a new fresh id for this name and update the data structures. *)
      method add_id_name_pair : id -> name -> unit (* Update the data structures with the given (id, name) pair. *)
      (* Lower level manipulation *)
      method set_id_of_name   : name -> id -> unit (* Adds the name to names and makes it correspond to the given id     (only one way, we have name -> id,  but not id  -> name!). *)
      method set_name_of_id   : id -> name -> unit (* Adds the id   to ids  and makes it correspond to the given object  (only one way, we have id   -> obj, but not obj -> id!  ). *)
      method id_to_name_map   : name Id_map.t      (* Retrieve directly the id -> object map. *)
      method name_to_id_map   : id Obj_map.t       (* Retrieve directly the object -> id map. *)
    end

    let catalog_of_obj_catalog (obj_catalog : obj_catalog) : catalog_iface =
      (* The name catalog: *)
      object
        method ids              = obj_catalog#ids
        method names            = obj_catalog#objs
        method id_of_name       = obj_catalog#id_of_obj
        method name_of_id       = obj_catalog#obj_of_id
        method get_else_add     = obj_catalog#get_else_add
        method add_id_name_pair = obj_catalog#add_id_obj_pair
        method add              = obj_catalog#add
        method set_id_of_name   = obj_catalog#set_id_of_obj
        method set_name_of_id   = obj_catalog#set_obj_of_id
        method id_to_name_map   = obj_catalog#id_to_obj_map
        method name_to_id_map   = obj_catalog#obj_to_id_map
      end

    class catalog : catalog_iface = 
      let obj_catalog = new obj_catalog in 
      (* TODO: Why cannot we just write "catalog_of_obj_catalog obj_catalog" here?! *)
      object
        method ids              = obj_catalog#ids
        method names            = obj_catalog#objs
        method id_of_name       = obj_catalog#id_of_obj
        method name_of_id       = obj_catalog#obj_of_id
        method get_else_add     = obj_catalog#get_else_add
        method add_id_name_pair = obj_catalog#add_id_obj_pair
        method add              = obj_catalog#add
        method set_id_of_name   = obj_catalog#set_id_of_obj
        method set_name_of_id   = obj_catalog#set_obj_of_id
        method id_to_name_map   = obj_catalog#id_to_obj_map
        method name_to_id_map   = obj_catalog#obj_to_id_map
      end

    (* A closed catalog (closed means that it cannot be modified. *)
    class type closed_catalog_iface = object
      method ids            : Id_set.t
      method names          : Obj_set.t
      method name_of_id     : id   -> name
      method id_of_name     : name -> id
      method id_to_name_map : name Id_map.t
      method name_to_id_map : id Obj_map.t
    end

    let close_catalog (catalog : #closed_catalog_iface) : closed_catalog_iface = object
      method ids             = catalog#ids
      method names           = catalog#names
      method name_of_id      = catalog#name_of_id
      method id_of_name      = catalog#id_of_name
      method id_to_name_map  = catalog#id_to_name_map
      method name_to_id_map  = catalog#name_to_id_map
    end

    (* Implementation of a closed catalog which throws appropriate exceptions. *)
    class closed_catalog_with_exceptions (catalog : #closed_catalog_iface) (not_found_functions : (id -> name) * (name -> id)) : closed_catalog_iface = 
      let (id_not_found, name_not_found) = not_found_functions in
      object
        method ids             = catalog#ids
        method names           = catalog#names
        method name_of_id id   = try catalog#name_of_id id   with Not_found -> id_not_found   id
        method id_of_name name = try catalog#id_of_name name with Not_found -> name_not_found name
        method id_to_name_map  = catalog#id_to_name_map
        method name_to_id_map  = catalog#name_to_id_map
      end
    
    (* Create a new catalog by taking a set of names and adding them all. *)
    let of_set_of_names (names : Obj_set.t) : catalog_iface = 
      catalog_of_obj_catalog (of_set_of_objs names)

    (* Create a new catalog corresponding to a given id -> name map. *)
    let of_id_to_name_map (id_to_name_map : name Id_map.t) : catalog_iface =
      catalog_of_obj_catalog (of_id_to_obj_map id_to_name_map)

  end