(* Copyright 2005-2008 Berke DURAK, INRIA Rocquencourt, Jaap BOENDER.

This file is part of Dose2.

Dose2 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.

Dose2 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 Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>. *)

open Napkin
open Rapids
open Diagnosis

module N =
struct
        type t = (package_id, (unit_id, (version_number * release_number), glob) versioned) reason
        type reason = t
end;;

module S = Solver.M(N);;
module PS = Package_set;;

let sf = Printf.sprintf;;

type solver =
	SAT (* Jerome Vouillon's SAT-based solver *)
| Direct (* Direct solver *);;

let current_solver = ref SAT;;
let current_verifier = ref None;;

let set_solver s = 
	current_solver := s;;

let get_solver () =
	!current_solver;;

let set_verifier v =
	current_verifier := v;;

let get_verifier () =
	!current_verifier;;

let list_diagnosis_of (pl: package_id list) r: (package_id list, package_id, (unit_id, version_number * release_number, glob) versioned) diagnosis =
{ dg_closure_size = 0;
	dg_conflicts = 0;
	dg_disjunctions = 0;
	dg_dependencies = 0;
	dg_failures = 
		(match r with
		| [] -> [| |]
		| r' -> [| (pl, r') |])
};;

(*** renumber_set *)
let renumber_set set =
  let set_size = PS.cardinal set in
  let backward = Hashtbl.create (2 * set_size) in
  let forward = Hashtbl.create (2 * set_size) in
  let i = ref 0 in
  PS.iter (fun p_id ->
    Hashtbl.add backward !i p_id;
    Hashtbl.add forward p_id !i;
    incr i) set;
  (backward, forward)
;;

let prepare db ?(log=ignore) ~(indicator: Progress.indicator) ?targets ~available () =
	let problem_set = match targets with
	| None -> available
 	| Some t -> 
 		(* Compute the dependency closure of the set *)
  	log "Computing closure";
		PS.union t (PS.inter available (Functions.dependency_closure db t)) in
  (* Number packages *)
  let problem_size = PS.cardinal problem_set in (* Number of affected packages *)
  let (backward, forward) = renumber_set problem_set in
  let f = Hashtbl.find forward
  and g = Hashtbl.find backward
  in
  (* Generate the boolean problem *)
  log (sf "Converting to boolean problem");
  let pb = S.initialize_problem problem_size in
  let num_conflicts = ref 0
  and num_disjunctions = ref 0
  and num_dependencies = ref 0
  in
  let encoding_size = ref 0 in
  let charge x = encoding_size := !encoding_size + 2 in
  let j = ref 0 in
  (*** add conflicts and dependencies *)
  indicator#start;
  indicator#set_label "Conflicts and dependencies...";
  PS.iter
    begin fun p_id ->
      indicator#display (!j,problem_size);
      incr j;
      let p = Functions.get_package_from_id db p_id in
                        let pn = Unit_index.find (get_unit_index db) p.pk_unit in 
      (*** Add conflicts *)
                        (* log (sf "Adding conflicts (%s)..." pn);*)
      (*let conflicts = PS.inter (get_conflicts db p_id) set_closure in*)
      let conflicts = PS.inter (Functions.conflicts db (PS.singleton p_id)) problem_set in
      PS.iter
        begin fun p_id' ->
          if p_id <> p_id' then
            begin
              let x = S.lit_of_var (f p_id) false
              and y = S.lit_of_var (f p_id') false
              in
              charge 2;
              S.add_bin_rule pb x y [Conflict(p_id, p_id')];
              incr num_conflicts
            end
        end
        conflicts;
      (* ***)
      (*** Add dependencies *)
                        (* log (sf "Adding dependencies (%s)..." pn); *)
      let process conjunction =
        List.iter
          begin fun disjunction ->
            incr num_disjunctions;
            if disjunction = [] then
              () (* XXX : ignore empty disjunctions *)
            else
              begin
                let ps =
                  List.fold_left
                    begin fun ps versioned ->
                      incr num_dependencies;
                                                                                        (* let (uid, sel) = versioned in *)
                                                                                        (* log (sf "Selecting for unit %s" (Unit_index.find (get_unit_index db) uid)); *)
                      PS.union ps
                        (PS.inter available (Functions.select db versioned))
                    end
                    PS.empty
                    disjunction
                in
                (* let ps = PS.inter set ps in *)
                let o = PS.cardinal ps in
                if o = 0 then
                  begin
                    S.add_un_rule pb (S.lit_of_var (f p_id) false)
                      [Empty_disjunction(p_id, disjunction)]
                  end
                else
                  begin
                    let pl = PS.elements ps in
                    let vl = List.map f pl in
                    let l = List.map (fun v -> S.lit_of_var v true) vl in
                    charge (1 + o);
                    S.add_rule pb (Array.of_list ((S.lit_of_var (f p_id) false)::l))
                      [Dependency(p_id, pl)];
                    if l <> [] then S.associate_vars pb (S.lit_of_var (f p_id) true) vl
                  end
              end
          end
          conjunction
      in
      process p.pk_depends;
      process p.pk_pre_depends;
      (* ***)
    end
    problem_set;
                indicator#finish;
  (* PS.iter
    begin fun p_id ->
      let v = S.lit_of_var (f p_id) false in
      S.add_un_rule pb v [Not_available p_id]
    end
    (PS.diff set_closure available); *)
  (* ***)
  (*let vars = List.map f (PS.elements set) in*)
  let failures = ref [] in
  log (sf "Done, formula of size %d" !encoding_size);
        (problem_size, f, g, problem_set, pb, failures, num_conflicts, num_disjunctions, num_dependencies);;

let check
  db
  ?(log=ignore)
	?preparation
  ~(indicator : Progress.indicator)
  ~targets
  ~available
  ()
  =
	let (closure_size, f, g, set, pb, failures, num_conflicts, num_disjunctions, num_dependencies) =
	match preparation with
	| None -> prepare db ~log ~indicator ~targets ~available ()
	| Some (cs, f, g, set, pb, fl, nc, nd, ndp) ->
		(cs, f, g, set, S.copy pb, fl, nc, nd, ndp) in
	S.reset pb;
  indicator#set_label "Solving";
  let unknown = Array.make closure_size true in
  for i = 0 to closure_size - 1 do
    indicator#display (i,closure_size);
    if PS.mem (g i) targets && unknown.(i) then
      begin
        if S.solve pb i or (S.reset pb; S.solve pb i) then
          (* This package is OK *)
          begin
            let a = S.assignment pb in
            for j = 0 to closure_size - 1 do
              if a.(j) = S.True then unknown.(j) <- false
            done
          end
        else
          begin
            S.reset pb;
            ignore (S.solve pb i);
            let reasons = S.collect_reasons pb i in
            failures := (g i, reasons) :: !failures;
            S.reset pb;
          end
      end
  done;
  indicator#finish;
  (* Sort failures *)
  let a = Array.of_list !failures in
  Array.sort
    begin fun (p_id,_) (p_id',_) ->
      let f p_id =
        let p = Functions.get_package_from_id db p_id in
        (Unit_index.find (get_unit_index db) p.pk_unit, p.pk_version)
      in
      compare (f p_id) (f p_id')
    end
    a;
  (* Create diagnosis *)
  { dg_closure_size = closure_size;
    dg_conflicts = !num_conflicts;
    dg_disjunctions = !num_disjunctions;
    dg_dependencies = !num_dependencies;
    dg_failures = a }
;;

let check_together
  db
  ?(log=ignore)
	?preparation
  ~(indicator : Progress.indicator)
  ~targets
  ~available
  ()
  =
begin
	let (closure_size, f, g, set, pb, failures, num_conflicts, num_disjunctions, num_dependencies) =
	match preparation with
	| None -> prepare db ~indicator ~targets ~available ()
	| Some (cs, f, g, set, pb, fl, nc, nd, ndp) ->
		(cs, f, g, set, S.copy pb, fl, nc, nd, ndp) in
  S.reset pb;
  indicator#set_label "Solving";
	let pkgs = ref PS.empty in
  (* let unknown = Array.make closure_size true in *)
	let tg_list = List.map f (PS.elements targets) in
	log (sf "Target list size %d" (List.length tg_list));
	if not (S.solve_lst pb tg_list) then
	begin
		let reasons = S.collect_reasons_lst pb tg_list in
		failures := (List.map g tg_list, reasons) :: !failures;
		log (sf "Not successful, %d failures" (List.length !failures))
	end
	else
	 	log (sf "Successful.");
  indicator#finish;
  { dg_closure_size = closure_size;
    dg_conflicts = !num_conflicts;
    dg_disjunctions = !num_disjunctions;
    dg_dependencies = !num_dependencies;
    dg_failures = Array.of_list !failures }
end;;

let install
  db
  ?(log=ignore)
  ?preparation
  ~(indicator : Progress.indicator)
  ~targets
  ~available
  ?(known=PS.empty)
  ()
  =
	let (closure_size, f, g, set, pb, failures, num_conflicts, num_disjunctions, num_dependencies) =
	match preparation with
	| None -> prepare db ~log ~indicator ~targets ~available ()
	| Some (cs, f, g, set, pb, fl, nc, nd, ndp) -> 
		(cs, f, g, set, S.copy pb, fl, nc, nd, ndp) in
	S.reset pb;
  indicator#set_label "Solving";
	let pkgs = ref PS.empty in
  (* let unknown = Array.make closure_size true in *)
	let tg_list = List.map f (PS.elements targets) in
 	log (sf "Target list size %d" (List.length tg_list));
 	if S.solve_lst pb tg_list then
	begin
		let a = S.assignment pb in
		for i = 0 to closure_size - 1 do
			if a.(i) = S.True then
				pkgs := PS.add (g i) !pkgs;             
		done;
	end;
  indicator#finish;
	!pkgs
;;

let abundance db ps =
begin
	let package_id = ref None in
	PS.iter (fun p_id ->
		let p = Functions.get_package_from_id db p_id in
		List.iter (fun disj ->
			if !package_id = None then
				let d_ok = List.exists
					(fun v -> let range = Functions.select db v in
						not (PS.is_empty (PS.inter ps range))
					) disj in
					if not d_ok then
						package_id := Some p_id
		) (p.pk_depends @ p.pk_pre_depends);
	) ps;
	!package_id 
end;;
(* ***)

let strong_dep db ?is ?preparation available p1 p2 =
begin
  let (closure_size, f, g, set, pb, failures, num_conflicts, num_disjunctions, num_dependencies) =
	match preparation with
	| None -> prepare db ~indicator:Progress.dummy ~available ()
	| Some (cs, f, g, set, pb, fl, nc, nd, ndp) ->
		(cs, f, g, set, S.copy pb, fl, nc, nd, ndp) in
	let v2 = S.lit_of_var (f p2) false in
	S.add_un_rule pb v2 [];
	not (S.solve pb (f p1))
end;;

let trim db ps =
begin
	let res_ps = ref ps in
	let d = check db ~indicator:Progress.dummy ~targets:ps ~available:ps () in
	Array.iter (fun (p_id, _) ->
		res_ps := Package_set.remove p_id !res_ps
	) d.dg_failures;
	!res_ps
end;;
