(**************************************************************************)
(*                                                                        *)
(*  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

#define __label __FILE__
let label =  __label ;;
include Util.Logging(struct let label = label 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 = []
}

(* we cannot just use the polymorphic compare here because that one checks
 * for structural equality and the Set data structure is structurally
 * different depending on the order in which elements were added to the set.
 * Thus instead, use Set.compare *)
let edge_compare e1 e2 = match e1, e2 with
  | { binaries = b1; strong = s1; strong_direct = sd1; annotation = a1},
    { binaries = b2; strong = s2; strong_direct = sd2; annotation = a2} ->
    let c = IntSet.compare !b1 !b2 in
    if c <> 0 then c
    else
      let c = IntSet.compare s1 s2 in
      if c <> 0 then c
      else
        let c = IntSet.compare sd1 sd2 in
        if c <> 0 then c else compare a1 a2

module PkgE = struct
  type t = et edge
  let compare x y = edge_compare x y
  let equal x y = ( edge_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 ?(global_constraints=[]) ?(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 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"
                  (BootstrapCommon.string_of_package pkg))
  in

  List.iter (fun srcpkg ->
    Util.Progress.progress progressbar_src_graph;
    let id1 = CudfAdd.pkgtoint univ srcpkg in
    let src1 = SrcPkg id1 in
    let iss, _ = BootstrapCommon.compute_dependency_sets ~global_constraints ~partition:false custom_is_ht pool univ srcpkg in
    IntSet.iter (fun pid ->
      let binpkg = CudfAdd.inttopkg univ pid in
      if not (available binpkg) then begin
        let id2 = CudfAdd.pkgtoint 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 native_arch 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

  let node l =
    match getstr "kind" l with
     | "SrcPkg" -> begin
         let cudfname = try
             CudfAdd.encode (getstr "cudfname" l)
           with Not_found ->
             failwith "cannot find mandatory SrcPkg vertex attribute \"cudfname\""
         in
       let cudfversion = getint "cudfversion" l in
       let srcpkg = try
           Cudf.lookup_package universe (cudfname,cudfversion)
         with Not_found ->
           failwith (Printf.sprintf "cannot find cudf package %s (= %d)"
                       cudfname cudfversion)
       in
       SrcPkg (CudfAdd.pkgtoint universe srcpkg)
     end
     | "SCC" -> begin
       let sources = try getstr "sources" l
       with Not_found -> failwith "cannot find mandatory SCC vertex attribute \"sources\"" in
       let is = BootstrapCommon.parse_debian_pkgstring universe native_arch sources in
       SCC is
     end
     | _ -> failwith "invalid node kind"
  in
  let edge l =
    let binaries = try getstr "binaries" l
    with Not_found -> failwith "cannot find mandatory edge attribute \"binaries\"" in
    let is = BootstrapCommon.parse_debian_pkgstring universe native_arch binaries in
    let strong = try getstr "strong" l
    with Not_found -> "" in
    let strongset = BootstrapCommon.parse_debian_pkgstring universe native_arch strong in
    let strong_direct = try getstr "strong_direct" l
    with Not_found -> "" in
    let strong_directset = BootstrapCommon.parse_debian_pkgstring universe native_arch strong_direct 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;
       "cudfname","string",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.inttopkg U.univ id in
        let kind = ("kind", string_of_vertex_kind vertex) in
        let cudfname = ("cudfname", CudfAdd.decode pkg.Cudf.package) in
        let prop =
          (* store cudf property "version" in vertex property "cudfversion"
           * store cudf property "number" in vertex property "version"
           * for all other vertex properties, take the cudf property directly *)
          List.filter_map (fun (key,_,_) ->
              let k =
                if key = "cudfversion" then "version"
                else if key = "version" then "number"
                else key
              in
              try let value = Cudf.lookup_package_property pkg k in
                Some(key,value)
              with Not_found -> None
          ) vertex_properties
        in
        let prop = kind :: cudfname :: 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.inttopkg U.univ pid in
            BootstrapCommon.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.inttopkg U.univ) (IntSet.elements label.strong) in
      let pkglist = List.map (fun pkg -> BootstrapCommon.string_of_package pkg) pkglist in
      ("strong", String.concat "," pkglist)
      in
    let strong_direct =
      let pkglist = List.map (CudfAdd.inttopkg U.univ) (IntSet.elements label.strong_direct) in
      let pkglist = List.map (fun pkg -> BootstrapCommon.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.inttopkg U.univ pid in
      BootstrapCommon.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))