(**************************************************************************)
(*                                                                        *)
(*  Copyright (C) 2012 Johannes 'josch' Schauer <j.schauer@email.de>      *)
(*  Copyright (C) 2012 Pietro Abate <pietro.abate@pps.jussieu.fr>         *)
(*                                                                        *)
(*  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 3 of the    *)
(*  License, or (at your option) any later version.  A special linking    *)
(*  exception to the GNU Lesser General Public License applies to this    *)
(*  library, see the COPYING file for more information.                   *)
(**************************************************************************)

open ExtLib
open Common
open Debian
open Algo

include Util.Logging(struct let label = __FILE__ end) ;;

let progressbar_src_graph = Util.Progress.create "src_graph"
let timer_src_graph = Util.Timer.create "src_graph"

module IntSet = BootstrapCommon.IntSet

type vertex =
  | SrcPkg of int
  | SCC of IntSet.t (* as they have no outgoing edges, uninstallable
                       source packages cannot be part of an scc. Therefor
                       it is not necessary to store their installability *)

let vertex_compare a b = match a,b with
  | SrcPkg a, SrcPkg b -> compare a b
  | SrcPkg _, SCC _ -> -1
  | SCC _, SrcPkg _ -> 1
  | SCC a, SCC b -> IntSet.compare a b

let vertex_hash a =
  (* since package ids are unique in the graph, the minimum set element unique
   * identifies sets *)
  match a with
    | SrcPkg i -> i
    | SCC i -> IntSet.min_elt i

type 'a edge = {
  binaries : IntSet.t ref;
  strong : IntSet.t;
  strong_direct : IntSet.t;
  annotation : 'a list
}

type et = [`Loop | `NoLoop ]

module PkgV = struct
  type t = vertex
  let compare = vertex_compare
  let hash = vertex_hash
  let equal v1 v2 = (vertex_compare v1 v2) = 0
end

let default_edge = {
  binaries = ref IntSet.empty;
  strong = IntSet.empty;
  strong_direct = IntSet.empty;
  annotation = []
}

module PkgE = struct
  type t = et edge
  let compare x y = compare x y
  let equal x y = ( compare x y ) = 0
  let default = default_edge
end

module G = Graph.Imperative.Digraph.ConcreteBidirectionalLabeled(PkgV)(PkgE)

module VertexSet = Set.Make(G.V)
module EdgeSet = Set.Make(G.E)

let dist_graph ?(available=(fun _ -> true)) ?(allowmismatch=false) ?(selfcycles=false) custom_is_ht univ sl =
  Util.Timer.start timer_src_graph;
  Util.Progress.set_total progressbar_src_graph (List.length sl);

  let g = G.create () in
  let pool = Depsolver_int.init_pool_univ ~global_constraints:true univ in

  let bin2src pkg = try
      BootstrapCommon.get_src_package ~allowmismatch univ pkg
    with Sources.NotfoundSrc ->
      failwith (Printf.sprintf "can't find source package for binary package %s" (CudfAdd.string_of_package pkg))
  in

  List.iter (fun srcpkg ->
    Util.Progress.progress progressbar_src_graph;
    let id1 = CudfAdd.vartoint univ srcpkg in
    let src1 = SrcPkg id1 in
    let iss, _ = BootstrapCommon.compute_dependency_sets ~global_constraints:true ~partition:false custom_is_ht pool univ srcpkg in
    IntSet.iter (fun pid ->
      let binpkg = CudfAdd.inttovar univ pid in
      if not (available binpkg) then begin
        let id2 = CudfAdd.vartoint univ (bin2src binpkg) in
        let src2 = SrcPkg id2 in
        if not selfcycles || id1 = id2 then begin
          try match G.find_edge g src1 src2 with
            | _,{ binaries = s },_ -> s := IntSet.add pid !s
          with Not_found -> begin
            let label = { default_edge with binaries = ref (IntSet.singleton pid) } in
            let edge = (src1,label,src2) in
            G.add_edge_e g edge
          end
        end
      end
    ) iss;
  ) sl;
  Util.Timer.stop timer_src_graph g
;;

let from_buildgraph bg =
  let sg = G.create () in
  BuildGraph.G.iter_vertex (fun v ->
    let vertex = BuildGraph.Unique.value v in
    match vertex with
      | BuildGraph.InstSet _ ->
        let succ = BuildGraph.G.fold_succ_e (fun (_,label,v) acc ->
          let v = BuildGraph.Unique.value v in
          (* add successor to source graph already in case it is not connected
           * to others *)
          begin match v with
            | BuildGraph.SrcPkg src ->
                G.add_vertex sg (SrcPkg src)
            | _ -> failwith "impossible"
          end;
          let s = match label with
            | { BuildGraph.depend = BuildGraph.BuildsFrom { contents = s } } -> s
            | _ -> failwith "impossible"
          in
          (v, s)::acc
        ) bg v [] in
        BuildGraph.G.iter_pred (fun v ->
          let pred = BuildGraph.Unique.value v in
          (* add predecessor to source graph already in case it is not connected
           * to others *)
          begin match pred with
            | BuildGraph.SrcPkg src ->
                G.add_vertex sg (SrcPkg src)
            | _ -> failwith "impossible"
          end;
          (* iterate over all pairs of predecessors and successors to
           * connect them with an edge in the source graph *)
          List.iter (fun (succ,bins) ->
            match pred,succ with
              | BuildGraph.SrcPkg src1, BuildGraph.SrcPkg src2 -> begin
                try match G.find_edge sg (SrcPkg src1) (SrcPkg src2) with
                  | _,{ binaries = s },_ -> s := IntSet.union bins !s
                with Not_found -> begin
                  let label = { default_edge with binaries = ref bins } in
                  let edge = (SrcPkg src1,label,SrcPkg src2) in
                  G.add_edge_e sg edge
                end end
              | _ -> failwith "impossible"
          ) succ;
        ) bg v
      | _ -> ()
  ) bg;
  sg
;;

let from_ic universe ic =
  let getstr n l =
   match List.assoc n l with
     | GraphmlReader.String s -> s
     | _ -> failwith "expected string"
  in
  let getint n l =
   try match List.assoc n l with
     | GraphmlReader.Int i -> i
     | _ -> failwith "expected integer"
   with Not_found -> failwith (Printf.sprintf "cannot find key %s in list" n)
  in

  (* this hashtable cuts about 1 second of runtime on a full graph for debian
   * sid with 16k vert and 200k edges *)
  let stringtointmap = Hashtbl.create 97 in

  let stringtoint s =
    match Hashtbl.find_option stringtointmap s with
   | Some i -> i
   | None -> begin
      let name,version = String.split s " " in
      let name = CudfAdd.encode name in
      (* extract 1.0.0 from "(= 1.0.0)" *)
      let version = String.sub version 3 ((String.length version) - 4) in
      let pkgs = List.filter (fun p ->
        CudfAdd.string_of_version p = version
      ) (Cudf.lookup_packages universe name) in
      let pkg = match pkgs with
       | [] -> failwith (Printf.sprintf "cannot find %s (=%s)" name version)
       | [p] -> p
       | _ -> failwith (Printf.sprintf "more than one match for %s (=%s)" name version)
      in
      let i = CudfAdd.vartoint universe pkg in
      Hashtbl.add stringtointmap s i;
      i
    end
  in

  let node l =
    match getstr "kind" l with
     | "SrcPkg" -> begin
       let name = try CudfAdd.encode (getstr "name" l)
       with Not_found -> failwith "cannot find mandatory SrcPkg vertex attribute \"name\"" in
       let cudfversion = getint "cudfversion" l in
       let srcpkg = try Cudf.lookup_package universe (name,cudfversion)
       with Not_found -> failwith (Printf.sprintf "cannot find cudf package %s (= %d)" name cudfversion) in
       SrcPkg (CudfAdd.vartoint universe srcpkg)
     end
     | "SCC" -> begin
       let sources = try String.nsplit (getstr "sources" l) ","
       with Not_found -> failwith "cannot find mandatory SCC vertex attribute \"sources\"" in
       let is = List.fold_right (fun s -> IntSet.add (stringtoint s)) sources IntSet.empty in
       SCC is
     end
     | _ -> failwith "invalid node kind"
  in
  let edge l =
    let binaries = try String.nsplit (getstr "binaries" l) ","
    with Not_found -> failwith "cannot find mandatory edge attribute \"binaries\"" in
    let is = List.fold_right (fun s -> IntSet.add (stringtoint s)) binaries IntSet.empty in
    let strong = try String.nsplit (getstr "strong" l) ","
    with Not_found -> [] in
    let strongset = List.fold_right (fun s -> IntSet.add (stringtoint s)) strong IntSet.empty in
    let strong_direct = try String.nsplit (getstr "strong_direct" l) ","
    with Not_found -> [] in
    let strong_directset = List.fold_right (fun s -> IntSet.add (stringtoint s)) strong_direct IntSet.empty in
    {binaries = (ref is); strong_direct = strong_directset; strong = strongset; annotation = []}
  in

  let module GB = Graph.Builder.I(G) in
  let module GR = GraphmlReader.Parse(GB)(struct let node = node let edge = edge end) in
  GR.parse ic
;;

module Graphml (U : sig val univ : Cudf.universe end)  = struct
  include G

  let vertex_properties =
      ["name","string",None;
       "version","string",None;
       "cudfversion","int",None;
       "sources","string",None;
       "kind","string",None
      ]

  let edge_properties = [
    "binaries","string",None;
    "strong","string",None;
    "strong_direct","string",None;
    "annotation","string",None
    ]

  let string_of_vertex_kind = function
   | SrcPkg _ -> "SrcPkg"
   | SCC _ -> "SCC"

  let map_vertex vertex =
    match vertex with
      | SrcPkg id->
        let pkg = CudfAdd.inttovar U.univ id in
        let name = CudfAdd.decode pkg.Cudf.package in
        let version = CudfAdd.string_of_version pkg in
  
        let kind = ("kind", string_of_vertex_kind vertex) in

        let name = ("name",name) in
        let version = ("version",version) in
  
        let prop =
          List.filter_map (fun (key,_,_) ->
            if key = "version" then None else begin
              let k = if key = "cudfversion" then "version" else key in
              try let value = Cudf.lookup_package_property pkg k in
                Some(key,value)
              with Not_found -> None
            end
          ) vertex_properties
        in
        let prop = kind :: name :: version :: prop in
        (* only set those attributes which are not empty *)
        List.filter_map (fun (k,v) ->
          if v = "" then None else Some(k,v)
        ) prop
      | SCC s ->
        let sl =
          List.map (fun pid ->
            let pkg = CudfAdd.inttovar U.univ pid in
            CudfAdd.string_of_package pkg
          ) (IntSet.elements s)
        in

        let kind = ("kind", string_of_vertex_kind vertex) in

        let prop = kind :: [("sources", String.concat "," sl)] in
        (* only set those attributes which are not empty *)
        List.filter_map (fun (k,v) ->
          if v = "" then None else Some(k,v)
        ) prop

  let map_edge (_,label,_) =
    let annot = List.filter_map (function
      | _ -> None
    ) label.annotation in
    let strong =
      let pkglist = List.map (CudfAdd.inttovar U.univ) (IntSet.elements label.strong) in
      let pkglist = List.map (fun pkg -> CudfAdd.string_of_package pkg) pkglist in
      ("strong", String.concat "," pkglist)
      in
    let strong_direct =
      let pkglist = List.map (CudfAdd.inttovar U.univ) (IntSet.elements label.strong_direct) in
      let pkglist = List.map (fun pkg -> CudfAdd.string_of_package pkg) pkglist in
      ("strong_direct", String.concat "," pkglist)
    in
    let annot = ("annotation", String.concat "," annot) in
    let s = List.map (fun pid ->
      let pkg = CudfAdd.inttovar U.univ pid in
      CudfAdd.string_of_package pkg
    ) (IntSet.elements !(label.binaries)) in
    let s = ("binaries", String.concat "," s) in
    let prop = [s;strong;strong_direct;annot] in
    (* only set those attributes which are not empty *)
    List.filter_map (fun (k,v) ->
      if v = "" then None else Some(k,v)
    ) prop

  let vertex_uid = G.V.hash
  let edge_uid e = Hashtbl.hash (vertex_uid (G.E.src e),G.E.label e,vertex_uid (G.E.dst e))
end

module Oper = Defaultgraphs.GraphOper(G)
module Comp = Graph.Components.Make(G)
module Cycles = GraphUtils.FindCycles(G)
module Utils = GraphUtils.GraphUtils(G)
module Dfs = Graph.Traverse.Dfs(G)
module Printer (U : sig val univ : Cudf.universe end) = Graph.Graphml.Print(G)(Graphml(struct let univ = U.univ end))
