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

module IntSet = BootstrapCommon.IntSet

module Make (U : sig val univ : Cudf.universe end) = struct
  module G = SrcGraph.G

  let string_of_intsetscc s =
    let minpkg = CudfAdd.inttovar U.univ (IntSet.min_elt s) in
    let pkgname = CudfAdd.decode minpkg.Cudf.package in
    let card = IntSet.cardinal s in
    Printf.sprintf "%s, ... and %d more" pkgname (card-1)

  let package_of_vertex = function
    | SrcGraph.SrcPkg id ->
        CudfAdd.inttovar U.univ id
    | SrcGraph.SCC s ->
        CudfAdd.inttovar U.univ (IntSet.min_elt s)

  let string_of_vertex ?(fvs=IntSet.empty) = function
    | SrcGraph.SrcPkg id ->
        let pkg = CudfAdd.inttovar U.univ id in
        let name = CudfAdd.decode pkg.Cudf.package in
        if IntSet.mem id fvs then name^"(*)" else name
    | SrcGraph.SCC s ->
        Printf.sprintf "SCC#%d (%s)" (IntSet.min_elt s) (string_of_intsetscc s)

  let annotate is_strong g =
    let ag = G.create () in
    G.iter_edges_e (fun (v1,label,v2) ->
      match v1 with
        | SrcGraph.SrcPkg sid ->
            let srcpkg = CudfAdd.inttovar U.univ sid in
            let binaries = !(label.SrcGraph.binaries) in
            let strong = IntSet.filter (fun pid -> is_strong srcpkg (CudfAdd.inttovar U.univ pid)) binaries in
            if IntSet.is_empty strong then
              G.add_edge_e ag (v1,label,v2)
            else begin
              (* these binary packages in the installation set are strong
               * dependencies of the source package
               * now figure out the set of binary packages from the source
               * package's dependencies of which those binary packages are also
               * strong dependencies *)
              let s = List.fold_left (fun acc vpkglist ->
                let pkgs = CudfAdd.resolve_deps U.univ vpkglist in
                (* calculate the strong dependencies for each package in the
                 * disjunction
                 * intersect those strong dependencies with the strong
                 * dependencies found above *)
                let inters = List.fold_left (fun acc pkg ->
                  let strong2 = IntSet.fold (fun pid acc ->
                    if is_strong pkg (CudfAdd.inttovar U.univ pid) then IntSet.add pid acc else acc
                  ) strong IntSet.empty in
                  IntSet.inter strong2 acc
                ) strong pkgs in
                let pkgs = List.map (CudfAdd.vartoint U.univ) pkgs in
                (* if the intersection of those sets is not empty, add the
                 * packages of the disjuction *)
                if IntSet.is_empty inters then acc
                else List.fold_right IntSet.add pkgs acc
              ) IntSet.empty (srcpkg.Cudf.depends) in
              G.add_edge_e ag (v1,{SrcGraph.binaries=ref binaries; strong=strong; strong_direct=s; annotation=[]},v2)
            end
        | SrcGraph.SCC _ ->
            failwith "not implemented"
    ) g;
    ag

  let collapse_scc g =
    (* non degenerate strongly connected components *)
    let sccs = (List.filter (function [] | [_] -> false | _ -> true) (SrcGraph.Comp.scc_list g)) in
    List.iter (fun scc ->
      (* for each scc, create a new SCC vertex, remove the old vertices and
       * reconnect their edges to the new SCC vertex *)
      let scc_set = List.fold_left (fun acc vert ->
        match vert with
          | SrcGraph.SrcPkg id -> IntSet.add id acc
          | _ -> failwith "not implemented"
      ) IntSet.empty scc in
      let scc_vert = SrcGraph.SCC scc_set in
      List.iter (fun vert ->
        G.iter_succ_e (fun (_,label,v) ->
          match v with
            | SrcGraph.SCC s ->
                if IntSet.compare s scc_set <> 0 then begin
                  try match G.find_edge g scc_vert v with
                    | _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
                  with Not_found -> G.add_edge_e g (scc_vert,label,v)
                end
            | SrcGraph.SrcPkg id ->
              if not (IntSet.mem id scc_set) then begin
                try match G.find_edge g scc_vert v with
                  | _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
                with Not_found -> G.add_edge_e g (scc_vert,label,v)
              end
        ) g vert;
        G.iter_pred_e (fun (v,label,_) ->
          match v with
            | SrcGraph.SCC s ->
                if IntSet.compare s scc_set <> 0 then begin
                  try match G.find_edge g v scc_vert with
                    | _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
                  with Not_found -> G.add_edge_e g (v,label,scc_vert)
                end
            | SrcGraph.SrcPkg id ->
                if not (IntSet.mem id scc_set) then begin
                  try match G.find_edge g v scc_vert with
                    | _,{ SrcGraph.binaries = s },_ -> s := IntSet.union !s !(label.SrcGraph.binaries)
                  with Not_found -> G.add_edge_e g (v,label,scc_vert)
                end
        ) g vert;
        G.remove_vertex g vert;
      ) scc;
    ) sccs;
    (* pass over the vertices in the resulting graph and replace all self cycles
     * with an SCC node *)
    G.iter_edges (fun v1 v2 ->
      match v1,v2 with
        | SrcGraph.SrcPkg sid1, SrcGraph.SrcPkg sid2 ->
            if sid1 = sid2 then begin
              G.remove_edge g v1 v2;
              let newvert = SrcGraph.SCC (IntSet.singleton sid1) in
              G.iter_succ_e (fun (_,label,v2) -> G.add_edge_e g (newvert,label,v2)) g v1;
              G.iter_pred_e (fun (v2,label,_) -> G.add_edge_e g (v2,label,newvert)) g v1;
              G.remove_vertex g v1;
            end
        | _ -> ()
    ) g;
end
