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

(* satbox.ml *)

external sbi_set_assertion_reasons : int -> int array -> unit = "sbi_set_assertion_reasons";;
external sbi_increase_activity : int -> int -> unit = "sbi_increase_activity";;
external sbi_weight_decay : unit -> unit = "sbi_weight_decay";;
external sbi_get_literal_weight : int -> int = "sbi_get_literal_weight";;
external sbi_satbox_init : unit -> unit = "sbi_satbox_init";;
external sbi_insert_clause : int array -> unit = "sbi_insert_clause";;
external sbi_insert_user_lemma : int array -> int = "sbi_insert_user_lemma";;
external sbi_remove_last_user_lemma : int -> int = "sbi_remove_last_user_lemma";;
external sbi_initial_bcp : unit -> int = "sbi_initial_bcp";;
external sbi_restart_search : unit -> unit = "sbi_restart_search";;
external sbi_get_level : unit -> int = "sbi_get_level";;
external sbi_get_number_of_forced_lits : unit -> int = "sbi_get_number_of_forced_lits";;
external sbi_get_forced_literal_n : int -> int = "sbi_get_forced_literal_n";;
external sbi_backtrack : int -> int = "sbi_backtrack";;
external sbi_assert_literals : int array -> int = "sbi_assert_literals";;
external sbi_decide_literal : int -> int = "sbi_decide_literal";;
external sbi_lit_value : int -> int = "sbi_lit_value";;
external sbi_var_value : int -> int = "sbi_var_value";;
external sbi_var_level : int -> int = "sbi_var_level";;
external sbi_back_to : int -> unit = "sbi_back_to";;
external sbi_print_stats : unit -> unit = "sbi_print_stats";;
external sbi_satbox_check_model : unit -> int = "sbi_satbox_check_model";;
external sbi_var_is_watched : int -> int = "sbi_var_is_watched";;

open Global

exception SBI_Incons
exception SBI_Stack_Error

let total_user_lemmas = ref 0
let initial_decision = ref 0

let cset = ref []

let cset_add (ll:Global.pred_id list) =
  if Global.pars.check_model then
    cset := ll::!cset

let lemma_stack = ref [(0,0)] (* level, #lemmas *)

let add_lemmas_to_stack num = 
  let level = State.current_level() in
  let rec alts ls out =
    match ls with
        [] -> failwith "tried to add lemma to level < 0"
      | (l,n)::s ->
          if l = level then
            begin
              lemma_stack := (l,n+num)::s;
              out
            end
          else if l < level then
            begin
              lemma_stack := (level,num)::ls;
              out
            end
          else
            begin
              alts s (out+n)
            end
  in
  alts !lemma_stack 0
  

(* stores the first decision we made *)
let set_initial_decision pid =
  if !initial_decision == 0 then
  initial_decision := pid

let reset_initial_decision () =
  initial_decision := 0

let sam_to_sb (id:Global.pred_id) =
id
(*
  if Global.is_positive id then
    (id lsl 1) lor 1
  else
    (id lsl 1)
*)

let sb_to_sam (id:int) =
id
(*
  if (id land 1) = 1 then
    (id lsr 1)
  else
    Global.compl (id lsr 1)
*)

let get_level () =
if debug then (print_string  ("satbox.get_level()");print_string "\n";flush stdout);
  sbi_get_level ()
  

(* this returns the oldest assigned literal first *)
let get_additional_preds () =
(* we want to work from end forwards *)
if debug then (print_string  ("satbox.get_additional_preds()");print_string "\n";flush stdout);
  let num = sbi_get_number_of_forced_lits () in
  let rec scan_preds n l =
    if n >= 0 then
      let id = (sb_to_sam(sbi_get_forced_literal_n n)) in
      scan_preds (n-1) (id::l)
    else
      l
  in
  scan_preds (num-1) []

let set_assertion_reasons id reasons =
  let sb_reasons = Array.of_list (List.map (sam_to_sb) reasons) in
  sbi_set_assertion_reasons (sam_to_sb id) sb_reasons

let weight_decay () = 
  sbi_weight_decay ()

let get_literal_weight id =
  sbi_get_literal_weight (sam_to_sb id)

let increase_activity id n =
  sbi_increase_activity (sam_to_sb (id)) n

let satbox_init () = 
if debug then (print_string ("Satbox.satbox_init");print_string "\n";flush stdout);
  sbi_satbox_init ()

let insert_clause ids =
if debug then (print_string  ("Satbox.insert_clause");print_string "\n";flush stdout);
let stime = Sys.time() in
(*pintl ids;*)
cset_add ids;
  let l = List.fold_left (fun acc x ->
      let i = sam_to_sb x in
      if List.mem i acc then
        acc
      else
        i::acc
    ) ids
  in
  sbi_insert_clause (Array.of_list (List.map (fun x -> 
(*print_string "%s " (Global.sid_string x);*)
               sam_to_sb x) ids))
(*;print_string "0\n"*)
;if debug then (print_string "Satbox.insert_clause done";print_string "\n";flush stdout)

(* remove the last n retractable clauses added *)
let retract_user_lemmas n =
  if n < 0 then
    begin
if debug then (print_string  ("-->Satbox.retract_user_lemmas "^(string_of_int n)^" at lev "^(string_of_int(State.current_level())));print_string "\n";flush stdout);
      total_user_lemmas := !total_user_lemmas - n;
      sbi_remove_last_user_lemma n
    end
  else 0


(* add a retractable clause *)
let insert_user_lemma ids =
if debug then (print_string  ("Satbox.insert_user_lemma "^(string_of_int !total_user_lemmas));print_string "\n";flush stdout);
cset_add ids;
  let l = List.fold_left (fun acc x ->
      let i = sam_to_sb x in
      if List.mem i acc then
        acc
      else
        i::acc
    ) ids
  in
  let sat = sbi_insert_user_lemma (Array.of_list (List.map (fun x ->
(*print_string "%s " (Global.sid_string x);print_string "\n";flush stdout;*)
               sam_to_sb x) ids))
  in
(*print_string "0: %d\n" sat;*)
  if sat = 0 then
(if debug then (print_string  ("Satbox.SBI_Incons insert_user_lemma");print_string "\n";flush stdout);
(*    (get_level(),get_additional_preds())*)
    raise SBI_Incons 
)
  else
    begin
      let out = (get_level(),get_additional_preds()) in
      total_user_lemmas := !total_user_lemmas + 1;
      let lemmas_to_remove = add_lemmas_to_stack 1 in
      retract_user_lemmas lemmas_to_remove;
      out
    end

(* this returns the oldest assigned literal first *)
let initial_bcp () = 
if debug then (print_string  ("Satbox.initial_bcp");print_string "\n";flush stdout);
  if sbi_initial_bcp () = 0 then
    raise SBI_Incons 
  else
    (get_level(),get_additional_preds())

(* this returns the oldest assigned literal first *)
let backtrack lit =
if debug then (print_string  ("Satbox.backtrack");print_string "\n";flush stdout);
  if sbi_backtrack (sam_to_sb lit) = 0 then
(if debug then (print_string  ("Satbox.SBI_Incons backtrack on "^(id_string lit));print_string "\n";flush stdout);
    raise SBI_Incons
)
  else
    (get_level(),get_additional_preds())

let back_to_level level =
if debug then (print_string ("Satbox.back_to_level "^(string_of_int level));print_string "\n";flush stdout);
  sbi_back_to level
    
(* this returns the oldest assigned literal first *)
let restart_search () =
if debug then (print_string ("Satbox.restart_search");print_string "\n";flush stdout);
  sbi_restart_search ();
(*  back_to_level 0;*)
  reset_initial_decision ();
  retract_user_lemmas (!total_user_lemmas)
(*  *)

(* this returns the oldest assigned literal first *)
let assert_literals ids =
if debug then (print_string  ("Satbox.assert_literals");print_string "\n";flush stdout);
(*print_string "Satbox.assert_literals ";*)
(*pintl ids;*)
  if sbi_assert_literals (Array.of_list (List.map (
(*fun x ->
print_string "%s " (Global.sid_string x);*)
  sam_to_sb (*x*)) ids)) = 0 then
(if debug then (print_string  "Satbox.SBI_Incons assert_literals";print_string "\n";flush stdout);
    raise SBI_Incons
)
  else
(*print_string "\n";*)
    (get_level(),get_additional_preds())

(* this returns the oldest assigned literal first *)
let decide_literal id =
if debug then (print_string  ("Satbox.decide_literal "^(sid_string id)^" at level "^(string_of_int (State.current_level())));print_string "\n";flush stdout);
  set_initial_decision id;
  if (sbi_decide_literal (sam_to_sb id)) = 0 then
(if debug then (print_string  "Satbox.SBI_Incons decide_literals";print_string "\n";flush stdout);
    raise SBI_Incons
)
  else
    (get_level(),get_additional_preds())

let lit_value id =
if debug then (print_string ("Satbox.lit_value "^(id_string id));print_string "\n";flush stdout);
let rv = 
  match sbi_lit_value id with
      0 -> Global.Unsat
    | 1 -> Global.Valid
    | _ -> Global.Undet
in
if debug then (print_string  ("Satbox.lit_value "^(val_string rv));print_string "\n";flush stdout);
rv

let lit_level id =
if debug then (print_string ("Satbox.lit_level "^(id_string id));print_string "\n";flush stdout);
  sbi_var_level (id lsr 1)


let lit_is_watched id =
  let ret = sbi_var_is_watched (id lsr 1) in
(*if debug then (print_string ("Satbox.lit_is_watched "^(id_string id)^":"^(string_of_int ret));print_string "\n";flush stdout);*)
  ret > 0

exception Valid_clause
exception Unsat_clause

let check_clause (cl:Global.pred_id list) =
  try
    if (List.fold_left (fun acc x -> 
      match lit_value x with
          Valid -> raise Valid_clause
        | Unsat -> acc + 1
        | Undet -> acc) 0 cl
    ) = List.length cl then
      Printf.printf "Clause UNSAT! : "
    else
      Printf.printf "Clause undet : ";
    pintl cl;
    flush stdout;
    raise Unsat_clause
  with Valid_clause -> ()

let check_cset () = 
  List.iter (fun x -> check_clause x) !cset

(* returns true if we have a partial model *)
let check_model () =
if debug then (print_string "Satbox.check_model\n"; flush stdout);
try
  check_cset ();
  true
with _ -> false
(*
  let res = sbi_satbox_check_model () in
(*print_string "SBI C M: %d\n" res;*)
  if res != 0 then
    true
  else
    false
*)

let print_stats () =
  flush(stdout); 
  sbi_print_stats ()



