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

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

(* theory.ml *)

(* The following list of functions are declared in C in theory.cpp *)

(* Generate a predicate from a prototype and a list of parameters *)
external cvc_AppPredicate : int -> int array -> int = "cvcApplyPredicate" ;;

(* Generate an uninterpreted function from a prototype and list of parameters *)
external cvc_AppFunction :int -> int array -> int = "cvcApplyFunction" ;;

(* Generate a boolean predicate *)
external cvc_DecBoolVar :string -> int = "cvcDeclareBoolVariable" ;;

(* Generate an uninterpreted variable *)
external cvc_DecVariable :string -> int -> int = "cvcDeclareVariable" ;;

(* Generate an uninterpreted constant *)
external cvc_DecNumeralConstant :string -> int = "cvcDeclareNumeralConstant" ;;

(* Generate a predicate function prototype *)
external cvc_DecPredicate :string -> int -> int = "cvcDeclarePredicate" ;;

(* Generate an uninterpreted function prototype *)
external cvc_DecFunction :string -> int -> int = "cvcDeclareFunction" ;;

(* Initialize the CVC and wrapper environment *)
external initializeTheory :unit -> unit = "cvcInitialize" ;;

(* Cleanup the CVC and wrapper environment. *)
external cleanupTheory :unit -> unit = "cvcCleanup" ;;

(* Cleanup after the parser to make algorithm more efficient *)
external cvc_cleanParsing :unit -> unit = "cvcCleanParsing" ;;

(* Assert the follownig predicate
     A positive number means to assert positive.
     A negative number means to assert negative. *)
external cvc_Assert :int -> unit = "cvcAssert" ;;

(* Pop the CVC context to the given layer *)
external cvc_PopTo :int -> unit = "cvcPopTo" ;;

(* Query whether the given predicate can be entailed *)
(* note this does NOT push the current scope internally *)
external cvc_Query :int -> bool = "cvcQuery" ;;

(* Push the layer of the given CVC context *)
external cvc_Push :unit -> unit = "cvcPush" ;;

(* For the following two functions, it was deemed easier to pass the iteration
     of a list through the OCAML/C interface than to allocate, construct and
     pass the list as a whole.  This has to do with memory allocation, garbage
     collection and other major differences between the two languages. *)
(* Start the enueration of an inconsistency *)
external cvc_StartInconsistency :unit -> unit = "cvcStartInconsistency" ;;

(* Iterate a given inconsistency *)
(* The end of the iteration is denoted by the pasing of the value 0. *)
external cvc_CollectInconsistency :unit -> int = "cvcCollectInconsistency" ;;

(* The method collect_implicants then produces a OCAML list given the two
    corresponding iterator functions.  First it initializes the iterator, then
    stacks until the value of 0 is passed, thus denoting the end of iteration *)

let collect_implicants id inlist =
(*Printf.printf "THEORY:collect_implicants %s\n" (Global.id_string id); flush
stdout;*)
    let rec collect_implicants' l =
    match cvc_CollectInconsistency () with
  0 -> l (* end of iterator, stop *)
      | n ->
    if n == id then
      collect_implicants' l  (* skip id *)
    else
      collect_implicants' (n::l)
  in
    (* create iterator for conflict set literals *)
 (*   cvc_StartInconsistency ();*)
    (* collect iterator's values into a list *)
    collect_implicants' inlist


(* Further external functions added by Jed Hagen 6/24/03 or later *)

(* returns true if the current context is inconsistent *)
(* this is used after bcp/parsing to verify that the theory is consistent *)
external cvc_CheckInconsistency :unit -> bool = "cvcCheckInconsistency";;

(* Generate a real variable *)
external cvc_DeclareRealVariable :string -> int = "cvcDeclareRealVariable";;

(* Generate a rational constant (this is a real-typed value) *)
external cvc_DeclareRationalConst :int -> int -> int =
"cvcDeclareRationalConst";;

(* Generate "-a" *)
external cvc_ApplyUnaryMinus :int -> int = "cvcApplyUnaryMinus";;

(* Generate "FLOORa" *)
external cvc_ApplyFloor :int -> int = "cvcApplyFloor";;

(* Generate "a+b" *)
external cvc_ApplyPlus :int -> int -> int = "cvcApplyPlus";;

(* Generate "a-b" *)
external cvc_ApplyMinus :int -> int -> int = "cvcApplyMinus";;

(* Generate "a*b" *)
external cvc_ApplyMult :int -> int -> int = "cvcApplyMult";;

(* Generate "a*b" *)
external cvc_ApplyPow :int -> int -> int = "cvcApplyPow";;

(* Generate "a*b" *)
external cvc_ApplyDiv :int -> int -> int = "cvcApplyDiv";;

(* Generate "a=b" (equality for real numbers only) *)
external cvc_CreateEquals :int -> int -> int = "cvcCreateEquals";;

(* Generate "a<b" *)
external cvc_CreateLessThan :int -> int -> int = "cvcCreateLessThan";;

(* Generate "a>b" *)
external cvc_CreateGreaterThan :int -> int -> int = "cvcCreateGreaterThan";;

(* Generate "a=<b" *)
external cvc_CreateLessThanOrEquals :int -> int -> int =
"cvcCreateLessThanOrEquals";;

(* Generate "a>=b" *)
external cvc_CreateGreaterThanOrEquals :int -> int -> int =
"cvcCreateGreaterThanOrEquals";;

external cvc_DeclareType : string -> int = "cvcDeclareType";;
external cvc_RenameType: string -> int -> int = "cvcRenameType";;
external cvc_IntType: unit -> int = "cvcIntType";;
external cvc_RealType: unit -> int = "cvcRealType";;
external cvc_BoolType: unit -> int = "cvcBoolType";;
external cvc_FunctionType: int -> int -> int = "cvcFunctionType";;
external cvc_RecordType: string array -> int array -> int = "cvcRecordType";;
external cvc_TupleType: int array -> int = "cvcTupleType";;
external cvc_ArrayType: int -> int -> int = "cvcArrayType";;
external cvc_SubType: int -> int = "cvcSubType";;
external cvc_SubrangeType: int -> int -> int = "cvcSubrangeType";;

(* returns a "free" unique identifier *)
external cvc_nextFreeIdentifier: unit -> int = "cvcNextFreeIdentifier";;
external cvc_ExprIsReal: int -> bool = "cvcExprIsReal";;
external cvc_ExprIsInteger: int -> bool = "cvcExprIsInteger";;
external cvc_ExprIsBoolean: int -> bool = "cvcExprIsBoolean";;
external cvc_ExprIsDeclared: string -> bool = "cvcIsDeclaredExpr";;
external cvc_AppLambda: int array -> int -> int = "cvcAppLambda";;
external cvc_RecordLiteral: string array -> int array -> int =
"cvcRecordLiteral";;
external cvc_TupleLiteral: int array -> int = "cvcTupleLiteral";;
external cvc_ReadArray: int -> int -> int =  "cvcReadArray";;
external cvc_RecordSelect: int -> string -> int = "cvcRecordSelect";;
external cvc_TupleSelect: int -> int -> int = "cvcTupleSelect";;
external cvc_WriteArray: int -> int -> int -> int =  "cvcWriteArray";;
external cvc_RecordUpdate: int -> string -> int -> int = "cvcRecordUpdate";;
external cvc_TupleUpdate: int -> int -> int -> int = "cvcTupleUpdate";;
external cvc_GetExprType: string -> int = "cvcGetExprType";;
external cvc_GetExprTypeFromId: int -> int = "cvcGetExprTypeFromId";;
external cvc_GetArrayReturnType: int -> int = "cvcGetArrayReturnType";;
external cvc_GetFunctionReturnType: int -> int = "cvcGetFunctionReturnType";;

external cvc_GetExprID: string -> int = "cvcGetExprID";;
external cvc_DeclarePredicateVariable : string -> int -> unit = 
  "cvcDeclarePredicateVariable";;
external cvc_Seconds: unit -> int = "cvcSeconds";;
external cvc_Microseconds: unit -> int = "cvcMicroseconds";;
external cvc_RemoveExpr: int -> unit = "cvcRemoveExpr";;
external cvc_RemoveType: int -> unit = "cvcRemoveType";;

external cvc_GetExprTypeID : int -> int = "cvcGetExprTypeID";;
external cvc_GetExprBaseTypeID : int -> int = "cvcGetExprBaseTypeID";;
external cvc_GetTypeBaseTypeID : int -> int = "cvcGetTypeBaseTypeID";;
external cvc_GetImpliedLiteral : unit -> int = "cvcGetImpliedLiteral";;

open Global

exception Incons

exception Not_supported of string

(*type hist_node = {mutable top:int}*)
type declType = CVCType | CVCExpr

let new_cvcl = true (* change this to use the floor functions *)


class theory =
(*  let max_check = 20 in (* stop if we've checked this many lits *)
  let pset_block = 100 in
*)
  let id_occurrences = (Hashtbl.create 100: (int,(declType*int))Hashtbl.t) in
  let add_id id t scope = 
    if not (Hashtbl.mem id_occurrences id) then
      Hashtbl.add id_occurrences id (t,scope)
  in
  (* removes any predicates from indicated scope or higher *)
  (* returns list of ids so removed *)
object(self)
  val mutable scope = 0
  val mutable decl_level = 0
  val mutable base_level = 0

  val mutable most_recent_id = (None:Global.pred_id option)
  val mutable most_recent_pos = false
  val mutable most_recent_neg = false

  (* returns id,status,set_implicants triple *)
  (* do NOT include asserted id in return values *)
  method private changed_preds asserted_id =
    let cpl = ref [] in
    let pid = ref (cvc_GetImpliedLiteral()) in
    while !pid != 0 do 
      if (!pid != asserted_id) then
        begin
if adebug then (Printf.printf "cvcl detected implied literal %d\n " !pid ;flush stdout);
          let elem =
            if is_negative !pid then
              (compl !pid,Unsat)
            else
              (!pid,Valid) 
          in 
          cpl := elem :: !cpl
        end;
      pid := cvc_GetImpliedLiteral()
    done;
    (!cpl:(Global.pred_id * Global.status) list)

  (* The function initializer - constructor, takes care of the initialization
       of the CVCLite Wrapper *)
  initializer
if debug then (print_string  "theory#initializer";print_string "\n";flush stdout);
    initializeTheory ()

    method next_id =
      cvc_nextFreeIdentifier ()

    method true_id=
      cvc_DecVariable "TRUE" (cvc_BoolType () )

    method mark_base_level =
      base_level <- scope

    method return_to_base_level =
      self#retract_last (scope - base_level)

    method decType (s:string) = 
      let result = 
      cvc_DeclareType s
      in
      add_id result CVCType decl_level;
      result


    (* types *)
    method intType = 
      cvc_IntType ()

    method realType = 
      cvc_RealType ()

    method boolType = 
       cvc_BoolType ()

    method functionType (ran:int) (dom:int) = 
      let result = 
      cvc_FunctionType ran dom
      in
      add_id result CVCType decl_level;
      result

    method decl_interpreted_type (name:string) (sl:string list) =
      match name,sl with
          "RECORD",s ->
            let inlist = Array.of_list s in
            let num = (Array.length inlist)/2 in
            let slist = Array.sub inlist 0 num in
            let ilist = Array.sub inlist num num in 
            let types = Array.map int_of_string ilist in
            let result = 
            cvc_RecordType (slist) (types)
            in
            add_id result CVCType decl_level;
            result
        | "TUPLE",s ->
            let types = List.map int_of_string s in
            let result = 
            cvc_TupleType (Array.of_list types)
            in
            add_id result CVCType decl_level;
            result
        | "ARRAY",[s1;s2] ->
            let ran = int_of_string s1 in
            let mytype = int_of_string s2 in
            let result = 
            cvc_ArrayType ran mytype
            in
            add_id result CVCType decl_level;
            result
        | "SUBRANGE",[s1;s2] ->
            let s = int_of_string s1 in
            let e = int_of_string s2 in
            let result = 
            cvc_SubrangeType s e 
            in
            add_id result CVCType decl_level;
            result
        | _ -> raise (Not_supported name)

    method pos_infinity = 
      let result = 
      cvc_DecNumeralConstant "()"
      in
      add_id result CVCExpr decl_level;
      result

    method neg_infinity = 
      let result = 
      cvc_DecNumeralConstant "()"
      in
      add_id result CVCExpr decl_level;
      result

    method is_bool (id:int) = 
      cvc_ExprIsBoolean id

    method appPow (l:int) (r:int) = 
      let result = 
      cvc_ApplyPow l r
      in
      add_id result CVCExpr decl_level;
      result


    method appMod (x:int) (y:int) =
      if true then
        raise (Not_supported "theory#appMod")
      else
        begin
      let result = 
      let z = cvc_ApplyFloor (cvc_ApplyDiv x y) in
      cvc_ApplyMinus x (cvc_ApplyMult z y)
      in
      add_id result CVCExpr decl_level;
      result
        end


    method appDiv (l:int) (r:int) = 
      let result = 
      cvc_ApplyDiv l r
      in
      add_id result CVCExpr decl_level;
      result

    method appIntDiv (l:int) (r:int) =
      if true then 
        raise (Not_supported "theory#appIntDiv")
      else
        begin
      let result = 
      cvc_ApplyFloor (cvc_ApplyDiv l r)
      in
      add_id result CVCExpr decl_level;
      result
        end


    method get_function_type (name: string) = 
      cvc_GetExprType name


    method get_tuple_literal_type (id: int) = 
      cvc_GetExprTypeFromId id

    method get_record_literal_type (id: int) = 
      cvc_GetExprTypeFromId id


    method decOldPred (name:string) (id:int) = 
      cvc_DeclarePredicateVariable name id;
      add_id id CVCExpr decl_level

    method decl_interpreted_function (name:string) (params:string list) =
      match name,params with
          "ISINT",[x1] ->
      if new_cvcl then
        raise (Not_supported "ISINT")
      else
            begin
      let id = int_of_string x1 in
      let result = cvc_CreateEquals id (cvc_ApplyFloor id) in
      add_id result CVCExpr decl_level;
      result
            end
        | "FLOOR",[x1] ->
      if new_cvcl then
        raise (Not_supported "FLOOR")
      else
            begin
      let n = int_of_string x1 in
      let result = cvc_ApplyFloor n in
      add_id result CVCExpr decl_level;
      result
            end
        | "ARRAY_LOOKUP",[x1;x2] ->
            begin
      let arrayid = int_of_string x1 in
      let subscrid = int_of_string x2 in
      let result = cvc_ReadArray arrayid subscrid in
      add_id result CVCExpr decl_level;
      result
            end
        | "TUPLE_LOOKUP",[x1;x2] ->
            begin
      let id = int_of_string x1 in
      let index = int_of_string x2 in
      let result = cvc_TupleSelect id index in
      add_id result CVCExpr decl_level;
      result
            end
        | "RECORD_LOOKUP",[x1;x2] ->
            begin
      let id = int_of_string x1 in
      let field = x2 in
      let result = cvc_RecordSelect id field in
      add_id result CVCExpr decl_level;
      result
            end
        | "TUPLE_LITERAL",xlist ->
            begin
      let ids = List.map (int_of_string) xlist in
      let result = cvc_TupleLiteral (Array.of_list ids) in
      add_id result CVCExpr decl_level;
      result
            end
        | "ARRAY_WRITE",[x1;x2;x3] ->
            begin
      let aid = int_of_string x1 in
      let sid = int_of_string x2 in
      let v = int_of_string x3 in
      let result = cvc_WriteArray aid sid v in
      add_id result CVCExpr decl_level;
      result
            end
        | "RECORD_WRITE",[x1;x2;x3] ->
            begin
      let id = int_of_string x1 in
      let field = x2 in
      let v = int_of_string x3 in
      let result = cvc_RecordUpdate id field v in
      add_id result CVCExpr decl_level;
      result
            end
        | "TUPLE_WRITE",[x1;x2;x3] ->
            begin
              let id = int_of_string x1 in
              let index = int_of_string x2 in
              let v = int_of_string x3 in
              let result = cvc_TupleUpdate id index v in
              add_id result CVCExpr decl_level;
              result
            end
(*        | "RECORD_LITERAL",xlist ->
            begin
      let inlist = Array.of_list xlist in
      let num = (Array.length inlist)/2 in
      let fields = Array.sub inlist 0 num in
      let es = Array.map int_of_string (Array.sub inlist num num) in
      let result = 
        cvc_RecordLiteral fields es
      in
      add_id result CVCExpr decl_level;
      result
            end
*)
	| _ -> raise (Not_supported name)


 (* Note:every assertion is done in a new CVC scope,
    to make it singly retractable later
 *)
  method assert_pos (id:Global.pred_id) =
if debug then (print_string ("theory#assert_pos "^(id_string id));print_string "\n";flush stdout);
    scope <- scope + 1;
    (* Generate the new scope *)
    cvc_Push ();
    (* Assert the predicate in this scope *)
    cvc_Assert id;
    if Global.pars.Global.augment_theory_return then
      self#changed_preds id
    else
      []

  (* Assert negative simply asserts the negation of the positive iD *)
  method assert_neg (id:Global.pred_id) =
if debug then (print_string ("theory#assert_neg "^(id_string id));print_string "\n";flush stdout);
    scope <- scope + 1;
    (* Generate the new scope *)
    cvc_Push ();
    (* Assert the complement of the predicate in this scope *)
    cvc_Assert (compl id);
    if Global.pars.Global.augment_theory_return then
      self#changed_preds (compl id)
    else
      []

  (* Retract the last n scopes (and thus assertions) *)
  method retract_last n =
if debug then (print_string ("theory#retract_last "^(string_of_int n));print_string "\n";flush stdout);
(*
    let rec retract x =
      if x > 0 then
        begin
          retract (x - 1)
        end
    in
    retract n;
*)
    if n > 0 then
      begin
        scope <- scope - n;
        cvc_PopTo scope
      end

  (* Note:[cvc__popto scope] is necessary to clean up any possible changes to
     the CVC context caused by [cvc__query id]
  *)
  (* This returns true if the pred is valid in the current context *)
  (* It is possible that CVC says both a pred and its negation are valid! *)
  method entails id =
    cvc_Push ();
    let v = cvc_Query id in
      cvc_PopTo scope;
      v

  method final_value id =
    (self#entails id) && not (self#entails (compl id))

  (* it appears that cvc_query may return true for both +id and -id *)
  (* I will interpret this as "undetermined" *)
  method status id =
if debug then (print_string ("theory#status "^(id_string id));print_string "\n";flush stdout);
    let pos_entails = self#entails id in
    let neg_entails = self#entails (compl id) in
    if pos_entails && neg_entails then
      raise Incons (* theory inconsistent *)
    else if pos_entails then
      Valid
    else if neg_entails then
      Unsat
    else
      Undet

  (* [sid] is a signed id denoting a literal that is valid
     in the current CVC context *)
  method implicants sid =
    cvc_Push();
    cvc_Query sid;
    cvc_StartInconsistency ();
    let impl_list = collect_implicants sid [] in
      (* undo assertion of [compl sid] *)
      cvc_PopTo scope;
      impl_list

  (* The following functions are used by the parser to generate the predicates
        in CVC *)


  (* Create a function given a prototype and a list of
       formulas as parameters *)
  method appFunction (id:int) (params:int list) =
      let result = 
    cvc_AppFunction id (Array.of_list params)
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate a variable expression *)
  method decVariable (id:string) (tid:int) =
      let result = 
    cvc_DecVariable id tid
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate an real numerical constant (such as 5.4)*)
  method decNumeralConstant (id:string) =
      let result = 
    cvc_DecNumeralConstant id
      in
      add_id result CVCExpr decl_level;
      result

  (* Create an uninterpreted function prototype *)
  method decFunction (id:string) (typeid:int) =
      let result = 
    cvc_DecFunction id typeid
      in
      add_id result CVCExpr decl_level;
      result

  (* Cleanup the theory module and the CVCLite engines *)
  method reset = 
    cleanupTheory();
    decl_level <- 0;
    scope <- 0;
    Hashtbl.clear id_occurrences;
    if Global.pars.Global.verbose then
      let sec = cvc_Seconds() in
      let msec = (cvc_Microseconds())/10000 in (* to nearest 1/100 *)
      let mstr =
        if msec > 9 then
          (string_of_int msec)
        else 
          "0"^(string_of_int msec)
      in
      Printf.printf "Time spent in theory: %d.%s seconds\n" sec mstr;
      flush stdout


  (* further methods added by Jed Hagen, 6/24/03 or later *)

  (* check consistency of current theory context.
     Raises Incons if inconsistent. *)
  method check_consistency =
    if cvc_CheckInconsistency() then raise Incons

  (* the following are real value operations:*)


  (* Generate a rational constant expression (real-typed) *)
  method decRationalConstant (numerator:int) (denominator:int) =
      let result = 
    cvc_DeclareRationalConst numerator denominator
      in
      add_id result CVCExpr decl_level;
      result

(*
  (* Generate an integer constant expression (real-typed) *)
  method decIntConstant (n:int) =
      let result = 
    cvc_DeclareRationalConst n 1
      in
      add_id result CVCExpr decl_level;
      result
*)

  (* Generate an expression "-a" *)
  method appUnaryMinus (expr:int) =
      let result = 
    cvc_ApplyUnaryMinus expr
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate an expression "a+b" *)
  method appPlus (lExpr:int) (rExpr:int) =
      let result = 
    cvc_ApplyPlus lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate an expression "a-b" *)
  method appMinus (lExpr:int) (rExpr:int) =
      let result = 
    cvc_ApplyMinus lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate an expression "a*b" *)
  method appMult (lExpr:int) (rExpr:int) =
      let result = 
    cvc_ApplyMult lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate a predicate "a=b" (same as equality, above) *)
  method create_equals (lExpr:int) (rExpr:int) =
      let result = 
    cvc_CreateEquals lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  method create_not_equals (lExpr:int) (rExpr:int) =
      let result = 
    -(cvc_CreateEquals lExpr rExpr)
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate a predicate "a<b" *)
  method create_less_than (lExpr:int) (rExpr:int) =
      let result = 
    cvc_CreateLessThan lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate a predicate "a>b" *)
  method create_greater_than (lExpr:int) (rExpr:int) =
      let result = 
    cvc_CreateGreaterThan lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate a predicate "a=<b" *)
  method create_less_than_or_equals (lExpr:int) (rExpr:int) =
      let result = 
    cvc_CreateLessThanOrEquals lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  (* Generate a predicate "a>=b" *)
  method create_greater_than_or_equals (lExpr:int) (rExpr:int) =
      let result = 
    cvc_CreateGreaterThanOrEquals lExpr rExpr
      in
      add_id result CVCExpr decl_level;
      result

  method remove_expression id =
    cvc_RemoveExpr id

  method get_expr_type id =
    cvc_GetExprTypeID id

  method get_expr_base_type id =
    cvc_GetExprBaseTypeID id

  method get_type_base_type id =
    cvc_GetTypeBaseTypeID id

end


