(*
This file is part of the dpll(t) engine sammy
Copyright (C) 2004  The University of Iowa
George Hagen

This program 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 2
of the License, or (at your option) any later version.

This program 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 this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
*)

(* dpllt.ml *)

(* This always checks a predicate's status before asserting it, and so never
   asserts determined predicates.
*)

let debugi = true

open Global

exception FinalIncons
exception Timeout
exception GlobalTimeout
exception AlreadySet
exception NoMoreLiterals
exception DontKnow
exception PartialModel
exception Backtrack
exception StatusError of int

exception Incons of Global.pred_id list

let debug_count = ref 0;;

(* note: in satbox lists, the MOST RECENTLY ASSIGNED literal should come FIRST *)

(* generate a new priority queue based on the current pred list *)
let create_pqueue () =
  let predlist = List.fold_left (fun acc x ->
                       if Pred.pred_status x = Global.Undet then
                         x::acc
                       else
                         acc
                 ) [] (Sys_state.pred_db#all_preds)
  in
  Pqueue.create_queue (Array.of_list predlist) State.initial_state


let p_list = ref ([]:Global.pred_id list)
let t_list = ref ([]:Global.pred_id list)
let pq = ref Pqueue.empty_queue
let conflict_num = ref 0 
let pred_db = Sys_state.pred_db
let cstore = Sys_state.cstore
let exhausted = ref false
(*let since_bcp = ref 0*)
let decision_lits = ref ([]:(Global.pred_id * int) list)


(**************************)
(* may want to still keep track of status locally *)
(*
let set_lit_status in_list =
if debug then (print_string  ("Dpllt.set_lit_status");print_string "\n";flush stdout);
    List.iter (fun x -> 
      let lit = pred_db#get_lit x in
      let pred = Pred.pred lit in
      let state = State.current_state() in
      let status = 
        if is_negative x then Unsat
        else Valid
      in
if debug then (print_string  ("setting status for: "^(id_string x)^" : "^(val_string status));print_string "\n";flush stdout);
      Pred.pred_set_status pred state status
    ) in_list
*)

(**************************)
let backtrack_to_level level =
(*
print_string ("\nDpllt.backtrack_to_level "^(string_of_int level)^"\n");
print_string "\n";flush stdout;
*)
if adebug then (print_string  ("\n\nDpllt.backtrack_to_level "^(string_of_int level));print_string "\n";flush stdout);
    let rec retracted_decisions ds =
      match ds with
          [] -> []
        | (_,lev)::r -> if lev > level then retracted_decisions r
                        else ds
    in
    conflict_num := !conflict_num + 1;
(*
    if !conflict_num mod Global.pars.activity_cycle = 0 then
      begin
if debug then (print_string  ((string_of_int !conflict_num)^" conflicts, initializing decay");print_string "\n";flush stdout);
        Satbox.weight_decay ()
      end;
    if !conflict_num mod Global.pars.restart_cycle = 0 then
      begin
        ()
      end;
*)
    State.backtrack_to_level level;
    let state = State.current_state() in
    cstore#backtrack state;
    decision_lits := retracted_decisions !decision_lits;
    Pqueue.backtrack_queue !pq state
(*;Pqueue.print_queue !pq*)


(**************************)
(* if we backtrack normally, nothing changes *)
let sat_check in_list =
if adebug then (print_string  ("\nDpllt.sat_check");print_string "\n";flush stdout);
(*pintl in_list;*)
    (* we may need to tell the satbox about the reasons for this *)
    List.iter (fun x -> 
if adebug then (Printf.printf  ("\nDpllt.sat_check set assertion %d\n") x;flush stdout);
      let implist = (cstore#implicants x) in
if debugi then begin
List.iter (fun y ->
let pred = pred_db#get_pred x in
let predx = pred_db#get_pred y in
if Pred.pred_status predx == Undet then
begin
Printf.printf "ERROR! %d's implicant %d undet\n" x y;
if Pred.is_interpreted pred then
Printf.printf "%d is a theory pred\n" x
else Printf.printf "%d is NOT a theory pred\n" x;
if Pred.is_interpreted predx then
Printf.printf "%d is a theory pred\n" y
else Printf.printf "%d is NOT a theory pred\n" y;
if Pred.is_interpreted pred then
Printf.printf "%d's theory value is %s\n" x (Global.val_string (cstore#t_status pred));
if Pred.is_interpreted predx then
Printf.printf "%d's theory value is %s\n" y (Global.val_string (cstore#t_status predx)
);
raise AlreadySet
end
) implist
end;
      Satbox.set_assertion_reasons x implist) in_list;
      
    let ((s_level,lits) as res) = Satbox.assert_literals in_list in
if adebug then (print_string  ((string_of_int s_level)^"/"^(string_of_int (State.current_level())));print_string "\n";flush stdout);
    if s_level < State.current_level() then
      begin
        backtrack_to_level s_level
      end;
    lits


(**************************)
(* if we hit an incons, we ask the satbox to backtrack *)
(* then we raise an incons to shortcut the fold *)
let theory_check lit_id =
if adebug then (print_string  ("\nDpllt.theory_check "^(id_string lit_id));print_string "\n";flush stdout);
    let lit = pred_db#get_lit lit_id in
if adebug then (print_string  ("asserting "^(id_string(Pred.lit_id lit)));print_string "\n";flush stdout);
(*    if Pred.is_interpreted (Pred.pred lit) then*)
      begin
        try
          cstore#assert_lit lit (* returns changed_lits *)
        with Theory.Incons ->
(*Printf.printf("Dpllt.Theory.Incons\n");*)
if adebug then (print_string  ("Theory.Incons");print_string "\n";flush stdout);
if adebug then (print_string  ((id_string lit_id)^" status "^(val_string (cstore#theory#status (unsigned lit_id))));print_string "\n";flush stdout);
          (* the lit was incons, so get the inconsistency of -lit *)
          let impl = cstore#implicants (compl lit_id) in
          Satbox.set_assertion_reasons lit_id impl;
          let (s_level,lits) = Satbox.backtrack ((*compl*) lit_id) in
if adebug then (print_string  ("after satbox backtrack");print_string "\n";flush stdout);
          backtrack_to_level s_level;
          raise (Incons lits)
      end
(*    else
      []
*)

(**************************)
(* this reverses the plist, so afterwards the newer should be first *)
(* base_list should either contain a just-discovered theory pred or be empty *)
let theory_check_loop (base_list:Global.pred_id list) =
if adebug then (print_string  ("Dpllt.theory_check_loop");print_string "\n";flush stdout);
(*pintl base_list;*)
(*pintl !p_list;*)
      (* p_list should be oldest first *)
      t_list := !p_list;
      while (!t_list != []) do
        begin
          try
            let l = List.fold_left
               (fun acc x ->
if adebug then (print_string  ("Dpllt.inside sat_theory_loop "^(id_string x));print_string "\n";flush stdout);
                  List.rev_append (theory_check x) acc) base_list !t_list
            in
            (* l should be oldest last *)
            p_list := l;
            t_list := []
          with Incons lits -> 
if adebug then (print_string  ("Dpllt.sat_theory_loop INCONS");print_string "\n";flush stdout);
            (* lits should be oldest first *)
            t_list := lits
        end
      done
(* at this point p_list should contain none of the predicates it had upon entry except those in base_list *)


(**************************)
let sat_theory_loop () =
if adebug then (print_string  ("-->sat_theory_loop start");print_string "\n";flush stdout);
    while (!p_list != []) do
(* At this point p_list is _oldest_ first.  We need to make it newest first *)
      p_list := sat_check !p_list;
(*set_lit_status !p_list;*)
      (* ready to do theory checks *)
      theory_check_loop []
(*;set_lit_status !p_list*)
    done
;if adebug then (print_string "-->sat_theory_loop done"; print_string "\n";flush stdout)


(**************************)
(* add one clause to the current context; this may cause assertions *)
(* assumes that we are at level zero *)
let update_clauses (cl: Global.pred_id list) =
if adebug then (print_string  ("Dpllt.update_clauses");print_string "\n";flush stdout);
  let (s_level, lits) = Satbox.insert_user_lemma cl in
  if s_level < State.current_level() then
    begin
      backtrack_to_level s_level
    end;
(*
Printf.printf "return level %d\n" s_level;
pintl lits;
print_string "\n";flush stdout;
*)
  p_list := lits;
  theory_check_loop [];
(*
pintl !p_list;
*)
  while (!p_list != []) do
    p_list := sat_check !p_list;
    theory_check_loop [];
    sat_theory_loop ()
  done;
  if s_level < State.current_level() then
    raise (Incons lits)



(**************************)
let current_decisions_lemma () =
  List.map (fun (x,y) -> compl x) !decision_lits


(**************************)
(* instantation *)
(* raises NoMoreLiterals & Incons *)
let instantiate skolemizer iset =
  let curr_level = State.current_level() in
  if Global.pars.verbose then
    begin
      Printf.printf "\nPotential model found at level %d\n" (curr_level);flush stdout;
(*pred_db#print_all();*)
    end;
  (* call skolemizer *)
  (*debug_count:= !debug_count +1;Printf.printf "skolemizer called %dst time\n" !debug_count;
  Term_db.term_db#print_templates;
  Term_db.term_db#print_term_db;
  flush stdout;*)
  let inst_return = skolemizer#get_new_lemmas in
  (*Printf.printf "skolemizer exited %dst time\n" !debug_count;
  Term_db.term_db#print_templates;
  Term_db.term_db#print_term_db;
  flush stdout;*)

    begin
      match inst_return with
       | Skolemizer.FINISH ->
                raise NoMoreLiterals (* DONE *)
       | Skolemizer.EXHAUSTED_INSTANTIATIONS -> (* cut off this model *)
              begin
         (* generate new lemma that rules out current model *)
         (* raises Incons *)
(*Printf.printf "dpllt: EXHAUSTED\nAdd a lemma to cut off this model\n";print_string "\n";flush stdout;*)
                (* create temporary clause based on model *)
                let lemma_lits = 
                  if Global.pars.narrow_model_rejection then
                    current_decisions_lemma()
                  else
                    begin
                      pred_db#quantified_lemma;
                    end
                in
(*pintl lit_list;*)
(*
List.sort compare                  
(current_decisions_lemma ()
)
*)
                exhausted:=true;
                (* check the levels of the literals involved! *)
                let maxlevel = 
                  List.fold_left (fun max x -> 
                    let llev = Satbox.lit_level x in
                    if max > llev then max else llev
                  ) 0 lemma_lits
                in
(*Printf.printf "MAX LEVEL = %d\n" maxlevel;*)
                if (maxlevel = 0) then
                  raise Satbox.SBI_Incons;
                try
                  update_clauses lemma_lits (*lit_list*)
                with (Incons _) -> ()
              end
                (* If the model rejection is at the empty level,
                   we don't know what the outcome is *)
       | Skolemizer.INSTANTIATIONS (new_preds, new_pred_id_lists) ->
              begin
(*Printf.printf "dpllt: INSTANTIATIONS\n";*)
                (* continue -- new_pred_id_lists must not be empty *)
                if not (new_preds = []) then
                  Pqueue.augment_queue !pq new_preds;
                try
                  iset#add_instance 
                    (List.map (fun x-> x) new_pred_id_lists);
                  List.iter (fun x-> 
                    update_clauses x
                  ) new_pred_id_lists
                with (Incons _) -> () (* shortcut the lemmas *)
             end
    end


(**************************)
let initial_bcp () =
    let ((init_level,init_lits)) = Satbox.initial_bcp () in (* may raise incons *)
    (* initial BCP *)
    p_list := init_lits;
(*    set_lit_status !p_list;*)
    p_list := List.fold_left
                (fun acc x -> 
                   List.rev_append (theory_check x) acc) [] !p_list;
(*    set_lit_status !p_list;*)
    sat_theory_loop()


(**************************)
(* check the reasons for a theory literal *)
(* assumes lit is theory-interpreted *)
(* backjump if necessary *)
(* othewise continues propagation *)
(*
let theory_level_check lit_id =
if adebug then (Printf.printf  ("theory_level_check %d \n") lit_id;flush stdout);
  let impl = cstore#implicants lit_id in
  let this_lev = List.fold_left (fun acc x -> 
                   let new_lev = Satbox.lit_level x in
                   if new_lev > acc then
                     new_lev
                   else
                     acc
                 ) 0 impl
  in (* level this literal should have been detected *)
Printf.printf "set_at %d; current_lev %d\n" this_lev (State.current_level());
  if this_lev < State.current_level() then
    begin
      Satbox.back_to_level (this_lev);
      backtrack_to_level (this_lev);
Printf.printf "new_lev %d\n" (State.current_level());
      update_clauses (lit_id::(List.map (fun x -> compl x) impl))
    end
  else
    begin
      p_list := [lit_id];
      theory_check_loop [lit_id];
      sat_theory_loop()
    end
*)



(**************************)
(* main dpllt loop *)
let satisfiable old_q (cstore:Cstore.cstore) pred_db (skolemizer:Skolemizer.skolemizer) (iset:Iset.iset) =
if adebug then (print_string  ("Dpllt.satisfiable start");print_string "\n";flush stdout);
  let stime = Sys.time() in

  let branch_num = ref 0 in

  exhausted := false;
(*  since_bcp := 0;*)

  (**************************)
  let print_stats () =
    Satbox.print_stats();
    Printf.printf "\nConflicts: %d\n" !conflict_num;
    Printf.printf "Branches: %d\n" !branch_num
  in

  (**************************)
  (* raises Pqueue.Empty & Incons & PartialModel *)
  (* assumes that the theory is not initially unsat! *)
  let rec next_lit() =
    let (p,s) = 
      (* get a watched lit *)
      if Global.pars.stop_on_partial_model then
        begin
          let p1 = Pqueue.peek_queue !pq in
          if not (Pred.is_watched p1) then
            begin
if adebug then (print_string ("Next lit "^(id_string (Pred.id p1))^" not watched");print_string "\n";flush stdout);
              Pqueue.sort_queue !pq;
              let p2 = Pqueue.peek_queue !pq in
              if not (Pred.is_watched p2) then
                begin
if adebug then (print_string ("Partial Model Found");print_string "\n";flush stdout);
                  raise PartialModel
                end
            end
        end;
      Pqueue.dequeue !pq
    in
(*    let lit = if s = Valid then
                pred_db#get_lit (Pred.id p)
              else
                pred_db#get_lit (compl (Pred.id p))
    in
*)

    let lit_id = 
      if s=Valid then
        Pred.id p
      else
        compl(Pred.id p)
(*    Pred.lit_id lit *)
    in
if adebug then (print_string  ("Dpllt.next_lit checking "^(id_string lit_id));print_string "\n";flush stdout);
(*if debug then (print_string  (Pred.lit_string lit);print_string "\n";flush stdout);*)
    match Satbox.lit_value lit_id with
        Undet -> (* make sure this is really undet *)
          begin
            let lit_t_status = 
              if s==Valid then
                cstore#t_status p
              else
                status_complement (cstore#t_status p)
            in
            match lit_t_status with
                Undet -> 
if adebug then (print_string  ("Dpllt.next_lit (undetermined)");print_string "\n";flush stdout);
                         lit_id
              | Valid -> 
if adebug then (print_string  ("Dpllt.next_lit (theory determined "^(id_string lit_id)^" valid)");print_string "\n";flush stdout);
(*                         theory_level_check lit_id;*)
                         p_list := [lit_id];
                         theory_check_loop [lit_id];
                         sat_theory_loop();
                         next_lit ()
              | Unsat -> 
if adebug then (print_string  ("Dpllt.next_lit (theory determined "^(id_string lit_id)^" unsat)");print_string "\n";flush stdout);
(*                         theory_level_check (compl lit_id);*)
                         p_list := [compl lit_id];
                         theory_check_loop [compl lit_id];
                         sat_theory_loop();
                         next_lit ()
          end

        | x -> (* the literal is already determined *)
if adebug then (print_string  ("Dpllt.next_lit (bcp determined)");print_string "\n";flush stdout);
            if extra_test then 
              begin
                let lit_t_status = 
                  if s=Valid then
                    cstore#t_status p
                  else
                    status_complement (cstore#t_status p)
                in
                if (Satbox.lit_value lit_id) <> lit_t_status then 
                  raise (StatusError(lit_id))
              end;
              next_lit()
  in



  (**************************)
  (* main loop *)
  (*
   * advance level
   * choose lit at this level
   * BCP
   * check with theory
   *)
  let main_loop p_decide =
(*if debug then (print_string  ("Dpllt.next_lit "^(string_of_int (State.current_level())));print_string "\n";flush stdout);*)

(*Pred.print_cset();*)

(*
begin
try
Printf.printf "\n\n====== 35:%s @ level %d\n" (val_string (Satbox.lit_value 35)) (State.current_level()); print_string "\n";flush stdout;
Printf.printf "====== 36:%s @ level %d\n" (val_string (Satbox.lit_value 36)) (State.current_level()); print_string "\n";flush stdout;
Printf.printf "====== 38:%s @ level %d\n" (val_string (Satbox.lit_value 38)) (State.current_level()); print_string "\n";flush stdout;
Printf.printf "====== 40:%s @ level %d\n" (val_string (Satbox.lit_value 40)) (State.current_level()); print_string "\n";flush stdout;
Printf.printf "====== 61:%s @ level %d\n" (val_string (Satbox.lit_value 61)) (State.current_level()); print_string "\n";flush stdout;
Printf.printf "====== 72:%s @ level %d\n" (val_string (Satbox.lit_value 72)) (State.current_level()); print_string "\n";flush stdout;
with _ -> ()
end;
*)
    State.next();
    Pqueue.mark_queue !pq;
(*Pqueue.print_queue !pq;*)
if adebug then (print_string  ("\nmain_loop Level: "^(string_of_int(State.current_level())));print_string "\n";flush stdout);
if adebug then (print_string  ("Dpllt.next_lit = "^(id_string p_decide));print_string "\n";flush stdout);

(*Pred.print_cset();*)

    if (Sys.time() -. stime > Global.pars.timeout) then
      raise Timeout;

(*
    if Global.pars.stop_on_partial_model && !since_bcp > 5 then
      begin
        if Satbox.check_model () then
          raise PartialModel
        else
          since_bcp := 0
      end;
*)

    let (s_level,lits) = Satbox.decide_literal p_decide in

    decision_lits := (p_decide,State.current_level())::!decision_lits;

    branch_num := !branch_num + 1;
    if !branch_num mod Global.pars.activity_cycle = 0 then
      begin
if adebug then (print_string  ((string_of_int !branch_num)^" branches, initializing decay");print_string "\n";flush stdout);
        Satbox.weight_decay ()
      end;
    if !branch_num mod Global.pars.restart_cycle = 0 then
      begin
        ()
      end;

(*set_lit_status [p_decide];*)
    if s_level < State.current_level() then
      begin
        backtrack_to_level s_level
      end;
(*
Printf.printf "%d : %d " !since_bcp p_decide;
pintl lits;
Pqueue.print_queue !pq;
*)

    if List.memq p_decide lits then 
      p_list := lits
    else
      p_list := p_decide::lits;
(*
    begin
      match lits with
        | p_decide::_ -> (*since_bcp := !since_bcp + 1;*)
                        p_list := lits
        | _ -> (*since_bcp := 0; *)
               p_list := p_decide::lits
    end;
*)
(*set_lit_status !p_list;*)
    theory_check_loop [];
(*set_lit_status !p_list;*)
    sat_theory_loop()
;if adebug then (Printf.printf "end main_loop";print_string "\n";flush stdout);
(*pred_db#check_all (Satbox.lit_value) (cstore#t_status);*)
  (* end main loop *)
  in

  (**************************)
  (* START *)
  try

    pq := create_pqueue();
if adebug then (print_string  ("PQUEUE CREATED!");print_string "\n";flush stdout);
(*Pred.print_cset();*)
    if Global.pars.verbose then 
      begin
        Printf.printf "Satbox setup time: %f seconds\n\n" 
          ((Sys.time()) -. stime);
        flush stdout;
      end;
    (* main loop *)
    while true do
if adebug then (print_string  ("\nDpllt.next_lit "^(string_of_int (State.current_level())));print_string "\n";flush stdout);
      try
        let the_next_lit = next_lit() in
(*Printf.printf "Dpllt.next_lit = %d %f\n" the_next_lit (Sys.time() -. stime); print_string "\n";flush stdout;*)
        p_list := [];
        main_loop the_next_lit
      with Pqueue.Empty | PartialModel ->
        instantiate skolemizer iset
    done;
    true
  with NoMoreLiterals ->
if adebug then (print_string  ("Dpllt Pqueue.Empty final");print_string "\n";flush stdout);
(*pred_db#check_all (Satbox.lit_value) (cstore#t_status);*)
(*pred_db#print_all ();*)
    begin
      if Global.pars.check_model then
        begin
          Printf.printf "Checking model...\n";
          pred_db#check_all (Satbox.lit_value) (cstore#t_status);
          if Satbox.check_model() then
            Printf.printf "Model checks out!\n"
          else
            Printf.printf "Model FAILS!\n";
          Printf.printf "Done checking model.\n"
        end;
      if Global.pars.verbose then
        begin
          let print_pred_val pred =
            if (not (Pred.is_abstract pred)) &&
            (Satbox.lit_value (Pred.id pred) = Valid) then
              Printf.printf "%s " ((Pred.formula pred)^" ")
          in
          print_stats ();
          Printf.printf "\nModel:\n";
          List.iter print_pred_val pred_db#all_preds;
          Printf.printf "\n\n"
        end;
(*cstore#theory#check_consistency;*)
      true
    end
  | Incons _ -> 
if adebug then (print_string  ("Dpllt.Incons final");print_string "\n";flush stdout);
                if Global.pars.verbose then 
                  begin
                    print_stats ()
                  end;
                if (!exhausted) then raise DontKnow;
                false
  | Satbox.SBI_Incons -> 
                if (!exhausted) then
                  begin
if debug then (print_string  "DontKnow SBI_Incons: should not have set exhausted";print_string "\n";flush stdout);
                    raise DontKnow;
                  end;
if adebug then (print_string  ("Dpllt.SBI_Incons final");print_string "\n";flush stdout);
                if Global.pars.verbose then 
                  begin
                    print_stats ()
                  end;
                false


