path: root/src/trace/coqTerms.ml

(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)


open Coqlib
open SmtMisc


let gen_constant = Structures.gen_constant


(* Int63 *)
let cint = Structures.cint
let ceq63 = gen_constant Structures.int63_modules "eqb"

(* PArray *)
let carray = gen_constant Structures.parray_modules "array"

(* is_true *)
let cis_true = gen_constant init_modules "is_true"

(* nat *)
let cnat = gen_constant init_modules "nat"
let cO = gen_constant init_modules "O"
let cS = gen_constant init_modules "S"

(* Positive *)
let positive_modules = [["Coq";"Numbers";"BinNums"];
                        ["Coq";"PArith";"BinPosDef";"Pos"]]

let cpositive = gen_constant positive_modules "positive"
let cxI = gen_constant positive_modules "xI"
let cxO = gen_constant positive_modules "xO"
let cxH = gen_constant positive_modules "xH"
let ceqbP = gen_constant positive_modules "eqb"

(* N *)
let n_modules = [["Coq";"NArith";"BinNat";"N"]]

let cN = gen_constant positive_modules "N"
let cN0 = gen_constant positive_modules "N0"
let cNpos = gen_constant positive_modules "Npos"

let cof_nat = gen_constant n_modules "of_nat"


(* Z *)
let z_modules = [["Coq";"Numbers";"BinNums"];
                 ["Coq";"ZArith";"BinInt"];
                 ["Coq";"ZArith";"BinInt";"Z"]]

let cZ = gen_constant z_modules "Z"
let cZ0 = gen_constant z_modules "Z0"
let cZpos = gen_constant z_modules "Zpos"
let cZneg = gen_constant z_modules "Zneg"
let copp = gen_constant z_modules "opp"
let cadd = gen_constant z_modules "add"
let csub = gen_constant z_modules "sub"
let cmul = gen_constant z_modules "mul"
let cltb = gen_constant z_modules "ltb"
let cleb = gen_constant z_modules "leb"
let cgeb = gen_constant z_modules "geb"
let cgtb = gen_constant z_modules "gtb"
let ceqbZ = gen_constant z_modules "eqb"
(* let cZeqbsym = gen_constant z_modules "eqb_sym" *)

(* Booleans *)
let bool_modules = [["Coq";"Bool";"Bool"]]

let cbool = gen_constant init_modules "bool"
let ctrue = gen_constant init_modules "true"
let cfalse = gen_constant init_modules "false"
let candb = gen_constant init_modules "andb"
let corb = gen_constant init_modules "orb"
let cxorb = gen_constant init_modules "xorb"
let cnegb = gen_constant init_modules "negb"
let cimplb = gen_constant init_modules "implb"
let ceqb = gen_constant  bool_modules "eqb"
let cifb = gen_constant bool_modules "ifb"
let ciff = gen_constant init_modules "iff"
let creflect = gen_constant bool_modules "reflect"

(* Lists *)
let clist = gen_constant init_modules "list"
let cnil = gen_constant init_modules "nil"
let ccons = gen_constant init_modules "cons"
let clength = gen_constant init_modules "length"

(* Option *)
let coption = gen_constant init_modules "option"
let cSome = gen_constant init_modules "Some"
let cNone = gen_constant init_modules "None"

(* Pairs *)
let cpair = gen_constant init_modules "pair"
let cprod = gen_constant init_modules "prod"

(* Dependent pairs *)
let csigT = gen_constant init_modules "sigT"
(* let cprojT1 = gen_constant init_modules "projT1" *)
(* let cprojT2 = gen_constant init_modules "projT2" *)
(* let cprojT3 = gen_constant init_modules "projT3" *)

(* let csigT2 = gen_constant init_modules "sigT2" *)
(* let csigT_of_sigT2 = gen_constant init_modules "sigT_of_sigT2" *)

(* Logical Operators *)
let cnot = gen_constant init_modules "not"
let ceq = gen_constant init_modules "eq"
let crefl_equal = gen_constant init_modules "eq_refl"
let cconj = gen_constant init_modules "conj"
let cand = gen_constant init_modules "and"

(* Bit vectors *)
let bv_modules = [["SMTCoq";"bva";"BVList";"BITVECTOR_LIST"]]
let cbitvector = gen_constant bv_modules "bitvector"
let cof_bits = gen_constant bv_modules "of_bits"
(* let c_of_bits = gen_constant bv_modules "_of_bits" *)
let cbitOf = gen_constant bv_modules "bitOf"
let cbv_eq = gen_constant bv_modules "bv_eq"
let cbv_not = gen_constant bv_modules "bv_not"
let cbv_neg = gen_constant bv_modules "bv_neg"
let cbv_and = gen_constant bv_modules "bv_and"
let cbv_or = gen_constant bv_modules "bv_or"
let cbv_xor = gen_constant bv_modules "bv_xor"
let cbv_add = gen_constant bv_modules "bv_add"
let cbv_mult = gen_constant bv_modules "bv_mult"
let cbv_ult = gen_constant bv_modules "bv_ult"
let cbv_slt = gen_constant bv_modules "bv_slt"
let cbv_concat = gen_constant bv_modules "bv_concat"
let cbv_extr = gen_constant bv_modules "bv_extr"
let cbv_zextn = gen_constant bv_modules "bv_zextn"
let cbv_sextn = gen_constant bv_modules "bv_sextn"
let cbv_shl = gen_constant bv_modules "bv_shl"
let cbv_shr = gen_constant bv_modules "bv_shr"


(* Arrays *)
let array_modules = [["SMTCoq";"array";"FArray"]]
let cfarray = gen_constant array_modules "FArray.farray"
let cselect = gen_constant array_modules "select"
let cstore = gen_constant array_modules "store"
let cdiff = gen_constant array_modules "diff"
let cequalarray = gen_constant array_modules "FArray.equal"

(* OrderedType *)
(* let cOrderedTypeCompare =
 *   gen_constant [["Coq";"Structures";"OrderedType"]] "Compare" *)

(* SMT_terms *)
let smt_modules = [ ["SMTCoq";"Misc"];
		    ["SMTCoq";"State"];
		    ["SMTCoq";"SMT_terms"];
		    ["SMTCoq";"SMT_terms";"Typ"];
		    ["SMTCoq";"SMT_terms";"Form"];
		    ["SMTCoq";"SMT_terms";"Atom"]
		  ]

let cState_C_t = gen_constant [["SMTCoq";"State";"C"]] "t"
let cState_S_t = gen_constant [["SMTCoq";"State";"S"]] "t"

let cdistinct = gen_constant smt_modules "distinct"

let ctype = gen_constant smt_modules "type"
let cTZ = gen_constant smt_modules "TZ"
let cTbool = gen_constant smt_modules "Tbool"
let cTpositive = gen_constant smt_modules "Tpositive"
let cTBV = gen_constant smt_modules "TBV"
let cTFArray = gen_constant smt_modules "TFArray"
let cTindex = gen_constant smt_modules "Tindex"

(* let ct_i = gen_constant smt_modules "t_i" *)
let cinterp_t = gen_constant smt_modules "Typ.interp"
let cdec_interp = gen_constant smt_modules "dec_interp"
let cord_interp = gen_constant smt_modules "ord_interp"
let ccomp_interp = gen_constant smt_modules "comp_interp"
let cinh_interp = gen_constant smt_modules "inh_interp"

let cinterp_eqb = gen_constant smt_modules "i_eqb"
(* let cinterp_eqb_eqb = gen_constant smt_modules "i_eqb_eqb" *)

let classes_modules = [["SMTCoq";"classes";"SMT_classes"];
                       ["SMTCoq";"classes";"SMT_classes_instances"]]

let ctyp_compdec = gen_constant classes_modules "typ_compdec"
let cTyp_compdec = gen_constant classes_modules "Typ_compdec"
(* let ctyp_compdec_from = gen_constant classes_modules "typ_compdec_from" *)
let cunit_typ_compdec = gen_constant classes_modules "unit_typ_compdec"
let cte_carrier = gen_constant classes_modules "te_carrier"
let cte_compdec = gen_constant classes_modules "te_compdec"
let ceqb_of_compdec = gen_constant classes_modules "eqb_of_compdec"
let cCompDec = gen_constant classes_modules "CompDec"

let cbool_compdec = gen_constant classes_modules "bool_compdec"
let cZ_compdec = gen_constant classes_modules "Z_compdec"
let cPositive_compdec = gen_constant classes_modules "Positive_compdec"
let cBV_compdec = gen_constant classes_modules "BV_compdec"
let cFArray_compdec = gen_constant classes_modules "FArray_compdec"

let ctval =  gen_constant smt_modules "tval"
let cTval =  gen_constant smt_modules "Tval"

let cCO_xH = gen_constant smt_modules "CO_xH"
let cCO_Z0 = gen_constant smt_modules "CO_Z0"
let cCO_BV = gen_constant smt_modules "CO_BV"

let cUO_xO = gen_constant smt_modules "UO_xO"
let cUO_xI = gen_constant smt_modules "UO_xI"
let cUO_Zpos = gen_constant smt_modules "UO_Zpos"
let cUO_Zneg = gen_constant smt_modules "UO_Zneg"
let cUO_Zopp = gen_constant smt_modules "UO_Zopp"
let cUO_BVbitOf = gen_constant smt_modules "UO_BVbitOf"
let cUO_BVnot = gen_constant smt_modules "UO_BVnot"
let cUO_BVneg = gen_constant smt_modules "UO_BVneg"
let cUO_BVextr = gen_constant smt_modules "UO_BVextr"
let cUO_BVzextn = gen_constant smt_modules "UO_BVzextn"
let cUO_BVsextn = gen_constant smt_modules "UO_BVsextn"

let cBO_Zplus = gen_constant smt_modules "BO_Zplus"
let cBO_Zminus = gen_constant smt_modules "BO_Zminus"
let cBO_Zmult = gen_constant smt_modules "BO_Zmult"
let cBO_Zlt = gen_constant smt_modules "BO_Zlt"
let cBO_Zle = gen_constant smt_modules "BO_Zle"
let cBO_Zge = gen_constant smt_modules "BO_Zge"
let cBO_Zgt = gen_constant smt_modules "BO_Zgt"
let cBO_eq = gen_constant smt_modules "BO_eq"
let cBO_BVand = gen_constant smt_modules "BO_BVand"
let cBO_BVor = gen_constant smt_modules "BO_BVor"
let cBO_BVxor = gen_constant smt_modules "BO_BVxor"
let cBO_BVadd = gen_constant smt_modules "BO_BVadd"
let cBO_BVmult = gen_constant smt_modules "BO_BVmult"
let cBO_BVult = gen_constant smt_modules "BO_BVult"
let cBO_BVslt = gen_constant smt_modules "BO_BVslt"
let cBO_BVconcat = gen_constant smt_modules "BO_BVconcat"
let cBO_BVshl = gen_constant smt_modules "BO_BVshl"
let cBO_BVshr = gen_constant smt_modules "BO_BVshr"
let cBO_select = gen_constant smt_modules "BO_select"
let cBO_diffarray = gen_constant smt_modules "BO_diffarray"

let cTO_store = gen_constant smt_modules "TO_store"

let cNO_distinct = gen_constant smt_modules "NO_distinct"

let catom = gen_constant smt_modules "atom"
let cAcop = gen_constant smt_modules "Acop"
let cAuop = gen_constant smt_modules "Auop"
let cAbop = gen_constant smt_modules "Abop"
let cAtop = gen_constant smt_modules "Atop"
let cAnop = gen_constant smt_modules "Anop"
let cAapp = gen_constant smt_modules "Aapp"

let cform  = gen_constant smt_modules "form"
let cFatom = gen_constant smt_modules "Fatom"
let cFtrue = gen_constant smt_modules "Ftrue"
let cFfalse = gen_constant smt_modules "Ffalse"
let cFnot2 = gen_constant smt_modules "Fnot2"
let cFand = gen_constant smt_modules "Fand"
let cFor = gen_constant smt_modules "For"
let cFxor = gen_constant smt_modules "Fxor"
let cFimp = gen_constant smt_modules "Fimp"
let cFiff = gen_constant smt_modules "Fiff"
let cFite = gen_constant smt_modules "Fite"
let cFbbT = gen_constant smt_modules "FbbT"

let cvalid_sat_checker = gen_constant [["SMTCoq";"Trace";"Sat_Checker"]] "valid"
let cinterp_var_sat_checker = gen_constant [["SMTCoq";"Trace";"Sat_Checker"]] "interp_var"

let make_certif_ops modules args =
  let gen_constant c =
    match args with
      | Some args -> lazy (mklApp (gen_constant modules c) args)
      | None -> gen_constant modules c in
 (gen_constant "step",
  gen_constant "Res", gen_constant "Weaken", gen_constant "ImmFlatten",
  gen_constant "CTrue", gen_constant "CFalse",
  gen_constant "BuildDef", gen_constant "BuildDef2",
  gen_constant "BuildProj",
  gen_constant "ImmBuildProj", gen_constant"ImmBuildDef",
  gen_constant"ImmBuildDef2",
  gen_constant "EqTr", gen_constant "EqCgr", gen_constant "EqCgrP",
  gen_constant "LiaMicromega", gen_constant "LiaDiseq",
  gen_constant "SplArith", gen_constant "SplDistinctElim",
  gen_constant "BBVar", gen_constant "BBConst",
  gen_constant "BBOp", gen_constant "BBNot", gen_constant "BBEq",
  gen_constant "BBDiseq",
  gen_constant "BBNeg", gen_constant "BBAdd", gen_constant "BBMul",
  gen_constant "BBUlt", gen_constant "BBSlt", gen_constant "BBConcat",
  gen_constant "BBExtract", gen_constant "BBZextend", gen_constant "BBSextend",
  gen_constant "BBShl", gen_constant "BBShr",
  gen_constant "RowEq", gen_constant "RowNeq", gen_constant "Ext",
  gen_constant "Hole", gen_constant "ForallInst")


(** Useful constructions *)

let ceq_refl_true =
  lazy (mklApp crefl_equal [|Lazy.force cbool;Lazy.force ctrue|])

let eq_refl_true () = Lazy.force ceq_refl_true

let vm_cast_true_no_check t =
  Structures.mkCast(eq_refl_true (),
              Structures.vmcast,
              mklApp ceq [|Lazy.force cbool; t; Lazy.force ctrue|])

(* This version checks convertibility right away instead of delaying it at
   Qed. This allows to report issues to the user as soon as he/she runs one of
   SMTCoq's tactics. *)
let vm_cast_true env t =
  try
    Structures.vm_conv Reduction.CUMUL env
      (mklApp ceq
         [|Lazy.force cbool; Lazy.force ctrue; Lazy.force ctrue|])
      (mklApp ceq [|Lazy.force cbool; t; Lazy.force ctrue|]);
    vm_cast_true_no_check t
  with Reduction.NotConvertible ->
    Structures.error ("SMTCoq was not able to check the proof certificate.")


(* Compute a nat *)
let rec mkNat = function
  | 0 -> Lazy.force cO
  | i -> mklApp cS [|mkNat (i-1)|]

(* Compute a positive *)
let rec mkPositive = function
  | 1 -> Lazy.force cxH
  | i ->
     let c = if (i mod 2) = 0 then cxO else cxI in
     mklApp c [|mkPositive (i / 2)|]

(* Compute a N *)
let mkN = function
  | 0 -> Lazy.force cN0
  | i -> mklApp cNpos [|mkPositive i|]

(* Compute a Boolean *)
let mkBool = function
  | true -> Lazy.force ctrue
  | false -> Lazy.force cfalse

(* Compute a Boolean list *)
let rec mk_bv_list = function
  | [] -> mklApp cnil [|Lazy.force cbool|]
  | b :: bv ->
    mklApp ccons [|Lazy.force cbool; mkBool b; mk_bv_list bv|]


(* Reification *)
let mk_bool b =
  let c, args = Structures.decompose_app b in
  if Structures.eq_constr c (Lazy.force ctrue) then true
  else if Structures.eq_constr c (Lazy.force cfalse) then false
  else assert false

let rec mk_bool_list bs =
  let c, args = Structures.decompose_app bs in
  if Structures.eq_constr c (Lazy.force cnil) then []
  else if Structures.eq_constr c (Lazy.force ccons) then
    match args with
    | [_; b; bs] -> mk_bool b :: mk_bool_list bs
    | _ -> assert false
  else assert false

let rec mk_nat n =
  let c, args = Structures.decompose_app n in
  if Structures.eq_constr c (Lazy.force cO) then
    0
  else if Structures.eq_constr c (Lazy.force cS) then
    match args with
    | [n] -> (mk_nat n) + 1
    | _ -> assert false
  else assert false

let rec mk_positive n =
  let c, args = Structures.decompose_app n in
  if Structures.eq_constr c (Lazy.force cxH) then
    1
  else if Structures.eq_constr c (Lazy.force cxO) then
    match args with
    | [n] -> 2 * (mk_positive n)
    | _ -> assert false
  else if Structures.eq_constr c (Lazy.force cxI) then
    match args with
    | [n] -> 2 * (mk_positive n) + 1
    | _ -> assert false
  else assert false


let mk_N n =
  let c, args = Structures.decompose_app n in
  if Structures.eq_constr c (Lazy.force cN0) then
    0
  else if Structures.eq_constr c (Lazy.force cNpos) then
    match args with
    | [n] -> mk_positive n
    | _ -> assert false
  else assert false


let mk_Z n =
  let c, args = Structures.decompose_app n in
  if Structures.eq_constr c (Lazy.force cZ0) then 0
  else if Structures.eq_constr c (Lazy.force cZpos) then
    match args with
    | [n] -> mk_positive n
    | _ -> assert false
  else if Structures.eq_constr c (Lazy.force cZneg) then
    match args with
    | [n] -> - mk_positive n
    | _ -> assert false
  else assert false


(* size of bivectors are either N.of_nat (length l) or an N *)
let mk_bvsize n =
  let c, args = Structures.decompose_app n in
  if Structures.eq_constr c (Lazy.force cof_nat) then
    match args with
    | [nl] ->
      let c, args = Structures.decompose_app nl in
      if Structures.eq_constr c (Lazy.force clength) then
        match args with
        | [_; l] -> List.length (mk_bool_list l)
        | _ -> assert false
      else assert false
    | _ -> assert false
  else mk_N n

(** Switches between constr and OCaml *)
(* Transform a option constr into a constr option *)
let option_of_constr_option co =
  let c, args = Structures.decompose_app co in
  if c = Lazy.force cSome then
    match args with
      | [_;c] -> Some c
      | _ -> assert false
  else
    None

(* Transform a tuple of constr into a (reversed) list of constr *)
let list_of_constr_tuple =
  let rec list_of_constr_tuple acc t =
    let c, args = Structures.decompose_app t in
    if c = Lazy.force cpair then
      match args with
        | [_;_;t1;t2] ->
           let acc' = list_of_constr_tuple acc t1 in
           list_of_constr_tuple acc' t2
        | _ -> assert false
    else
      t::acc
  in
  list_of_constr_tuple []