diff --git a/library/TLAPS.tla b/library/TLAPS.tla index b52ec259..c250a674 100644 --- a/library/TLAPS.tla +++ b/library/TLAPS.tla @@ -72,6 +72,16 @@ YicesT(X) == TRUE (*{ by (prover:"yices3"; timeout:@) }*) veriT == TRUE (*{ by (prover: "verit") }*) veriTT(X) == TRUE (*{ by (prover:"verit"; timeout:@) }*) +(**************************************************************************) +(* Backend pragma: Zipperposition solver *) +(* *) +(* This method translates the proof obligation to TPTP and *) +(* calls Zipperposition. *) +(**************************************************************************) + +Zipper == TRUE (*{ by (prover: "zipper") }*) +ZipperT(X) == TRUE (*{ by (prover:"zipper"; timeout:@) }*) + (**************************************************************************) (* Backend pragma: Z3 SMT solver *) (* *) diff --git a/src/backend.ml b/src/backend.ml index 1ab5ea9e..3fd7ab4a 100644 --- a/src/backend.ml +++ b/src/backend.ml @@ -7,5 +7,5 @@ module Toolbox = Toolbox module Zenon = Zenon module Fingerprints = Fingerprints module Fpfile = Fpfile -(* module Smtlib = Smtlib *) +module Smtlib = Smtlib module Prep = Prep diff --git a/src/backend.mli b/src/backend.mli index 9310abea..b374b15b 100644 --- a/src/backend.mli +++ b/src/backend.mli @@ -68,3 +68,8 @@ module Toolbox: sig val print_message_url: string -> string -> unit end + + +module Smtlib: sig + val repls: (char * string) list +end diff --git a/src/backend/fpfile.ml b/src/backend/fpfile.ml index d15243b8..912a5a1f 100644 --- a/src/backend/fpfile.ml +++ b/src/backend/fpfile.ml @@ -50,6 +50,7 @@ module V13 = struct | Cvc33 of floatomega | Yices3 of floatomega | Verit of floatomega + | Zipper of floatomega | Spass of floatomega | Tptp of floatomega | LS4 of floatomega @@ -126,7 +127,7 @@ module V13 = struct - any number of (Digest.t, sti list) pairs *) - let version = 13 + let version = 14 end @@ -229,6 +230,7 @@ and meth_to_Vx m = | M.Cvc33 tmo -> Cvc33 (floatomega_to_Vx tmo) | M.Yices3 tmo -> Yices3 (floatomega_to_Vx tmo) | M.Verit tmo -> Verit (floatomega_to_Vx tmo) + | M.Zipper tmo -> Zipper (floatomega_to_Vx tmo) | M.Spass tmo -> Spass (floatomega_to_Vx tmo) | M.Tptp tmo -> Tptp (floatomega_to_Vx tmo) | M.LS4 tmo -> LS4 (floatomega_to_Vx tmo) @@ -269,6 +271,7 @@ type prover = | Pcvc33 | Pyices3 | Pverit + | Pzipper | Pspass | Ptptp | Pls4 @@ -299,6 +302,7 @@ let prover_of_method m = | Cvc33 _ -> Pcvc33 | Yices3 _ -> Pyices3 | Verit _ -> Pverit + | Zipper _ -> Pzipper | Spass _ -> Pspass | Tptp _ -> Ptptp | LS4 _ -> Pls4 @@ -328,6 +332,7 @@ let normalize m = | Cvc33 (Omega) -> Cvc33 (F infinity) | Yices3 (Omega) -> Yices3 (F infinity) | Verit (Omega) -> Verit (F infinity) + | Zipper (Omega) -> Zipper (F infinity) | Spass (Omega) -> Spass (F infinity) | Tptp (Omega) -> Tptp (F infinity) | LS4 (Omega) -> LS4 (F infinity) @@ -723,6 +728,10 @@ let print_sti_13 (st, d, pv, zv, iv) = printf "Verit ("; print_floatomega tmo; printf ")"; + | V13.Zipper tmo -> + printf "Zipper ("; + print_floatomega tmo; + printf ")"; | V13.Spass tmo -> printf "Spass ("; print_floatomega tmo; @@ -927,6 +936,7 @@ and vx_to_meth m = | Cvc33 tmo -> Some (M.Cvc33 (vx_to_floatomega tmo)) | Yices3 tmo -> Some (M.Yices3 (vx_to_floatomega tmo)) | Verit tmo -> Some (M.Verit (vx_to_floatomega tmo)) + | Zipper tmo -> Some (M.Zipper (vx_to_floatomega tmo)) | Spass tmo -> Some (M.Spass (vx_to_floatomega tmo)) | Tptp tmo -> Some (M.Tptp (vx_to_floatomega tmo)) | LS4 tmo -> Some (M.LS4 (vx_to_floatomega tmo)) diff --git a/src/backend/isabelle.ml b/src/backend/isabelle.ml index c9504d7d..ff13de2d 100644 --- a/src/backend/isabelle.ml +++ b/src/backend/isabelle.ml @@ -662,6 +662,7 @@ let thy_temp ob tac tempname thyout = thy_header ~verbose:false tempname thyout; let obid = Option.get ob.id in let obfp = Option.default "no fingerprint" ob.fingerprint in + Printf.fprintf thyout "(* Generated from %s *)\n" (Util.location ~cap:false ob.obl); Printf.fprintf thyout "lemma ob'%d: (* %s *)\n" obid obfp; let ff = Format.formatter_of_out_channel thyout in begin try diff --git a/src/backend/prep.ml b/src/backend/prep.ml index 1b57c7ee..c91a4f1e 100644 --- a/src/backend/prep.ml +++ b/src/backend/prep.ml @@ -318,6 +318,58 @@ let isabelle_prove ob org_ob tmo tac res_cont = Schedule.Immediate (res_cont w (Method.NotTried msg) None) +let zipper_unsat_re = Str.regexp "SZS status Theorem";; + +let zipper_prove ob org_ob time res_cont = + let cleanup = ref (fun () -> ()) in + try + let (inf, inc, outf, outc) = mk_temps cleanup ".p" in + let zcmd = + Printf.sprintf "%s >%s" (Params.solve_cmd Params.zipper inf) outf + in + let in_text = + ignore (Format.flush_str_formatter ()); + Thf.pp_print_obligation Format.str_formatter ob; + Format.flush_str_formatter () + in + output_string inc in_text; + flush inc; + let warnings = Errors.get_warnings () in + let finished time_used = + let zinput = + let header = "\n(* BEGIN ZIPPERPOSITION INPUT\n" in + let footer = "\nEND ZIPPERPOSITION INPUT *)\n" in + Printf.sprintf "%s;; %s\n%s%s" header zcmd in_text footer + in + let result = Std.input_all outc in + !cleanup (); + let success = + try ignore (Str.search_forward zipper_unsat_re result 0); true + with Not_found -> false + in + if success then + res_cont warnings (Method.Proved (zinput ^ result)) time_used + else + let msg = "" in + res_cont warnings (Method.Failed msg) time_used + in + let done_cont = mk_donec finished cleanup res_cont warnings in + let timo = Printf.sprintf "(%g s)" time in + let + time_cont = mk_timec ob org_ob warnings time (Some "zipper", Some timo) + in + Schedule.Todo { + Schedule.line = zcmd; + Schedule.timeout = float_of_int !Params.wait; + Schedule.timec = time_cont; + Schedule.donec = done_cont; + } + with Failure msg -> + !cleanup (); + let w = Errors.get_warnings () in + Schedule.Immediate (res_cont w (Method.NotTried msg) None) +;; + (****************************************************************************) let print_obligation ob = @@ -361,13 +413,13 @@ let print_obl_and_msg let pp_print_ob ?comm:(c=";;") chan ob = - output_string chan (Printf.sprintf "%s Proof obligation:\n%s" c c); + output_string chan (Printf.sprintf "%s Proof obligation:\n" c); let ob_buf = Buffer.create 2000 in let fmt = Format.formatter_of_buffer ob_buf in Proof.Fmt.pp_print_obligation fmt ob; Format.pp_print_flush fmt (); - let replace inp out = Str.global_replace (Str.regexp_string inp) out in - let ob_str = replace "\n" ("\n"^c^" ") (Buffer.contents ob_buf) in + let pat = Str.regexp "^" in + let ob_str = Str.global_replace pat (c ^ "\t") (Buffer.contents ob_buf) in output_string chan ob_str; output_string chan "\n" @@ -442,38 +494,48 @@ let gen_smt_solve suffix exec desc fmt_expr meth ob org_ob f res_cont comm = Schedule.Immediate (res_cont w (Method.NotTried msg) None) +(* FIXME Remove all the oldsmt code *) +let get_encode_smtlib () = + if Params.debugging "oldsmt" then Smt.encode_smtlib + else Smtlib.pp_print_obligation + +(* FIXME *) +let get_encode_fof () = + if Params.debugging "oldsmt" then Smt.encode_fof + else Smtlib.pp_print_obligation ~solver:"fof" + let smt_solve ob org_ob f res_cont = - gen_smt_solve ".smt" Params.smt "default SMT solver" Smt.encode_smtlib + gen_smt_solve ".smt" Params.smt "default SMT solver" (get_encode_smtlib ()) (Method.Smt3 f) ob org_ob f res_cont ";;" let cvc3_solve ob org_ob f res_cont = - gen_smt_solve ".smt" Params.cvc4 "CVC4" Smt.encode_smtlib + gen_smt_solve ".smt" Params.cvc4 "CVC4" (get_encode_smtlib () ~solver:"CVC4") (Method.Cvc33 f) ob org_ob f res_cont ";;" let yices_solve ob org_ob f res_cont = - gen_smt_solve ".ys" Params.yices "Yices" Smt.encode_smtlib + gen_smt_solve ".ys" Params.yices "Yices" (get_encode_smtlib ()) (Method.Yices3 f) ob org_ob f res_cont ";;" let z3_solve ob org_ob f res_cont = - gen_smt_solve ".smt2" Params.z3 "Z3" (Smt.encode_smtlib ~solver:"Z3") + gen_smt_solve ".smt2" Params.z3 "Z3" ((get_encode_smtlib ()) ~solver:"Z3") (Method.Z33 f) ob org_ob f res_cont ";;" let verit_solve ob org_ob f res_cont = - gen_smt_solve ".smt2" Params.verit "veriT" Smt.encode_smtlib + gen_smt_solve ".smt2" Params.verit "veriT" (get_encode_smtlib () ~solver:"veriT") (Method.Verit f) ob org_ob f res_cont ";;" let spass_solve ob org_ob f res_cont = - gen_smt_solve ".tptp" Params.spass_tptp "Spass" Smt.encode_fof + gen_smt_solve ".tptp" Params.spass_tptp "Spass" (get_encode_fof ()) (Method.Spass f) ob org_ob f res_cont "%%" let tptp_solve ob org_ob f res_cont = - gen_smt_solve ".tptp" Params.eprover "Tptp" Smt.encode_fof + gen_smt_solve ".tptp" Params.eprover "Tptp" (get_encode_fof ()) (Method.Tptp f) ob org_ob f res_cont "% " @@ -571,6 +633,7 @@ let get_prover_name m = | Method.Cvc33 _ -> "CVC33" | Method.Yices3 _ -> "Yices3" | Method.Verit _ -> "Verit" + | Method.Zipper _ -> "Zipperposition" | Method.Spass _ -> "Spass" | Method.Tptp _ -> "TPTP" | Method.ExpandENABLED -> "ExpandENABLED" @@ -733,6 +796,9 @@ let prove_with ob org_ob meth save = (* FIXME add success fuction *) | Method.Verit f -> vprintf "(* ... using Verit *)\n" ; verit_solve ob org_ob f res_cont + | Method.Zipper f -> + vprintf "(* ... using Zipperposition *)\n" ; + zipper_prove ob org_ob f res_cont | Method.Spass f -> vprintf "(* ... using Spass *)\n" ; spass_solve ob org_ob f res_cont @@ -1167,6 +1233,9 @@ let compute_meth def args usept = | Some "verit" -> let tmo = Option.default Method.default_smt2_timeout !timeout in Method.Verit tmo + | Some "zipper" -> + let tmo = Option.default Method.default_zipper_timeout !timeout in + Method.Zipper tmo | Some "spass" -> let tmo = Option.default Method.default_spass_timeout !timeout in Method.Spass tmo diff --git a/src/backend/smt.ml b/src/backend/smt.ml index f762e8c7..0706eec8 100644 --- a/src/backend/smt.ml +++ b/src/backend/smt.ml @@ -720,14 +720,6 @@ let reset () = Smt.ctr := 0; E.ctr_types := 0; T.ctr_funarg := 0; - Smt.typesystem_mode := begin - if Params.debugging "notypes" then 0 (** Untyped *) - else if Params.debugging "types0" then 0 (** Untyped *) - else if Params.debugging "types1" then 1 (** Elementary type system *) - else if Params.debugging "types2" then 2 (** Refinement type system *) - else 1 - end; - Smt.ifprint 1 "** Type system mode = %d" !Smt.typesystem_mode; Smt.verbosity := begin if Params.debugging "verbose0" then 0 else if Params.debugging "verbose1" then 1 @@ -736,6 +728,14 @@ let reset () = else if Params.debugging "verbose4" then 4 else 0 end; + Smt.typesystem_mode := begin + if Params.debugging "notypes" then 0 (** Untyped *) + else if Params.debugging "types0" then 0 (** Untyped *) + else if Params.debugging "types1" then 1 (** Elementary type system *) + else if Params.debugging "types2" then 2 (** Refinement type system *) + else 1 + end; + Smt.ifprint 1 "** Type system mode = %d" !Smt.typesystem_mode; abstract_func := begin if Params.debugging "abstract1" then Preprocess.abstract else if Params.debugging "abstract2" then Preprocess.abstract2 diff --git a/src/backend/smtlib.ml b/src/backend/smtlib.ml new file mode 100644 index 00000000..6adf4358 --- /dev/null +++ b/src/backend/smtlib.ml @@ -0,0 +1,673 @@ +(* + * backend/smtlib.ml --- direct translation to SMT-LIB + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Format + +open Ext +open Property +open Fmtutil +open Tla_parser + +open Expr.T +open Type.T +open Util.Coll + +module Smb = Encode.Smb +module T = Encode.Table +module B = Builtin + +let (@@@) = Stdlib.(@@) + +let error ?at mssg = + let mssg = "Backend.Smtlib: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + +let primed s = s ^ "__prime" + + +(* {3 Context} *) + +let repls = + [ '_', "__" (* keep the tempfiles readable *) + ; '\\', "backslash_" + ; '+', "plussign_" + ; '-', "hyphen_" + ; '*', "asterisk_" + ; '/', "slash_" + ; '%', "percentsign_" + ; '^', "circumflexaccent_" + ; '&', "ampersand_" + ; '@', "atsign_" + ; '#', "pound_" + ; '$', "dollarsign_" + ; '(', "leftparenthesis_" + ; ')', "rightparenthesis_" + ; '|', "verticalbar_" + ; '.', "period_" + ; ':', "colon_" + ; '?', "questionmark_" + ; '!', "exclamationmark_" + ; '<', "lessthansign_" + ; '>', "greaterthansign_" + ; '=', "equalsign_" + ; ' ', "space_" + ] + +let escaped = + List.fold_right begin fun (c, repl) -> + let rgx = Str.regexp (Str.quote (String.make 1 c)) in + Str.global_replace rgx repl + end repls + +let format_smt s = + "smt__" ^ escaped s + +let adj cx v = + let nm = format_smt v.core in + let cx = Ctx.push cx nm in + (cx, Ctx.string_of_ident (Ctx.front cx)) + +let bump cx = + fst (adj cx ("" %% [])) + +let lookup_id cx n = + Ctx.string_of_ident (fst (Ctx.index cx n)) + +let quoted_symbol s = + "|" ^ s ^ "|" + + +(* {3 Expression Formatting} *) + +let pp_box fmt ff x = + fprintf ff "@[%a@]" fmt x + +let pp_print_sexpr fmt ff v = + fprintf ff "@[(%a@])" fmt v + +let rec pp_print_sort ff ty = + begin match ty with + | TAtm TABol -> pp_print_string ff "Bool" + | TAtm TAInt -> pp_print_string ff "Int" + | _ -> pp_print_string ff (ty_to_string ty) + end + +let pp_print_binding ff (nm, ty) = + fprintf ff "(%s %a)" nm pp_print_sort ty + + +let rec pp_apply cx ff op args = + match op.core with + | Ix n -> + let id = lookup_id cx n in + begin match args with + | [] -> + pp_print_string ff id + | _ -> + pp_print_sexpr begin fun ff (op, args) -> + fprintf ff "%s@ %a" op + (pp_print_delimited ~sep:pp_print_space (pp_box @@@ pp_print_expr cx)) args + end ff (id, args) + end + + | Opaque s when has op Smb.smb_prop -> + (* The symbols that are left correspond to native operators of SMB-LIB *) + let smb = get op Smb.smb_prop in + begin match Smb.get_defn smb, args with + | T.TIntLit n, [] -> + pp_print_int ff n + | T.TIntPlus, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff "+@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntUminus, [ e ] -> + pp_print_sexpr begin fun ff e -> + fprintf ff "-@ %a" + (pp_box @@@ pp_print_expr cx) e + end ff e + | T.TIntMinus, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff "-@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntTimes, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff "*@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntQuotient, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff "div@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntRemainder, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff "mod@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntLteq, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff "<=@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntLt, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff "<@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntGteq, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff ">=@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | T.TIntGt, [ e ; f ] -> + pp_print_sexpr begin fun ff (e, f) -> + fprintf ff ">@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + end ff (e, f) + | _, _ -> + (* assuming arity is always correct *) + let mssg = "unknown native operator '" ^ Smb.get_name smb ^ "'" in + error ~at:op mssg + end + + | Opaque s -> + begin match args with + | [] -> + (* FIXME This code formats primed variables. + * Would be cleaner to eliminate these beforehand *) + let s = + match String.split_on_char '#' s with + | [ s ; "prime" ] -> primed (format_smt s) + | _ -> s + in + pp_print_string ff (format_smt s) + | _ -> + pp_print_sexpr begin fun ff (op, args) -> + fprintf ff "%s@ %a" op + (pp_print_delimited ~sep:pp_print_space (pp_box @@@ pp_print_expr cx)) args + end ff (s, args) + end + + | Internal b -> + let kw = + (* All non-boolean builtins should be encoded away at this point *) + match b with + | B.TRUE -> "true" + | B.FALSE -> "false" + | B.Implies -> "=>" + | B.Equiv -> "=" + | B.Conj -> "and" + | B.Disj -> "or" + | B.Neg -> "not" + | B.Eq -> "=" + | B.Neq -> "distinct" + | _ -> + let mssg = "Unexpected builtin encountered '" ^ B.builtin_to_string b ^ "'" in + error ~at:op mssg + in + begin match args with + | [] -> + pp_print_string ff kw + | _ -> + pp_print_sexpr begin fun ff (op, args) -> + fprintf ff "%s@ %a" op + (pp_print_delimited ~sep:pp_print_space (pp_box @@@ pp_print_expr cx)) args + end ff (kw, args) + end + + | _ -> error ~at:op "Unexpected operator encountered" + +and fmt_expr cx oe = + if has oe pattern_prop then + Fu.Atm (fun ff -> + let pats = get oe pattern_prop in + let pp_print_pat ff es = + fprintf ff ":pattern %a" + (pp_print_sexpr ( + pp_print_delimited ~sep:pp_print_space (pp_box @@@ pp_print_expr cx)) + ) es + in + pp_print_sexpr begin fun ff () -> + fprintf ff "!@ %a@ %a" + (pp_box @@@ pp_print_expr cx) (remove_pats oe) + (pp_print_delimited ~sep:pp_print_space pp_print_pat) pats + end ff ()) + else + match oe.core with + | Ix _ | Opaque _ | Internal _ -> + Fu.Atm (fun ff -> pp_apply cx ff oe []) + + | Lambda ([], e) -> + fmt_expr cx e + | Lambda _ -> + let mssg = "Unexpected lambda-abstraction" in + error ~at:oe mssg + + | Apply ({ core = Internal B.Unprimable }, [ e ]) -> + fmt_expr cx e + + | Apply (op, args) -> + Fu.Atm (fun ff -> pp_apply cx ff op args) + + | Sequent sq -> + begin match Deque.front sq.context with + | None -> fmt_expr cx sq.active + + | Some ({ core = Fact (e, Visible, _)}, hs) -> + let ncx = bump cx in + Fu.Atm begin fun ff -> + pp_print_sexpr begin fun ff (e1, e2) -> + fprintf ff "=>@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e1 + (pp_box @@@ pp_print_expr ncx) e2 + end ff (e, Sequent { sq with context = hs } @@ oe) + end + + | Some ({ core = Fact (e, Hidden, _)}, hs) -> + let ncx = bump cx in + fmt_expr ncx (Sequent { sq with context = hs } @@ oe) + + | Some ({ core = Flex nm }, hs) -> + error ~at:oe "Nested variable declaration not supported" + + | Some ({ core = Fresh (nm, _, _, _) }, hs) -> + (* NOTE Second-order quantification rejected *) + let ty = get nm Props.ty0_prop in + let ncx, nm = adj cx nm in + Fu.Atm begin fun ff -> + pp_print_sexpr begin fun ff (nm, ty, e) -> + fprintf ff "forall@ %a@ %a" + (pp_print_sexpr pp_print_binding) (nm, ty) + (pp_box @@@ pp_print_expr ncx) e + end ff (nm, ty, Sequent { sq with context = hs } @@ oe) + end + + | _ -> error ~at:oe "Unsupported sequent expression" + end + + | With (e, _) -> + fmt_expr cx e + + | If (e, f, g) -> + Fu.Atm begin fun ff -> + pp_print_sexpr begin fun ff (e, f, g) -> + fprintf ff "ite@ %a@ %a@ %a" + (pp_box @@@ pp_print_expr cx) e + (pp_box @@@ pp_print_expr cx) f + (pp_box @@@ pp_print_expr cx) g + end ff (e, f, g) + end + + | List (Refs, []) -> + error ~at:oe "Empty LIST expression" + + | List (q, [e]) -> + fmt_expr cx e + + | List (q, es) -> + let op = + match q with + | And | Refs -> "and" + | Or -> "or" + in + Fu.Atm begin fun ff -> + pp_print_sexpr begin fun ff (op, es) -> + fprintf ff "%s@ %a" op + (pp_print_delimited ~sep:pp_print_space (pp_box @@@ pp_print_expr cx)) es + end ff (op, es) + end + + | Let ([], e) -> + fmt_expr cx e + + | Let (ds, e) -> + let ncx, vs = + let rec f acc_cx acc_vs ds = + match ds with + | [] -> (acc_cx, acc_vs) + | { core = Operator (_, { core = Lambda _ }) } :: _ -> + error ~at:oe "Higher-order LET expression" + | { core = Operator (nm, e) } :: ds -> + let acc_cx, nm = adj acc_cx nm in + let acc_vs = (nm, e) :: acc_vs in + f acc_cx acc_vs ds + | _ -> + error ~at:oe "Unsupported LET expression" + in + f cx [] ds + in + let pp_print_vbind cx ff (nm, e) = + fprintf ff "(%s %a)" nm + (pp_print_expr cx) e + in + Fu.Atm begin fun ff -> + pp_print_sexpr begin fun ff (vs, e) -> + fprintf ff "let %a@ %a" + (pp_print_sexpr ( + pp_print_delimited ~sep:pp_print_space (pp_print_vbind cx))) vs + (pp_box @@@ pp_print_expr ncx) e + end ff (vs, e) + end + + | Quant (q, bs, e) -> + let ncx, rbs = + let rec spin acc_cx acc_bs bs = + match bs with + | [] -> (acc_cx, acc_bs) + | (nm, _, _) :: bs -> + let ty = get nm Props.ty0_prop in + let acc_cx, nm = adj acc_cx nm in + let acc_bs = (nm, ty) :: acc_bs in + spin acc_cx acc_bs bs + in + spin cx [] bs + in + let bs = List.rev rbs in + let qrep = + match q with + | Forall -> "forall" + | Exists -> "exists" + in + Fu.Atm begin fun ff -> + pp_print_sexpr begin fun ff (bs, e) -> + fprintf ff "%s@ %a@ %a" qrep + (pp_print_sexpr ( + pp_print_delimited ~sep:pp_print_space pp_print_binding)) bs + (pp_box @@@ pp_print_expr ncx) e + end ff (bs, e) + end + + | Case (_, None) -> + error ~at:oe "Incomplete CASE expression encountered" + + | Case ([], _) -> + error ~at:oe "Empty CASE expression" + + | Case ([ (e1, e2) ], Some e3) -> + fmt_expr cx (If (e1, e2, e3) @@ oe) + + | Case ((e1, e2) :: ps, Some o) -> + fmt_expr cx (If (e1, e2, Case (ps, Some o) %% []) @@ oe) + + | Parens (e, _) -> + fmt_expr cx e + + | _ -> + error ~at:oe "Unsupported expression" + +and pp_print_expr cx ff e = + Fu.pp_print_minimal ff (fmt_expr cx e) + + +(* {3 Preprocessing} *) + +(* This very important function applies several transformations to the sequent + * to shape it into something translatable to SMT-LIB. *) +let preprocess ~solver sq = + + let cx = (Deque.empty, Ctx.dot) in + let pp_print_sequent ff sq = ignore (Expr.Fmt.pp_print_sequent cx ff sq) in + + let debug mssg sq = + if (Params.debugging "verbose") then begin + eprintf " [DEBUG] %s@.%a@.@." mssg + pp_print_sequent sq + end; + sq + in + + (* The "smarter_types" debug flag will activate elementary type inference to + translate integer expressions more efficiently for SMT. *) + + let disable_arithmetic = Params.debugging "disable_arithmetic" in + let smarter_types = Params.debugging "smarter_types" in + + let typelvl = + if disable_arithmetic then 0 + else if smarter_types then 2 + else 1 + in + + let rwlvl = + if Params.debugging "rw+" then 3 + else if Params.debugging "rw" then 2 + else if Params.debugging "rwsetext" then 1 + else 0 + in + + let smt_set_extensionality = not (Params.debugging "no_smt_set_extensionality") in + + let sq = sq + |> debug "Original Obligation:" + |> Encode.Rewrite.elim_flex + |> Type.Synthesize.main ~typelvl + |> Encode.Rewrite.elim_notmem + |> Encode.Rewrite.elim_compare + |> Encode.Rewrite.elim_multiarg + |> Encode.Rewrite.elim_bounds (* make all '\in' visible *) + |> Encode.Rewrite.sort_recfields + |> Encode.Rewrite.simplify_sets ~rwlvl ~disable_arithmetic + |> debug "Disambiguate and Simplify:" + |> Encode.Standardize.main ~smt_set_extensionality + |> debug "Standardize:" + |> Encode.Axiomatize.main ~solver ~disable_arithmetic ~smt_set_extensionality + |> debug "Axiomatize:" + |> Encode.Flatten.main + |> debug "Flatten:" + in + sq + + +(* {3 Sort Collection} *) + +let collect_sorts sq = + let srts = Type.Collect.main sq in + let srts = + Ts.fold begin fun srt -> + Ss.add (ty_to_string srt) + end srts Ss.empty + in + let srts = Ss.diff srts (Ss.of_list [ + "Bool" ; "Int" ; "Real" + ]) in + Ss.elements srts + + +(* {3 Obligation Formatting} *) + +let pp_print_assert ?meta cx ff e = + match meta with + | None -> + pp_print_sexpr begin fun ff () -> + fprintf ff "assert@ %a" + (pp_box @@@ pp_print_expr cx) e + end ff (); + pp_print_newline ff () + | Some m -> + fprintf ff ";; %s" + begin match m.hkind with + | Axiom -> "Axiom: " ^ m.name + | Hypothesis -> "Hypothesis: " ^ m.name + | Goal -> "Goal" + end; + pp_print_newline ff (); + pp_print_sexpr begin fun ff () -> + fprintf ff "assert@ %a" + begin pp_box @@@ pp_print_sexpr + begin fun ff e -> + fprintf ff "!@ %a@ :named %s" + (pp_box @@@ pp_print_expr cx) e + (*("name__" ^ format_smt m.name)*) + (quoted_symbol m.name) + end + end e + end ff (); + pp_print_newline ff () + +let pp_print_declaresort ff nm ar = + pp_print_sexpr begin fun ff () -> + fprintf ff "declare-sort %s %d" + nm ar + end ff (); + pp_print_newline ff () + +let pp_print_declarefun ff nm ins out = + pp_print_sexpr begin fun ff () -> + fprintf ff "declare-fun %s (%a) %a" nm + (pp_print_delimited ~sep:pp_print_space pp_print_sort) ins + pp_print_sort out + end ff (); + pp_print_newline ff () + +let pp_print_obligation ?(solver="SMT") ff ob = + (* Shape the sequent into a form that can be translated; + * Append a top context containing additional declarations and axioms *) + let sq = preprocess ~solver ob.Proof.T.obl.core in + + (* Print preample *) + fprintf ff ";; TLA+ Proof Manager %s@." (Params.rawversion ()); + fprintf ff ";; Proof obligation #%d@." (Option.get ob.id); + fprintf ff ";; Generated from %s@." (Util.location ~cap:false ob.obl); + pp_print_newline ff (); + + (* Print options *) + let logic = + if Params.debugging "disable_arithmetic" then "UF" + else if solver = "veriT" then "UFLIA" + else !Params.smt_logic (* default: UFNIA *) + in + fprintf ff "(set-logic %s)@." logic; + pp_print_newline ff (); + + (* Print sorts *) + fprintf ff ";; Sorts@."; + pp_print_newline ff (); + let srts = collect_sorts sq in + List.iter begin fun s -> + pp_print_declaresort ff s 0 + end srts; + pp_print_newline ff (); + + (* Print hypotheses *) + fprintf ff ";; Hypotheses@."; + + let is_sndord_fact e = + match e.core with + | Sequent sq -> + Option.is_some begin + Deque.find sq.context begin fun h -> + match h.core with + | Fresh (_, Shape_op n, _, _) when n > 0 -> + true + | _ -> + false + end + end + | _ -> + false + in + + let rec spin cx hs = + match Deque.front hs with + | None -> + cx + + | Some ({ core = Fact (e, vis, _) }, hs) -> + let ncx = bump cx in + begin if vis = Hidden then + fprintf ff "; hidden fact@." + else if is_sndord_fact e then + fprintf ff "; omitted fact (second-order)@." + else + pp_print_assert ?meta:(query e meta_prop) cx ff e + end; + pp_print_newline ff (); + spin ncx hs + + | Some ({ core = Flex nm }, hs) -> + let ty = get nm Props.ty0_prop in + let ncx, nm = adj cx nm in + pp_print_declarefun ff nm [] ty; + pp_print_newline ff (); + spin ncx hs + + | Some ({ core = Fresh (nm, _, _, _) }, hs) + | Some ({ core = Defn ({ core = Operator (nm, _) }, _, _, _) }, hs) + | Some ({ core = Defn ({ core = Instance (nm, _) }, _, _, _) }, hs) + | Some ({ core = Defn ({ core = Recursive (nm, _) }, _, _, _) }, hs) + | Some ({ core = Defn ({ core = Bpragma (nm, _, _) }, _, _, _) }, hs) -> + (* The only part of the definition that matters is the declaration. + * The 'hidden' flag only applies to the definition, so here it does not + * matter. Bounds to fresh variables have been removed beforehand. *) + if has nm Props.ty0_prop then + let ins = [] in + let out = get nm Props.ty0_prop in + let ncx, nm = adj cx nm in + pp_print_declarefun ff nm ins out; + pp_print_newline ff (); + spin ncx hs + + else if has nm Props.ty1_prop then + let Ty1 (ins, out) = get nm Props.ty1_prop in + let ncx, nm = adj cx nm in + pp_print_declarefun ff nm ins out; + pp_print_newline ff (); + spin ncx hs + + else if has nm Props.ty2_prop then + let ty2 = get nm Props.ty2_prop in + begin match safe_downcast_ty1 ty2 with + | None -> + let ncx = bump cx in + fprintf ff "; omitted declaration of '%s' (second-order)@." nm.core; + pp_print_newline ff (); + spin ncx hs + | Some (Ty1 (ins, out)) -> + let ncx, nm = adj cx nm in + pp_print_declarefun ff nm ins out; + pp_print_newline ff (); + spin ncx hs + end + + else + let ncx = bump cx in + fprintf ff "; omitted declaration of '%s' (missing type)@." nm.core; + pp_print_newline ff (); + spin ncx hs + in + + pp_print_newline ff (); + let cx = + if Deque.size sq.context = 0 then begin + pp_print_newline ff (); + Ctx.dot + end else + spin Ctx.dot sq.context + in + + (* Print goal *) + if is_sndord_fact sq.active then + eprintf "; omitted goal (second-order)@." + else + pp_print_assert ~meta:{ hkind = Goal ; name = "Goal" } cx ff (Apply (Internal B.Neg %% [], [sq.active]) %% []); + pp_print_newline ff (); + + fprintf ff "(check-sat)@."; + fprintf ff "(exit)@." + diff --git a/src/backend/smtlib.mli b/src/backend/smtlib.mli new file mode 100644 index 00000000..3b4e3b87 --- /dev/null +++ b/src/backend/smtlib.mli @@ -0,0 +1,16 @@ +(* + * backend/smtlib.ml --- direct translation to SMT-LIB + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +(** Replacement strings for special characters. + Shared with module Thf *) +val repls : (char * string) list + +(** Print in SMT-LIB format a sequent reduced to first-order logic + without TLA+ primitives +*) +val pp_print_obligation : ?solver:string -> Format.formatter -> Proof.T.obligation -> unit;; + diff --git a/src/backend/smtlib.mlt b/src/backend/smtlib.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/backend/smtlib.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/backend/thf.ml b/src/backend/thf.ml new file mode 100644 index 00000000..58429828 --- /dev/null +++ b/src/backend/thf.ml @@ -0,0 +1,583 @@ +(* + * backend/thf.mli --- translation to TPTP/THF + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Format + +open Ext +open Property +open Fmtutil + +open Expr.T +open Type.T +open Util.Coll + +module B = Builtin + +let error ?at mssg = + let mssg = "Backend.Thf: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + +let primed s = s ^ "__prime" + + +(* {3 Context} *) + +let init_cx = Ctx.dot + +let repls = Smtlib.repls + +let escaped = + List.fold_right begin fun (c, repl) -> + let rgx = Str.regexp (Str.quote (String.make 1 c)) in + Str.global_replace rgx repl + end repls + +let format_l s = + if String.length s > 0 then + "THF__" ^ escaped s + else s + +let format_g s = + if String.length s > 0 then + "thf__" ^ escaped s + else s + +let adj_l cx v = + let nm = format_l v.core in + let cx = Ctx.push cx nm in + (cx, Ctx.string_of_ident (Ctx.front cx)) + +let adj_g cx v = + let nm = format_g v.core in + let cx = Ctx.push cx nm in + (cx, Ctx.string_of_ident (Ctx.front cx)) + +let bump cx = + fst (adj_l cx ("" %% [])) + +let lookup_id cx n = + Ctx.string_of_ident (fst (Ctx.index cx n)) + + +(* {3 Expression Formatting} *) + +(* FIXME fix formatting then remove *) +let pp_print_commasp ff () = + pp_print_string ff ", " + +(* FIXME fix formatting then remove *) +let pp_print_delimited ?(sep=pp_print_commasp) = + Fmtutil.pp_print_delimited ~sep + +let pp_print_sort ff ty = + let s = + match ty with + | TAtm TAIdv -> "$i" + | TAtm TABol -> "$o" + | TAtm TAInt -> "$int" + | _ -> ty_to_string ty + in + pp_print_string ff s + +let pp_print_conn s ff () = + fprintf ff " %s@ " s + +let pp_print_tyfunc ff (Ty2 (ty1s, ty)) = + let pp_print_ty1 ff = function + | Ty1 ([], ty) -> + pp_print_sort ff ty + | Ty1 (ty0s, ty) -> + fprintf ff "( %a )" + (pp_print_delimited ~sep:(pp_print_conn ">") pp_print_sort) + (ty0s @ [ ty ]) + in + pp_print_delimited ~sep:(pp_print_conn ">") + pp_print_ty1 ff (ty1s @ [ Ty1 ([], ty) ]) + +(* Print type attached to hint, not the hint itself *) +let pp_print_typeof ff v = + if has v Props.ty0_prop then + let ty = get v Props.ty0_prop in + pp_print_sort ff ty + else if has v Props.ty2_prop then + let ty2 = get v Props.ty2_prop in + pp_print_tyfunc ff ty2 + else if has v Props.ty1_prop then + let ty1 = get v Props.ty1_prop in + pp_print_tyfunc ff (upcast_ty2 ty1) + else + let mssg = "Missing type annotation on \ + '" ^ v.core ^ "'" + in + error ~at:v mssg + +let pp_print_binding ff v = + fprintf ff "%s: %a" v.core pp_print_typeof v + + +let is_arith op = + false (* FIXME *) + + +let rec pp_print_thf_atomic cx ff oe = + match oe.core with + | Ix n -> + let id = lookup_id cx n in + pp_print_string ff id + + | Apply ({ core = Internal (B.Unprimable | B.Irregular) }, [ e ]) -> + pp_print_thf_atomic cx ff e + + | Opaque s -> + (* FIXME Ad hoc trick that formats primed variables. + * Would be cleaner to eliminate these beforehand *) + let s = + match String.split_on_char '#' s with + | [ s ; "prime" ] -> primed (format_g s) + | _ -> + (* Allowing this would make the encoding unsound, as + * Zipperposition may just take undeclared identifiers + * for variables universally quantified on at top level. *) + error ~at:oe ("Undeclared opaque '" ^ s ^ "'") + in + pp_print_string ff s + + | Internal B.TRUE -> + pp_print_string ff "$true" + + | Internal B.FALSE -> + pp_print_string ff "$false" + + | Internal b -> + let mssg = "Unsupported builtin '" ^ B.builtin_to_string b ^ "'" in + error ~at:oe mssg + + | Apply (e, []) -> + pp_print_thf_atomic cx ff e + + | List (Refs, [e]) -> + pp_print_thf_atomic cx ff e + + | Let ([], e) -> + pp_print_thf_atomic cx ff e + + | Quant (_, [], e) -> + pp_print_thf_atomic cx ff e + + | Num (m, "") -> + fprintf ff "%s" m + + | Num (m, n) -> + fprintf ff "%s.%s" m n + + | Parens (e, _) -> + pp_print_thf_atomic cx ff e + + | _ -> + fprintf ff "@[( %a@] )" + (pp_print_thf_logic cx) oe + +and pp_print_thf_logic cx ff oe = + match oe.core with + | Apply ({ core = Internal B.Neg }, [ e ]) -> + fprintf ff "~ %a" + (pp_print_thf_atomic cx) e + + | Apply ({ core = Internal (B.Implies | B.Equiv | B.Conj | B.Disj | B.Eq | B.Neq as b) }, [ e ; f ]) -> + let s = + match b with + | B.Implies -> "=>" + | B.Equiv -> "<=>" + | B.Conj -> "&" + | B.Disj -> "|" + | B.Eq -> "=" + | B.Neq -> "!=" + | _ -> error "Unexpected builtin" + in + fprintf ff "%a%a%a" + (pp_print_thf_atomic cx) e + (pp_print_conn s) () + (pp_print_thf_atomic cx) f + + | List (q, es) -> + let s = + match q with + | And | Refs -> "&" + | Or -> "|" + in + pp_print_delimited ~sep:(pp_print_conn s) + (pp_print_thf_atomic cx) ff es + + | Sequent sq -> + pp_print_thf_logic_sq cx ff sq + + | _ -> + pp_print_thf_apply cx ff oe + +and pp_print_thf_logic_sq ?status:status ?(factlvl=0) cx ff sq = + (* status is true if last hyp was a binding; false if it was a fact; None at the beginning *) + let print_first_bind v = + fprintf ff "! [ %a" pp_print_binding v + in + let print_bind v = + pp_print_commasp ff (); + pp_print_binding ff v + in + let close_bindings () = + fprintf ff " ] :@ " + in + let print_first_fact cx e = + fprintf ff "@[( @[( %a" (pp_print_thf_atomic cx) e + in + let print_fact cx e = + pp_print_conn "&" ff (); + pp_print_thf_atomic cx ff e + in + let close_facts () = + fprintf ff " ) "; + pp_print_conn "=>" ff () + in + let close_factlvls () = + let rec spin n = + if n = 0 then () + else begin + fprintf ff "@] )"; + spin (n - 1) + end + in + spin factlvl + in + + match Deque.front sq.context with + | None -> + Option.iter begin function + | true -> close_bindings () + | false -> close_facts () + end status; + pp_print_thf_atomic cx ff sq.active; + close_factlvls () + + | Some ({ core = Fact (e, Visible, _) }, hs) -> + let ncx = bump cx in + let nfactlvl = + match status with + | None -> print_first_fact cx e; factlvl + 1 + | Some false -> print_fact cx e; factlvl + | Some true -> close_bindings (); print_first_fact cx e; factlvl + 1 + in + pp_print_thf_logic_sq ~status:false ~factlvl:nfactlvl ncx ff { sq with context = hs } + + | Some ({ core = Fresh (v, _, _, Unbounded) }, hs) -> + let ncx, nm = adj_l cx v in + let v = nm @@ v in + begin match status with + | None -> print_first_bind v + | Some false -> close_facts (); print_first_bind v + | Some true -> print_bind v + end; + pp_print_thf_logic_sq ~status:true ~factlvl:factlvl ncx ff { sq with context = hs } + + | Some ({ core = Flex v }, hs) -> + let ncx, nm = adj_l cx v in + let v = nm @@ v in + let v_primed = primed nm @@ v in + begin match status with + | None -> print_first_bind v; print_bind v_primed + | Some false -> close_facts (); print_first_bind v; print_bind v_primed + | Some true -> print_bind v; print_bind v_primed + end; + pp_print_thf_logic_sq ~status:true ~factlvl:factlvl cx ff { sq with context = hs } + + | _ -> + let h = Option.get (Deque.front sq.context) |> fst in + error ~at:h "Unsupported expression (internal sequent)" + +and pp_print_thf_apply cx ff oe = + match oe.core with + | Apply (op, args) when not (is_arith op) -> + pp_print_delimited ~sep:(pp_print_conn "@") + (pp_print_thf_atomic cx) ff (op :: args) + + | _ -> + pp_print_thf_quant cx ff oe + +and pp_print_thf_quant cx ff oe = + match oe.core with + | Lambda (xs, e) -> + let ncx, rvs = + List.fold_left begin fun (cx, rvs) (v, _) -> + let ncx, nm = adj_l cx v in + let v = nm @@ v in + (ncx, v :: rvs) + end (cx, []) xs + in + fprintf ff "^ [ %a ] :@ %a" + (pp_print_delimited pp_print_binding) (List.rev rvs) + (pp_print_thf_atomic ncx) e + + | Quant (q, bs, e) -> + let ncx, rbs = + let rec spin acc_cx acc_bs bs = + match bs with + | [] -> (acc_cx, acc_bs) + | (v, _, _) :: bs -> + let acc_cx, nm = adj_l acc_cx v in + let v = nm @@ v in + let acc_bs = v :: acc_bs in + spin acc_cx acc_bs bs + in + spin cx [] bs + in + let qrep = + match q with + | Forall -> "!" + | Exists -> "?" + in + fprintf ff "%s [ %a ] :@ %a" qrep + (pp_print_delimited pp_print_binding) (List.rev rbs) + (pp_print_thf_atomic ncx) e + + | _ -> + pp_print_thf_let cx ff oe + +and pp_print_thf_let cx ff oe = + match oe.core with + | Let (ds, e) -> + let ncx, vs = + let rec f acc_cx acc_vs ds = + match ds with + | [] -> (acc_cx, acc_vs) + | { core = Operator (nm, e) } :: ds -> + let acc_cx, nm = adj_l acc_cx nm in + let acc_vs = (nm, e) :: acc_vs in + f acc_cx acc_vs ds + | _ -> + error ~at:oe "unsupported LET expression" + in + f cx [] ds + in + let pp_print_vbind cx ff (nm, e) = + fprintf ff "%s :=@ %a" nm + (pp_print_thf_atomic cx) e + in + fprintf ff "@[$let([ %a ],@ %a@])" + (pp_print_delimited (pp_print_vbind cx)) vs + (pp_print_thf_atomic ncx) e + + | _ -> + pp_print_thf_ite cx ff oe + +and pp_print_thf_ite cx ff oe = + match oe.core with + | If (e, f, g) -> + fprintf ff "@[$ite(@,%a,@ %a,@ %a@])" + (pp_print_thf_atomic cx) e + (pp_print_thf_atomic cx) f + (pp_print_thf_atomic cx) g + + | Case (_, None) -> + error ~at:oe "CASE with missing 'default'" + + | Case ([ (e1, e2) ], Some e3) -> + pp_print_thf_ite cx ff (If (e1, e2, e3) @@ oe) + + | Case ((e1, e2) :: ps, Some o) -> + pp_print_thf_ite cx ff (If (e1, e2, Case (ps, Some o) %% []) @@ oe) + + | Bang _ | With _ | Tquant _ + | Choose _ | SetSt _ | SetOf _ | Product _ | Tuple _ + | Fcn _ | FcnApp _ | Arrow _ | Rect _ | Record _ + | Except _ | Dot _ | Sub _ | Tsub _ | Fair _ | String _ + | At _ -> + error ~at:oe "Unsupported expression" + + | _ -> + pp_print_thf_arith cx ff oe + +and pp_print_thf_arith cx ff oe = + match oe.core with + | Apply (op, es) when is_arith op -> + error ~at:oe "Not implemented" (* FIXME *) + (*let smb = get op smb_prop in + let s = + match Option.get (get_defn smb) with + | Plus -> "sum" + | Uminus -> "uminus" + | Minus -> "minus" + | Times -> "product" + | Lteq -> "lesseq" + | Lt -> "less" + | Gteq -> "greatereq" + | Gt -> "greater" + | _ -> error ~at:op "Expected arithmetic operator" + in + fprintf ff "@[$%s(@,%a@])" s + (pp_print_delimited (pp_print_thf_atomic cx)) es*) + + | _ -> + pp_print_thf_atomic cx ff oe + +let pp_print_expr cx ff oe = + pp_print_thf_atomic cx ff oe + + +(* {3 Preprocessing} *) + +(* This very important function applies several transformations to the sequent + * to shape it into something translatable to THF. *) +let preprocess ~solver sq = + + let cx = (Deque.empty, Ctx.dot) in + let pp_print_sequent ff sq = ignore (Expr.Fmt.pp_print_sequent cx ff sq) in + + let debug mssg sq = + if (Params.debugging "verbose") then begin + fprintf err_formatter " [DEBUG] %s@.%a@.@." mssg + pp_print_sequent sq + end; + sq + in + + let sq = sq + |> debug "Original Obligation:" + |> Type.Synthesize.main ~typelvl:0 + |> Encode.Rewrite.elim_notmem + |> Encode.Rewrite.elim_compare + |> Encode.Rewrite.elim_except + |> Encode.Rewrite.elim_multiarg + |> Encode.Rewrite.elim_bounds (* make all '\in' visible *) + |> Encode.Rewrite.simplify_sets ~rwlvl:1 ~disable_arithmetic:true (* simplify equalities between sets by ext. *) + |> debug "Disambiguate and Simplify:" + |> Encode.Standardize.main ~smt_set_extensionality:false + |> debug "Standardize:" + |> Encode.Axiomatize.main ~solver ~disable_arithmetic:true ~smt_set_extensionality:false + |> debug "Axiomatize:" + in + sq + + +(* {3 Obligation Formatting} *) + +type form = + | Sort of ty + | Opr of Util.hint + | Form of expr + +type role = + | Type + | Definition + | Axiom + | Conjecture + +let pp_print_formula cx ff = function + | Sort ty -> + fprintf ff "( %a: $tType )" pp_print_sort ty + | Opr v -> + fprintf ff "( %a )" pp_print_binding v + | Form e -> + pp_print_expr cx ff e + +let pp_print_role ff = function + | Type -> pp_print_string ff "type" + | Definition -> pp_print_string ff "definition" + | Axiom -> pp_print_string ff "axiom" + | Conjecture -> pp_print_string ff "conjecture" + +let pp_print_thf cx ff ?comment name role form = + Option.iter begin fun comment -> + fprintf ff "%%---- %s@." comment + end comment; + fprintf ff "@[thf(%s, %a,@ %a@]).@." + name pp_print_role role (pp_print_formula cx) form + +let pp_print_obligation ?(solver="Zipper") ff ob = + (* Shape the sequent into a form that can be translated + * Append a top context containing additional declarations and axioms *) + let sq = preprocess ~solver ob.Proof.T.obl.core in + + (* Print preample *) + fprintf ff "%%---- TLA+ Proof Manager %s@." (Params.rawversion ()); + fprintf ff "%%---- Proof obligation #%d@." (Option.get ob.id); + fprintf ff "%%---- Generated from %s@." (Util.location ~cap:false ob.obl); + pp_print_newline ff (); + + (* Print sorts *) + let srts = Type.Collect.main sq in + let srts = Ts.filter begin function + TAtm TAIdv | TAtm TABol | TAtm TAInt -> false | _ -> true + end srts in + if not (Ts.is_empty srts) then begin + fprintf ff "%%---- Sorts@."; + pp_print_newline ff (); + List.iteri begin fun i ty -> + pp_print_thf Ctx.dot ff ("type" ^ string_of_int i) Type (Sort ty) + end (Ts.elements srts); + pp_print_newline ff () + end; + + (* Print hypotheses *) + let rec spin cx hs = + match Deque.front hs with + | None -> + cx + + | Some ({ core = Fact (e, vis, _) }, hs) -> + let ncx = bump cx in + begin if vis = Visible then + let i = Ctx.length cx in + pp_print_thf cx ff ("fact" ^ string_of_int i) Axiom (Form e) + else + fprintf ff "%%---- hidden fact@." + end; + pp_print_newline ff (); + spin ncx hs + + | Some ({ core = Flex v }, hs) -> + let ncx, nm = adj_g cx v in + let v = nm @@ v in + let nm_primed = primed nm in + let v_primed = nm_primed @@ v in + pp_print_thf cx ff ("flex_" ^ nm) Type (Opr v); + pp_print_newline ff (); + pp_print_thf cx ff ("flex_" ^ nm_primed) Type (Opr v_primed); + pp_print_newline ff (); + spin ncx hs + + | Some ({ core = Fresh (v, _, _, _) }, hs) -> + let ncx, nm = adj_g cx v in + let v = nm @@ v in + pp_print_thf cx ff ("fresh_" ^ nm) Type (Opr v); + pp_print_newline ff (); + spin ncx hs + + | Some ({ core = Defn ({ core = Operator (v, _) }, _, vis, _) }, hs) + | Some ({ core = Defn ({ core = Instance (v, _) }, _, vis, _) }, hs) + | Some ({ core = Defn ({ core = Recursive (v, _) }, _, vis, _) }, hs) + | Some ({ core = Defn ({ core = Bpragma (v, _, _) }, _, vis, _) }, hs) -> + let ncx, nm = adj_g cx v in + let v = nm @@ v in + pp_print_thf cx ff ("defn_" ^ nm) Type (Opr v); + pp_print_newline ff (); + spin ncx hs + in + + let cx = + if Deque.size sq.context = 0 then begin + Ctx.dot + end else begin + fprintf ff "%%---- Hypotheses@."; + pp_print_newline ff (); + spin Ctx.dot sq.context + end + in + + (* Print goal *) + fprintf ff "%%---- Goal@."; + pp_print_thf cx ff "goal" Conjecture (Form sq.active); + pp_print_newline ff (); + diff --git a/src/backend/thf.mli b/src/backend/thf.mli new file mode 100644 index 00000000..dc52dbd9 --- /dev/null +++ b/src/backend/thf.mli @@ -0,0 +1,12 @@ +(* + * backend/thf.ml --- translation to TPTP/THF + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +(** Print in THF format a sequent (possibly higher-order) + without TLA+ primitives +*) +val pp_print_obligation : ?solver:string -> Format.formatter -> Proof.T.obligation -> unit;; + diff --git a/src/backend/thf.mlt b/src/backend/thf.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/backend/thf.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/builtin.ml b/src/builtin.ml index af924f73..b507f383 100644 --- a/src/builtin.ml +++ b/src/builtin.ml @@ -31,3 +31,77 @@ type builtin = | SortSeq | RandomElement | Any | ToString (* special *) | Unprimable | Irregular + +let builtin_to_string = function + | TRUE -> "TRUE" + | FALSE -> "FALSE" + | Implies -> "Implies" + | Equiv -> "Equiv" + | Conj -> "Conj" + | Disj -> "Disj" + | Neg -> "Neg" + | Eq -> "Eq" + | Neq -> "Neq" + | STRING -> "STRING" + | BOOLEAN -> "BOOLEAN" + | SUBSET -> "SUBSET" + | UNION -> "UNION" + | DOMAIN -> "DOMAIN" + | Subseteq -> "Subseteq" + | Mem -> "Mem" + | Notmem -> "Notmem" + | Setminus -> "Setminus" + | Cap -> "Cap" + | Cup -> "Cup" + | Prime -> "Prime" + | StrongPrime -> "StrongPrime" + | Leadsto -> "Leadsto" + | ENABLED -> "ENABLED" + | UNCHANGED -> "UNCHANGED" + | Cdot -> "Cdot" + | Actplus -> "Actplus" + | Box true -> "Box(true)" + | Box false -> "Box(false)" + | Diamond -> "Diamond" + | Nat -> "Nat" + | Int -> "Int" + | Real -> "Real" + | Plus -> "Plus" + | Minus -> "Minus" + | Uminus -> "Uminus" + | Times -> "Times" + | Ratio -> "Ratio" + | Quotient -> "Quotient" + | Remainder -> "Remainder" + | Exp -> "Exp" + | Infinity -> "Infinity" + | Lteq -> "Lteq" + | Lt -> "Lt" + | Gteq -> "Gteq" + | Gt -> "Gt" + | Divides -> "Divides" + | Range -> "Range" + | Seq -> "Seq" + | Len -> "Len" + | BSeq -> "BSeq" + | Cat -> "Cat" + | Append -> "Append" + | Head -> "Head" + | Tail -> "Tail" + | SubSeq -> "SubSeq" + | SelectSeq -> "SelectSeq" + | OneArg -> "OneArg" + | Extend -> "Extend" + | Print -> "Print" + | PrintT -> "PrintT" + | Assert -> "Assert" + | JavaTime -> "JaveTime" + | TLCGet -> "TLCGet" + | TLCSet -> "TLCSet" + | Permutations -> "Permutations" + | SortSeq -> "SortSeq" + | RandomElement -> "RandomElement" + | Any -> "Any" + | ToString -> "ToString" + | Unprimable -> "Unprimable" + | Irregular -> "Irregular" diff --git a/src/builtin.mli b/src/builtin.mli index 5614c4df..c9a0f7c1 100644 --- a/src/builtin.mli +++ b/src/builtin.mli @@ -81,3 +81,5 @@ type builtin = (* special *) | Unprimable | Irregular + +val builtin_to_string : builtin -> string diff --git a/src/encode.ml b/src/encode.ml new file mode 100644 index 00000000..508e3288 --- /dev/null +++ b/src/encode.ml @@ -0,0 +1,13 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +(* Packaging module for the modules that implement PO transformations *) + +module Rewrite = N_rewrite +module Table = N_table +module Smb = N_smb +module Standardize = N_standardize +module Axiomatize = N_axiomatize +module Flatten = N_flatten + diff --git a/src/encode.mli b/src/encode.mli new file mode 100644 index 00000000..e83923ed --- /dev/null +++ b/src/encode.mli @@ -0,0 +1,142 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +(* Packaging module for the modules that implement PO transformations *) + +module Rewrite : sig + open Expr.T + val elim_bounds : sequent -> sequent + val elim_flex : sequent -> sequent + val elim_notmem : sequent -> sequent + val elim_compare : sequent -> sequent + val elim_except : sequent -> sequent + val elim_multiarg : sequent -> sequent + val elim_except : sequent -> sequent + val elim_tuples : sequent -> sequent + val elim_records : sequent -> sequent + val sort_recfields : sequent -> sequent + + val simplify_range : sequent -> sequent + val simplify_sets : ?limit:int -> ?rwlvl:int -> disable_arithmetic:bool -> sequent -> sequent +end + +module Table : sig + open Type.T + type tla_smb = + | Choose + | Mem + | SubsetEq + | SetEnum of int + | Add + | Union + | Subset + | Cup + | Cap + | SetMinus + | SetSt + | SetOf of int + | BoolSet + | StrSet + | StrLit of string + | IntSet + | NatSet + | IntLit of int + | IntPlus + | IntUminus + | IntMinus + | IntTimes + | IntQuotient + | IntRemainder + | IntExp + | IntLteq + | IntLt + | IntGteq + | IntGt + | IntRange + | FunIsafcn + | FunSet + | FunConstr + | FunDom + | FunIm + | FunApp + | FunExcept + | Tuple of int + | Product of int + | Rec of string list + | RecSet of string list + | SeqSeq + | SeqLen + | SeqBSeq + | SeqCat + | SeqAppend + | SeqHead + | SeqTail + | SeqSubSeq + | SeqSelectSeq + | FSIsFiniteSet + | FSCard + | TIntLit of int + | TIntPlus + | TIntUminus + | TIntMinus + | TIntTimes + | TIntQuotient + | TIntRemainder + (*| TIntExp*) + | TIntLteq + | TIntLt + | TIntGteq + | TIntGt + | TFSCard of ty + | TFSMem of ty + | TFSSubseteq of ty + | TFSEmpty of ty + | TFSSingleton of ty + | TFSAdd of ty + | TFSCup of ty + | TFSCap of ty + | TFSSetminus of ty + | Cast of ty + | Proj of ty + | True of ty + | Anon of string * ty2 + | ExtTrigEq of ty + | ExtTrig + | IsSetOf +end + +module Smb : sig + open Type.T + open Property + + type smb + val smb_prop : smb pfuncs + module SmbSet : Set.S with type elt = smb + val equal_smb : smb -> smb -> bool + val get_name : smb -> string + val get_ty2 : smb -> ty2 + val get_ty1 : smb -> ty1 + val get_ty0 : smb -> ty0 + val get_ord : smb -> int + val get_defn : smb -> Table.tla_smb + + val pp_print_smb : Format.formatter -> smb -> unit +end + +module Standardize : sig + open Expr.T + val main : ?smt_set_extensionality:bool -> sequent -> sequent +end + +module Axiomatize : sig + open Property + open Expr.T + val main : solver:string -> disable_arithmetic:bool -> smt_set_extensionality:bool -> sequent -> sequent +end + +module Flatten : sig + open Expr.T + val main : sequent -> sequent +end + diff --git a/src/encode.mlt b/src/encode.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_axiomatize.ml b/src/encode/n_axiomatize.ml new file mode 100644 index 00000000..702bb38f --- /dev/null +++ b/src/encode/n_axiomatize.ml @@ -0,0 +1,202 @@ +(* + * encode/axiomatize.ml --- add axioms in a sequent + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Ext +open Property +open Expr.T + +open N_smb +open N_data +open N_axioms +open N_table + + +(* {3 Contexts} *) + +module TlaAxmSet = Set.Make (struct + type t = tla_axm + let compare = Stdlib.compare +end) + +type ecx = s * SmbSet.t * TlaAxmSet.t + +let init_ecx = + let init_smbs = + [] |> + List.map mk_smb |> + SmbSet.of_list + in + (init, init_smbs, TlaAxmSet.empty) + + +(* {3 Helpers} *) + +let error ?at mssg = + let mssg = "Encode.Axiomatize: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + +(* Native symbols do not lead to a declaration, they are translated + * as builtins of the backends *) +let is_native ~solver smb = + begin match solver with + | "SMT" | "Z3" | "CVC4" | "veriT" -> + begin match get_defn smb with + | TIntLit _ + | TIntPlus + | TIntUminus + | TIntMinus + | TIntTimes + | TIntQuotient + | TIntRemainder + | TIntLteq + | TIntLt + | TIntGteq + | TIntGt -> true + | _ -> false + end + | _ -> false + end + + +(* {3 Collection} *) + +(* NOTE Important function + * Add symbol to extended context, along with all depending + * symbols and axioms *) +let add_smb ~solver ~disable_arithmetic ~smt_set_extensionality smb ecx = + let rec spin (s, acc_smbs, acc_facts as ecx) work_smbs = + try + let smb = SmbSet.choose work_smbs in + if SmbSet.mem smb acc_smbs then + let work_smbs = SmbSet.remove smb work_smbs in + spin ecx work_smbs + else + let s, deps = get_deps ~solver ~disable_arithmetic ~smt_set_extensionality (get_defn smb) s in + let smb_deps = List.fold_left begin fun smbs tla_smb -> + let smb = mk_smb tla_smb in + smb :: smbs + end [] deps.dat_deps in + let acc_smbs = SmbSet.add smb acc_smbs in + let acc_facts = List.fold_right TlaAxmSet.add deps.dat_axms acc_facts in + let work_smbs = SmbSet.remove smb work_smbs in + let work_smbs = List.fold_right SmbSet.add smb_deps work_smbs in + spin (s, acc_smbs, acc_facts) work_smbs + with Not_found -> + ecx + in + spin ecx (SmbSet.singleton smb) + +let collect_visitor = object (self : 'self) + inherit [string * bool * bool, ecx] Expr.Visit.fold as super + + method expr ((solver, disable_arithmetic, smt_set_extensionality), cx as scx) ecx oe = + begin match oe.core with + | Opaque _ when has oe smb_prop -> + let smb = get oe smb_prop in + add_smb ~solver ~disable_arithmetic ~smt_set_extensionality smb ecx + + | _ -> super#expr scx ecx oe + + end |> + fold_pats (fun es ecx -> List.fold_left (self#expr scx) ecx es) oe + + + method hyp scx ecx h = + match h.core with + | Defn (_, _, Hidden, _) + | Fact (_, Hidden, _) -> + let scx = Expr.Visit.adj scx h in + (scx, ecx) + | _ -> + super#hyp scx ecx h +end + +let collect ~solver ~disable_arithmetic ~smt_set_extensionality ecx sq = + let scx = ((solver, disable_arithmetic, smt_set_extensionality), Deque.empty) in + snd (collect_visitor#sequent scx ecx sq) + + +(* {3 Assembly} *) + +let mk_decl smb = + let v = get_name smb %% [] in + let ty2 = get_ty2 smb in + let v = assign v Type.T.Props.ty2_prop ty2 in + let shp = Shape_op 0 in (* special *) + let h = Fresh (v, shp, Constant, Unbounded) %% [] in + assign h smb_prop smb + +let mk_fact ~solver ~disable_arithmetic ~smt_set_extensionality tla_axm = + let e = get_axm ~solver ~disable_arithmetic ~smt_set_extensionality tla_axm in + let meta = { hkind = Axiom ; name = axm_desc tla_axm } in + let e = assign e meta_prop meta in + let h = Fact (e, Visible, NotSet) %% [] in + (* The optional smb_prop annotation is used in Flattening + * for detecting axiom instances *) + let h = Option.fold (fun h -> assign h smb_prop) h (query e smb_prop) in + h + +let assemble_visitor = object (self : 'self) + inherit [string] Expr.Visit.map as super + + method expr (solver, hx as scx) oe = + begin match oe.core with + | Opaque _ when has oe smb_prop && not (is_native ~solver (get oe smb_prop)) -> + let smb = get oe smb_prop in + let s = get_name smb in + let is_fresh_s = fun h -> + hyp_name h = s + in + begin try + let n = + match Deque.find ~backwards:true hx is_fresh_s with + | Some (n, _) -> n + | None -> + let mssg = "cannot find symbol '" + ^ s ^ "' in context" in + error ~at:oe mssg + in + let ix = 1 + n in + remove (Ix ix @@ oe) smb_prop + with _ -> oe end + + | _ -> super#expr scx oe + + end |> + map_pats (List.map (self#expr scx)) + + method hyp scx h = + match h.core with + | Defn (_, _, Hidden, _) + | Fact (_, Hidden, _) -> + let scx = Expr.Visit.adj scx h in + (scx, h) + | _ -> + super#hyp scx h +end + +let assemble ~solver ~disable_arithmetic ~smt_set_extensionality (_, decls, axms) sq = + let decls = SmbSet.filter (fun smb -> not (is_native ~solver smb)) decls in + let decls = Deque.map (fun _ -> mk_decl) (SmbSet.elements decls |> Deque.of_list) in + let axms = TlaAxmSet.fold (fun tla_axm dq -> Deque.snoc dq (mk_fact ~solver ~disable_arithmetic ~smt_set_extensionality tla_axm)) axms Deque.empty in + let top_hx = Deque.append decls axms in + + let sq = { sq with context = Deque.append top_hx sq.context } in + let scx = (solver, Deque.empty) in + let _, sq = assemble_visitor#sequent scx sq in + sq + + +(* {3 Main} *) + +let main ~solver ~disable_arithmetic ~smt_set_extensionality sq = + let ecx = init_ecx in + let ecx = collect ~solver ~disable_arithmetic ~smt_set_extensionality ecx sq in + let sq = assemble ~solver ~disable_arithmetic ~smt_set_extensionality ecx sq in + sq + diff --git a/src/encode/n_axiomatize.mli b/src/encode/n_axiomatize.mli new file mode 100644 index 00000000..860a380d --- /dev/null +++ b/src/encode/n_axiomatize.mli @@ -0,0 +1,55 @@ +(* + * encode/axiomatize.mli --- add axioms in a sequent + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Property +open Expr.T + +open N_smb + +(** This module implements Axiomatization, the process by which every + `Opaque s` with a {!smb} attached is replaced by a reference (De Bruijn + variable) to a NEW constant declaration. + NOTE Opaques without a {!smb} are not affected. + + Additionally, if a {!smb} has dependencies and axioms implemented by + {!N_data.get_deps}, they are added in the context. + + The layout of the new sequent follows this convention: + NEW declarations, NEW axioms, original hyps' |- original goal' +*) + + +(* {3 Extended context} *) + +(** Extended context; used to store symbols and axioms data in an + intermediary form *) +type ecx + +(** The initial context may contain some mandatory new declarations *) +val init_ecx : ecx + + +(* {3 Main} *) + +(** Collect relevant symbols and axioms *) +val collect : solver:string -> disable_arithmetic:bool -> smt_set_extensionality:bool -> ecx -> sequent -> ecx + +(** Assemble a sequent with an extended context *) +val assemble : solver:string -> disable_arithmetic:bool -> smt_set_extensionality:bool -> ecx -> sequent -> sequent + +(** Combine collect and assemble + @param solver the target backend. + @param disable_arithmetic set to true to disregard native support for arithmetic + @param smt_set_extensionality set to true to use special SMT axioms for set extensionality +*) +val main : solver:string -> disable_arithmetic:bool -> smt_set_extensionality:bool -> sequent -> sequent +(** If a backend is given, the operators of TLA+ that correspond to builtins + of that backend are untouched. + Available backends: + - SMT +*) + diff --git a/src/encode/n_axiomatize.mlt b/src/encode/n_axiomatize.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_axiomatize.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_axioms.ml b/src/encode/n_axioms.ml new file mode 100644 index 00000000..5ff8a060 --- /dev/null +++ b/src/encode/n_axioms.ml @@ -0,0 +1,5034 @@ +(* + * encode/axioms.ml --- axioms for TLA+ symbols + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Ext +open Property +open Expr.T +open Type.T + +open N_smb + +module B = Builtin +module T = N_table + + +(* {3 Helpers} *) + +let error ?at mssg = + let mssg = "Encode.Axioms: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + +let t_idv = TAtm TAIdv +let t_bol = TAtm TABol +let t_int = TAtm TAInt +let t_str = TAtm TAStr + +let maybe_assign prop = + Option.fold (fun x -> assign x prop) + +let app ?tys op es = + let op = maybe_assign Props.tpars_prop op tys in + (* `app op []` is `Apply(op, [])` so that properties of op are not lost *) + Apply (op, es) + +let appb ?tys b es = + app ?tys (Internal b %% []) es + +let apps tla_smb es = + let smb = mk_smb tla_smb in + let opq = Opaque (get_name smb) %% [] in + let opq = assign opq smb_prop smb in + app opq es + +let quant q xs ty0s ?pats e = + if xs <> [] then + let xs = + List.map2 begin fun x ty0 -> + (assign (x %% []) Props.ty0_prop ty0, Constant, No_domain) + end xs ty0s + in + let e = maybe_assign pattern_prop e pats in + Quant (q, xs, e) + else + e.core + +let lam xs ty0s e = + let xs = + List.map2 begin fun x ty0 -> + (assign (x %% []) Props.ty0_prop ty0, Shape_expr) + end xs ty0s + in + Lambda (xs, e) + +let dupl a n = List.init n (fun _ -> a) + +let gen x n = List.init n (fun i -> x ^ string_of_int (i + 1)) +(** [gen "x" n] = [ "x1" ; .. ; "xn" ] *) + +let ixi ?(shift=0) n = List.init n (fun i -> Ix (shift + n - i) %% []) +(** [ixi n] = [ Ix n ; .. ; Ix 2 ; Ix 1 ] + [ixi ~shift:s n] = [ Ix (s+n) ; .. ; Ix (s+2) ; Ix (s+1) ] +*) + +let fresh x ty1 = + let shp = + match ty1 with + | Ty1 ([], _) -> Shape_expr + | Ty1 (ty0s, _) -> Shape_op (List.length ty0s) + in + let v = assign (x %% []) Props.ty2_prop (upcast_ty2 ty1) in + Fresh (v, shp, Constant, Unbounded) + +let seq xs ty1s e = + let hs = List.map2 fresh xs ty1s in + let hs = List.map noprops hs in + Sequent { context = Deque.of_list hs ; active = e } + + +(* {3 Main} *) + +(* {4 Special} *) + +let cast_inj ty0 = + match ty0 with + | TAtm TABol -> + appb B.Conj + [ appb ~tys:[ t_idv ] B.Eq + [ apps (T.Cast t_bol) + [ appb B.TRUE [] %% [] + ] %% [] + ; apps (T.True t_idv) [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Neq + [ apps (T.Cast t_bol) + [ appb B.FALSE [] %% [] + ] %% [] + ; apps (T.True t_idv) [] %% [] + ] %% [] + ] %% [] + + | _ -> + quant Forall + [ "x" ; "y" ] [ ty0 ; ty0 ] + ~pats:[ [ + appb ~tys:[ t_idv ] B.Eq + [ apps (T.Cast ty0) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb ~tys:[ t_idv ] B.Eq + [ apps (T.Cast ty0) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ ty0 ] B.Eq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let cast_inj_alt ty0 = + match ty0 with + | TAtm TABol -> + appb B.Conj + [ appb ~tys:[ t_idv ] B.Eq + [ apps (T.Cast t_bol) + [ appb B.TRUE [] %% [] + ] %% [] + ; apps (T.True t_idv) [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Neq + [ apps (T.Cast t_bol) + [ appb B.FALSE [] %% [] + ] %% [] + ; apps (T.True t_idv) [] %% [] + ] %% [] + ] %% [] + + | _ -> + quant Forall + [ "x" ] [ ty0 ] + ~pats:[ [ + apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ] ] + ( appb ~tys:[ ty0 ] B.Eq + [ Ix 1 %% [] + ; apps (T.Proj ty0) + [ apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let type_guard ty0 = + quant Forall + [ "x" ] [ t_idv ] + ( appb B.Equiv + [ begin match ty0 with + | TAtm TAIdv -> + appb B.TRUE [] %% [] + | TAtm TABol -> + apps T.Mem + [ Ix 1 %% [] + ; apps T.BoolSet [] %% [] + ] %% [] + | TAtm TAInt -> + apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + | TAtm TAStr -> + apps T.Mem + [ Ix 1 %% [] + ; apps T.StrSet [] %% [] + ] %% [] + | _ -> error "Not implemented" + end + ; quant Exists + [ "y" ] [ ty0 ] + ( appb ~tys:[ t_idv ] B.Eq + [ Ix 2 %% [] + ; apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + ] %% [] + ) %% [] + +let type_guard_intro ty0 = + quant Forall + [ "z" ] [ ty0 ] + ~pats:[ [ + apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ] ] + ( begin match ty0 with + | TAtm TAIdv -> + appb B.TRUE [] %% [] + | TAtm TABol -> + apps T.Mem + [ apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ; apps T.BoolSet [] %% [] + ] %% [] + | TAtm TAInt -> + apps T.Mem + [ apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ; apps T.IntSet [] %% [] + ] %% [] + | TAtm TAStr -> + apps T.Mem + [ apps (T.Cast ty0) + [ Ix 1 %% [] + ] %% [] + ; apps T.StrSet [] %% [] + ] %% [] + | _ -> error "Not implemented" + end + ) %% [] + +let type_guard_elim ty0 = + let p = + match ty0 with + | TAtm TAIdv -> + appb B.TRUE [] %% [] + | TAtm TABol -> + apps T.Mem + [ Ix 1 %% [] + ; apps T.BoolSet [] %% [] + ] %% [] + | TAtm TAInt -> + apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + | TAtm TAStr -> + apps T.Mem + [ Ix 1 %% [] + ; apps T.StrSet [] %% [] + ] %% [] + | _ -> error "Not implemented" + in + quant Forall + [ "x" ] [ t_idv ] + ~pats:[ [ + p + ] ] + ( appb B.Implies + [ p + ; if ty0 = TAtm TABol then + appb B.Disj + [ appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; apps (T.Cast ty0) + [ appb B.TRUE [] %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; apps (T.Cast ty0) + [ appb B.FALSE [] %% [] + ] %% [] + ] %% [] + ] %% [] + else + appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; apps (T.Cast ty0) + [ apps (T.Proj ty0) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let op_intquotient_typing () = + quant Forall + [ "x" ; "y" ] [ t_int ; t_int ] + ~pats:[ [ + apps T.IntQuotient + [ apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.TIntGt + [ Ix 1 %% [] + ; apps (T.TIntLit 0) [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.IntQuotient + [ apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps (T.Cast t_int) + [ apps T.TIntQuotient + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let op_intremainder_typing () = + quant Forall + [ "x" ; "y" ] [ t_int ; t_int ] + ~pats:[ [ + apps T.IntRemainder + [ apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.TIntGt + [ Ix 1 %% [] + ; apps (T.TIntLit 0) [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.IntRemainder + [ apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps (T.Cast t_int) + [ apps T.TIntRemainder + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let op_typing t_smb = + match t_smb with + | T.TIntQuotient -> op_intquotient_typing () + | T.TIntRemainder -> op_intremainder_typing () + | _ -> begin + + let t_dat = N_data.get_data t_smb in + let i_smb = Option.get (t_dat.dat_tver) in + let i_dat = N_data.get_data i_smb in + + let i_ty2 = i_dat.dat_ty2 in + let t_ty2 = t_dat.dat_ty2 in + + (* It is assumed that i_ty2 is obtained from t_ty2 by replacing every sort + * other than Bool with Idv, and possibly some occurrences of Bool with Idv + * (but not necessarily all). *) + (* TODO: Support second-order shapes *) + + let Ty1 (_, i_ty0) = + try downcast_ty1 i_ty2 + with _ -> error "Not implemented" + in + let Ty1 (t_ty0s, t_ty0) = + try downcast_ty1 t_ty2 + with _ -> error "Not implemented" + in + + let cast ty_from e = + if ty_from = t_idv then e + else apps (T.Cast ty_from) [ e ] %% [] + in + let proj ty_from e = + if ty_from = t_bol then e + else + appb ~tys:[ ty_from ] B.Eq + [ e + ; apps (T.True ty_from) [] %% [] + ] %% [] + in + + let n = List.length t_ty0s in + let is_pred = (t_ty0 = t_bol) in + + quant Forall + (gen "x" n) t_ty0s + ~pats:[ [ + apps i_smb + (List.map2 begin fun e ty0 -> + cast ty0 e + end (ixi n) t_ty0s) %% [] + ] ] + ( begin + if is_pred then appb B.Equiv + else appb ~tys:[ t_idv ] B.Eq + end + [ apps i_smb + (List.map2 cast t_ty0s (ixi n)) %% [] |> + begin + if is_pred then proj i_ty0 + else fun e -> e + end + ; apps t_smb + (ixi n) %% [] |> + begin + if is_pred then fun e -> e + else cast t_ty0 + end + ] %% [] + ) %% [] + + end + +let exttrigeq_def ty0 = + let actual_ty = + match ty0 with + | TAtm (TAInt | TABol) -> ty0 + | _ -> t_idv + in + quant Forall + [ "x" ; "y" ] [ actual_ty ; actual_ty ] + ~pats:[ [ + apps (T.ExtTrigEq ty0) + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps (T.ExtTrigEq ty0) + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; appb ~tys:[ actual_ty ] B.Eq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let exttrigeq_trigger ty0 = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps (T.ExtTrigEq (TSet ty0)) + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( apps T.ExtTrig + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ) %% [] + +let disjoint_trigger () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Cap + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( apps T.ExtTrig + [ apps T.Cap + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps (T.SetEnum 0) [] %% [] + ] %% [] + ) %% [] + +let emptycomprehension_trigger () = + seq + [ "P" ] [ Ty1 ([ t_idv ], t_bol) ] + ( quant Forall + [ "a" ] [ t_idv ] + ~pats:[ [ + apps T.SetSt + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + ( apps T.ExtTrig + [ apps T.SetSt + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps (T.SetEnum 0) [] %% [] + ] %% [] + ) %% [] + ) %% [] + +let assert_issetof n = + seq [ "P" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + [ "a" ] [ t_idv ] + ~pats:[ [ + apps (T.SetOf n) + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + ( apps T.IsSetOf + [ apps (T.SetOf n) + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let compare_setof_trigger () = + quant Forall + [ "a" ; "b" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IsSetOf + [ Ix 2 %% [] + ] %% [] + ; apps T.IsSetOf + [ Ix 1 %% [] + ] %% [] + ] ] + ( apps T.ExtTrig + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ) %% [] + +let exttrigeq_card () = + Internal B.TRUE %% [] + + +(* {4 Logic} *) + +let choose_def () = + seq + [ "P" ] + [ Ty1 ([ t_idv ], t_bol) ] + ( quant Forall + [ "x" ] [ t_idv ] + ( appb B.Implies + [ app (Ix 2 %% []) + [ Ix 1 %% [] + ] %% [] + ; app (Ix 2 %% []) + [ apps T.Choose + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let choose_ext () = + seq + [ "P" ; "Q" ] + (dupl (Ty1 ([ t_idv ], t_bol)) 2) + ( appb B.Implies + [ quant Forall + [ "x" ] [ t_idv ] + ( appb B.Equiv + [ app (Ix 3 %% []) + [ Ix 1 %% [] + ] %% [] + ; app (Ix 2 %% []) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.Choose + [ Ix 2 %% [] + ] %% [] + ; apps T.Choose + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + + +(* {4 Sets} *) + +let set_ext ~smt_set_extensionality = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ?pats:(if smt_set_extensionality then Some [ [ + apps T.ExtTrig + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + else None) + ( appb B.Implies + [ quant Forall + [ "z" ] [ t_idv ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let subseteq_def () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.SubsetEq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.SubsetEq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; quant Forall + [ "z" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + ] %% [] + ) %% [] + +let subseteq_intro () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.SubsetEq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ quant Forall + [ "z" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + ; apps T.SubsetEq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let subseteq_elim () = + quant Forall + [ "x" ; "y" ; "z" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.SubsetEq + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.SubsetEq + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + +let subseteq_antisym () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.SubsetEq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.SubsetEq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.SubsetEq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let setenum_def n = + quant Forall + (gen "a" n @ [ "x" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetEnum n) + (ixi ~shift:1 n) %% [] + ] %% [] + ] ] + begin if (n = 0) then + appb B.Neg + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetEnum 0) [] %% [] + ] %% [] + ] %% [] + else + appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetEnum n) + (ixi ~shift:1 n) %% [] + ] %% [] + ; List.init n begin fun i -> + appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; Ix (n-i+1) %% [] + ] %% [] + end |> + function + | [e] -> e + | es -> List (Or, es) %% [] + ] %% [] + end %% [] + +let setenum_intro n = + begin if (n = 0) then + Internal B.TRUE %% [] + else + quant Forall + (gen "a" n) (dupl t_idv n) + ~pats:[ [ + apps (T.SetEnum n) + (ixi n) %% [] + ] ] + begin + List.init n begin fun i -> + apps T.Mem + [ Ix (n - i) %% [] + ; apps (T.SetEnum n) + (ixi n) %% [] + ] %% [] + end |> + function + | [e] -> e + | es -> List (And, es) %% [] + end %% [] + end + +let setenum_elim n = + quant Forall + (gen "a" n @ [ "x" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetEnum n) + (ixi ~shift:1 n) %% [] + ] %% [] + ] ] + begin if (n = 0) then + appb B.Neg + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetEnum 0) [] %% [] + ] %% [] + ] %% [] + else + appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetEnum n) + (ixi ~shift:1 n) %% [] + ] %% [] + ; List.init n begin fun i -> + appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; Ix (n-i+1) %% [] + ] %% [] + end |> + function + | [e] -> e + | es -> List (Or, es) %% [] + ] %% [] + end %% [] + +let union_def () = + quant Forall + [ "a" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.Union + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.Union + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; quant Exists + [ "y" ] [ t_idv ] + ( appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + ] %% [] + ) %% [] + +let union_intro () = + quant Forall + [ "a" ; "x" ; "y" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; apps T.Union + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; apps T.Union + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.Union + [ Ix 3 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; apps T.Union + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let union_elim () = + quant Forall + [ "a" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.Union + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.Union + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; quant Exists + [ "y" ] [ t_idv ] + ( appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + ] %% [] + ) %% [] + +let subset_def () = + quant Forall + [ "a" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.Subset + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.Subset + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; quant Forall + [ "y" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + ] %% [] + ) %% [] + +let subset_def_alt () = + quant Forall + [ "a" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.Subset + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.SubsetEq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Subset + [ Ix 2 %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.Subset + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps T.SubsetEq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + +let subset_intro () = + quant Forall + [ "a" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.Subset + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ quant Forall + [ "y" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.Subset + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let subset_elim () = + quant Forall + [ "a" ; "x" ; "y" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 2 %% [] + ; apps T.Subset + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 2 %% [] + ; apps T.Subset + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.Subset + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + +let cup_def () = + quant Forall + [ "a" ; "b" ; "x" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.Cup + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Cup + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Cup + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.Cup + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; appb B.Disj + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let cap_def () = + quant Forall + [ "a" ; "b" ; "x" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.Cap + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Cap + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Cap + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.Cap + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let setminus_def () = + quant Forall + [ "a" ; "b" ; "x" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.SetMinus + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.SetMinus + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.SetMinus + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.SetMinus + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; appb B.Neg + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let setst_def () = + seq + [ "P" ] + [ Ty1 ([ t_idv ], t_bol) ] + ( quant Forall + [ "a" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.SetSt + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.SetSt + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.SetSt + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ; appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; app (Ix 3 %% []) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let setof_def n = + seq + [ "F" ] + [ Ty1 (dupl t_idv n, t_idv) ] + ( quant Forall + (gen "a" n @ [ "x" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetOf n) + (List.init n begin fun i -> + Ix (n-i+1) %% [] + end @ + [ Ix (n+2) %% [] + ]) %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetOf n) + (List.init n begin fun i -> + Ix (n-i+1) %% [] + end @ + [ Ix (n+2) %% [] + ]) %% [] + ] %% [] + ; quant Exists + (gen "y" n) (dupl t_idv n) + ( List (And, + List.init n begin fun i -> + apps T.Mem + [ Ix (n-i) %% [] + ; Ix (2*n-i+1) %% [] + ] %% [] + end @ + [ appb ~tys:[ t_idv ] B.Eq + [ Ix (n+1) %% [] + ; app (Ix (2*n+2) %% []) + (ixi n) %% [] + ] %% [] + ] + ) %% [] + ) %% [] + ] %% [] + ) %% [] + ) %% [] + +let setof_intro n = + seq + [ "F" ] + [ Ty1 (dupl t_idv n, t_idv) ] + ( quant Forall + (gen "a" n @ gen "y" n) (dupl t_idv (n+n)) + ~pats:[ [ + app (Ix (n+n+1) %% []) + (ixi n) %% [] + ; apps (T.SetOf n) + (ixi ~shift:n n @ + [ Ix (n+n+1) %% [] + ]) %% [] + ] ; [ + apps (T.SetOf n) + (ixi ~shift:n n @ + [ Ix (n+n+1) %% [] + ]) %% [] + ] @ List.init n begin fun i -> + apps T.Mem + [ Ix (n-i) %% [] + ; Ix (n+n-i) %% [] + ] %% [] + end ] + ( appb B.Implies + [ List (And, + List.init n begin fun i -> + apps T.Mem + [ Ix (n-i) %% [] + ; Ix (n+n-i) %% [] + ] %% [] + end + ) %% [] + ; apps T.Mem + [ app (Ix (2*n+1) %% []) + (ixi n) %% [] + ; apps (T.SetOf n) + (ixi ~shift:n n @ + [ Ix (n+n+1) %% [] + ]) %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let setof_elim n = + seq + [ "F" ] + [ Ty1 (dupl t_idv n, t_idv) ] + ( quant Forall + (gen "a" n @ [ "x" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetOf n) + (ixi ~shift:1 n @ + [ Ix (n+2) %% [] + ]) %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.SetOf n) + (ixi ~shift:1 n @ + [ Ix (n+2) %% [] + ]) %% [] + ] %% [] + ; quant Exists + (gen "y" n) (dupl t_idv n) + ( List (And, + List.init n begin fun i -> + apps T.Mem + [ Ix (n-i) %% [] + ; Ix (n+n-i+1) %% [] + ] %% [] + end @ + [ appb ~tys:[ t_idv ] B.Eq + [ Ix (n+1) %% [] + ; app (Ix (n+n+2) %% []) + (ixi n) %% [] + ] %% [] + ] + ) %% [] + ) %% [] + ] %% [] + ) %% [] + ) %% [] + + +(* {4 Functions} *) + +let fcn_ext () = + quant Forall + [ "f" ; "g" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.FunIsafcn + [ Ix 2 %% [] + ] %% [] + ; apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.FunIsafcn + [ Ix 2 %% [] + ] %% [] + ; apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ Ix 2 %% [] + ] %% [] + ; apps T.FunDom + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; quant Forall + [ "x" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunDom + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.FunApp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnconstr_isafcn () = + seq + [ "F" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + ~pats:[ [ + apps T.FunConstr + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + [ "a" ] [ t_idv ] + ( apps T.FunIsafcn + [ apps T.FunConstr + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let fcnset_def () = + quant Forall + [ "a" ; "b" ; "f" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; List (And, + [ apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ; quant Forall + [ "x" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 4 %% [] + ] %% [] + ; apps T.Mem + [ apps T.FunApp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + ]) %% [] + ] %% [] + ) %% [] + +let fcnset_intro () = + quant Forall + [ "a" ; "b" ; "f" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ; quant Forall + [ "x" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 4 %% [] + ] %% [] + ; apps T.Mem + [ apps T.FunApp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + ]) %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnset_elim1 () = + quant Forall + [ "a" ; "b" ; "f" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; appb B.Conj + [ apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnset_elim2 () = + quant Forall + [ "a" ; "b" ; "f" ; "x" ] [ t_idv ; t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 2 %% [] + ; apps T.FunSet + [ Ix 4 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 4 %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 2 %% [] + ; apps T.FunSet + [ Ix 4 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.FunApp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.FunSet + [ Ix 4 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 4 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.FunApp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnsetim_intro () = + quant Forall + [ "f" ] [ t_idv ] + ~pats:[ [ + apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.FunSet + [ apps T.FunDom + [ Ix 1 %% [] + ] %% [] + ; apps T.FunIm + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnset_subs () = + quant Forall + [ "a" ; "b" ; "c" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.SubsetEq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.SubsetEq + [ apps T.FunSet + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.FunSet + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcndom_def () = + seq + [ "F" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + [ "a" ] [ t_idv ] + ~pats:[ [ + apps T.FunConstr + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ apps T.FunConstr + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ) %% [] + ) %% [] + +let fcnapp_def () = + seq + [ "F" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + [ "a" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.FunApp + [ apps T.FunConstr + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.FunConstr + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.FunConstr + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ; app (Ix 3 %% []) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let fcnconstr_typing () = + seq + [ "F" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + [ "a" ; "b" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.FunConstr + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.FunSet + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ quant Forall + [ "x" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ app (Ix 4 %% []) + [ Ix 1 %% [] + ] %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + ; apps T.Mem + [ apps T.FunConstr + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.FunSet + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let fcnexcept_isafcn () = + quant Forall + [ "f" ; "x" ; "y" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.FunExcept + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( apps T.FunIsafcn + [ apps T.FunExcept + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnexceptdom_def () = + quant Forall + [ "f" ; "x" ; "y" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.FunExcept + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ apps T.FunExcept + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.FunDom + [ Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnexceptapp1_def () = + quant Forall + [ "f" ; "x" ; "y" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.FunExcept + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.FunDom + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.FunExcept + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 2 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnexceptapp2_def () = + quant Forall + [ "f" ; "x" ; "y" ; "z" ] [ t_idv ; t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.FunApp + [ apps T.FunExcept + [ Ix 4 %% [] + ; Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] ; [ + apps T.FunExcept + [ Ix 4 %% [] + ; Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.FunApp + [ Ix 4 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunDom + [ Ix 4 %% [] + ] %% [] + ] %% [] + ; appb B.Conj + [ appb B.Implies + [ appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.FunExcept + [ Ix 4 %% [] + ; Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; appb B.Implies + [ appb ~tys:[ t_idv ] B.Neq + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.FunExcept + [ Ix 4 %% [] + ; Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.FunApp + [ Ix 4 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnexcept_typing () = + quant Forall + [ "f" ; "x" ; "y" ; "a" ; "b" ] [ t_idv ; t_idv ; t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.FunExcept + [ Ix 5 %% [] + ; Ix 4 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.Mem + [ Ix 5 %% [] + ; apps T.FunSet + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 5 %% [] + ; apps T.FunSet + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; appb B.Implies + [ apps T.Mem + [ Ix 4 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.Mem + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.FunExcept + [ Ix 5 %% [] + ; Ix 4 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.FunSet + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnim_def () = + quant Forall + [ "f" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.FunIm + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunIm + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; quant Exists + [ "y" ] [ t_idv ] + ( appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunDom + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ Ix 2 %% [] + ; apps T.FunApp + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ] %% [] + ) %% [] + +let fcnim_intro () = + quant Forall + [ "f" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.FunApp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( apps T.Mem + [ apps T.FunApp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.FunIm + [ Ix 2 %% [] + ] %% [] + ] %% [] + ) %% [] + +let fcnim_elim () = + quant Forall + [ "f" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.FunIm + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunIm + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; quant Exists + [ "y" ] [ t_idv ] + ( appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunDom + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ Ix 2 %% [] + ; apps T.FunApp + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ] %% [] + ) %% [] + + +(* {4 Strings} *) + +let strlit_isstr s = + apps T.Mem + [ apps (T.StrLit s) [] %% [] + ; apps T.StrSet [] %% [] + ] %% [] + +let strlit_distinct s1 s2 = + appb ~tys:[ t_idv ] B.Neq + [ apps (T.StrLit s1) [] %% [] + ; apps (T.StrLit s2) [] %% [] + ] %% [] + + +(* {4 Arithmetic} *) + +let natset_def ~disable_arithmetic = + quant Forall + [ "x" ] [ t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; appb B.Conj + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ begin + if disable_arithmetic then + apps (T.IntLit 0) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit 0) [] %% [] + ] %% [] + end + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +(* NOTE According to Specifying Systems, the definition is: + * a..b == { i \in Int : a <= i /\ i <= b } + * By this definition it is not required that a, b \in Int + *) +let intrange_def () = + quant Forall + [ "a" ; "b" ; "x" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.IntRange + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntRange + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; List (And, + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ]) %% [] + ] %% [] + ) %% [] + +let intlit_isint n = + apps T.Mem + [ apps (T.IntLit n) [] %% [] + ; apps T.IntSet [] %% [] + ] %% [] + +let intlit_distinct m n = + appb ~tys:[ t_idv ] B.Neq + [ apps (T.IntLit m) [] %% [] + ; apps (T.IntLit n) [] %% [] + ] %% [] + +let intlit_zerocmp n = + if n <= 0 then + apps T.IntLteq + [ apps (T.IntLit n) [] %% [] + ; apps (T.IntLit 0) [] %% [] + ] %% [] + else + apps T.IntLteq + [ apps (T.IntLit 0) [] %% [] + ; apps (T.IntLit n) [] %% [] + ] %% [] + +let intplus_typing () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntPlus + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.IntPlus + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let intuminus_typing () = + quant Forall + [ "x" ] [ t_idv ] + ~pats:[ [ + apps T.IntUminus + [ Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ apps T.IntUminus + [ Ix 1 %% [] + ] %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let intminus_typing () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntMinus + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.IntMinus + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let inttimes_typing () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntTimes + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.IntTimes + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let intexp_typing ~disable_arithmetic = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntExp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; begin + if disable_arithmetic then + appb B.Disj + [ appb ~tys:[ t_idv ] B.Neq + [ Ix 2 %% [] + ; apps (T.IntLit 0) [] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + else + appb B.Disj + [ appb ~tys:[ t_idv ] B.Neq + [ Ix 2 %% [] + ; apps (T.Cast t_int) + [ apps (T.TIntLit 0) [] %% [] + ] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.Cast t_int) + [ apps (T.TIntLit 1) [] %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + end + ]) %% [] + ; apps T.Mem + [ apps T.IntExp + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let intquotient_typing () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntQuotient + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 0) [] %% [] + ; Ix 1 %% [] + ] %% [] + ]) %% [] + ; apps T.Mem + [ apps T.IntQuotient + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let intremainder_typing () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntRemainder + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 0) [] %% [] + ; Ix 1 %% [] + ] %% [] + ]) %% [] + ; apps T.Mem + [ apps T.IntRemainder + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntRange + [ apps (T.IntLit 0) [] %% [] + ; apps T.IntMinus + [ Ix 1 %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let natplus_typing () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntPlus + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.IntPlus + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let nattimes_typing () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.IntTimes + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.IntTimes + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] %% [] + ) %% [] + +let nonneg_ispos () = + quant Forall + [ "x" ] [ t_idv ] + ~pats:[ [ + apps T.IntLteq + [ apps (T.IntLit 0) [] %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.IntLteq + [ apps (T.IntLit 0) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Neq + [ apps (T.IntLit 0) [] %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let lteq_reflexive () = + quant Forall + [ "x" ] [ t_idv ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let lteq_transitive () = + quant Forall + [ "x" ; "y" ; "z" ] [ t_idv ; t_idv ; t_idv ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 3 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ]) %% [] + ; apps T.IntLteq + [ Ix 3 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let lteq_antisym () = + quant Forall + [ "x" ; "y" ] [ t_idv ; t_idv ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + + +(* {4 Tuples} *) + +let tuple_isafcn n = + if n = 0 then + apps T.FunIsafcn + [ apps (T.Tuple 0) [] %% [] + ] %% [] + else + quant Forall + (gen "x" n) (dupl t_idv n) + ~pats:[ [ + apps (T.Tuple n) + (ixi n) %% [] + ] ] + ( apps T.FunIsafcn + [ apps (T.Tuple n) + (ixi n) %% [] + ] %% [] + ) %% [] + +let tupdom_def ~disable_arithmetic n = + quant Forall + (gen "x" n) (dupl t_idv n) + ~pats:[ [ + apps (T.Tuple n) + (ixi n) %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ apps (T.Tuple n) + (ixi n) %% [] + ] %% [] + ; apps (T.SetEnum n) + (List.init n begin fun i -> + if disable_arithmetic then + apps (T.IntLit (i + 1)) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit (i + 1)) [] %% [] + ] %% [] + end) %% [] + ] %% [] + ) %% [] + +let tupapp_def ~disable_arithmetic n = + quant Forall + (gen "x" n) (dupl t_idv n) + ~pats:[ [ + apps (T.Tuple n) + (ixi n) %% [] + ] ] + ( List ( + And, + List.init n begin fun i -> + appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps (T.Tuple n) + (ixi n) %% [] + ; begin + if disable_arithmetic then + apps (T.IntLit (i + 1)) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit (i + 1)) [] %% [] + ] %% [] + end + ] %% [] + ; Ix (n - i) %% [] + ] %% [] + end + ) %% [] + ) %% [] + +let tupexcept_def ~disable_arithmetic n i = + quant Forall + (gen "x" n @ [ "x" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.FunExcept + [ apps (T.Tuple n) + (ixi ~shift:1 n) %% [] + ; begin + if disable_arithmetic then + apps (T.IntLit (i + 1)) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit (i + 1)) [] %% [] + ] %% [] + end + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.FunExcept + [ apps (T.Tuple n) + (ixi ~shift:1 n) %% [] + ; begin + if disable_arithmetic then + apps (T.IntLit (i + 1)) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit (i + 1)) [] %% [] + ] %% [] + end + ; Ix 1 %% [] + ] %% [] + ; apps (T.Tuple n) + (ixi ~shift:(n-i+2) (i-1) @ [ Ix 1 %% [] ] @ ixi ~shift:1 (n-i)) %% [] + ] %% [] + ) %% [] + +let productset_def n = + quant Forall + (gen "s" n @ [ "t" ]) (dupl t_idv (n + 1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.Product n) + (ixi ~shift:1 n) %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.Product n) + (ixi ~shift:1 n) %% [] + ] %% [] + ; quant Exists + (gen "x" n) (dupl t_idv n) + ( List (And, + [ appb ~tys:[ t_idv ] B.Eq + [ Ix (n + 1) %% [] + ; apps (T.Tuple n) + (ixi n) %% [] + ] %% [] + ] @ + List.init n begin fun i -> + apps T.Mem + [ Ix (n - i) %% [] + ; Ix (2*n - i + 1) %% [] + ] %% [] + end) %% [] + ) %% [] + ] %% [] + ) %% [] + +let productset_intro n = + quant Forall + (gen "s" n @ gen "x" n) (dupl t_idv (2 * n)) + ~pats:[ [ + apps (T.Tuple n) + (ixi n) %% [] + ; apps (T.Product n) + (ixi ~shift:n n) %% [] + ] ] + ( appb B.Implies + [ List (And, + List.init n begin fun i -> + apps T.Mem + [ Ix (n - i) %% [] + ; Ix (2*n - i) %% [] + ] %% [] + end) %% [] + ; apps T.Mem + [ apps (T.Tuple n) + (ixi n) %% [] + ; apps (T.Product n) + (ixi ~shift:n n) %% [] + ] %% [] + ] %% [] + ) %% [] + +let productset_elim ~disable_arithmetic n = + quant Forall + (gen "s" n @ [ "t" ]) (dupl t_idv (n + 1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.Product n) + (ixi ~shift:1 n) %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.Product n) + (ixi ~shift:1 n) %% [] + ] %% [] + ; List (And, + [ appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; apps (T.Tuple n) + (List.init n begin fun i -> + apps T.FunApp + [ Ix 1 %% [] + ; begin + if disable_arithmetic then + apps (T.IntLit (i + 1)) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit (i + 1)) [] %% [] + ] %% [] + end + ] %% [] + end) %% [] + ] %% [] + ] @ + List.init n begin fun i -> + apps T.Mem + [ apps T.FunApp + [ Ix 1 %% [] + ; begin + if disable_arithmetic then + apps (T.IntLit (i + 1)) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit (i + 1)) [] %% [] + ] %% [] + end + ] %% [] + ; Ix (n - i + 1) %% [] + ] %% [] + end) %% [] + ] %% [] + ) %% [] + + +(* {4 Records} *) + +let record_isafcn fs = + let n = List.length fs in + quant Forall + (gen "x" n) (dupl t_idv n) + ~pats:[ [ + apps (T.Rec fs) + (ixi n) %% [] + ] ] + ( apps T.FunIsafcn + [ apps (T.Rec fs) + (ixi n) %% [] + ] %% [] + ) %% [] + +let recdom_def fs = + let n = List.length fs in + quant Forall + (gen "x" n) (dupl t_idv n) + ~pats:[ [ + apps (T.Rec fs) + (ixi n) %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ apps (T.Rec fs) + (ixi n) %% [] + ] %% [] + ; apps (T.SetEnum n) + (List.map begin fun s -> + apps (T.StrLit s) [] %% [] + end fs) %% [] + ] %% [] + ) %% [] + +let recapp_def fs = + let n = List.length fs in + quant Forall + (gen "x" n) (dupl t_idv n) + ~pats:[ [ + apps (T.Rec fs) + (ixi n) %% [] + ] ] + ( List (And, + List.mapi begin fun i s -> + appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps (T.Rec fs) + (ixi n) %% [] + ; apps (T.StrLit s) [] %% [] + ] %% [] + ; Ix (n - i) %% [] + ] %% [] + end fs) %% [] + ) %% [] + +let recexcept_def fs i = + let n = List.length fs in + let s = List.nth fs (i-1) in + quant Forall + (gen "x" n @ [ "x" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.FunExcept + [ apps (T.Rec fs) + (ixi ~shift:1 n) %% [] + ; apps (T.StrLit s) [] %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.FunExcept + [ apps (T.Rec fs) + (ixi ~shift:1 n) %% [] + ; apps (T.StrLit s) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps (T.Rec fs) + (ixi ~shift:(n-i+2) (i-1) @ [ Ix 1 %% [] ] @ ixi ~shift:1 (n-i)) %% [] + ] %% [] + ) %% [] + +let recset_def fs = + let n = List.length fs in + quant Forall + (gen "s" n @ [ "r" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.RecSet fs) + (ixi ~shift:1 n) %% [] + ] %% [] + ] ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.RecSet fs) + (ixi ~shift:1 n) %% [] + ] %% [] + ; quant Exists + (gen "x" n) (dupl t_idv n) + ( List (And, + [ appb ~tys:[ t_idv ] B.Eq + [ Ix (n + 1) %% [] + ; apps (T.Rec fs) + (ixi n) %% [] + ] %% [] + ] @ + List.mapi begin fun i s -> + apps T.Mem + [ Ix (n - i) %% [] + ; Ix (2*n + 1 - i) %% [] + ] %% [] + end fs) %% [] + ) %% [] + ] %% [] + ) %% [] + +let recset_intro fs = + let n = List.length fs in + quant Forall + (gen "s" n @ gen "x" n) (dupl t_idv (2*n)) + ~pats:[ [ + apps (T.Rec fs) + (ixi n) %% [] + ; apps (T.RecSet fs) + (ixi ~shift:n n) %% [] + ] ] + ( appb B.Implies + [ List (And, + List.mapi begin fun i s -> + apps T.Mem + [ Ix (n - i) %% [] + ; Ix (2*n - i) %% [] + ] %% [] + end fs) %% [] + ; apps T.Mem + [ apps (T.Rec fs) + (ixi n) %% [] + ; apps (T.RecSet fs) + (ixi ~shift:n n) %% [] + ] %% [] + ] %% [] + ) %% [] + +let recset_elim fs = + let n = List.length fs in + quant Forall + (gen "s" n @ [ "r" ]) (dupl t_idv (n+1)) + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps (T.RecSet fs) + (ixi ~shift:1 n) %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps (T.RecSet fs) + (ixi ~shift:1 n) %% [] + ] %% [] + ; List (And, + [ appb ~tys:[ t_idv ] B.Eq + [ Ix 1 %% [] + ; apps (T.Rec fs) + (List.map begin fun s -> + apps T.FunApp + [ Ix 1 %% [] + ; apps (T.StrLit s) [] %% [] + ] %% [] + end fs) %% [] + ] %% [] + ] @ + List.mapi begin fun i s -> + apps T.Mem + [ apps T.FunApp + [ Ix 1 %% [] + ; apps (T.StrLit s) [] %% [] + ] %% [] + ; Ix (n + 1 - i) %% [] + ] %% [] + end fs) %% [] + ] %% [] + ) %% [] + + +(* {4 Sequences} *) + +let seqset_intro ~disable_arithmetic = + quant Forall + [ "a" ; "s" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ; if disable_arithmetic then + apps T.Mem + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + else + apps T.TIntGteq + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps (T.TIntLit 0) [] %% [] + ] %% [] + ; quant Forall + [ "i" ] [ t_idv ] + ( appb B.Equiv + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunDom + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; List (And, + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + else + apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; apps (T.Proj t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntLteq + [ Ix 1 %% [] + ; apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + else + apps T.TIntLteq + [ apps (T.Proj t_int) + [ Ix 1 %% [] + ] %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ] %% [] + ) %% [] + ; quant Forall + [ "i" ] [ if disable_arithmetic then t_idv else t_int ] + ( appb B.Implies + [ List (And, + begin if disable_arithmetic then + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] + else [] + end @ + [ if disable_arithmetic then + apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + else + apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntLteq + [ Ix 1 %% [] + ; apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + else + apps T.TIntLteq + [ Ix 1 %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ; apps T.Mem + [ apps T.FunApp + [ Ix 2 %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + ]) %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqset_elim1 ~disable_arithmetic = + quant Forall + [ "a" ; "s" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; List (And, + [ apps T.FunIsafcn + [ Ix 1 %% [] + ] %% [] + ; apps T.Mem + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ Ix 1 %% [] + ] %% [] + ; apps T.IntRange + [ if disable_arithmetic then + apps (T.IntLit 1) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit 1) [] %% [] + ] %% [] + ; apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ] %% [] + ) %% [] + +let seqset_elim2 ~disable_arithmetic = + quant Forall + [ "a" ; "s" ; "i" ] [ t_idv ; t_idv ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.Mem + [ Ix 2 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.FunApp + [ Ix 2 %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] @ + if disable_arithmetic then + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] + else + [ apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.TIntLteq + [ Ix 1 %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ; apps T.Mem + [ apps T.FunApp + [ Ix 2 %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqlen_def ~disable_arithmetic = + quant Forall + [ "s" ; "z" ] [ t_idv ; if disable_arithmetic then t_idv else t_int ] + ( appb B.Implies + [ appb B.Conj + [ if disable_arithmetic then + apps T.Mem + [ Ix 1 %% [] + ; apps T.NatSet [] %% [] + ] %% [] + else + apps T.TIntGteq + [ Ix 1 %% [] + ; apps (T.TIntLit 0) [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunDom + [ Ix 2 %% [] + ] %% [] + ; apps T.IntRange + [ if disable_arithmetic then + apps (T.IntLit 1) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit 1) [] %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqcat_typing () = + quant Forall + [ "a" ; "s" ; "t" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 2 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.SeqCat + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ; [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.SeqCat + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.SeqCat + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqcatlen_def ~disable_arithmetic = + quant Forall + [ "s" ; "t" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.SeqCat + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; apps T.Mem + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps T.SeqCat + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntPlus + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + else + apps (T.Cast t_int) + [ apps T.TIntPlus + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqcatapp1_def ~disable_arithmetic = + quant Forall + [ "s" ; "t" ; "i" ] [ t_idv ; t_idv ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.FunApp + [ apps T.SeqCat + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.SeqCat + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.FunApp + [ Ix 3 %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; apps T.Mem + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] @ + if disable_arithmetic then + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] + else + [ apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.TIntLteq + [ Ix 1 %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.SeqCat + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.FunApp + [ Ix 3 %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqcatapp2_def ~disable_arithmetic = + quant Forall + [ "s" ; "t" ; "i" ] [ t_idv ; t_idv ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.FunApp + [ apps T.SeqCat + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; apps T.Mem + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] @ + if disable_arithmetic then + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; apps T.IntPlus + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ; apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ]%% [] + ] %% [] + ; apps T.IntLteq + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Neq + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] + else + [ apps T.TIntLteq + [ Ix 1 %% [] + ; apps T.TIntPlus + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ; apps T.TIntLt + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.SeqCat + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.FunApp + [ Ix 2 %% [] + ; if disable_arithmetic then + apps T.IntMinus + [ Ix 1 %% [] + ; apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + else + apps (T.Cast t_int) + [ apps T.TIntMinus + [ Ix 1 %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqappend_typing () = + quant Forall + [ "a" ; "s" ; "x" ] [ t_idv ; t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 2 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.SeqSeq + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqappendlen_def ~disable_arithmetic = + quant Forall + [ "s" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntPlus + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + else + apps (T.Cast t_int) + [ apps T.TIntPlus + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqappendapp1_def ~disable_arithmetic = + quant Forall + [ "s" ; "x" ; "i" ] [ t_idv ; t_idv ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.FunApp + [ apps T.SeqAppend + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ; [ + apps T.SeqAppend + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; apps T.FunApp + [ Ix 3 %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ] @ + if disable_arithmetic then + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] + else + [ apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.TIntLteq + [ Ix 1 %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.SeqAppend + [ Ix 3 %% [] + ; Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.FunApp + [ Ix 3 %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqappendapp2_def ~disable_arithmetic = + quant Forall + [ "s" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntPlus + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + else + apps (T.Cast t_int) + [ apps T.TIntPlus + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqhead_def ~disable_arithmetic = + quant Forall + [ "s" ] [ t_idv ] + ~pats:[ [ + apps T.SeqHead + [ Ix 1 %% [] + ] %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqHead + [ Ix 1 %% [] + ] %% [] + ; apps T.FunApp + [ Ix 1 %% [] + ; if disable_arithmetic then + apps (T.IntLit 1) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqtail_typing ~disable_arithmetic = + quant Forall + [ "a" ; "s" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps T.SeqTail + [ Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ if disable_arithmetic then t_idv else t_int ] B.Neq + [ if disable_arithmetic then + apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + else + apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + apps (T.IntLit 0) [] %% [] + else + apps (T.TIntLit 0) [] %% [] + ] %% [] + ]) %% [] + ; apps T.Mem + [ apps T.SeqTail + [ Ix 1 %% [] + ] %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqtaillen_def ~disable_arithmetic = + quant Forall + [ "s" ] [ t_idv ] + ~pats:[ [ + apps T.SeqTail + [ Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; appb ~tys:[ if disable_arithmetic then t_idv else t_int ] B.Neq + [ if disable_arithmetic then + apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + else + apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + apps (T.IntLit 0) [] %% [] + else + apps (T.TIntLit 0) [] %% [] + ] %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps T.SeqTail + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntMinus + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + else + apps (T.Cast t_int) + [ apps T.TIntMinus + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqtailapp_def ~disable_arithmetic = + quant Forall + [ "s" ; "i" ] [ t_idv ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.FunApp + [ apps T.SeqTail + [ Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; appb ~tys:[ if disable_arithmetic then t_idv else t_int ] B.Neq + [ if disable_arithmetic then + apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + else + apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + apps (T.IntLit 0) [] %% [] + else + apps (T.TIntLit 0) [] %% [] + ] %% [] + ] @ + if disable_arithmetic then + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.IntLteq + [ Ix 1 %% [] + ; apps T.IntMinus + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + ] %% [] + ] + else + [ apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps T.TIntLteq + [ Ix 1 %% [] + ; apps T.TIntMinus + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.SeqTail + [ Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.FunApp + [ Ix 2 %% [] + ; if disable_arithmetic then + apps T.IntPlus + [ Ix 1 %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + else + apps (T.Cast t_int) + [ apps T.TIntPlus + [ Ix 1 %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqsubseq_typing ~disable_arithmetic = + quant Forall + [ "a" ; "s" ; "x" ; "y" ] [ t_idv ; t_idv ; if disable_arithmetic then t_idv else t_int ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.Mem + [ Ix 3 %% [] + ; apps T.SeqSeq + [ Ix 4 %% [] + ] %% [] + ] %% [] + ; apps T.SeqSubSeq + [ Ix 3 %% [] + ; if disable_arithmetic then + Ix 2 %% [] + else + apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + [ apps T.Mem + [ Ix 3 %% [] + ; apps T.SeqSeq + [ Ix 4 %% [] + ] %% [] + ] %% [] + ] @ + (if disable_arithmetic then + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] + else []) @ + [ if disable_arithmetic then + apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 2 %% [] + ] %% [] + else + apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntLteq + [ Ix 1 %% [] + ; apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + else + apps T.TIntLteq + [ Ix 1 %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ; apps T.Mem + [ apps T.SeqSubSeq + [ Ix 3 %% [] + ; if disable_arithmetic then + Ix 2 %% [] + else + apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.SeqSeq + [ Ix 4 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqsubseqlen_def ~disable_arithmetic = + quant Forall + [ "s" ; "x" ; "y" ] [ t_idv ; if disable_arithmetic then t_idv else t_int ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.SeqSubSeq + [ Ix 3 %% [] + ; if disable_arithmetic then + Ix 2 %% [] + else + apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( if disable_arithmetic then + appb B.Implies + [ appb B.Conj + [ apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] %% [] + ; List (And, + [ appb B.Implies + [ apps T.IntLteq + [ Ix 2 %% [] + ; apps T.IntPlus + [ Ix 1 %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps T.SeqSubSeq + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.IntMinus + [ apps T.IntPlus + [ Ix 1 %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ; appb B.Implies + [ appb B.Neg + [ apps T.IntLteq + [ Ix 2 %% [] + ; apps T.IntPlus + [ Ix 1 %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps T.SeqSubSeq + [ Ix 3 %% [] + ; Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ; apps (T.IntLit 0) [] %% [] + ] %% [] + ] %% [] + ]) %% [] + ] %% [] + else + List (And, + [ appb B.Implies + [ apps T.TIntLteq + [ Ix 2 %% [] + ; apps T.TIntPlus + [ Ix 1 %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps T.SeqSubSeq + [ Ix 3 %% [] + ; apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ; apps (T.Cast t_int) + [ apps T.TIntMinus + [ apps T.TIntPlus + [ Ix 1 %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ; appb B.Implies + [ apps T.TIntGt + [ Ix 2 %% [] + ; apps T.TIntPlus + [ Ix 1 %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps T.SeqSubSeq + [ Ix 3 %% [] + ; apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ; apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ; apps (T.Cast t_int) + [ apps (T.TIntLit 0) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ) %% [] + +let seqsubseqapp_def ~disable_arithmetic = + quant Forall + [ "s" ; "x" ; "y" ; "z" ] [ t_idv ; if disable_arithmetic then t_idv else t_int ; if disable_arithmetic then t_idv else t_int ; if disable_arithmetic then t_idv else t_int ] + ~pats:[ [ + apps T.FunApp + [ apps T.SeqSubSeq + [ Ix 4 %% [] + ; if disable_arithmetic then + Ix 3 %% [] + else + apps (T.Cast t_int) + [ Ix 3 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 2 %% [] + else + apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] ] + ( appb B.Implies + [ List (And, + (if disable_arithmetic then + [ apps T.Mem + [ Ix 3 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 2 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ; apps T.Mem + [ Ix 1 %% [] + ; apps T.IntSet [] %% [] + ] %% [] + ] + else []) @ + [ if disable_arithmetic then + apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 3 %% [] + ] %% [] + else + apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 3 %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntLteq + [ apps (T.IntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + else + apps T.TIntLteq + [ apps (T.TIntLit 1) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntLteq + [ Ix 1 %% [] + ; apps T.IntMinus + [ apps T.IntPlus + [ Ix 2 %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + else + apps T.TIntLteq + [ Ix 1 %% [] + ; apps T.TIntMinus + [ apps T.TIntPlus + [ Ix 2 %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.FunApp + [ apps T.SeqSubSeq + [ Ix 4 %% [] + ; if disable_arithmetic then + Ix 3 %% [] + else + apps (T.Cast t_int) + [ Ix 3 %% [] + ] %% [] + ; if disable_arithmetic then + Ix 2 %% [] + else + apps (T.Cast t_int) + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; if disable_arithmetic then + Ix 1 %% [] + else + apps (T.Cast t_int) + [ Ix 1 %% [] + ] %% [] + ] %% [] + ; apps T.FunApp + [ Ix 4 %% [] + ; if disable_arithmetic then + apps T.IntMinus + [ apps T.IntPlus + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps (T.IntLit 1) [] %% [] + ] %% [] + else + apps (T.Cast t_int) + [ apps T.TIntMinus + [ apps T.TIntPlus + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps (T.TIntLit 1) [] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqselectseq_typing () = + seq + [ "T" ] [ Ty1 ([ t_idv ], t_bol) ] + ( quant Forall + [ "a" ; "s" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps T.SeqSelectSeq + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ; apps T.Mem + [ apps T.SeqSelectSeq + [ Ix 1 %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.SeqSeq + [ Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let seqselectseqlen_def ~disable_arithmetic = + seq + [ "T" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + [ "s" ] [ t_idv ] + ~pats:[ [ + apps T.SeqSelectSeq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ; apps T.NatSet [] %% [] + ] %% [] + ; if disable_arithmetic then + apps T.IntLteq + [ apps T.SeqLen + [ apps T.SeqSelectSeq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ; apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + else + apps T.TIntLteq + [ apps (T.Proj t_int) + [ apps T.SeqLen + [ apps T.SeqSelectSeq + [ Ix 1 %% [] + ; Ix 2 %% [] + ] %% [] + ] %% [] + ] %% [] + ; apps (T.Proj t_int) + [ apps T.SeqLen + [ Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + ) %% [] + +let seqselectseqnil_def () = + seq + [ "T" ] [ Ty1 ([ t_idv ], t_idv) ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqSelectSeq + [ apps (T.Tuple 0) [] %% [] + ; Ix 1 %% [] + ] %% [] + ; apps (T.Tuple 0) [] %% [] + ] %% [] + ) %% [] + +let seqselectseqapp_def () = + seq + [ "T" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + [ "s" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.FunApp + [ apps T.SeqSelectSeq + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] ] + ( appb B.Implies + [ apps T.Mem + [ Ix 1 %% [] + ; apps T.FunDom + [ apps T.SeqSelectSeq + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ; Apply ( + Ix 3 %% [], + [ apps T.FunApp + [ apps T.SeqSelectSeq + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ]) %% [] + ] %% [] + ) %% [] + ) %% [] + +let seqselectseqappend_def () = + seq + [ "T" ] [ Ty1 ([ t_idv ], t_idv) ] + ( quant Forall + [ "s" ; "x" ] [ t_idv ; t_idv ] + ~pats:[ [ + apps T.SeqSelectSeq + [ apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ] ] + ( List (And, + [ appb B.Implies + [ Apply ( + Ix 3 %% [], + [ Ix 1 %% [] + ]) %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqSelectSeq + [ apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.SeqAppend + [ apps T.SeqSelectSeq + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ; Ix 1 %% [] + ] %% [] + ] %% [] + ] %% [] + ; appb B.Implies + [ appb B.Neg + [ Apply ( + Ix 3 %% [], + [ Ix 1 %% [] + ]) %% [] + ] %% [] + ; appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqSelectSeq + [ apps T.SeqAppend + [ Ix 2 %% [] + ; Ix 1 %% [] + ] %% [] + ; Ix 3 %% [] + ] %% [] + ; apps T.SeqSelectSeq + [ Ix 2 %% [] + ; Ix 3 %% [] + ] %% [] + ] %% [] + ] %% [] + ]) %% [] + ) %% [] + ) %% [] + +let seqtup_typing n = + quant Forall + ([ "a" ] @ gen "x" n) (dupl t_idv (n + 1)) + ~pats:[ + (List.init n begin fun i -> + apps T.Mem + [ Ix (n - i) %% [] + ; Ix (n + 1) %% [] + ] %% [] + end) @ + [ apps (T.Tuple n) + (ixi n) %% [] + ] + ] + ( if n = 0 then + apps T.Mem + [ apps (T.Tuple 0) [] %% [] + ; apps T.SeqSeq + [ Ix 1 %% [] + ] %% [] + ] %% [] + else + appb B.Implies + [ List (And, + List.init n begin fun i -> + apps T.Mem + [ Ix (n - i) %% [] + ; Ix (n + 1) %% [] + ] %% [] + end) %% [] + ; apps T.Mem + [ apps (T.Tuple n) + (ixi n) %% [] + ; apps T.SeqSeq + [ Ix (n + 1) %% [] + ] %% [] + ] %% [] + ] %% [] + ) %% [] + +let seqtuplen_def ~disable_arithmetic n = + quant Forall + (gen "x" n) (dupl t_idv n) + ~pats:[ [ + apps (T.Tuple n) + (ixi n) %% [] + ] ] + ( appb ~tys:[ t_idv ] B.Eq + [ apps T.SeqLen + [ apps (T.Tuple n) + (ixi n) %% [] + ] %% [] + ; if disable_arithmetic then + apps (T.IntLit n) [] %% [] + else + apps (T.Cast t_int) + [ apps (T.TIntLit n) [] %% [] + ] %% [] + ] %% [] + ) %% [] + + +(* {3 Get Axiom} *) + +(* These annotations are used to identify axiom schemas. + * See {!N_flatten}. *) +let mark tla_smb e = + let smb = mk_smb tla_smb in + assign e smb_prop smb + +let get_axm ~solver ?(disable_arithmetic=false) ?(smt_set_extensionality=false) tla_smb = + match tla_smb with + | T.ChooseDef -> choose_def () |> mark T.Choose + | T.ChooseExt -> choose_ext () + | T.SetExt -> set_ext ~smt_set_extensionality + | T.SubsetEqDef -> subseteq_def () + | T.SubsetEqIntro -> subseteq_intro () + | T.SubsetEqElim -> subseteq_elim () + | T.EnumDef n -> setenum_def n + | T.EnumDefIntro n -> setenum_intro n + | T.EnumDefElim n -> setenum_elim n + | T.UnionDef -> union_def () + | T.UnionIntro -> union_intro () + | T.UnionElim -> union_elim () + | T.SubsetDef -> subset_def () + | T.SubsetDefAlt -> subset_def_alt () + | T.SubsetIntro -> subset_intro () + | T.SubsetElim -> subset_elim () + | T.CupDef -> cup_def () + | T.CapDef -> cap_def () + | T.SetMinusDef -> setminus_def () + | T.SetStDef -> setst_def () |> mark T.SetSt + | T.SetOfDef n -> setof_def n |> mark (T.SetOf n) + | T.SetOfIntro n -> setof_intro n |> mark (T.SetOf n) + | T.SetOfElim n -> setof_elim n |> mark (T.SetOf n) + | T.StrLitIsstr s -> strlit_isstr s + | T.StrLitDistinct (s1, s2) -> strlit_distinct s1 s2 + | T.IntLitIsint n -> intlit_isint n + | T.IntLitDistinct (m, n) -> intlit_distinct m n + | T.IntLitZeroCmp n -> intlit_zerocmp n + | T.NatSetDef -> natset_def ~disable_arithmetic + | T.IntPlusTyping -> intplus_typing () + | T.IntUminusTyping -> intuminus_typing () + | T.IntMinusTyping -> intminus_typing () + | T.IntTimesTyping -> inttimes_typing () + | T.IntQuotientTyping -> intquotient_typing () + | T.IntRemainderTyping -> intremainder_typing () + | T.IntExpTyping -> intexp_typing ~disable_arithmetic + | T.NatPlusTyping -> natplus_typing () + | T.NatTimesTyping -> nattimes_typing () + | T.IntRangeDef -> intrange_def () + | T.NonNegIsPos -> nonneg_ispos () + | T.LteqReflexive -> lteq_reflexive () + | T.LteqTransitive -> lteq_transitive () + | T.LteqAntisym -> lteq_antisym () + | T.FunExt -> fcn_ext () + | T.FunConstrIsafcn -> fcnconstr_isafcn () |> mark T.FunConstr + | T.FunSetDef -> fcnset_def () + | T.FunSetIntro -> fcnset_intro () + | T.FunSetElim1 -> fcnset_elim1 () + | T.FunSetElim2 -> fcnset_elim2 () + | T.FunSetImIntro -> fcnsetim_intro () + | T.FunSetSubs -> fcnset_subs () + | T.FunDomDef -> fcndom_def () |> mark T.FunConstr + | T.FunAppDef -> fcnapp_def () |> mark T.FunConstr + | T.FunTyping -> fcnconstr_typing () |> mark T.FunConstr + | T.FunExceptIsafcn -> fcnexcept_isafcn () + | T.FunExceptDomDef -> fcnexceptdom_def () + | T.FunExceptAppDef1 -> fcnexceptapp1_def () + | T.FunExceptAppDef2 -> fcnexceptapp2_def () + | T.FunExceptTyping -> fcnexcept_typing () + | T.FunImDef -> fcnim_def () + | T.FunImIntro -> fcnim_intro () + | T.FunImElim -> fcnim_elim () + | T.TupIsafcn n -> tuple_isafcn n + | T.TupDomDef n -> tupdom_def ~disable_arithmetic n + | T.TupAppDef n -> tupapp_def ~disable_arithmetic n + | T.TupExcept (n, i) -> tupexcept_def ~disable_arithmetic n i + | T.ProductDef n -> productset_def n + | T.ProductIntro n -> productset_intro n + | T.ProductElim n -> productset_elim ~disable_arithmetic n + | T.RecIsafcn fs -> record_isafcn fs + | T.RecDomDef fs -> recdom_def fs + | T.RecAppDef fs -> recapp_def fs + | T.RecExcept (fs, s) -> recexcept_def fs s + | T.RecSetDef fs -> recset_def fs + | T.RecSetIntro fs -> recset_intro fs + | T.RecSetElim fs -> recset_elim fs + + | T.SeqSetIntro -> seqset_intro ~disable_arithmetic + | T.SeqSetElim1 -> seqset_elim1 ~disable_arithmetic + | T.SeqSetElim2 -> seqset_elim2 ~disable_arithmetic + | T.SeqLenDef -> seqlen_def ~disable_arithmetic + | T.SeqCatTyping -> seqcat_typing () + | T.SeqCatLen -> seqcatlen_def ~disable_arithmetic + | T.SeqCatApp1 -> seqcatapp1_def ~disable_arithmetic + | T.SeqCatApp2 -> seqcatapp2_def ~disable_arithmetic + | T.SeqAppendTyping -> seqappend_typing () + | T.SeqAppendLen -> seqappendlen_def ~disable_arithmetic + | T.SeqAppendApp1 -> seqappendapp1_def ~disable_arithmetic + | T.SeqAppendApp2 -> seqappendapp2_def ~disable_arithmetic + | T.SeqHeadDef -> seqhead_def ~disable_arithmetic + | T.SeqTailTyping -> seqtail_typing ~disable_arithmetic + | T.SeqTailLen -> seqtaillen_def ~disable_arithmetic + | T.SeqTailApp -> seqtailapp_def ~disable_arithmetic + | T.SeqSubseqTyping -> seqsubseq_typing ~disable_arithmetic + | T.SeqSubseqLen -> seqsubseqlen_def ~disable_arithmetic + | T.SeqSubseqApp -> seqsubseqapp_def ~disable_arithmetic + | T.SeqSelectseqTyping -> seqselectseq_typing () |> mark T.SeqSelectSeq + | T.SeqSelectseqLen -> seqselectseqlen_def ~disable_arithmetic |> mark T.SeqSelectSeq + | T.SeqSelectseqNil -> seqselectseqnil_def () |> mark T.SeqSelectSeq + | T.SeqSelectseqApp -> seqselectseqapp_def () |> mark T.SeqSelectSeq + | T.SeqSelectseqAppend -> seqselectseqappend_def () |> mark T.SeqSelectSeq + | T.SeqTupTyping n -> seqtup_typing n + | T.SeqTupLen n -> seqtuplen_def ~disable_arithmetic n + + | T.CastInj ty0 -> cast_inj ty0 + | T.CastInjAlt ty0 -> cast_inj_alt ty0 + | T.TypeGuard ty0 -> type_guard ty0 + | T.TypeGuardIntro ty0 -> type_guard_intro ty0 + | T.TypeGuardElim ty0 -> type_guard_elim ty0 + | T.Typing tla_smb -> op_typing tla_smb + | T.ExtTrigEqDef ty0 -> exttrigeq_def ty0 + | T.ExtTrigEqTrigger ty0 -> exttrigeq_trigger ty0 + | T.DisjointTrigger -> disjoint_trigger () + | T.EmptyComprehensionTrigger -> emptycomprehension_trigger () + | T.AssertIsSetOf n -> assert_issetof n |> mark (T.SetOf n) + | T.CompareSetOfTrigger -> compare_setof_trigger () + | T.ExtTrigEqCardPropagate -> exttrigeq_card () + diff --git a/src/encode/n_axioms.mli b/src/encode/n_axioms.mli new file mode 100644 index 00000000..7e4ecdd5 --- /dev/null +++ b/src/encode/n_axioms.mli @@ -0,0 +1,209 @@ +(* + * encode/axioms.mli --- axioms for TLA+ symbols + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open Type.T + +open N_table + +(** Axioms used in the TPTP and SMT encodings, all in standard form + (see {!Encode.Smb} and {!Encode.Standardize}). + *) + +(** Return the actual expression for an axiom + @param disable_arithmetic default=false; no link with solver's native arithmetic + @param smt_set_extensionality default=false; use special SMT triggers for set extensionality + *) +val get_axm : + solver:string -> + ?disable_arithmetic:bool -> + ?smt_set_extensionality:bool -> + tla_axm -> expr +(** This is the only function from this module you should use. + The rest below is documentation. + *) + + +(* {3 Special} *) + +val cast_inj : ty0 -> expr +val cast_inj_alt : ty0 -> expr +val type_guard : ty0 -> expr +val type_guard_intro : ty0 -> expr +val type_guard_elim : ty0 -> expr +val op_typing : tla_smb -> expr + +(* FIXME The [op_typing] schema should be extended for dependent types + * but this will have to wait. For now, the function will redirect to one + * of the special cases below. *) +val op_intquotient_typing : unit -> expr +val op_intremainder_typing : unit -> expr + +val exttrigeq_def : ty0 -> expr +val exttrigeq_trigger : ty0 -> expr +val disjoint_trigger : unit -> expr +val emptycomprehension_trigger : unit -> expr +val assert_issetof : int -> expr +val compare_setof_trigger : unit -> expr +val exttrigeq_card : unit -> expr + + + +(* {3 Main} *) + +(* {4 Logic} *) + +val choose_def : unit -> expr +val choose_ext : unit -> expr + +(* {4 Sets} *) + +val set_ext : smt_set_extensionality:bool -> expr + +val subseteq_def : unit -> expr +val subseteq_intro : unit -> expr +val subseteq_elim : unit -> expr +val subseteq_antisym : unit -> expr + +val setenum_def : int -> expr +val setenum_intro : int -> expr +val setenum_elim : int -> expr + +val union_def : unit -> expr +val union_intro : unit -> expr +val union_elim : unit -> expr + +val subset_def : unit -> expr +val subset_def_alt : unit -> expr +val subset_intro : unit -> expr +val subset_elim : unit -> expr + +val cup_def : unit -> expr +val cap_def : unit -> expr +val setminus_def : unit -> expr + +val setst_def : unit -> expr + +val setof_def : int -> expr +val setof_intro : int -> expr +val setof_elim : int -> expr + +(* {4 Functions} *) + +val fcn_ext : unit -> expr + +val fcnconstr_isafcn : unit -> expr +val fcndom_def : unit -> expr +val fcnapp_def : unit -> expr +val fcnconstr_typing : unit -> expr + +val fcnset_def : unit -> expr +val fcnset_intro : unit -> expr +val fcnset_elim1 : unit -> expr +val fcnset_elim2 : unit -> expr +val fcnsetim_intro : unit -> expr +val fcnset_subs : unit -> expr + +val fcnexcept_isafcn : unit -> expr +val fcnexceptdom_def : unit -> expr +val fcnexceptapp1_def : unit -> expr +val fcnexceptapp2_def : unit -> expr +val fcnexcept_typing : unit -> expr + +val fcnim_def : unit -> expr +val fcnim_intro : unit -> expr +val fcnim_elim : unit -> expr + +(* {4 Strings} *) + +val strlit_isstr : string -> expr + +val strlit_distinct : string -> string -> expr + +(* {4 Arithmetic} *) + +val natset_def : disable_arithmetic:bool -> expr +val intrange_def : unit -> expr + +val intlit_distinct : int -> int -> expr +val intlit_zerocmp : int -> expr + +val intlit_isint : int -> expr +val intplus_typing : unit -> expr +val intuminus_typing : unit -> expr +val intminus_typing : unit -> expr +val inttimes_typing : unit -> expr +val intquotient_typing : unit -> expr +val intremainder_typing : unit -> expr +val intexp_typing : disable_arithmetic:bool -> expr +val natplus_typing : unit -> expr +val nattimes_typing : unit -> expr + +val nonneg_ispos : unit -> expr + +val lteq_reflexive : unit -> expr +val lteq_transitive : unit -> expr +val lteq_antisym : unit -> expr + +(* {4 Tuples} *) + +val tuple_isafcn : int -> expr +val tupdom_def : disable_arithmetic:bool -> int -> expr +val tupapp_def : disable_arithmetic:bool -> int -> expr +val tupexcept_def : disable_arithmetic:bool -> int -> int -> expr + +val productset_def : int -> expr +val productset_intro : int -> expr +val productset_elim : disable_arithmetic:bool -> int -> expr + +(* {4 Records} *) + +val record_isafcn : string list -> expr +val recdom_def : string list -> expr +val recapp_def : string list -> expr +val recexcept_def : string list -> int -> expr + +val recset_def : string list -> expr +val recset_intro : string list -> expr +val recset_elim : string list -> expr + +(* {4 Sequences} *) + +val seqset_intro : disable_arithmetic:bool -> expr +val seqset_elim1 : disable_arithmetic:bool -> expr +val seqset_elim2 : disable_arithmetic:bool -> expr + +val seqlen_def : disable_arithmetic:bool -> expr + +val seqcat_typing : unit -> expr +val seqcatlen_def : disable_arithmetic:bool -> expr +val seqcatapp1_def : disable_arithmetic:bool -> expr +val seqcatapp2_def : disable_arithmetic:bool -> expr + +val seqappend_typing : unit -> expr +val seqappendlen_def : disable_arithmetic:bool -> expr +val seqappendapp1_def : disable_arithmetic:bool -> expr +val seqappendapp2_def : disable_arithmetic:bool -> expr + +val seqhead_def : disable_arithmetic:bool -> expr + +val seqtail_typing : disable_arithmetic:bool -> expr +val seqtaillen_def : disable_arithmetic:bool -> expr +val seqtailapp_def : disable_arithmetic:bool -> expr + +val seqsubseq_typing : disable_arithmetic:bool -> expr +val seqsubseqlen_def : disable_arithmetic:bool -> expr +val seqsubseqapp_def : disable_arithmetic:bool -> expr + +val seqselectseq_typing : unit -> expr +val seqselectseqlen_def : disable_arithmetic:bool -> expr +val seqselectseqnil_def : unit -> expr +val seqselectseqappend_def : unit -> expr + +val seqtup_typing : int -> expr +val seqtuplen_def : disable_arithmetic:bool -> int -> expr + diff --git a/src/encode/n_axioms.mlt b/src/encode/n_axioms.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_axioms.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_data.ml b/src/encode/n_data.ml new file mode 100644 index 00000000..736ef1a1 --- /dev/null +++ b/src/encode/n_data.ml @@ -0,0 +1,703 @@ +(* + * encode/data.ml --- symbol data + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Type.T +open Util.Coll + +open N_table + + +(* {3 Helpers} *) + +let error ?at mssg = + let mssg = "Encode.Data: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + +let t_idv = TAtm TAIdv +let t_bol = TAtm TABol +let t_int = TAtm TAInt +let t_str = TAtm TAStr + +let t_fs s = TFSet s + +let t_cst ty = Ty1 ([], ty) +let t_una ty1 ty2 = Ty1 ([ ty1 ], ty2) +let t_bin ty1 ty2 ty3 = Ty1 ([ ty1 ; ty2 ], ty3) + + +(* {3 Types} *) + +type smb_kind = Untyped | Typed | Special + +type data = + { dat_name : string + ; dat_ty2 : Type.T.ty2 + ; dat_kind : smb_kind + ; dat_tver : tla_smb option + } + +type dep_data = + { dat_deps : tla_smb list + ; dat_axms : tla_axm list + } + + +(* {3 Data} *) + +let untyped_data tla_smb = + begin match tla_smb with + (* Logic *) + | Choose -> + ("Choose", [ t_una t_idv t_bol ], t_idv) + (* Set Theory *) + | Mem -> + ("Mem", [ t_cst t_idv ; t_cst t_idv ], t_bol) + | SubsetEq -> + ("SubsetEq", [ t_cst t_idv ; t_cst t_idv ], t_bol) + | SetEnum n -> + ("SetEnum_" ^ string_of_int n, + List.init n (fun _ -> t_cst t_idv), t_idv) + | Add -> + ("Add", [ t_cst t_idv ], t_idv) + | Union -> + ("Union", [ t_cst t_idv ], t_idv) + | Subset -> + ("Subset", [ t_cst t_idv ], t_idv) + | Cup -> + ("Cup", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | Cap -> + ("Cap", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | SetMinus -> + ("SetMinus", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | SetSt -> + ("SetSt", [ t_cst t_idv ; t_una t_idv t_bol ], + t_idv) + | SetOf n -> + ("SetOf_" ^ string_of_int n, + List.init n (fun _ -> t_cst t_idv) + @ [ Ty1 (List.init n (fun _ -> t_idv), t_idv) ], + t_idv) + (* Booleans *) + | BoolSet -> + ("BoolSet", [], t_idv) + (* Strings *) + | StrSet -> + ("StrSet", [], t_idv) + | StrLit str -> + ("StrLit_" ^ str, [], t_idv) + (* Arithmetic *) + | IntSet -> + ("IntSet", [], t_idv) + | NatSet -> + ("NatSet", [], t_idv) + | IntLit n -> + ("IntLit_" ^ string_of_int n, + [], t_idv) + | IntPlus -> + ("IntPlus", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | IntUminus -> + ("IntUminus", [ t_cst t_idv ], t_idv) + | IntMinus -> + ("IntMinus", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | IntTimes -> + ("IntTimes", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | IntQuotient -> + ("IntQuotient", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | IntRemainder -> + ("IntRemainder", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | IntExp -> + ("IntExp", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | IntLteq -> + ("IntLteq", [ t_cst t_idv ; t_cst t_idv ], t_bol) + | IntLt -> + ("IntLt", [ t_cst t_idv ; t_cst t_idv ], t_bol) + | IntGteq -> + ("IntGteq", [ t_cst t_idv ; t_cst t_idv ], t_bol) + | IntGt -> + ("IntGt", [ t_cst t_idv ; t_cst t_idv ], t_bol) + | IntRange -> + ("IntRange", [ t_cst t_idv ; t_cst t_idv ], t_idv) + (* Functions *) + | FunIsafcn -> + ("FunIsafcn", [ t_cst t_idv ], t_bol) + | FunSet -> + ("FunSet", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | FunConstr -> + ("FunFcn", [ t_cst t_idv ; t_una t_idv t_idv ], t_idv) + | FunDom -> + ("FunDom", [ t_cst t_idv ], t_idv) + | FunIm -> + ("FunIm", [ t_cst t_idv ], t_idv) + | FunApp -> + ("FunApp", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | FunExcept -> + ("FunExcept", [ t_cst t_idv ; t_cst t_idv ; t_cst t_idv ], + t_idv) + (* Tuples *) + | Tuple n -> + ("Tuple_" ^ string_of_int n, + List.init n (fun _ -> t_cst t_idv), t_idv) + | Product n -> + ("Product_" ^ string_of_int n, + List.init n (fun _ -> t_cst t_idv), t_idv) + (* Records *) + | Rec fs -> + let n = List.length fs in + ("Record_" ^ (String.concat "_" fs), + List.init n (fun _ -> t_cst t_idv), t_idv) + | RecSet fs -> + let n = List.length fs in + ("RecordSet_" ^ String.concat "_" fs, + List.init n (fun _ -> t_cst t_idv), t_idv) + (* Sequences *) + | SeqSeq -> + ("Seq", [ t_cst t_idv ], t_idv) + | SeqLen -> + ("Len", [ t_cst t_idv ], t_idv) + | SeqBSeq -> + ("BSeq", [ t_cst t_idv ], t_idv) + | SeqCat -> + ("Cat", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | SeqAppend -> + ("Append", [ t_cst t_idv ; t_cst t_idv ], t_idv) + | SeqHead -> + ("Head", [ t_cst t_idv ], t_idv) + | SeqTail -> + ("Tail", [ t_cst t_idv ], t_idv) + | SeqSubSeq -> + ("SubSeq", [ t_cst t_idv ; t_cst t_idv ; t_cst t_idv ], + t_idv) + | SeqSelectSeq -> + ("SelectSeq", [ t_cst t_idv ; t_una t_idv t_idv ], t_idv) + (* Finite Sets *) + | FSIsFiniteSet -> + ("IsFiniteSet", [ t_cst t_idv ], t_bol) + | FSCard -> + ("Cardinality", [ t_cst t_idv ], t_idv) + + | _ -> + error "internal error" + end + +let typed_data tla_smb = + begin match tla_smb with + (* Arithmetic *) + | TIntLit n -> + ("TIntLit_" ^ string_of_int n, + [], t_int, + IntLit n) + | TIntPlus -> + ("TIntPlus", [ t_cst t_int ; t_cst t_int ], t_int, + IntPlus) + | TIntUminus -> + ("TIntUminus", [ t_cst t_int ], t_int, + IntUminus) + | TIntMinus -> + ("TIntMinus", [ t_cst t_int ; t_cst t_int ], t_int, + IntMinus) + | TIntTimes -> + ("TIntTimes", [ t_cst t_int ; t_cst t_int ], t_int, + IntTimes) + | TIntQuotient -> + ("TIntQuotient", [ t_cst t_int ; t_cst t_int ], t_int, + IntQuotient) + | TIntRemainder -> + ("TIntRemainder", [ t_cst t_int ; t_cst t_int ], t_int, + IntRemainder) + (*| TIntExp -> + ("TIntExp", [ t_cst t_int ; t_cst t_int ], t_int, + IntExp)*) + | TIntLteq -> + ("TIntLteq", [ t_cst t_int ; t_cst t_int ], t_bol, + IntLteq) + | TIntLt -> + ("TIntLt", [ t_cst t_int ; t_cst t_int ], t_bol, + IntLt) + | TIntGteq -> + ("TIntGteq", [ t_cst t_int ; t_cst t_int ], t_bol, + IntGteq) + | TIntGt -> + ("TIntGt", [ t_cst t_int ; t_cst t_int ], t_bol, + IntGt) + (* Finite Sets *) + | TFSCard s -> + ("TFSCard_" ^ ty_to_string s, + [ t_cst (t_fs s) ], t_int, + FSCard) + | TFSMem s -> + ("TFSMem_" ^ ty_to_string s, + [ t_cst s ; t_cst (t_fs s) ], t_bol, + Mem) + | TFSSubseteq s -> + ("TFSSubseteq_" ^ ty_to_string s, + [ t_cst (t_fs s) ; t_cst (t_fs s) ], t_bol, + SubsetEq) + | TFSEmpty s -> + ("TFSEmpty_" ^ ty_to_string s, + [], t_fs s, + SetEnum 0) + | TFSSingleton s -> + ("TFSSingleton_" ^ ty_to_string s, + [ t_cst s ], t_fs s, + SetEnum 1) + | TFSAdd s -> + ("TFSAdd_" ^ ty_to_string s, + [ t_cst s ; t_cst (t_fs s) ], t_fs s, + Add) + | TFSCup s -> + ("TFSCup_" ^ ty_to_string s, + [ t_cst (t_fs s) ; t_cst (t_fs s) ], t_fs s, + Cup) + | TFSCap s -> + ("TFSCap_" ^ ty_to_string s, + [ t_cst (t_fs s) ; t_cst (t_fs s) ], t_fs s, + Cap) + | TFSSetminus s -> + ("TFSSetminus_" ^ ty_to_string s, + [ t_cst (t_fs s) ; t_cst (t_fs s) ], t_fs s, + SetMinus) + + | _ -> + error "internal error" + end + +let special_data tla_smb = + begin match tla_smb with + | Cast ty -> + ("Cast_" ^ ty_to_string ty, + [ t_cst ty ], t_idv) + | Proj ty -> + ("Proj_" ^ ty_to_string ty, + [ t_cst t_idv ], ty) + | True ty -> + ("Tt_" ^ ty_to_string ty, + [], ty) + | Anon (s, Ty2 (ty1s, ty0)) -> + ("Anon_" ^ s, ty1s, ty0) + | ExtTrigEq ty -> + (* get the sort as it will appear in SMT *) + let actual_ty = + match ty with + | TAtm (TAInt | TABol) -> ty + | _ -> t_idv + in + ("TrigEq_" ^ ty_to_string ty, + [ t_cst actual_ty ; t_cst actual_ty ], t_bol) + | ExtTrig -> + ("SetExtTrigger", + [ t_cst t_idv ; t_cst t_idv ], t_bol) + | IsSetOf -> + ("IsSetOf", [ t_cst t_idv ], t_bol) + + | _ -> + error "internal error" + end + +let get_data tla_smb = + match tla_smb with + | Choose | Mem | SubsetEq | SetEnum _ | Add | Union | Subset | Cup | Cap + | SetMinus | SetSt | SetOf _ | BoolSet | StrSet | StrLit _ | IntSet + | NatSet | IntLit _ | IntPlus | IntUminus | IntMinus | IntTimes + | IntQuotient | IntRemainder | IntExp | IntLteq | IntLt | IntGteq | IntGt + | IntRange | FunIsafcn | FunSet | FunConstr | FunDom | FunIm | FunApp + | FunExcept | Tuple _ | Product _ | Rec _ | RecSet _ | SeqSeq | SeqLen + | SeqBSeq | SeqCat | SeqAppend | SeqHead | SeqTail | SeqSubSeq + | SeqSelectSeq | FSIsFiniteSet | FSCard -> + let (nm, tins, tout) = untyped_data tla_smb in + { dat_name = "TLA__" ^ nm + ; dat_ty2 = Ty2 (tins, tout) + ; dat_kind = Untyped + ; dat_tver = None + } + | TIntLit _ | TIntPlus | TIntUminus | TIntMinus | TIntTimes | TIntQuotient + | TIntRemainder (*| TIntExp*) | TIntLteq | TIntLt | TIntGteq | TIntGt | TFSCard _ + | TFSMem _ | TFSSubseteq _ | TFSEmpty _ | TFSSingleton _ | TFSAdd _ | TFSCup _ + | TFSCap _ | TFSSetminus _ -> + let (nm, tins, tout, tver) = typed_data tla_smb in + { dat_name = "TLA__" ^ nm + ; dat_ty2 = Ty2 (tins, tout) + ; dat_kind = Typed + ; dat_tver = Some tver + } + | Cast _ | Proj _ | True _ | Anon _ | ExtTrigEq _ | ExtTrig | IsSetOf -> + let (nm, tins, tout) = special_data tla_smb in + { dat_name = "TLA__" ^ nm + ; dat_ty2 = Ty2 (tins, tout) + ; dat_kind = Special + ; dat_tver = None + } + + +(* {3 Dependencies} *) + +type s = + { strlits : Ss.t + ; intlits : Is.t + ; t_strlits : Ss.t + ; funconstr : bool + ; funset : bool + ; except : bool + ; tups : int list + ; recs : (string list) list + } + +let init = + { strlits = Ss.empty + ; intlits = Is.empty + ; t_strlits = Ss.empty + ; funconstr = false + ; funset = false + ; except = false + ; tups = [] + ; recs = [] + } + +let untyped_deps ~solver ~disable_arithmetic ~smt_set_extensionality tla_smb s = + let s' = + match tla_smb with + | StrLit str -> + { s with strlits = Ss.add str s.strlits } + | IntLit n -> + { s with intlits = Is.add n s.intlits } + | FunConstr -> + { s with funconstr = true } + | FunSet -> + { s with funset = true } + | FunExcept -> + { s with except = true } + | Tuple n -> + { s with tups = n :: s.tups } + | Rec fs -> + { s with recs = fs :: s.recs } + | _ -> s + in + let noarith = disable_arithmetic in + let ext = smt_set_extensionality in + begin match tla_smb with + (* Logic *) + | Choose -> + ([], [ ChooseDef (*; ChooseExt*) ]) + (* Set Theory *) + | Mem when ext -> + ([ ExtTrig ], + [ SetExt ]) + | Mem -> + ([], [ (*SetExt*) ]) + | SubsetEq -> + ([ Mem ], [ SubsetEqIntro ; SubsetEqElim ]) + | SetEnum 0 -> + ([ Mem ], [ EnumDefElim 0 ]) + | SetEnum n -> + ([ Mem ], [ EnumDefIntro n ; EnumDefElim n ]) + | Union -> + ([ Mem ], [ UnionIntro ; UnionElim ]) + | Subset -> + ([ Mem ; SubsetEq ], + [ SubsetDefAlt ]) + | Cup -> + ([ Mem ], [ CupDef ]) + | Cap when ext -> + ([ Mem ; SetEnum 0 ; ExtTrig ], + [ CapDef ; DisjointTrigger ]) + | Cap -> + ([ Mem ], [ CapDef ]) + | SetMinus -> + ([ Mem ], [ SetMinusDef ]) + | SetSt when ext -> + ([ Mem ; SetEnum 0; ExtTrig ], + [ SetStDef ; EmptyComprehensionTrigger ]) + | SetSt -> + ([ Mem ], [ SetStDef ]) + | SetOf n when ext -> + ([ Mem ; IsSetOf ], + [ SetOfIntro n ; SetOfElim n ; AssertIsSetOf n ; CompareSetOfTrigger ]) + | SetOf n -> + ([ Mem ], [ SetOfIntro n ; SetOfElim n ]) + (* Booleans *) + | BoolSet -> + ([], []) + (* Strings *) + | StrSet -> + ([], []) + | StrLit str -> + let distincts = + Ss.fold (fun str2 -> List.cons (StrLitDistinct (str, str2))) s.strlits [] + in + ([ Mem ; StrSet ], [ StrLitIsstr str ] @ distincts) + (* Arithmetic *) + | IntSet -> + ([], []) + | NatSet when noarith -> + ([ IntSet ; IntLit 0 ; IntLteq ], [ NatSetDef ]) + | NatSet -> + ([ IntSet ; TIntLit 0 ; Cast (TAtm TAInt) ; IntLteq ], + [ NatSetDef ]) + | IntLit n -> + let distincts = + Is.fold (fun m -> List.cons (IntLitDistinct (m, n))) s.intlits [] + in + ([ Mem ; IntSet ; IntLit 0 ; IntLteq ] @ + begin if n = 0 && noarith then [ IntLit 1 ] else [] end, + [ IntLitIsint n ; IntLitZeroCmp n ] @ distincts @ + begin if n = 0 && noarith then [ NonNegIsPos ] else [] end) + | IntPlus when noarith -> + ([ Mem ; IntSet ; NatSet ], [ IntPlusTyping ; NatPlusTyping ]) + | IntUminus when noarith -> + ([ Mem ; IntSet ], [ IntUminusTyping ]) + | IntMinus when noarith -> + ([ Mem ; IntSet ], [ IntMinusTyping ]) + | IntTimes when noarith -> + ([ Mem ; IntSet ; NatSet ], [ IntTimesTyping ; NatTimesTyping ]) + | IntQuotient when noarith -> + ([ Mem ; IntSet ; NatSet ; IntLteq ; IntLit 0 ], + [ IntQuotientTyping ]) + | IntRemainder when noarith -> + ([ Mem ; IntSet ; NatSet ; IntLteq ; IntLit 0 ; IntLit 1 ; + IntRange ; IntMinus ], [ IntRemainderTyping ]) + | IntExp when noarith -> + ([ Mem ; IntSet ; IntLteq ; IntLit 0 ; IntLit 1 ], + [ IntExpTyping ]) + | IntLteq | IntLt | IntGteq | IntGt when noarith -> + ([ Mem ; IntSet ], [ LteqReflexive ; LteqTransitive ; LteqAntisym ]) + | IntPlus -> + ([ Cast (TAtm TAInt) ; TIntPlus ], [ Typing TIntPlus ]) + | IntUminus -> + ([ Cast (TAtm TAInt) ; TIntUminus ], [ Typing TIntUminus ]) + | IntMinus -> + ([ Cast (TAtm TAInt) ; TIntMinus ], [ Typing TIntMinus ]) + | IntTimes -> + ([ Cast (TAtm TAInt) ; TIntTimes ], [ Typing TIntTimes ]) + | IntQuotient -> + ([ Cast (TAtm TAInt) ; TIntQuotient ], [ Typing TIntQuotient ]) + | IntRemainder -> + ([ Cast (TAtm TAInt) ; TIntRemainder ], [ Typing TIntRemainder ]) + | IntExp -> + (* NOTE SMT has no symbol for exponentiation *) + (*([ Cast (TAtm TAInt) ; TIntExp ], [ Typing TIntExp ])*) + ([ Mem ; IntSet ; Cast (TAtm TAInt) ; TIntLteq ; TIntLit 0 ; TIntLit 1 ], + [ IntExpTyping ]) + | IntLteq -> + ([ Cast (TAtm TAInt) ; TIntLteq ], [ Typing TIntLteq ]) + | IntLt -> + ([ Cast (TAtm TAInt) ; TIntLt ], [ Typing TIntLt ]) + | IntGteq -> + ([ Cast (TAtm TAInt) ; TIntGteq ], [ Typing TIntGteq ]) + | IntGt -> + ([ Cast (TAtm TAInt) ; TIntGt ], [ Typing TIntGt ]) + | IntRange -> + ([ Mem ; IntSet ; IntLteq ], [ IntRangeDef ]) + (* Functions *) + | FunIsafcn -> + ([ Mem ; FunDom ; FunConstr ; FunApp ], + [ FunExt ]) + | FunSet -> + ([ Mem ; FunIsafcn ; FunDom ; FunApp ], + [ FunSetIntro ; FunSetElim1 ; FunSetElim2 ] @ + (if s.funconstr then [ FunTyping ] else [])) + | FunConstr -> + ([ FunIsafcn ], [ FunConstrIsafcn ] @ + (if s.funset then [ FunTyping ] else [])) + | FunDom -> + ([ FunConstr ], [ FunDomDef ]) + | FunApp -> + ([ Mem ; FunConstr ], [ FunAppDef ]) + | FunExcept -> + let axms_tups = List.map (fun n -> List.init n (fun i -> TupExcept (n, i+1))) s.tups |> List.concat in + let axms_recs = List.map (fun fs -> List.init (List.length fs) (fun i -> RecExcept (fs, i+1))) s.recs |> List.concat in + ([ Mem ; FunIsafcn ; FunDom ; FunApp ], + [ FunExceptIsafcn ; FunExceptDomDef ; FunExceptAppDef1 ; FunExceptAppDef2 ] @ axms_tups @ axms_recs) + | FunIm -> + ([ Mem ; FunDom ; FunApp ], [ FunImIntro ; FunImElim ]) + (* Tuples *) + | Tuple 0 when noarith -> + ([ FunIsafcn ; IntLit 0 ; SeqSeq ; SeqLen ], + [ TupIsafcn 0 ; SeqTupTyping 0 ; SeqTupLen 0 ]) + | Tuple 0 -> + ([ FunIsafcn ; Cast (TAtm TAInt) ; SeqSeq ; SeqLen ], + [ TupIsafcn 0 ; SeqTupTyping 0 ; SeqTupLen 0 ]) + | Tuple n when n > 0 && noarith -> + let axms_except = if s.except then List.init n (fun i -> TupExcept (n, i+1)) else [] in + ([ FunIsafcn ; FunDom ; FunApp ; SetEnum n ; Mem ; SeqSeq ; SeqLen ] + @ List.init n (fun i -> IntLit (i+1)), + [ TupIsafcn n ; TupDomDef n ; TupAppDef n ; SeqTupTyping n ; SeqTupLen n ] @ axms_except) + | Tuple n when n > 0 -> + let axms_except = if s.except then List.init n (fun i -> TupExcept (n, i+1)) else [] in + ([ FunIsafcn ; FunDom ; FunApp ; SetEnum n ; Cast (TAtm TAInt) ; Mem ; SeqSeq ; SeqLen ], + [ TupIsafcn n ; TupDomDef n ; TupAppDef n ; SeqTupTyping n ; SeqTupLen n ] @ axms_except) + | Product n -> + ([ Mem ; Tuple n ; FunApp ] + @ List.init n (fun i -> + if noarith then IntLit (i + 1) + else TIntLit (i + 1)) + @ (if noarith then [] else [ Cast (TAtm TAInt) ; Proj (TAtm TAInt) ]), + [ ProductIntro n ; ProductElim n ]) + (* Records *) + | Rec fs -> + let n = List.length fs in + let axms_except = if s.except then List.init (List.length fs) (fun i -> RecExcept (fs, i+1)) else [] in + ([ FunIsafcn ; FunDom ; FunApp ; SetEnum n ] + @ List.map (fun s -> StrLit s) fs, + [ RecIsafcn fs ; RecDomDef fs ; RecAppDef fs ] @ axms_except) + | RecSet fs -> + ([ Mem ; Rec fs ; FunApp ] + @ List.map (fun s -> StrLit s) fs, + [ RecSetIntro fs ; RecSetElim fs ]) + (* Sequences *) + | SeqSeq when noarith -> + ([ Mem ; SeqLen ; FunIsafcn ; FunDom ; FunApp ; IntSet ; NatSet ; IntRange ; IntLteq ; IntLit 1 ], + [ SeqSetIntro ; SeqSetElim1 ; SeqSetElim2 ]) + | SeqSeq -> + ([ Mem ; SeqLen ; FunIsafcn ; FunDom ; FunApp ; IntSet ; NatSet ; IntRange ; Cast (TAtm TAInt) ; Proj (TAtm TAInt) ], + [ SeqSetIntro ; SeqSetElim1 ; SeqSetElim2 ]) + | SeqLen when noarith -> + ([ Mem ; FunDom ; IntRange ; NatSet ; IntLit 1 ], + [ SeqLenDef ]) + | SeqLen -> + ([ FunDom ; IntRange ; Cast (TAtm TAInt) ], + [ SeqLenDef ]) + | SeqCat when noarith -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; IntSet ; NatSet ; IntPlus ; IntLteq ; IntLit 1 ], + [ SeqCatTyping ; SeqCatLen ; SeqCatApp1 ; SeqCatApp2 ]) + | SeqCat -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; NatSet ; Cast (TAtm TAInt) ; Proj (TAtm TAInt) ], + [ SeqCatTyping ; SeqCatLen ; SeqCatApp1 ; SeqCatApp2 ]) + | SeqAppend when noarith -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; IntSet ; NatSet ; IntPlus ; IntLteq ; IntLit 1 ], + [ SeqAppendTyping ; SeqAppendLen ; SeqAppendApp1 ; SeqAppendApp2 ]) + | SeqAppend -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; NatSet ; Cast (TAtm TAInt) ; Proj (TAtm TAInt) ], + [ SeqAppendTyping ; SeqAppendLen ; SeqAppendApp1 ; SeqAppendApp2 ]) + | SeqHead when noarith -> + ([ FunApp ; IntLit 1 ], + [ SeqHeadDef ]) + | SeqHead -> + ([ FunApp ; Cast (TAtm TAInt) ], + [ SeqHeadDef ]) + | SeqTail when noarith -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; IntSet ; NatSet ; IntPlus ; IntMinus ; IntLteq ; IntLit 0 ; IntLit 1 ], + [ SeqTailTyping ; SeqTailLen ; SeqTailApp ]) + | SeqTail -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; NatSet ; Cast (TAtm TAInt) ; Proj (TAtm TAInt) ], + [ SeqTailTyping ; SeqTailLen ; SeqTailApp ]) + | SeqSubSeq when noarith -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; IntSet ; IntPlus ; IntMinus ; IntLteq ; IntLit 0 ; IntLit 1 ], + [ SeqSubseqTyping ; SeqSubseqLen ; SeqSubseqApp ]) + | SeqSubSeq -> + ([ Mem ; SeqSeq ; SeqLen ; FunApp ; IntSet ; Cast (TAtm TAInt) ; Proj (TAtm TAInt) ], + [ SeqSubseqTyping ; SeqSubseqLen ; SeqSubseqApp ]) + | SeqSelectSeq when noarith -> + ([ Mem ; SeqSeq ; SeqLen ; SeqAppend ; FunApp ; FunDom ; IntSet ; NatSet ; Tuple 0 ; IntLteq ], + [ SeqSelectseqTyping ; SeqSelectseqLen ; SeqSelectseqNil ; SeqSelectseqApp ; SeqSelectseqAppend ]) + | SeqSelectSeq -> + ([ Mem ; SeqSeq ; SeqLen ; SeqAppend ; FunApp ; FunDom ; IntSet ; NatSet ; Tuple 0 ; Proj (TAtm TAInt) ], + [ SeqSelectseqTyping ; SeqSelectseqLen ; SeqSelectseqNil ; SeqSelectseqApp ; SeqSelectseqAppend ]) + | SeqBSeq -> + ([], []) + + | _ -> + error "internal error" + end |> + fun x -> (s', x) + +let typed_deps tla_smb s = + begin match tla_smb with + (* Arithmetic *) + | TIntLit _ -> + ([], []) + | TIntPlus -> + ([ IntPlus ], []) + | TIntUminus -> + ([ IntUminus ], []) + | TIntMinus -> + ([ IntMinus ], []) + | TIntTimes -> + ([ IntTimes ], []) + | TIntQuotient -> + ([ IntQuotient ], []) + | TIntRemainder -> + ([ IntRemainder ], []) + (*| TIntExp -> + ([ IntExp ], [])*) + (* NOTE Best to declare only Lteq and not the four variants *) + | TIntLteq -> + ([ IntLteq ], [ Typing TIntLteq ]) + | TIntLt -> + ([ (*IntLt*) IntLteq ], [ Typing TIntLteq ]) + | TIntGteq -> + ([ (*IntGteq*) IntLteq ], [ Typing TIntLteq ]) + | TIntGt -> + ([ (*IntGt*) IntLteq ], [ Typing TIntLteq ]) + | _ -> + error "internal error" + end |> + fun x -> (s, x) + +let special_deps tla_smb = + begin match tla_smb with + | Cast ty0 -> + let tla_smbs = + match ty0 with + | TAtm TAIdv -> [] + | TAtm TABol -> [ Mem ; BoolSet ; True (TAtm TAIdv) ] + | TAtm TAInt -> [ Mem ; IntSet ] + | TAtm TAStr -> [ Mem ; StrSet ] + | _ -> [] + in + (tla_smbs @ (if ty0 = TAtm TABol then [] else [ Proj ty0 ]), + [ CastInjAlt ty0 ; TypeGuardIntro ty0 ; TypeGuardElim ty0 ]) + | Proj _ -> + ([], []) + | True ty0 -> + ([], []) + | Anon _ -> + ([], []) + | ExtTrigEq (TSet ty01 as ty0) -> + ([ ExtTrig ], [ ExtTrigEqDef ty0 ; ExtTrigEqTrigger ty01 ]) + | ExtTrigEq ty0 -> + ([], [ ExtTrigEqDef ty0 ]) + | ExtTrig -> + ([], []) + | IsSetOf -> + ([], []) + | _ -> + error "internal error" + end |> + fun x -> (fun s -> (s, x)) + +let get_deps ~solver ~disable_arithmetic ~smt_set_extensionality tla_smb s = + match tla_smb with + | Choose | Mem | SubsetEq | SetEnum _ | Add | Union | Subset | Cup | Cap + | SetMinus | SetSt | SetOf _ | BoolSet | StrSet | StrLit _ | IntSet + | NatSet | IntLit _ | IntPlus | IntUminus | IntMinus | IntTimes + | IntQuotient | IntRemainder | IntExp | IntLteq | IntLt | IntGteq | IntGt + | IntRange | FunIsafcn | FunSet | FunConstr | FunDom | FunIm | FunApp + | FunExcept | Tuple _ | Product _ | Rec _ | RecSet _ | SeqSeq | SeqLen + | SeqBSeq | SeqCat | SeqAppend | SeqHead | SeqTail | SeqSubSeq + | SeqSelectSeq | FSIsFiniteSet | FSCard -> + let s, (smbs, axms) = untyped_deps ~solver ~disable_arithmetic ~smt_set_extensionality tla_smb s in + s, + { dat_deps = smbs + ; dat_axms = axms + } + | TIntLit _ | TIntPlus | TIntUminus | TIntMinus | TIntTimes | TIntQuotient + | TIntRemainder (*| TIntExp*) | TIntLteq | TIntLt | TIntGteq | TIntGt + | TFSCard _ | TFSMem _ | TFSSubseteq _ | TFSEmpty _ | TFSSingleton _ + | TFSAdd _ | TFSCup _ | TFSCap _ | TFSSetminus _ -> + + let s, (smbs, axms) = typed_deps tla_smb s in + s, + { dat_deps = smbs + ; dat_axms = axms + } + | Cast _ | Proj _ | True _ | Anon _ | ExtTrigEq _ | ExtTrig | IsSetOf -> + let s, (smbs, axms) = special_deps tla_smb s in + s, + { dat_deps = smbs + ; dat_axms = axms + } + diff --git a/src/encode/n_data.mli b/src/encode/n_data.mli new file mode 100644 index 00000000..b5415632 --- /dev/null +++ b/src/encode/n_data.mli @@ -0,0 +1,38 @@ +(* + * encode/data.mli --- symbol data + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Type.T + +open N_table + +type smb_kind = Untyped | Typed | Special + +(** Basic information associated to a symbol *) +type data = + { dat_name : string + ; dat_ty2 : ty2 + ; dat_kind : smb_kind + ; dat_tver : tla_smb option + } + +(** Dependencies of a symbol (other symbols and axioms). + The dependencies may depend on previous declarations in some cases. For + that reason, they are separated from the basic info, which is the same + whatever the context. +*) +type dep_data = + { dat_deps : tla_smb list + ; dat_axms : tla_axm list + } + +val get_data : tla_smb -> data + +type s +val init : s + +val get_deps : solver:string -> disable_arithmetic:bool -> smt_set_extensionality:bool -> tla_smb -> s -> s * dep_data + diff --git a/src/encode/n_data.mlt b/src/encode/n_data.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_data.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_flatten.ml b/src/encode/n_flatten.ml new file mode 100644 index 00000000..54071fc8 --- /dev/null +++ b/src/encode/n_flatten.ml @@ -0,0 +1,604 @@ +(* + * encode/flatten.ml --- eliminate second-order features + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open Type.T +open Property +open Ext + +module Subst = Expr.Subst +module Is = Util.Coll.Is + +let subst = N_subst.subst + +(** Outline of the algorithm: + + Facts in a sequent are treated one by one, starting from the end. For each + fact, the expression is parsed until a HO application is found. If one is + found, it is treated immediately (the current fact is updated, and new + hypotheses are inserted above it), then the fact is parsed again. If no + HO application is found, then the algorithm continues with the next fact. + + For this module, it is relevant to know which part of a context is global + (hypotheses of the sequent), and which part is local (quantified variables, + let definitions, etc.) + + Let [gtx] and [ltx] denote the global and local parts of some context, and + assume the following HO application occurs in that context: + + F(e1, G, e2, LAMBDA x : x \in Int /\ x # y, e3) + + Where [e1], [e2] and [e3] are expressions, [G] is an operator identifier, + and [y] is a variable that is bound locally (in [ltx]). The blueprint + for that application would contain: + - The index of [F], that must be bound in [gtx]; + - The HO arguments, here [G] and [LAMBDA x : x \in Int /\ x # y]; + - The local free variables in those arguments, here just [y]; + - The context itself (otherwise the expressions cannot be made sense of). + The blueprint is put on [F] as an annotation for later. + + (Note that [Int] and [y] are both internally represented by indexes, but + only [y] is bound locally. Note also that locally bound variables cannot + refer to operators, which are only declared globally.) + + In the next step, a declaration for the replacement operator is prepared. + This can be done systematically from the type of [F]: every first-order + argument is kept, all HO arguments are discarded, and every local variable + of the HO arguments leads to a new argument. In that case, the generated + declaration is: + + NEW F_flat(_, _, _, _) (H) + + The first three arguments correspond to [e1], [e2] and [e3], the fourth is + for the variable [y]. + + There may be axioms attached to [F]. Suppose the only one is: + + ASSUME NEW H(_), + NEW P(_), + NEW a, + NEW b, + NEW c + PROVE F(a, H, b, P, c) = { x \in H(a) : P(b) /\ c } (A) + + It is assumed all axioms are sequents, of which the first parameters are + operator parameters that correspond to the HO arguments of the HO operator, + in the same order (first the leftmost argument, etc.) + + (A) must be instantiated with the relevant HO arguments. Since these + arguments contain variables bound locally in the original expressions, + quantifiers must also be appended on top of (A) to recover the relevant + variables of [ltx]. The result is: + + ASSUME NEW y, + NEW a, + NEW b, + NEW c + PROVE F(a, G, b, LAMBDA x : x \in Int /\ x # y, c) + = { x \in G(a) : b \in Int /\ b # y /\ c } (A') + + Now, (A') still contains an occurrence of [F], which is similar to the one + that was encountered in the original expression. That [F] is annotated + with the same blueprint. + + What remains to be done is insert (H) and (A') below [gtx], and rewrite the + applications of [F] inside (A') and the original expression. Since + inserting hypotheses in [gtx] modifies the context, the blueprints + annotations contain deprecated information. This is not a problem, because + the only relevant information to perform rewritings is a reference to + [F_flat]; which arguments are first-order (easy to determine from the type + of [F]); and the local variables of HO arguments, which are bound locally, + so modifying [gtx] does not affect them. + + Now every occurrence of [F] applied is of the form: + + F(E1, G, E2, LAMBDA x : x \in Int /\ x # y, E3) + + With [F] annotated with a blueprint. They are all rewritten: + + F_flat(E1, E2, E3, y) + +*) + + +(* {3 Helpers} *) + +let error ?at mssg = + let mssg = "Encode.Flatten: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + +let is_sndord = function + | Ty2 (ty1s, _) -> + List.exists (function Ty1 ([], _) -> false | _ -> true) ty1s + +let get_hyp ctx ix = + Option.get (Deque.nth ~backwards:true (snd ctx) (ix - 1)) + +let get_ty2 h = + let v = hyp_hint h in + if has v Props.ty2_prop then + get v Props.ty2_prop + else if has v Props.ty1_prop then + upcast_ty2 (get v Props.ty1_prop) + else if has v Props.ty0_prop then + upcast_ty2 (upcast_ty1 (get v Props.ty0_prop)) + else + let mssg = "Missing type annotation on '" ^ hyp_name h ^ "'" in + error ~at:h mssg + + +(* {3 Context} *) + +(* NOTE Contexts are implemented in such a way that {!Expr.Visit.adj} appends + * hypotheses in the local part of the context. Therefore, the methods of + * {!Expr.Visit} need not be reimplemented if visitors are only used on + * individual facts (not used to parse a top context). *) + +type ctx = int Expr.Visit.scx + +let init_ctx = (0, Deque.empty) + +let sz (_, cx) = Deque.size cx +let global_sz (k, _) = k +let local_sz ctx = sz(ctx) - global_sz(ctx) + +let global_adj (k, cx as ctx) (h : hyp) = + if local_sz ctx = 0 then + (k + 1, Deque.snoc cx h) + else + let mssg = "Cannot append in global context from a local context" in + error ~at:h mssg + +(* For debugging *) +let pp_print_ctx ff (k, cx) = + Format.fprintf ff "(%d, %a)" + k + (fun ff a -> Fmtutil.pp_print_delimited_fold Expr.Fmt.pp_print_hyp (cx, Ctx.dot) ff a |> ignore) (Deque.to_list cx) + + +(* {3 Blueprints} *) + +(** A blueprint is a record of all information relevant + to an application that is to be flattened. +*) +type bp = + { bp_id : int (** Identifier for the blueprint *) + ; bp_ctx : ctx (** Context of the rewritten application *) + ; bp_orig_ix : int (** Index of the original operator (must be declared) *) + ; bp_ho_args : expr list (** The original HO arguments in the order they appear *) + ; bp_lf_vars : int list (** The local free variables of all HO arguments (no duplicates) *) + } + +let bp_prop = make "Encode.Flatten.bp_prop" + +let bp_count = ref 0 +let init_bp_count () = (bp_count := 0) +let new_bp_id () = incr bp_count; !bp_count + +(* For debugging *) +let pp_print_bp ff bp = + Format.fprintf ff "{ bp_id = %d@ ; bp_ctx = %a@ ; bp_orig_ix = %d@ ; bp_ho_args = %a@ ; bp_lf_vars = %a@ }" + bp.bp_id + pp_print_ctx bp.bp_ctx + bp.bp_orig_ix + (Fmtutil.pp_print_delimited (Expr.Fmt.pp_print_expr (snd bp.bp_ctx, Ctx.dot))) bp.bp_ho_args + (Fmtutil.pp_print_delimited Format.pp_print_int) bp.bp_lf_vars + + +(* {3 Functions} *) + +let is_sndord_hyp h = + match h.core with + | Fresh (_, Shape_op _, _, _) -> true + | _ -> false + +let find_hoapp_visitor = object (self : 'self) + inherit [int, bp option] Expr.Visit.foldmap as super + + method expr ctx obp oe = + if Option.is_some obp then (obp, oe) + else match oe.core with + | Apply ({ core = Ix n } as op, es) -> + let obp, es = + List.fold_left begin fun (obp, r_es) e -> + let obp, e = self#expr ctx obp e in + (obp, e :: r_es) + end (obp, []) es |> + fun (obp, r_es) -> + (obp, List.rev r_es) + in + if Option.is_some obp then + (obp, Apply (Ix n @@ op, es) @@ oe) + else begin + + let h = get_hyp ctx n in + let ty2 = get_ty2 h in + if not (is_sndord ty2) then + (obp, Apply (Ix n @@ op, es) @@ oe) + else begin + + let Ty2 (ty1s, _) = ty2 in + let ho_args = + List.combine es ty1s |> + List.filter_map begin function + | _, Ty1 ([], _) -> None + | e, _ -> Some e + end + in + + let is_local ix = (ix <= local_sz ctx) in + let lf_vars = + List.fold_left begin fun vs e -> + let vs_e = Expr.Collect.fvs e in + let vs_e = Is.filter is_local vs_e in + Is.union vs vs_e + end Is.empty ho_args |> + Is.elements |> + List.sort ~cmp:(fun i j -> Stdlib.compare j i) + in + + let bp = + { bp_id = new_bp_id () + ; bp_orig_ix = n + ; bp_ctx = ctx + ; bp_ho_args = ho_args + ; bp_lf_vars = lf_vars + } + in + let op = assign (Ix n @@ op) bp_prop bp in + (Some bp, Apply (op, es) @@ oe) + end + end + + | Sequent sq when Deque.find sq.context is_sndord_hyp |> Option.is_some -> + (obp, Sequent sq @@ oe) + + | _ -> super#expr ctx obp oe +end + +let find_hoapp gtx e = + let obp, e = find_hoapp_visitor#expr gtx None e in + Option.map (fun bp -> bp, e) obp + + +let mk_flat_declaration bp = + let h = get_hyp bp.bp_ctx bp.bp_orig_ix in + let Ty2 (ty1s, ty0) = get_ty2 h in + let ty0s_1 = List.filter_map safe_downcast_ty0 ty1s in + let ty0s_2 = + bp.bp_lf_vars |> + List.map (get_hyp bp.bp_ctx) |> + List.map get_ty2 |> + List.map downcast_ty1 |> + List.map downcast_ty0 + in + let ty1 = Ty1 (ty0s_1 @ ty0s_2, ty0) in + let s = hyp_name h ^ "_flatnd_" ^ string_of_int bp.bp_id in + let v = assign (s %% []) Props.ty1_prop ty1 in + let shp = + (*let n = List.length ty0s_1 + List.length ty0s_2 in + if n = 0 then Shape_expr + else Shape_op n*) + Shape_op 0 + in + Fresh (v, shp, Constant, Unbounded) %% [] + + +let find_axms bp = + let ctx = bp.bp_ctx in + let h = get_hyp ctx bp.bp_orig_ix in + if not (has h N_smb.smb_prop) then + [] + else begin + let smb = get h N_smb.smb_prop in + let gtx = + Deque.to_list (snd ctx) |> + List.rev |> + List.split_nth (local_sz ctx) |> + snd + in + List.fold_left begin fun (es, i) h -> + match query h N_smb.smb_prop, h.core with + | Some smb', Fact (e, Visible, _) when N_smb.equal_smb smb smb' -> + (subst#expr (Subst.shift i) e :: es, i + 1) + | _, _ -> + (es, i + 1) + end ([], 1) gtx |> fst + end + + +let mark_visitor = object (self : 'self) + inherit [bp] Expr.Visit.map as super + + method expr (bp, cx as scx) oe = + begin match oe.core with + | Apply ({ core = Ix n } as op, es) + when n - Deque.size cx = bp.bp_orig_ix - local_sz bp.bp_ctx -> + let es = List.map (self#expr scx) es in + (* Dirty hack: setup the lf_vars field for rewriting. + * The lf_vars indexes are very different in the axioms compared to + * the original application. *) + let m = Deque.size cx in + let lf_vars' = List.init (List.length bp.bp_lf_vars) (fun i -> m - i) in + let bp' = { bp with bp_lf_vars = lf_vars' } in + let op = assign op bp_prop bp' in + Apply (op, es) @@ oe + + | _ -> super#expr scx oe + end |> + map_pats (List.map (self#expr scx)) +end + +let instantiate bp e = + let ho_args = bp.bp_ho_args in + let lf_vars = bp.bp_lf_vars in + let ctx = bp.bp_ctx in + + (* If the local context has depth 5, but only the vars 2 and 4 occur + * in the HO argument, then the following mapping is applied to it: + * 1 |-> X + * 2 |-> 1 + * 3 |-> X + * 4 |-> 2 + * 5 |-> X + * 6 |-> 3 + * 7 |-> 4 + * ... + * n |-> n-3 + * Where 'X' is a dummy expression + * Other representation: + * cons(X, cons(1, cons(X, cons(2, cons(X, cons(3, cons(4, ..))))))) + *) + + (* NOTE For safety, best to use a dummy that SMT does not support, + * in case it ends up in the final output *) + let dummy = Bang (Opaque "IAmError" %% [], []) %% [] in + let maptos = + List.init (local_sz ctx) (fun i -> i + 1) |> fun l -> + (* fold left to iterate left-to-right *) + List.fold_left begin fun (j, maptos) i -> + if List.mem i lf_vars then + let j' = j + 1 in + let e = Ix j' %% [] in + (j', e :: maptos) + else + let e = dummy in + (j, e :: maptos) + end (0, []) l |> + snd |> List.rev + in + let shift = Subst.shift (List.length lf_vars) in + let squash = List.fold_right Subst.scons maptos shift in + let ho_args = List.map (subst#expr squash) ho_args in + + let inst = List.fold_right Subst.scons ho_args shift in + let e = + match e.core with + | Sequent { context = hs ; active = g } -> + let hs = + List.fold_left begin fun hs _ -> + match Deque.front hs with + | Some (_, hs) -> hs + | None -> error ~at:e "Not enough parameters to instantiate" + end hs ho_args + in + if Deque.null hs then + g $$ e + else + Sequent { context = hs ; active = g } @@ e + | _ -> error ~at:e "Expected a sequent expression" + in + let e = subst#expr inst e in + + (* lf_vars set in decreasing order *) + let bs = + List.map begin fun ix -> + let h = get_hyp ctx ix in + let v = hyp_hint h in + (v, Constant, No_domain) + end lf_vars + in + let e = + match bs, e.core with + | [], _ -> e + | _, Quant (Forall, bs', e') -> + Quant (Forall, bs @ bs', e') @@ e + | _, Sequent { context = hs ; active = e' } -> + let bs = + List.map begin fun (v, k, _) -> + Fresh (v, Shape_expr, k, Unbounded) %% [] + end bs + in + let hs = Deque.prepend_list bs hs in + Sequent { context = hs ; active = e' } @@ e + | _, _ -> + Quant (Forall, bs, e) %% [] + in + + mark_visitor#expr (bp, Deque.empty) e + + +let test_bp_id bp a = + match query a bp_prop with + | None -> false + | Some bp' -> bp.bp_id = bp'.bp_id + +let rewrite_expr_visitor = object (self : 'self) + inherit [int * bp] Expr.Visit.map as super + + method expr ((s, bp), hx as scx) oe = + begin match oe.core with + | Apply (op, es) when test_bp_id bp op -> + (* size(hx) is the depth of the local context. + * s is the additionnal shift corresponding to the declaration + * in the top context. *) + let op' = Ix (Deque.size hx + s) %% [] in + let h = get_hyp bp.bp_ctx bp.bp_orig_ix in + let Ty2 (ty1s, _) = get_ty2 h in + let es_1' = + List.combine es ty1s |> + List.filter_map begin function + | e, Ty1 ([], _) -> Some e + | _, _ -> None + end + in + let bp' = get op bp_prop in (* Dirty hack (see mark_visitor above) *) + let es_2' = + bp'.bp_lf_vars |> + List.map (fun i -> Ix i %% []) + in + Apply (op', es_1' @ es_2') @@ oe + + | _ -> super#expr scx oe + end |> + map_pats (List.map (self#expr scx)) +end + +let rewrite_expr bp s e = + let scx = ((s, bp), Deque.empty) in + rewrite_expr_visitor#expr scx e + + +(* {3 Main} *) + +let compare_expr bp1 bp2 e1 e2 = + (* Compare e1 and e2 in their respective original contexts bp1 and bp2 + * (field bp_ctx). + * Global variables must match, but since the contexts are desynchronized, + * only the names are compared (same for function {!same_app} below.) + * Variables that are bound locally in bp1 or bp2 do not need to match. *) + let lsz1 = local_sz bp1.bp_ctx in + let lsz2 = local_sz bp2.bp_ctx in + let rec comp s e1 e2 = + match e1.core, e2.core with + | Ix m, Ix n -> + if m <= s && n <= s then + m = n + else if m > s && (m - s) <= lsz1 + && n > s && (n - s) <= lsz2 then + true + else if m > s && (m - s) > lsz1 + && n > s && (n - s) > lsz2 then + let h1 = get_hyp bp1.bp_ctx (m - s) in + let h2 = get_hyp bp2.bp_ctx (n - s) in + hyp_name h1 = hyp_name h2 + else + false + | Opaque s1, Opaque s2 -> + s1 = s2 + | Apply (op1, es1), Apply (op2, es2) -> + comp s op1 op2 && List.length es1 = List.length es2 && List.for_all2 (comp s) es1 es2 + | Internal b1, Internal b2 -> + b1 = b2 + | Lambda (vs1, e1), Lambda (vs2, e2) + when List.length vs1 = List.length vs2 -> + comp (s + List.length vs1) e1 e2 + | List (bl1, es1), List (bl2, es2) -> + bl1 = bl2 && List.length es1 = List.length es2 && List.for_all2 (comp s) es1 es2 + | _, _ -> + false + in + comp 0 e1 e2 + +let same_app bp' bp = + let h1 = get_hyp bp'.bp_ctx bp'.bp_orig_ix in + let h2 = get_hyp bp.bp_ctx bp.bp_orig_ix in + hyp_name h1 = hyp_name h2 + && List.for_all2 (compare_expr bp' bp) bp'.bp_ho_args bp.bp_ho_args + +let rec match_previous_bp bps bp = + match bps with + | [] -> None + | bp' :: bps -> + if same_app bp' bp then Some bp' + else match_previous_bp bps bp + +let treat_expr bps gtx e = + let rec spin gtx' bps acc e = + match find_hoapp gtx' e with + | None -> + (gtx, bps, acc, e) + | Some (bp, e') -> begin + match match_previous_bp bps bp with + | Some bp' -> + (* The declaration from a previous call can be recycled *) + let n, _ = + Deque.find ~backwards:true (snd gtx') begin fun h -> + match query h bp_prop with + | None -> false + | Some bp -> bp.bp_id = bp'.bp_id + end |> + Option.get + in + let e' = rewrite_expr bp (n + 1) e' in + spin gtx' bps acc e' + + | None -> + let h = mk_flat_declaration bp in + let h = assign h bp_prop bp in (* to find this hyp again later *) + let axms = find_axms bp in + let instantiate bp e = + Option.fold begin fun e m -> + assign e meta_prop { m with name = m.name ^ " " ^ hyp_name h } + end (instantiate bp e) (query e meta_prop) + in + let axms = List.map (instantiate bp) axms in + + (* So far the variables of axms and e' are calibrated for the same + * context gtx. We need to shift all of them to setup the new context: + * gtx, h, axm1, .., axm2, e' + * After this step, the blueprint annotations in axms and e' will be + * partially deprecated. *) + let n = List.length axms in + let axms = + List.mapi (fun i -> subst#expr (Subst.shift (i + 1))) axms + in + let e' = subst#expr (Subst.shift (n + 1)) e' in + + let axms = + List.mapi (fun i -> rewrite_expr bp (i + 1)) axms + in + let e' = rewrite_expr bp (n + 1) e' in + + let axms = List.map (fun e -> Fact (e, Visible, NotSet) %% []) axms in + let hs' = h :: axms in + let gtx' = List.fold_left global_adj gtx' hs' in + let acc' = Deque.append_list acc hs' in + spin gtx' (bp :: bps) acc' e' + end + in + spin gtx bps (Deque.empty) e + +let main sq = + init_bp_count (); + let rec spin bps gtx hs = + match Deque.front hs with + | None -> + snd gtx + | Some ({ core = Fact (e, Visible, tm) } as h, hs) -> + let gtx, bps, hs', e = treat_expr bps gtx e in + let h = Fact (e, Visible, tm) @@ h in + let gtx = Deque.fold_left global_adj gtx hs' in + let gtx = global_adj gtx h in + let shift = Subst.shift (Deque.size hs') in + let hs = snd (subst#hyps shift hs) in + spin bps gtx hs + | Some (h, hs) -> + let gtx = global_adj gtx h in + spin bps gtx hs + in + let hs = Deque.snoc sq.context (Fact (sq.active, Visible, NotSet) %% []) in + let gtx = init_ctx in + let hs = spin [] gtx hs in + let hs, e = + match Deque.rear hs with + | Some (hs, { core = Fact (e, Visible, NotSet) }) -> (hs, e) + | _ -> error "Internal error" + in + { context = hs ; active = e } + diff --git a/src/encode/n_flatten.mli b/src/encode/n_flatten.mli new file mode 100644 index 00000000..4bc1bf2a --- /dev/null +++ b/src/encode/n_flatten.mli @@ -0,0 +1,92 @@ +(* + * encode/flatten.mli --- eliminate second-order features + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T + +(** TLA+ expressions may contain second-order applications: + + F(e1, e2, .., G1, G2, ..) where Gi are operators or LAMBDAs + + The purpose of flattening is to replace these applications by first-order + ones: + + F_g(e1, e2, .., z1, z2, ..) where zj are the free variables of all Gi + + The function {!main} is defined on sequents. Applications are rewritten + in all hypotheses and the goal. Declarations are inserted for the new + operators, and in some special cases, axioms are also added. + + Axioms for a given operator are recognized with {!N_smb.smb_prop} + annotations. If the same annotation is placed on the declaration of an + operator, and a subsequent fact, then each flattening involving that + operator will trigger an instantiation of the fact. + + This module is implemented for standardized expressions. See the module + {!N_standardize}. +*) + +(* Signatures are included for documentation *) + + +(* {3 Context} *) + +(** Context partitioned into a global and a local sections. + + ctx = (k, cx) where: + cx is a double-ended queue that represents the context proper and + k is an int that indicates the size of the global section + + The size of the local context is given by: size(cx) - k. +*) +type ctx = int Expr.Visit.scx + + +(* {3 Blueprints} *) + +(** A blueprint is a record of all information relevant + to an application waiting to be flattened. +*) +type bp + + +(* {3 Main} *) + +(** [find_hoapp ctx e] returns some [bp] and [e'] if [e] contains a HO + application. [bp] is the blueprint for that application, [e'] is [e] + with the application marked for later. + Returns [None] if [e] does not contain a HO application. +*) +val find_hoapp : ctx -> expr -> (bp * expr) option + +(** [mk_flat_declaration bp] is the declaration of a first-order operator + for flattening the HO application that triggered [bp]. +*) +val mk_flat_declaration : bp -> hyp + +(** [find_axms bp] returns a list of closed expressions that must + be instantiated in order to specify the flattened operator. + Renamings are applied to each axiom so all are calibrated to the + global context of [bp]. +*) +val find_axms : bp -> expr list + +(** [instantiate bp e] returns [e'] obtained by instantiating [e] with + the HO arguments recorded in [bp]. Additionnally, every occurrence of the + applied HO operator in that axiom is marked, so that it can be identified + later for rewriting. +*) +val instantiate : bp -> expr -> expr + +(** [rewrite_expr bp s e] rewrites the applications of [e] that are marked with + the identifier of [bp] into flattened applications. [s] is the index of + the new operator. +*) +val rewrite_expr : bp -> int -> expr -> expr + +(** Main function; you should only use this one. *) +val main : sequent -> sequent + diff --git a/src/encode/n_flatten.mlt b/src/encode/n_flatten.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_flatten.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_rewrite.ml b/src/encode/n_rewrite.ml new file mode 100644 index 00000000..53c3a5d4 --- /dev/null +++ b/src/encode/n_rewrite.ml @@ -0,0 +1,1293 @@ +(* + * encode/rewrite.ml --- rewrite sequents + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + + +open Ext +open Property +open Expr.T +open Type.T + +module Subst = Expr.Subst +module Visit = Expr.Visit +module B = Builtin + +let subst = N_subst.subst + + +(* {3 Helpers} *) + +let error ?at mssg = + let mssg = "Encode.Rewrite: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + +let maybe_assign prop a = function + | Some p -> assign a prop p + | None -> a + +(* Return a with the value of prop attached to from, if present *) +let copy_prop prop a from = + maybe_assign prop a (query from prop) + + +(* {3 Bounds Elimination} *) + +let elim_bounds_visitor = object (self : 'self) + inherit [unit] Visit.map as super + + method expr scx oe = + match oe.core with + + | Quant (q, bs, e) -> + let n = List.length bs in + let scx, bs, hs, _, _ = + List.fold_left begin fun (nscx, r_bs, r_hs, dit, i) (v, k, d) -> + let h = Fresh (v, Shape_expr, k, Unbounded) %% [] in + let nscx = Visit.adj scx h in + let b = (v, k, No_domain) in + match d, dit with + | No_domain, _ -> + (nscx, b :: r_bs, r_hs, None, i - 1) + | Domain d, _ -> + let d = self#expr scx d in + let d = subst#expr (Subst.shift n) d in + let op = + Option.map (fun ty -> [ ty ]) (query d Props.mpars_prop) |> + maybe_assign Props.tpars_prop (Internal B.Mem %% []) + in + let ix = copy_prop Props.icast_prop (Ix i %% []) v in + let h = Apply (op, [ ix ; d ]) %% [] in + (nscx, b :: r_bs, h :: r_hs, Some d, i - 1) + | Ditto, Some d -> + let op = + Option.map (fun ty -> [ ty ]) (query d Props.mpars_prop) |> + maybe_assign Props.tpars_prop (Internal B.Mem %% []) + in + let ix = copy_prop Props.icast_prop (Ix i %% []) v in + let h = Apply (op, [ ix ; d ]) %% [] in + (nscx, b :: r_bs, h :: r_hs, Some d, i - 1) + | _, _ -> + error ~at:oe "Missing bound" + end (scx, [], [], None, n) bs |> + fun (nscx, r_bs, r_hs, dit, i) -> + (nscx, List.rev r_bs, List.rev r_hs, dit, i) + in + let e = self#expr scx e in + let e, opats = + (* Patterns must be displaced as the body of a quantified expr + * is modified. *) + match query e pattern_prop with + | None -> e, None + | Some pats -> remove_pats e, Some pats + in + let e = + match hs, q with + | [], _ -> e + | [h], Forall -> + Apply (Internal B.Implies %% [], [ + h ; e + ]) %% [] + | _, Forall -> + Apply (Internal B.Implies %% [], [ + List (And, hs) %% [] ; e + ]) %% [] + | _, Exists -> + List (And, hs @ [ e ]) %% [] + in + let e = Option.fold add_pats e opats in + Quant (q, bs, e) @@ oe + + | Choose (v, Some d, e) -> + let d = self#expr scx d in + let h = Fresh (v, Shape_expr, Constant, Unbounded) %% [] in + let scx = Visit.adj scx h in + let e = self#expr scx e in + let op = + Option.map (fun ty -> [ ty ]) (query d Props.mpars_prop) |> + maybe_assign Props.tpars_prop (Internal B.Mem %% []) + in + let ix = copy_prop Props.icast_prop (Ix 1 %% []) v in + let h = Apply (op, [ ix ; subst#expr (Subst.shift 1) d ]) %% [] in + let e = Apply (Internal B.Conj %% [], [ h ; e ]) %% [] in + Choose (v, None, e) @@ oe + + | _ -> super#expr scx oe + + (* NOTE method hyps is ignored, because a substitution must be built across the context + * and applied to each hyp and the succedent. This substitution renames variables to + * account for new hypotheses in the context. *) + method sequent scx sq = + let rec spin scx sub hs = + match Deque.front hs with + | None -> (scx, sub, Deque.empty) + + | Some ({ core = Fresh (v, shp, k, Bounded (d, vis)) } as h, hs) -> + let d = subst#expr sub d in + let d = self#expr scx d in + let h = Fresh (v, shp, k, Unbounded) @@ h in + let op = + Option.map (fun ty -> [ ty ]) (query d Props.mpars_prop) |> + maybe_assign Props.tpars_prop (Internal B.Mem %% []) + in + let ix = copy_prop Props.icast_prop (Ix 1 %% []) v in + let e = Apply (op, [ ix ; subst#expr (Subst.shift 1) d ]) %% [] in + let hh = Fact (e, vis, NotSet) %% [] in + let scx = Visit.adj scx h in + let sub = Subst.bump sub in + let scx = Visit.adj scx hh in + let sub = Subst.compose (Subst.shift 1) sub in + let scx, sub, hs = spin scx sub hs in + (scx, sub, Deque.cons h (Deque.cons hh hs)) + + | Some (h, hs) -> + let sub, h = subst#hyp sub h in + let scx, h = self#hyp scx h in + let scx, sub, hs = spin scx sub hs in + (scx, sub, Deque.cons h hs) + in + let scx, sub, hs = spin scx (Subst.shift 0) sq.context in + let e = subst#expr sub sq.active in + let e = self#expr scx e in + (scx, { context = hs ; active = e }) +end + +let elim_bounds sq = + let cx = ((), Deque.empty) in + snd (elim_bounds_visitor#sequent cx sq) + + +(* {3 Flex Elimination} *) + +let is_prime s = + let rgx = Str.regexp "#prime$" in + try + let _ = Str.search_forward rgx s 0 in + true + with Not_found -> + false + +let remove_prime s = + let rgx = Str.regexp "#prime$" in + Str.replace_first rgx "" s + +let mk_prime s = + s ^ "_prime" + +let elim_flex_visitor = object (self : 'self) + inherit [unit] Expr.Visit.map as super + + method expr scx oe = + match oe.core with + | Opaque s when is_prime s -> + let s = mk_prime (remove_prime s) in + let n, _ = Option.get (Deque.find ~backwards:true (snd scx) (fun h -> hyp_name h = s)) in + Ix (n + 1) %% [] + | _ -> super#expr scx oe + + (* See the sequent method for elim_bounds_visitor *) + method sequent scx sq = + let rec spin scx sub hs = + match Deque.front hs with + | None -> (scx, sub, Deque.empty) + + | Some ({ core = Flex v } as h, hs) -> + let h1 = Fresh (v, Shape_expr, Constant, Unbounded) @@ h in + let v' = mk_prime v.core %% [] in + let h2 = Fresh (v', Shape_expr, Constant, Unbounded) %% [] in + let scx = Visit.adj scx h1 in + let sub = Subst.bump sub in + let scx = Visit.adj scx h2 in + let sub = Subst.compose (Subst.shift 1) sub in + let scx, sub, hs = spin scx sub hs in + (scx, sub, Deque.cons h1 (Deque.cons h2 hs)) + + | Some (h, hs) -> + let sub, h = subst#hyp sub h in + let scx, h = self#hyp scx h in + let scx, sub, hs = spin scx sub hs in + (scx, sub, Deque.cons h hs) + in + let scx, sub, hs = spin scx (Subst.shift 0) sq.context in + let e = subst#expr sub sq.active in + let e = self#expr scx e in + (scx, { context = hs ; active = e }) +end + +let elim_flex sq = + let cx = ((), Deque.empty) in + snd (elim_flex_visitor#sequent cx sq) + + +(* {3 NotMem Simplification} *) + +let elim_notmem_visitor = object (self : 'self) + inherit [unit] Visit.map as super + + method expr scx oe = + match oe.core with + | Apply ({ core = Internal B.Notmem } as op, [ e ; f ]) -> + let e = self#expr scx e in + let f = self#expr scx f in + Apply (Internal B.Neg %% [], [ + Apply (Internal B.Mem @@ op, [ e ; f ]) %% [] + ]) @@ oe + | _ -> super#expr scx oe +end + +let elim_notmem sq = + let cx = ((), Deque.empty) in + snd (elim_notmem_visitor #sequent cx sq) + + +(* {3 Comparisons Simplification} *) + +let elim_compare_visitor = object (self : 'self) + inherit [unit] Visit.map as super + + method expr scx oe = + match oe.core with + | Apply ({ core = Internal B.Lt } as op, [ e ; f ]) + when not (has op Props.tpars_prop) -> + let e = self#expr scx e in + let f = self#expr scx f in + let neq_op = assign (Internal B.Neq %% []) Props.tpars_prop [ TAtm TAIdv ] in + if has oe Props.icast_prop then + Apply (Internal B.Conj %% [], [ + remove (Apply (Internal B.Lteq @@ op, [ e ; f ]) @@ oe) Props.icast_prop ; + Apply (neq_op, [ e ; f ]) %% [] + ]) %% [] |> fun oe -> + assign oe Props.icast_prop (TAtm TABol) + else + Apply (Internal B.Conj %% [], [ + Apply (Internal B.Lteq @@ op, [ e ; f ]) @@ oe ; + Apply (neq_op, [ e ; f ]) %% [] + ]) %% [] + + | Apply ({ core = Internal B.Gt } as op, [ e ; f ]) + when not (has op Props.tpars_prop) -> + let e = self#expr scx e in + let f = self#expr scx f in + let neq_op = assign (Internal B.Neq %% []) Props.tpars_prop [ TAtm TAIdv ] in + if has oe Props.icast_prop then + Apply (Internal B.Conj %% [], [ + remove (Apply (Internal B.Lteq @@ op, [ f ; e ]) @@ oe) Props.icast_prop ; + Apply (neq_op, [ f ; e ]) %% [] + ]) %% [] |> fun oe -> + assign oe Props.icast_prop (TAtm TABol) + else + Apply (Internal B.Conj %% [], [ + Apply (Internal B.Lteq @@ op, [ f ; e ]) @@ oe ; + Apply (neq_op, [ f ; e ]) %% [] + ]) %% [] + + | Apply ({ core = Internal B.Gteq } as op, [ e ; f ]) + when not (has op Props.tpars_prop) -> + let e = self#expr scx e in + let f = self#expr scx f in + Apply (Internal B.Lteq @@ op, [ f ; e ]) @@ oe + + | _ -> super#expr scx oe +end + +let elim_compare sq = + let cx = ((), Deque.empty) in + snd (elim_compare_visitor #sequent cx sq) + + +(* {3 EXCEPT Elimination} *) + +let elim_except_visitor = object (self : 'self) + inherit [unit] Visit.map as super + + method expr scx oe = + match oe.core with + | Except (e, [ ([d], a as exp) ]) when not (has oe Props.tpars_prop) -> + let e = self#expr scx e in + let exp = self#exspec scx exp in + let d, a = + match exp with + | [Except_dot s], a -> String s %% [], a + | [Except_apply d], a -> d, a + | _ -> failwith "" + in + let b = Apply (Internal B.DOMAIN %% [], [ e ]) %% [] in + let v = assign ("x" %% []) Props.ty0_prop (TAtm TAIdv) in + Fcn ( + [ v, Constant, Domain b ], + If ( + Apply (Internal B.Eq %% [], [ Ix 1 %% [] ; subst#expr (Subst.shift 1) d ]) %% [], + subst#expr (Subst.shift 1) a, + FcnApp (subst#expr (Subst.shift 1) e, [ Ix 1 %% [] ]) %% [] + ) %% [] + ) %% [] + + (* FIXME Cases below are preprocessed away in {!Expr.Elab} *) + + | Except (e, [ d :: ds, a ]) -> + Except (e, [ [d], begin + let app = + match d with + | Except_dot s -> Dot (e, s) %% [] + | Except_apply d -> FcnApp (e, [d]) %% [] + in + Except (app, [ ds, a ]) %% [] + end ]) %% [] |> + self#expr scx + + | Except (e, exs) (* when List.length exs > 1 *) -> + List.fold_left begin fun e exp -> + Except (e, [ exp ]) %% [] + end e exs |> + self#expr scx + + | _ -> super#expr scx oe +end + +let elim_except sq = + let cx = ((), Deque.empty) in + snd (elim_except_visitor #sequent cx sq) + + +(* {3 Multi-arguments Functions Elimination} *) + +let elim_multiarg_visitor = object (self : 'self) + inherit [unit] Visit.map as super + + method expr scx oe = + match oe.core with + | Fcn (bs, e) when List.length bs > 1 && not (has oe Props.tpars_prop) -> + let scx, bs = self#bounds scx bs in + let vs, bs, _ = + List.fold_left begin fun (r_vs, r_bs, dit) (v, _, d) -> + match d, dit with + | Domain b, _ + | Ditto, Some b -> + (v :: r_vs, b :: r_bs, Some b) + | _, _ -> error ~at:oe "Missing bound on Fcn" + end ([], [], None) bs |> + fun (r_vs, r_bs, dit) -> + (List.rev r_vs, List.rev r_bs, dit) + in + let v = assign ("t" %% []) Props.ty0_prop (TAtm TAIdv) in + let b = Product bs %% [] in + let e = self#expr scx e in + let dfs = + List.mapi begin fun i v -> + Operator (v, FcnApp ( + Ix 1 %% [], [ Num (string_of_int (i + 1), "") %% [] ] + ) %% []) %% [] + end vs + in + let e = Let (dfs, e) %% [] in + Fcn ([ v, Constant, Domain b ], e) @@ oe + + | FcnApp (e1, es) when List.length es > 1 && not (has oe Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let es = List.map (self#expr scx) es in + let e2 = Tuple es %% [] in + FcnApp (e1, [ e2 ]) @@ oe + + | _ -> super#expr scx oe +end + +let elim_multiarg sq = + let cx = ((), Deque.empty) in + snd (elim_multiarg_visitor #sequent cx sq) + + +(* {3 Tuples Elimination} *) + +let elim_tuples_visitor = object (self : 'self) + inherit [unit] Visit.map as super + + method expr scx oe = + match oe.core with + | Product es when not (has oe Props.tpars_prop) -> + let es = List.map (self#expr scx) es in + let n = List.length es in + let rg = + Apply ( + Internal B.Range %% [], + [ Num ("1", "") %% [] ; Num (string_of_int n, "") %% [] ] + ) %% [] + in + let e1 = + Arrow ( + rg, + Apply ( + Internal B.UNION %% [], + [ SetEnum es %% [] ] + ) %% [] + ) %% [] + in + let e2 = + List ( + And, + List.mapi begin fun i e -> + Apply ( + Internal B.Mem %% [], + [ + FcnApp (Ix 1 %% [], [ Num (string_of_int (i + 1), "") %% [] ]) %% [] ; + subst#expr (Subst.shift 1) e + ] + ) %% [] + end es + ) %% [] + in + let v = assign ("f" %% []) Props.ty0_prop (TAtm TAIdv) in + SetSt (v, e1, e2) @@ oe + + | Tuple es when not (has oe Props.tpars_prop) -> + let es = List.map (self#expr scx) es in + let n = List.length es in + let b = + Apply ( + Internal B.Range %% [], + [ Num ("1", "") %% [] ; Num (string_of_int n, "") %% [] ] + ) %% [] + in + let e = + Case ( + List.mapi begin fun i e -> + let p = + Apply ( + Internal B.Eq %% [], + [ Ix 1 %% [] ; Num (string_of_int (i + 1), "") %% [] ] + ) %% [] + in + (p, subst#expr (Subst.shift 1) e) + end es, + None + ) %% [] + in + let v = assign ("i" %% []) Props.ty0_prop (TAtm TAIdv) in + Fcn ([ v, Constant, Domain b ], e) @@ oe + + | _ -> super#expr scx oe +end + +let elim_tuples sq = + let cx = ((), Deque.empty) in + snd (elim_tuples_visitor#sequent cx sq) + + +(* {3 Records Elimination} *) + +let elim_records_visitor = object (self : 'self) + inherit [unit] Visit.map as super + + method expr scx oe = + match oe.core with + | Rect fs when not (has oe Props.tpars_prop) -> + let rg = SetEnum (List.map (fun (s, _) -> String s %% []) fs) %% [] in + let im = SetEnum (List.map snd fs) %% [] in + let e1 = Arrow (rg, Apply (Internal B.UNION %% [], [ im ]) %% []) %% [] in + let e2 = + List ( + And, + List.map begin fun (s, e) -> + Apply ( + Internal B.Mem %% [], + [ FcnApp (Ix 1 %% [], [ String s %% [] ]) %% [] + ; subst#expr (Subst.shift 1) e ] + ) %% [] + end fs + ) %% [] + in + let v = assign ("f" %% []) Props.ty0_prop (TAtm TAIdv) in + SetSt (v, e1, e2) @@ oe + + | Record fs when not (has oe Props.tpars_prop) -> + let rg = SetEnum (List.map (fun (s, _) -> String s %% []) fs) %% [] in + let ps = + List.map begin fun (s, e) -> + let p = + Apply ( + Internal B.Eq %% [], + [ Ix 1 %% [] ; String s %% [] ]) %% [] + in + (p, subst#expr (Subst.shift 1) e) + end fs + in + let e = Case (ps, None) %% [] in + let v = assign ("s" %% []) Props.ty0_prop (TAtm TAIdv) in + Fcn ([ v, Constant, Domain rg ], e) @@ oe + + | Dot (e, s) when not (has oe Props.tpars_prop) -> + FcnApp (e, [ String s %% [] ]) @@ oe + + | _ -> super#expr scx oe + + method exspec scx (trail, res) = + let do_trail = function + | Except_dot s -> Except_apply (String s %% []) + | Except_apply e -> Except_apply (self#expr scx e) + in + (List.map do_trail trail, self#expr scx res) + +end + +let elim_records sq = + let cx = ((), Deque.empty) in + snd (elim_records_visitor#sequent cx sq) + + +(* {3 Sort Record Fields} *) + +let cmp_fs (f1, e1) (f2, e2) = + Stdlib.compare f1 f2 + +let sort_recfields_visitor = object (self : 'self) + inherit [unit] Expr.Visit.map as super + + method expr scx oe = + match oe.core with + | Record fs -> Record (List.sort ~cmp:cmp_fs fs) @@ oe + | Rect fs -> Rect (List.sort ~cmp:cmp_fs fs) @@ oe + | _ -> super#expr scx oe +end + +let sort_recfields sq = + let cx = ((), Deque.empty) in + snd (sort_recfields_visitor#sequent cx sq) + + +(* {3 Range Simplification} *) + +let simplify_range_visitor = object (self : 'self) + inherit [unit] Expr.Visit.map as super + + method expr scx oe = + match oe.core with + | Apply ({ core = Internal B.Mem } as op, [ e1 ; { core = Apply ({ core = Internal B.Range } as rg, [ e2 ; e3 ]) } ]) + when not (has op Props.tpars_prop) && not (has rg Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + List (And, + [ Apply (Internal B.Mem %% [], [ e1 ; Internal B.Int %% [] ]) %% [] + ; Apply (Internal B.Lteq %% [], [ e2 ; e1 ]) %% [] + ; Apply (Internal B.Lteq %% [], [ e1 ; e3 ]) %% [] + ]) @@ oe + | _ -> super#expr scx oe +end + +let simplify_range sq = + let cx = ((), Deque.empty) in + snd (simplify_range_visitor#sequent cx sq) + + +(* {3 Apply Extensionnality} *) + +let is_set e = + match e.core with + | SetEnum _ + | SetSt _ + | SetOf _ + | Apply ({ core = Internal (B.Cap | B.Cup | B.Setminus | B.Range) }, [ _ ; _ ]) + | Product _ + | Arrow _ + | Rect _ + | Internal (B.STRING | B.BOOLEAN | B.Nat | B.Int) -> + true + | _ -> + false + +type pol = + | Positive + | Negative + | Neither + +let inv = function + | Positive -> Negative + | Negative -> Positive + | Neither -> Neither + +let rewrite_by_extensionality ?(b=B.Equiv) ty0 e1 e2 = + let ty0, cast = + match ty0 with + | TAtm TAIdv -> + TAtm TAIdv, + fun e -> e + | TSet ty0 -> + ty0, + fun e -> assign e Props.icast_prop ty0 + | _ -> + error "internal error" + in + let v = assign ("x" %% []) Props.ty0_prop ty0 in + + Quant ( + Forall, [ v, Constant, No_domain ], + Apply ( + Internal b %% [], + [ Apply (Internal B.Mem %% [], + [ cast (Ix 1 %% []) + ; subst#expr (Subst.shift 1) e1 ]) %% [] + ; Apply (Internal B.Mem %% [], + [ cast (Ix 1 %% []) + ; subst#expr (Subst.shift 1) e2 ]) %% [] + ]) %% [] + ) + +let rewrite_subseteq = rewrite_by_extensionality ~b:B.Implies + + +let apply_ext_visitor = object (self : 'self) + inherit [pol] Expr.Visit.map as super + + method expr (pol, hx as scx) oe = + match oe.core with + (* x = y + * --> + * \A z : z \in x <=> z \in y *) + | Apply ({ core = Internal B.Eq } as op, [ e ; f ]) + when (pol = Positive) && (match query op Props.tpars_prop with + | Some [TAtm TAIdv] -> is_set e || is_set f + | Some [TSet _] -> true + | _ -> false) -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ty0] -> ty0 + | _ -> error ~at:op "internal error" + in + rewrite_by_extensionality ty0 e f @@ oe + + | Apply ({ core = Internal B.Neq } as op, [ e ; f ]) + when (pol = Negative) && (match query op Props.tpars_prop with + | Some [TAtm TAIdv] -> is_set e || is_set f + | Some [TSet _] -> true + | _ -> false) -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ty0] -> ty0 + | _ -> error ~at:op "internal error" + in + Apply (Internal B.Neg %% [], + [ rewrite_by_extensionality ty0 e f %% [] ]) @@ oe + + (* x \subseteq y + * --> + * \A z : z \in x => z \in y *) + | Apply ({ core = Internal B.Subseteq } as op, [ e ; f ]) + when pol = Positive -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ty0] -> ty0 + | _ -> error ~at:op "internal error" + in + rewrite_subseteq ty0 e f @@ oe + + | Apply ({ core = Internal B.Implies } as op, [ e ; f ]) -> + let e = self#expr (inv pol, hx) e in + let f = self#expr scx f in + Apply (op, [ e ; f ]) @@ oe + + | Apply ({ core = Internal B.Equiv } as op, [ e ; f ]) -> + let e1 = self#expr (inv pol, hx) e in + let f1 = self#expr (pol, hx) f in + let e2 = self#expr (pol, hx) e in + let f2 = self#expr (inv pol, hx) f in + Apply ( + Internal B.Conj @@ op, + [ Apply ( + Internal B.Implies %% [], + [ e1 + ; f1 + ]) %% [] + ; Apply ( + Internal B.Implies %% [], + [ f2 + ; e2 + ]) %% [] + ]) @@ oe + + | Apply ({ core = Internal (B.Conj | B.Disj) } as op, [ e ; f ]) -> + let e = self#expr (pol, hx) e in + let f = self#expr (pol, hx) f in + Apply (op, [ e ; f ]) @@ oe + + | Apply ({ core = Internal B.Neg } as op, [ e ]) -> + let e = self#expr (inv pol, hx) e in + Apply (op, [ e ]) @@ oe + + | Apply (op, es) -> + let es = List.map (self#expr (Neither, hx)) es in + Apply (op, es) @@ oe + + | _ -> super#expr scx oe + + method sequent (pol, hx) sq = + let (_, hx), hs = self#hyps (inv pol, hx) sq.context in + let e = self#expr (pol, hx) sq.active in + (pol, hx), { context = hs ; active = e } +end + +let apply_ext sq = + let cx = (Positive, Deque.empty) in + snd (apply_ext_visitor#sequent cx sq) + + +(* {3 Simplify Sets} *) + +let subst_one a b = + let lam = Lambda ([ "x" %% [], Shape_expr ], a) %% [] in + Subst.normalize lam [b] @@ a + +let simplify_sets_visitor ~disable_arithmetic = object (self : 'self) + inherit [pol] Expr.Visit.map as super + + method expr (pol, hx as scx) oe = + match oe.core with + (* x \in { a1, .., an } + * --> + * x = a1 \/ .. \/ x = an *) + | Apply ({ core = Internal B.Mem } as op, [ e1 ; { core = SetEnum es } as e2 ]) + when not (has op Props.tpars_prop) -> + let n = List.length es in + if n = 0 then + Internal B.FALSE @@ oe + else if n = 1 then + let e1 = self#expr scx e1 in + let es = List.map (self#expr scx) es in + let e2 = + match es with + | [e] -> e $$ e2 + | _ -> error ~at:e2 "Internal error" + in + let eq = assign (Internal B.Eq %% []) Props.tpars_prop [ TAtm TAIdv ] in + Apply (eq, [ e1 ; e2 ]) @@ oe + else + let e1 = self#expr scx e1 in + let es = List.map (self#expr scx) es in + let eq = assign (Internal B.Eq %% []) Props.tpars_prop [ TAtm TAIdv ] in + List (Or, List.map begin fun e2 -> + Apply (eq, [ e1 ; e2 ]) %% [] + end es) @@ e2 + + (* x \in SUBSET a + * --> + * \A y : y \in x => y \in a *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Apply ({ core = Internal B.SUBSET } as op2, [ e2 ]) } ]) + when not (has op1 Props.tpars_prop) && not (has op2 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let v = assign ("v" %% []) Props.ty0_prop (TAtm TAIdv) in + let e = + let e1 = subst#expr (Subst.shift 1) e1 in + let e2 = subst#expr (Subst.shift 1) e2 in + Apply ( + Internal B.Implies %% [], + [ Apply ( + Internal B.Mem %% [], + [ Ix 1 %% [] + ; e1 ] + ) %% [] + ; Apply ( + Internal B.Mem %% [], + [ Ix 1 %% [] + ; e2 ] + ) %% [] ] + ) %% [] + in + Quant (Forall, [ v, Constant, No_domain ], e) @@ oe + + (* x \in UNION a + * --> + * \E y : y \in a /\ x \in y *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Apply ({ core = Internal B.UNION } as op2, [ e2 ]) } ]) + when not (has op1 Props.tpars_prop) && not (has op2 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let v = assign ("v" %% []) Props.ty0_prop (TAtm TAIdv) in + let e = + let e1 = subst#expr (Subst.shift 1) e1 in + let e2 = subst#expr (Subst.shift 1) e2 in + Apply ( + Internal B.Conj %% [], + [ Apply ( + Internal B.Mem %% [], + [ Ix 1 %% [] + ; e2 ] + ) %% [] + ; Apply ( + Internal B.Mem %% [], + [ e1 + ; Ix 1 %% [] ] + ) %% [] ] + ) %% [] + in + Quant (Exists, [ v, Constant, No_domain ], e) @@ oe + + (* x \in a \cup b + * --> + * x \in a \/ x \in b *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Apply ({ core = Internal B.Cup } as op2, [ e2 ; e3 ]) } ]) + when not (has op1 Props.tpars_prop) && not (has op2 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + Apply ( + Internal B.Disj %% [], + [ Apply ( + Internal B.Mem %% [], + [ e1 + ; e2 ] + ) %% [] + ; Apply ( + Internal B.Mem %% [], + [ e1 + ; e3 ] + ) %% [] ] + ) @@ oe + + (* x \in a \cap b + * --> + * x \in a /\ x \in b *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Apply ({ core = Internal B.Cap } as op2, [ e2 ; e3 ]) } ]) + when not (has op1 Props.tpars_prop) && not (has op2 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + Apply ( + Internal B.Conj %% [], + [ Apply ( + Internal B.Mem %% [], + [ e1 + ; e2 ] + ) %% [] + ; Apply ( + Internal B.Mem %% [], + [ e1 + ; e3 ] + ) %% [] ] + ) @@ oe + + (* x \in a \ b + * --> + * x \in a /\ ~ x \in b *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Apply ({ core = Internal B.Setminus } as op2, [ e2 ; e3 ]) } ]) + when not (has op1 Props.tpars_prop) && not (has op2 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + Apply ( + Internal B.Conj %% [], + [ Apply ( + Internal B.Mem %% [], + [ e1 + ; e2 ] + ) %% [] + ; Apply ( + Internal B.Neg %% [], + [ Apply ( + Internal B.Mem %% [], + [ e1 + ; e3 ] + ) %% [] ] + ) %% [] ] + ) @@ oe + + (* x \in { y \in S : P(y) } + * --> + * x \in S /\ P(x) *) + | Apply ({ core = Internal B.Mem } as op, [ e1 ; { core = SetSt (v, e2, e3) } ]) + when not (has op Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let h = Fresh (v, Shape_expr, Constant, Unbounded) %% [] in + let scx' = Expr.Visit.adj scx h in + let e3 = self#expr scx' e3 in + Apply ( + Internal B.Conj %% [], + [ Apply ( + Internal B.Mem %% [], + [ e1 + ; e2 ] + ) %% [] + ; subst_one e3 e1 ] + ) @@ oe + + (* x \in { F(y1, .., yn) : y1 \in a1, .., yn \in an } + * --> + * \E y1, .., yn : y1 \in a1 /\ .. /\ yn \in an /\ x = F(y1, .., yn) *) + | Apply ({ core = Internal B.Mem } as op, [ e1 ; { core = SetOf (e2, bs) } ]) + when not (has op Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let scx', bs = self#bounds scx bs in + let e2 = self#expr scx' e2 in + let bs, ds = + List.fold_left begin fun (r_bs, r_ds, dit) (v, k, dom) -> + match dom, dit with + | Domain d, _ + | Ditto, Some d -> + (v, k, No_domain) :: r_bs, d :: r_ds, Some d + | _ -> + error ~at:v "Missing bound" + end ([], [], None) bs |> + fun (r_bs, r_ds, _) -> + (List.rev r_bs, List.rev r_ds) + in + let eq_op = assign (Internal B.Eq %% []) Props.tpars_prop [ TAtm TAIdv ] in + let n = List.length bs in + Quant ( + Exists, + bs, + List ( + And, + Apply ( + eq_op, + [ subst#expr (Subst.shift n) e1 + ; e2 + ] + ) %% [] :: + List.mapi begin fun i d -> + Apply ( + Internal B.Mem %% [], + [ Ix (i + 1) %% [] + ; subst#expr (Subst.shift n) d + ] + ) %% [] + end ds + ) %% [] + ) @@ oe + + (* x \in [ a -> b ] + * --> + * IsAFcn(x) /\ DOMAIN x = a /\ \A y : y \in a => x[y] \in b *) + (* FIXME This rule inserts an Opaque "IsAFcn" which is recognized later + * during standardization. Careful when modifying! *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Arrow (e2, e3) } ]) + when not (has op1 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + let eq_op = assign (Internal B.Eq %% []) Props.tpars_prop [ TAtm TAIdv ] in + List ( + And, + [ Apply ( + Opaque "IsAFcn" %% [], + [ e1 + ]) %% [] + ; Apply ( + eq_op, + [ Apply ( + Internal B.DOMAIN %% [], + [ e1 + ]) %% [] + ; e2 + ]) %% [] + ; Quant ( + Forall, + [ assign ("x" %% []) Props.ty0_prop (TAtm TAIdv), Constant, No_domain ], + Apply ( + Internal B.Implies %% [], + [ Apply ( + Internal B.Mem %% [], + [ Ix 1 %% [] + ; subst#expr (Subst.shift 1) e2 + ]) %% [] + ; Apply ( + Internal B.Mem %% [], + [ FcnApp ( + subst#expr (Subst.shift 1) e1, + [ Ix 1 %% [] + ]) %% [] + ; subst#expr (Subst.shift 1) e3 + ]) %% [] + ] + ) %% [] + ) %% [] + ]) @@ oe + + (* x \in a1 \X .. \X an + * --> + * x = << x[1], .., x[n] >> /\ x[1] \in a1 /\ .. /\ x[n] \in an *) + | Apply ({ core = Internal B.Mem } as op, [ e1 ; { core = Product es } ]) + when not (has op Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let es = List.map (self#expr scx) es in + let eq_op = assign (Internal B.Eq %% []) Props.tpars_prop [ TAtm TAIdv ] in + let n = List.length es in + let num i = + Num (string_of_int i, "" ) %% [] |> fun e -> + if disable_arithmetic then + e + else + assign (assign e Props.tpars_prop []) Props.icast_prop (TAtm TAInt) + in + List ( + And, + Apply ( + eq_op, + [ e1 + ; Tuple ( + List.init n begin fun i -> + FcnApp (e1, [ num (i + 1) ]) %% [] + end) %% [] + ] + ) %% [] :: + List.mapi begin fun i e -> + Apply ( + Internal B.Mem %% [], + [ FcnApp (e1, [ num (i + 1) ]) %% [] + ; e + ] + ) %% [] + end es + ) @@ oe + + (* x \in [ f1 : a1, .., fn : an ] + * --> + * x = [ f1 |-> x.f1, .., fn |-> x.fn ] /\ x.f1 \in a1 /\ .. /\ x.fn \in an *) + | Apply ({ core = Internal B.Mem } as op, [ e1 ; { core = Rect fs } ]) + when not (has op Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let fs = + List.map begin fun (f, e) -> + (f, self#expr scx e) + end fs + in + let eq_op = assign (Internal B.Eq %% []) Props.tpars_prop [ TAtm TAIdv ] in + List ( + And, + Apply ( + eq_op, + [ e1 + ; Record ( + List.map begin fun (f, _) -> + (f, Dot (e1, f) %% []) + end fs) %% [] + ] + ) %% [] :: + List.map begin fun (f, e) -> + Apply ( + Internal B.Mem %% [], + [ Dot (e1, f) %% [] + ; e + ] + ) %% [] + end fs + ) %% [] + + (* x \in a..b + * --> + * x \in Int /\ a <= x /\ x <= b *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Apply ({ core = Internal B.Range } as op2, [ e2 ; e3 ]) } ]) + when not (has op1 Props.tpars_prop) && not (has op2 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + List ( + And, + [ Apply ( + Internal B.Mem %% [], + [ e1 + ; Internal B.Int %% [] + ]) %% [] + ; Apply ( + Internal B.Lteq %% [], + [ e2 + ; e1 + ]) %% [] + ; Apply ( + Internal B.Lteq %% [], + [ e1 + ; e3 + ]) %% [] + ] + ) @@ oe + + (* x \in Nat + * --> + * x \in Int /\ 0 <= x *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Internal B.Nat } as op2 ]) + when not (has op1 Props.tpars_prop) && not (has op2 Props.tpars_prop) -> + let e1 = self#expr scx e1 in + let zero_op = + if disable_arithmetic then + Num ("0", "") %% [] + else + Num ("0", "") %% [] |> fun e -> + assign e Props.tpars_prop [] |> fun e -> + assign e Props.icast_prop (TAtm TAInt) + in + Apply ( + Internal B.Conj %% [], + [ Apply ( + Internal B.Mem %% [], + [ e1 + ; Internal B.Int %% [] + ]) %% [] + ; Apply ( + Internal B.Lteq %% [], + [ zero_op + ; e1 + ]) %% [] + ]) %% [] + + (* x \in a..b when x, a, b : int + * --> + * a <= x /\ x <= b *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Apply ({ core = Internal B.Range } as op2, [ e2 ; e3 ]) } ]) + when query op2 Props.tpars_prop = Some [] + && ((query op1 Props.tpars_prop = Some [ TAtm TAInt ]) + || (not (has op1 Props.tpars_prop) + && query e1 Props.icast_prop = Some (TAtm TAInt))) -> + let e1 = Property.remove (self#expr scx e1) Props.icast_prop in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + let lteq_op = assign (Internal B.Lteq %% []) Props.tpars_prop [ TAtm TAInt ] in + List ( + And, + [ Apply ( + lteq_op, + [ e2 + ; e1 + ]) %% [] + ; Apply ( + lteq_op, + [ e1 + ; e3 + ]) %% [] + ] + ) @@ oe + + (* x \in Int when x : int + * --> + * TRUE *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Internal B.Int } as op2 ]) + when (query op2 Props.tpars_prop = Some []) + && ((query op1 Props.tpars_prop = Some [ TAtm TAInt ]) + || (not (has op1 Props.tpars_prop) + && query e1 Props.icast_prop = Some (TAtm TAInt))) -> + Internal B.TRUE @@ oe + + (* x \in Nat when x : int + * --> + * 0 <= x *) + | Apply ({ core = Internal B.Mem } as op1, [ e1 ; { core = Internal B.Nat } as op2 ]) + when (query op2 Props.tpars_prop = Some []) + && ((query op1 Props.tpars_prop = Some [ TAtm TAInt ]) + || (not (has op1 Props.tpars_prop) + && query e1 Props.icast_prop = Some (TAtm TAInt))) -> + let e1 = Property.remove (self#expr scx e1) Props.icast_prop in + let lteq_op = assign (Internal B.Lteq %% []) Props.tpars_prop [ TAtm TAInt ] in + let zero_op = assign (Num ("0", "") %% []) Props.tpars_prop [] in + Apply ( + lteq_op, + [ zero_op + ; e1 + ]) @@ oe + + (* x = y + * --> + * \A z : z \in x <=> z \in y *) + | Apply ({ core = Internal B.Eq } as op, [ e ; f ]) + when (pol = Positive) && (match query op Props.tpars_prop with + | Some [TAtm TAIdv] -> is_set e || is_set f + | Some [TSet _] -> true + | _ -> false) -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ty0] -> ty0 + | _ -> error ~at:oe "internal error" + in + rewrite_subseteq ty0 e f @@ oe + + | Apply ({ core = Internal B.Neq } as op, [ e ; f ]) + when (pol = Negative) && (match query op Props.tpars_prop with + | Some [TAtm TAIdv] -> is_set e || is_set f + | Some [TSet _] -> true + | _ -> false) -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ty0] -> ty0 + | _ -> error ~at:oe "internal error" + in + Apply (Internal B.Neg %% [], + [ rewrite_subseteq ty0 e f %% [] ]) @@ oe + + (* x \subseteq y + * --> + * \A z : z \in x => z \in y *) + | Apply ({ core = Internal B.Subseteq } as op, [ e ; f ]) + when pol = Positive -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ty0] -> ty0 + | _ -> error ~at:oe "internal error" + in + rewrite_subseteq ty0 e f @@ oe + + | Apply ({ core = Internal B.Implies } as op, [ e ; f ]) -> + let e = self#expr (inv pol, hx) e in + let f = self#expr scx f in + Apply (op, [ e ; f ]) @@ oe + + | Apply ({ core = Internal B.Equiv } as op, [ e ; f ]) -> + let e1 = self#expr (inv pol, hx) e in + let f1 = self#expr (pol, hx) f in + let e2 = self#expr (pol, hx) e in + let f2 = self#expr (inv pol, hx) f in + Apply ( + Internal B.Conj @@ op, + [ Apply ( + Internal B.Implies %% [], + [ e1 + ; f1 + ]) %% [] + ; Apply ( + Internal B.Implies %% [], + [ f2 + ; e2 + ]) %% [] + ]) @@ oe + + | Apply ({ core = Internal B.Neg } as op, [ e ]) -> + let e = self#expr (inv pol, hx) e in + Apply (op, [ e ]) @@ oe + + | Apply (op, es) -> + let es = List.map (self#expr (Neither, hx)) es in + Apply (op, es) @@ oe + + | _ -> super#expr scx oe + + method sequent (pol, hx) sq = + let (_, hx), hs = self#hyps (inv pol, hx) sq.context in + let e = self#expr (pol, hx) sq.active in + (pol, hx), { context = hs ; active = e } +end + +let rec repeat k f x = + if k = 0 then x + else repeat (k - 1) f (f x) + +let simplify_sets ?(limit=10) ?(rwlvl=2) ~disable_arithmetic sq = + let cx = (Positive, Deque.empty) in + if rwlvl = 0 then sq + else if rwlvl = 1 then + snd (apply_ext_visitor#sequent cx sq) + else + repeat limit begin fun sq -> + let visit = simplify_sets_visitor ~disable_arithmetic in + snd (visit#sequent cx sq) + end sq + diff --git a/src/encode/n_rewrite.mli b/src/encode/n_rewrite.mli new file mode 100644 index 00000000..a2ff858e --- /dev/null +++ b/src/encode/n_rewrite.mli @@ -0,0 +1,55 @@ +(* + * encode/rewrite.mli --- rewrite sequents + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T + +(** Bounds attached to variables (bound or declared) are eliminated + and replaced by a guard. +*) +val elim_bounds : sequent -> sequent + +(** Every [Flex v] replaced by two declarations for [v] and [v'], + with occurrences of [Opaque v'] replaced by an index. +*) +val elim_flex : sequent -> sequent + +(** Simplify NotMem *) +val elim_notmem : sequent -> sequent + +(** Simplify Lt, Gteq and Gt *) +val elim_compare : sequent -> sequent + +(** Reduce EXCEPT-functions to regular functions *) +val elim_except : sequent -> sequent + +(** Reduce functions to one-argument functions (using tuples) *) +val elim_multiarg : sequent -> sequent +(** NOTE: Call before {!elim_tuples}, since this introduces new tuples *) + +(** Reduce tuples to functions *) (* FIXME remove *) +val elim_tuples : sequent -> sequent + +(** Reduce records to functions *) (* FIXME remove *) +val elim_records : sequent -> sequent + +(** Sort fields of records and record sets *) +val sort_recfields : sequent -> sequent + +(** Simplify propositions involving ranges *) +val simplify_range : sequent -> sequent + +(** Apply extensionality axioms to equalities; also simplifies subseteq *) +val apply_ext : sequent -> sequent + +(** Simplify expressions of set theory + @param limit specify the number of times expressions are parsed + @param rwlvl if 0: do nothing; + 1: only simplify set extensionality and subseteq; + 2: simplify all set expressions; +*) +val simplify_sets : ?limit:int -> ?rwlvl:int -> disable_arithmetic:bool -> sequent -> sequent + diff --git a/src/encode/n_rewrite.mlt b/src/encode/n_rewrite.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_rewrite.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_smb.ml b/src/encode/n_smb.ml new file mode 100644 index 00000000..4e096b85 --- /dev/null +++ b/src/encode/n_smb.ml @@ -0,0 +1,75 @@ +(* + * encode/smb.ml --- symbols for expressions in standard form + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Type.T +open Ext +open Property + +open N_table +open N_data + + +(* {3 Symbols} *) + +type smb_kind = N_data.smb_kind + +type smb = + { smb_name : string + ; smb_ty2 : ty2 + ; smb_smb : tla_smb + ; smb_kind : smb_kind + ; smb_tver : tla_smb option + } + +let smb_prop = make "Encode.Smb.smb_prop" + +module SmbOrd = struct + type t = smb + let compare smb1 smb2 = + Stdlib.compare smb1.smb_name smb2.smb_name +end + +module SmbSet = Set.Make (SmbOrd) + +let mk_smb tla_smb = + let dat = get_data tla_smb in + { smb_name = dat.dat_name + ; smb_ty2 = dat.dat_ty2 + ; smb_smb = tla_smb + ; smb_kind = dat.dat_kind + ; smb_tver = dat.dat_tver + } + +let equal_smb smb1 smb2 = + smb1.smb_name = smb2.smb_name + +let get_name smb = smb.smb_name +let get_ty2 smb = smb.smb_ty2 +let get_ty1 smb = downcast_ty1 smb.smb_ty2 +let get_ty0 smb = downcast_ty0 (downcast_ty1 smb.smb_ty2) + +let get_defn smb = smb.smb_smb +let get_kind smb = smb.smb_kind +let get_tdefn smb = Option.get smb.smb_tver + +let get_ord smb = + let ty2 = smb.smb_ty2 in + match safe_downcast_ty1 ty2 with + | None -> 2 + | Some ty1 -> + match safe_downcast_ty0 ty1 with + | None -> 1 + | Some _ -> 0 + + +(* {3 Pretty-printing} *) + +let pp_print_smb ff smb = + Format.fprintf ff "{ %s : %a }" + (get_name smb) + pp_print_ty2 (get_ty2 smb) + diff --git a/src/encode/n_smb.mli b/src/encode/n_smb.mli new file mode 100644 index 00000000..59762828 --- /dev/null +++ b/src/encode/n_smb.mli @@ -0,0 +1,57 @@ +(* + * encode/smb.mli --- symbols for expressions in standard form + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +(** Symbols offer a common representation for TLA+ operators, builtins, and + primitive constructs. Using symbols, every TLA+ expression can be put in + a standard form. An expression in standard form does not contain + primitives that fall outside of first-order logic with second-order + application. (Temporal logic is ignored). + + The principle of this representation is to encode primitive constructs + using symbols. For instance: [a \cup b] is represented by [cup(a, b)], + where [cup] is a symbol. With second-order application, every expression + can be represented as an application: [{ x \in a : P }] may also be written + [setst(a, LAMBDA x : P)] where [setst] is a symbol. +*) + +open Type.T +open Property + +open N_table +open N_data + + +(* {3 Symbols} *) + +type smb_kind = N_data.smb_kind + +type smb + +val smb_prop : smb pfuncs + +module SmbSet : Set.S with type elt = smb + +val mk_smb : tla_smb -> smb + +(** Use this function rather than (=) *) +val equal_smb : smb -> smb -> bool + +val get_name : smb -> string +val get_ty2 : smb -> ty2 +val get_ty1 : smb -> ty1 (** May raise {!Type.T.Invalid_type_downcast} *) +val get_ty0 : smb -> ty0 (** May raise {!Type.T.Invalid_type_downcast} *) +val get_ord : smb -> int + +val get_defn : smb -> tla_smb +val get_kind : smb -> smb_kind +val get_tdefn : smb -> tla_smb (** Raise {!Invalid_argument} is {!get_kind} does not return [Untyped] *) + + +(* {3 Pretty-printing} *) + +val pp_print_smb : Format.formatter -> smb -> unit + diff --git a/src/encode/n_smb.mlt b/src/encode/n_smb.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_smb.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_standardize.ml b/src/encode/n_standardize.ml new file mode 100644 index 00000000..89331f60 --- /dev/null +++ b/src/encode/n_standardize.ml @@ -0,0 +1,487 @@ +(* + * encode/standardize.ml + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Ext +open Property +open Expr.T +open Type.T + +open N_table +open N_smb + +module B = Builtin + + +let error ?at mssg = + let mssg = "Encode.Standardize: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + + +(* {3 Helpers} *) + +let adj scx h = + Expr.Visit.adj scx h + +let mk_opq smb = + let op = Opaque (get_name smb) %% [] in + let op = assign op smb_prop smb in + op + +let err_count = ref 0 + +let is_set e = + match e.core with + | Apply ({ core = Opaque s } as op, _) when has op smb_prop -> + let smb = get op smb_prop in + begin match get_defn smb with + | SetEnum _ | Union | Subset | Cup | Cap | SetMinus | SetSt + | SetOf _ | BoolSet | StrSet | IntSet | NatSet | IntRange | FunSet + | Product _ | RecSet _ | SeqSeq -> + true + | _ -> false + end + | _ -> false + + +(* {3 Main} *) + +(* NOTE This module does not perform type inference, it only works + * from the type annotations it can find. *) + +let visitor = object (self : 'self) + inherit [unit] Expr.Visit.map as super + + method expr scx oe = + if has oe Props.icast_prop then + let ty0 = get oe Props.icast_prop in + let oe = self#expr scx (remove oe Props.icast_prop) in + let smb = mk_smb (Cast ty0) in + let opq = mk_opq smb in + Apply (opq, [ oe ]) %% [] + + else if has oe Props.sproj_prop then + let ty0 = get oe Props.sproj_prop in + let oe = self#expr scx (remove oe Props.sproj_prop) in + let smb = mk_smb (Proj ty0) in + let opq = mk_opq smb in + Apply (opq, [ oe ]) %% [] + + else if has oe Props.bproj_prop then + let ty0 = get oe Props.bproj_prop in + let oe = self#expr scx (remove oe Props.bproj_prop) in + let smb = mk_smb (True ty0) in + let opq = mk_opq smb in + let op = assign (Internal B.Eq %% []) Props.tpars_prop [ ty0 ] in + Apply (op, [ oe ; opq ]) %% [] + else + + begin match oe.core with + + (* FIXME Rewriting may add this special primitive in expressions *) + | Apply ({ core = Opaque "IsAFcn" } as op, [ e ]) -> + let e = self#expr scx e in + let smb = mk_smb FunIsafcn in + let opq = mk_opq smb $$ op in + Apply (opq, [ e ]) @@ oe + + | Opaque s -> + let ty2 = Ty2 ([], TAtm TAIdv) in + let s = "OPAQUE_" ^ s in + let smb = mk_smb (Anon (s, ty2)) in + let opq = mk_opq smb $$ oe in + opq + | Apply ({ core = Opaque s } as op, es) -> + let es = List.map (self#expr scx) es in + let ty1 = Ty1 (List.map (fun _ -> TAtm TAIdv) es, TAtm TAIdv) in + let smb = mk_smb (Anon (s, upcast_ty2 ty1)) in + let opq = mk_opq smb $$ op in + Apply (opq, es) @@ oe + + | Internal (B.TRUE | B.FALSE + | B.Implies | B.Equiv | B.Conj | B.Disj + | B.Neg | B.Eq | B.Neq + | B.Unprimable | B.Irregular) -> + (* Ignored builtins *) + oe + + | Internal b -> + let tla_smb = + match b, query oe Props.tpars_prop with + | Mem, None -> Mem + | Subseteq, None -> SubsetEq + | UNION, None -> Union + | SUBSET, None -> Subset + | Cup, None -> Cup + | Cap, None -> Cap + | Setminus, None -> SetMinus + | BOOLEAN, None -> BoolSet + | STRING, None -> StrSet + | Int, None -> IntSet + | Nat, None -> NatSet + | Plus, None -> IntPlus + | Uminus, None -> IntUminus + | Minus, None -> IntMinus + | Times, None -> IntTimes + | Exp, None -> IntExp + | Quotient, None -> IntQuotient + | Remainder, None -> IntRemainder + | Lteq, None -> IntLteq + | Lt, None -> IntLt + | Gteq, None -> IntGteq + | Gt, None -> IntGt + | Range, None -> IntRange + | DOMAIN, None -> FunDom + | Seq, None -> SeqSeq + | Len, None -> SeqLen + | BSeq, None -> SeqBSeq + | Cat, None -> SeqCat + | Append, None -> SeqAppend + | Head, None -> SeqHead + | Tail, None -> SeqTail + | SubSeq, None -> SeqSubSeq + | SelectSeq, None -> SeqSelectSeq + + | Plus, Some [ TAtm TAInt ] -> TIntPlus + | Uminus, Some [ TAtm TAInt ] -> TIntUminus + | Minus, Some [ TAtm TAInt ] -> TIntMinus + | Times, Some [ TAtm TAInt ] -> TIntTimes + (*| Exp, Some [ TAtm TAInt ] -> TIntExp*) + | Quotient, Some [ ] -> TIntQuotient + | Remainder, Some [ ] -> TIntRemainder + | Lteq, Some [ TAtm TAInt ] -> TIntLteq + | Lt, Some [ TAtm TAInt ] -> TIntLt + | Gteq, Some [ TAtm TAInt ] -> TIntGteq + | Gt, Some [ TAtm TAInt ] -> TIntGt + + | (Plus | Uminus | Minus | Times | Exp | Lteq | Lt | Gteq | Gt), + Some [ TAtm TARel ] -> + error ~at:oe "Real numbers not implemented" + | _, Some _ -> + error ~at:oe "unexpected type annotation" + | _, _ -> + let mssg = "Unexpected builtin '" ^ + B.builtin_to_string b ^ "'" + in + error ~at:oe mssg + in + let smb = mk_smb tla_smb in + mk_opq smb + + | Choose (v, Some dom, e) -> + error ~at:oe "Unsupported bounded choose-expression" + | Choose (v, None, e) -> + let h = Fresh (v, Shape_expr, Constant, Unbounded) %% [] in + let scx = adj scx h in + let e = self#expr scx e in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb Choose in + let opq = mk_opq smb in + Apply (opq, [ Lambda ([ v, Shape_expr ], e) %% [] ]) @@ oe + + | SetEnum es -> + let es = + List.fold_left begin fun (r_es) e -> + let e = self#expr scx e in + (e :: r_es) + end ([]) es |> + fun (r_es) -> (List.rev r_es) + in + if has oe Props.tpars_prop then + error ~at:oe "T1 not implemented" + else + let n = List.length es in + let smb = mk_smb (SetEnum n) in + let opq = mk_opq smb in + Apply (opq, es) @@ oe + + | SetSt (v, e1, e2) -> + let e1 = self#expr scx e1 in + let h = Fresh (v, Shape_expr, Constant, Bounded (e1, Visible)) %% [] in + let scx = adj scx h in + let e2 = self#expr scx e2 in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb SetSt in + let opq = mk_opq smb in + Apply (opq, [ e1 ; Lambda ([ v, Shape_expr ], e2) %% [] ]) %% [] + + | SetOf (e, bs) -> + let scx, bs = self#bounds scx bs in + let e = self#expr scx e in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let n = List.length bs in + let smb = mk_smb (SetOf n) in + let opq = mk_opq smb in + let ds, bs = + List.fold_left begin fun (r_ds, r_bs, last) (v, _, dom) -> + match dom, last with + | Domain d, _ + | Ditto, Some d -> + (d :: r_ds, (v, Shape_expr) :: r_bs, Some d) + | _, _ -> + error ~at:v "Missing domain on bound" + end ([], [], None) bs |> + fun (r_ds, r_bs, _) -> + (List.rev r_ds, List.rev r_bs) + in + Apply (opq, (ds @ [ Lambda (bs, e) %% [] ])) %% [] + + | String str -> + let smb = mk_smb (StrLit str) in + let opq = mk_opq smb in + opq + + | Num (m, "") -> + if has oe Props.tpars_prop then + let n = int_of_string m in + let smb = mk_smb (TIntLit n) in + let opq = mk_opq smb in + opq + else + let n = int_of_string m in + let smb = mk_smb (IntLit n) in + let opq = mk_opq smb in + opq + + | Arrow (e1, e2) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb FunSet in + let opq = mk_opq smb in + Apply (opq, [ e1 ; e2 ]) %% [] + + | Fcn (bs, _) when List.length bs <> 1 -> + error ~at:oe "Unsupported multi-arguments function" + | Fcn ([ v, Constant, Domain (e1) ], e2) -> + let e1 = self#expr scx e1 in + let h = Fresh (v, Shape_expr, Constant, Bounded (e1, Visible)) %% [] in + let scx = adj scx h in + let e2 = self#expr scx e2 in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb FunConstr in + let opq = mk_opq smb in + Apply (opq, [ e1 ; Lambda ([ v, Shape_expr ], e2) %% [] ]) %% [] + + | FcnApp (_, es) when List.length es <> 1 -> + error ~at:oe "Unsupported multi-arguments application" + | FcnApp (e1, [ e2 ]) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb FunApp in + let opq = mk_opq smb in + Apply (opq, [ e1 ; e2 ]) %% [] + + | Except (e1, [ [ Except_apply e2 ], e3 ]) -> + let e1 = self#expr scx e1 in + let e2 = self#expr scx e2 in + let e3 = self#expr scx e3 in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb FunExcept in + let opq = mk_opq smb in + Apply (opq, [ e1 ; e2 ; e3 ]) %% [] + | Except (e1, [ [ Except_dot s ], e3 ]) -> + let e1 = self#expr scx e1 in + let e3 = self#expr scx e3 in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb FunExcept in + let opq = mk_opq smb in + let strlit = mk_smb (StrLit s) in + let strlit_opq = mk_opq strlit in + Apply (opq, [ e1 ; strlit_opq ; e3 ]) %% [] + + | Except _ -> + error ~at:oe "Unsupported EXCEPT expression" + + | Tuple es -> + let es = List.map (self#expr scx) es in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let n = List.length es in + let smb = mk_smb (Tuple n) in + let opq = mk_opq smb in + Apply (opq, es) %% [] + + | Product es -> + let es = List.map (self#expr scx) es in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let n = List.length es in + let smb = mk_smb (Product n) in + let opq = mk_opq smb in + Apply (opq, es) %% [] + + | Record fs -> + let fs = List.map (fun (f, e) -> (f, self#expr scx e)) fs in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let fs, es = List.split fs in + let smb = mk_smb (Rec fs) in + let opq = mk_opq smb in + Apply (opq, es) %% [] + + | Rect fs -> + let fs = List.map (fun (f, e) -> (f, self#expr scx e)) fs in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let fs, es = List.split fs in + let smb = mk_smb (RecSet fs) in + let opq = mk_opq smb in + Apply (opq, es) %% [] + + | Dot (e, s) -> + let e = self#expr scx e in + if has oe Props.tpars_prop then + error ~at:oe "unexpected type annotation" + else + let smb = mk_smb FunApp in + let opq = mk_opq smb in + let strlit = mk_smb (StrLit s) in + let strlit_opq = mk_opq strlit in + Apply (opq, [ e ; strlit_opq ]) %% [] + + | Case (ps, None) -> + let ps = + List.map begin fun (p, e) -> + (self#expr scx p, self#expr scx e) + end ps + in + let ty0 = + match get oe Props.tpars_prop with + | [ ty0 ] -> ty0 + | _ -> error ~at:oe "Bad type annotation" + in + incr err_count; + let err = "incomplete_case_error_" ^ string_of_int !err_count in + let smb = mk_smb (Anon (err, Ty2 ([], ty0))) in + let opq = mk_opq smb in + Case (ps, Some opq) @@ oe + + | _ -> super#expr scx oe + + end |> + map_pats (List.map (self#expr scx)) + + method hyp scx h = + match h.core with + | Defn (_, _, Hidden, _) + | Fact (_, Hidden, _) -> + let scx = adj scx h in + (scx, h) + | _ -> super#hyp scx h + +end + + +(* For SMT, we also replace equalities by uninterpreted symbols to permit + additional trigger instantiations *) + +type pol = + | Positive + | Negative + | Neither + +let inv = function + | Positive -> Negative + | Negative -> Positive + | Neither -> Neither + +let set_extensionality_visitor = object (self : 'self) + inherit [pol] Expr.Visit.map as super + + method expr (pol, hx as scx) oe = + match oe.core with + | Apply ({ core = Internal B.Eq } as op, [ e ; f ]) + when ((pol = Positive) || (pol = Neither)) + && (match query op Props.tpars_prop with + | Some [ TSet _ ] -> true + | _ -> is_set e || is_set f) -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ TSet ty0 ] -> TSet ty0 + | _ -> TSet (TAtm TAIdv) + in + let smb = mk_smb (ExtTrigEq ty0) in + let opq = mk_opq smb $$ op in + Apply (opq, [ e ; f ]) @@ oe + + | Apply ({ core = Internal B.Neq } as op, [ e ; f ]) + when ((pol = Negative) || (pol = Neither)) + && (match query op Props.tpars_prop with + | Some [ TSet _ ] -> true + | _ -> is_set e || is_set f) -> + let e = self#expr scx e in + let f = self#expr scx f in + let ty0 = + match query op Props.tpars_prop with + | Some [ TSet ty0 ] -> TSet ty0 + | _ -> TSet (TAtm TAIdv) + in + let smb = mk_smb (ExtTrigEq ty0) in + let opq = mk_opq smb $$ op in + Apply (Internal B.Neg %% [], + [ Apply (opq, [ e ; f ]) %% [] ]) @@ oe + + | Apply ({ core = Internal B.Implies } as op, [ e ; f ]) -> + let e = self#expr (inv pol, hx) e in + let f = self#expr scx f in + Apply (op, [ e ; f ]) @@ oe + + | Apply ({ core = Internal (B.Conj | B.Disj) } as op, [ e ; f ]) -> + let e = self#expr (pol, hx) e in + let f = self#expr (pol, hx) f in + Apply (op, [ e ; f ]) @@ oe + + | Apply ({ core = Internal B.Neg } as op, [ e ]) -> + let e = self#expr (inv pol, hx) e in + Apply (op, [ e ]) @@ oe + + | Apply (op, es) -> + let es = List.map (self#expr (Neither, hx)) es in + Apply (op, es) @@ oe + + | _ -> super#expr scx oe + + method sequent (pol, hx) sq = + let (_, hx), hs = self#hyps (inv pol, hx) sq.context in + let e = self#expr (pol, hx) sq.active in + (pol, hx), { context = hs ; active = e } +end + + +let main ?(smt_set_extensionality=false) sq = + let cx = ((), Deque.empty) in + let _, sq = visitor#sequent cx sq in + + if smt_set_extensionality then + snd (set_extensionality_visitor#sequent (Positive, Deque.empty) sq) + else + sq + diff --git a/src/encode/n_standardize.mli b/src/encode/n_standardize.mli new file mode 100644 index 00000000..669039c7 --- /dev/null +++ b/src/encode/n_standardize.mli @@ -0,0 +1,42 @@ +(* + * encode/standardize.mli + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open Type.T + +(** This module removes all builtins and other TLA+ primitives from + expressions. All primitives are replaced by constants or operators + with special annotations on them. + + For instance, the arithmetic expression: + [m + n] + put in standard form becomes: + [plus(m, n)] + + The new constants are opaque expressions with {!Smb.smb_prop} annotations + on them. Type annotations are interpreted to disambiguate expressions. + For instance, the [plus] operator will be addition on [int] only if a [int] + annotation was attached to [+]. If not, it will be uninterpreted addition. + This module is intended to be used after {!Type.Reconstruct}. + + Using second-order applications, all primitives can be put in standard + form. For instance, set comprehension: + [{ x \in s : p }] + becomes: + [setst(s, LAMBDA x : p)] + + The primitives that are ignored by this module are: all boolean primitives + (in the liberal interpretation, they will always be interpreted in the + traditional way); temporal logic operators; builtins Unprimable and + Irregular. +*) + + +(* {3 Main} *) + +val main : ?smt_set_extensionality:bool -> sequent -> sequent + diff --git a/src/encode/n_standardize.mlt b/src/encode/n_standardize.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_standardize.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_subst.ml b/src/encode/n_subst.ml new file mode 100644 index 00000000..9d8eada9 --- /dev/null +++ b/src/encode/n_subst.ml @@ -0,0 +1,27 @@ +(* + * encode/subst.ml --- expressions (substitution) + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Property +open Expr.T +open Expr.Subst + +class map_encode = object (self: 'self) + inherit map as super + + method expr scx oe = + begin + match oe.core with + | Apply (op, []) -> + self#expr scx op $$ oe + | _ -> + super#expr scx oe + + end |> map_pats (List.map (self#expr scx)) + +end + +let subst = new map_encode diff --git a/src/encode/n_subst.mli b/src/encode/n_subst.mli new file mode 100644 index 00000000..3358f73d --- /dev/null +++ b/src/encode/n_subst.mli @@ -0,0 +1,16 @@ +(* + * encode/subst.ml --- substitutions + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open Expr.Subst + +(** A modified version of substitution for the {!Encode} package *) +val subst : map +(** Substitutions are applied to SMT patterns. + Applications to 0 arguments are normalized in such a way that annotations + are no longer discarded. + *) diff --git a/src/encode/n_subst.mlt b/src/encode/n_subst.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_subst.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/encode/n_table.ml b/src/encode/n_table.ml new file mode 100644 index 00000000..2354b528 --- /dev/null +++ b/src/encode/n_table.ml @@ -0,0 +1,438 @@ +(* + * encode/table.ml --- table of symbols and axioms used to encode POs + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Type.T + + +type tla_smb = + (* UNTYPED *) + (* Logic *) + | Choose + (* Set Theory *) + | Mem + | SubsetEq + | SetEnum of int + | Add (* unused *) + | Union + | Subset + | Cup + | Cap + | SetMinus + | SetSt + | SetOf of int + (* Booleans *) + | BoolSet + (* Strings *) + | StrSet + | StrLit of string + (* Arithmetic *) + | IntSet + | NatSet + | IntLit of int + | IntPlus + | IntUminus + | IntMinus + | IntTimes + | IntQuotient + | IntRemainder + | IntExp + | IntLteq + | IntLt + | IntGteq + | IntGt + | IntRange + (* Functions *) + | FunIsafcn + | FunSet + | FunConstr + | FunDom + | FunIm + | FunApp + | FunExcept + (* Tuples *) + | Tuple of int + | Product of int + (* Records *) + | Rec of string list + | RecSet of string list + (* Sequences *) + | SeqSeq + | SeqLen + | SeqBSeq + | SeqCat + | SeqAppend + | SeqHead + | SeqTail + | SeqSubSeq + | SeqSelectSeq + (* Finite Sets *) + | FSIsFiniteSet + | FSCard + + (* TYPED *) + (* Arithmetic *) + | TIntLit of int + | TIntPlus + | TIntUminus + | TIntMinus + | TIntTimes + | TIntQuotient + | TIntRemainder + (*| TIntExp*) + | TIntLteq + | TIntLt + | TIntGteq + | TIntGt + (* Finite Sets *) + | TFSCard of ty + | TFSMem of ty + | TFSSubseteq of ty + | TFSEmpty of ty + | TFSSingleton of ty + | TFSAdd of ty + | TFSCup of ty + | TFSCap of ty + | TFSSetminus of ty + + (* SPECIAL *) + | Cast of ty + | Proj of ty + | True of ty + | Anon of string * ty2 + | ExtTrigEq of ty + | ExtTrig + | IsSetOf + +type tla_axm = + (* UNTYPED *) + (* Logic *) + | ChooseDef + | ChooseExt + (* Set Theory *) + | SetExt + | SubsetEqDef + | SubsetEqIntro + | SubsetEqElim + | EnumDef of int + | EnumDefIntro of int + | EnumDefElim of int + | UnionDef + | UnionIntro + | UnionElim + | SubsetDef + | SubsetDefAlt + | SubsetIntro + | SubsetElim + | CupDef + | CapDef + | SetMinusDef + | SetStDef + | SetOfDef of int + | SetOfIntro of int + | SetOfElim of int + (* Strings *) + | StrLitIsstr of string + | StrLitDistinct of string * string + (* Arithmetic *) + | IntLitIsint of int + | IntLitDistinct of int * int + | IntLitZeroCmp of int + | NatSetDef + | IntPlusTyping + | IntUminusTyping + | IntMinusTyping + | IntTimesTyping + | IntQuotientTyping + | IntRemainderTyping + | IntExpTyping + | NatPlusTyping + | NatTimesTyping + | IntRangeDef + | NonNegIsPos + | LteqReflexive + | LteqTransitive + | LteqAntisym + (* Functions *) + | FunExt + | FunConstrIsafcn + | FunSetDef + | FunSetIntro + | FunSetElim1 + | FunSetElim2 + | FunSetImIntro + | FunSetSubs + | FunDomDef + | FunAppDef + | FunTyping + | FunExceptIsafcn + | FunExceptDomDef + | FunExceptAppDef1 + | FunExceptAppDef2 + | FunExceptTyping + | FunImDef + | FunImIntro + | FunImElim + (* Tuples *) + | TupIsafcn of int + | TupDomDef of int + | TupAppDef of int + | TupExcept of int * int + | ProductDef of int + | ProductIntro of int + | ProductElim of int + (* Records *) + | RecIsafcn of string list + | RecDomDef of string list + | RecAppDef of string list + | RecExcept of string list * int + | RecSetDef of string list + | RecSetIntro of string list + | RecSetElim of string list + (* Sequences *) + | SeqSetIntro + | SeqSetElim1 + | SeqSetElim2 + | SeqLenDef + | SeqCatTyping + | SeqCatLen + | SeqCatApp1 + | SeqCatApp2 + | SeqAppendTyping + | SeqAppendLen + | SeqAppendApp1 + | SeqAppendApp2 + | SeqHeadDef + | SeqTailTyping + | SeqTailLen + | SeqTailApp + | SeqSubseqTyping + | SeqSubseqLen + | SeqSubseqApp + | SeqSelectseqTyping + | SeqSelectseqLen + | SeqSelectseqNil + | SeqSelectseqApp + | SeqSelectseqAppend + | SeqTupTyping of int + | SeqTupLen of int + + (* SPECIAL *) + | CastInj of ty + | CastInjAlt of ty + | TypeGuard of ty + | TypeGuardIntro of ty + | TypeGuardElim of ty + | Typing of tla_smb (** Only for typed symbols *) + | ExtTrigEqDef of ty + | ExtTrigEqTrigger of ty + | DisjointTrigger + | EmptyComprehensionTrigger + | AssertIsSetOf of int + | CompareSetOfTrigger + | ExtTrigEqCardPropagate + + +let tla_smb_desc = function + | Choose -> "Choose" + | Mem -> "Mem" + | SubsetEq -> "SubsetEq" + | SetEnum n -> Format.sprintf "SetEnum %d" n + | Add -> "Add" + | Union -> "Union" + | Subset -> "Subset" + | Cup -> "Cup" + | Cap -> "Cap" + | SetMinus -> "SetMinus" + | SetSt -> "SetSt" + | SetOf n -> Format.sprintf "SetOf %d" n + | BoolSet -> "BoolSet" + | StrSet -> "StrSet" + | StrLit s -> Format.sprintf "StrLit %s" s + | IntSet -> "IntSet" + | NatSet -> "NatSet" + | IntLit n -> Format.sprintf "IntLit %d" n + | IntPlus -> "IntPlus" + | IntUminus -> "IntUminus" + | IntMinus -> "IntMinus" + | IntTimes -> "IntTimes" + | IntQuotient -> "IntQuotient" + | IntRemainder -> "IntRemainder" + | IntExp -> "IntExp" + | IntLteq -> "IntLteq" + | IntLt -> "IntLt" + | IntGteq -> "IntGteq" + | IntGt -> "IntGt" + | IntRange -> "IntRange" + | FunIsafcn -> "FunIsafcn" + | FunSet -> "FunSet" + | FunConstr -> "FunConstr" + | FunDom -> "FunDom" + | FunIm -> "FunIm" + | FunApp -> "FunApp" + | FunExcept -> "FunExcept" + | Tuple n -> Format.sprintf "Tuple %d" n + | Product n -> Format.sprintf "Product %d" n + | Rec fs -> String.concat " " ("Rec" :: fs) + | RecSet fs -> String.concat " " ("RecSet" :: fs) + | SeqSeq -> "SeqSeq" + | SeqLen -> "SeqLen" + | SeqBSeq -> "SeqBSeq" + | SeqCat -> "SeqCat" + | SeqAppend -> "SeqAppend" + | SeqHead -> "SeqHead" + | SeqTail -> "SeqTail" + | SeqSubSeq -> "SeqSubSeq" + | SeqSelectSeq -> "SeqSelectSeq" + | FSIsFiniteSet -> "FSIsFiniteSet" + | FSCard -> "FSCard" + | TIntLit n -> Format.sprintf "TIntLit %d" n + | TIntPlus -> "TIntPlus" + | TIntUminus -> "TIntUminus" + | TIntMinus -> "TIntMinus" + | TIntTimes -> "TIntTimes" + | TIntQuotient -> "TIntQuotient" + | TIntRemainder -> "TIntRemainder" + (*| TIntExp -> "TIntExp"*) + | TIntLteq -> "TIntLteq" + | TIntLt -> "TIntLt" + | TIntGteq -> "TIntGteq" + | TIntGt -> "TIntGt" + | TFSCard s -> "TFSCard_" ^ ty_to_string s + | TFSMem s -> "TFSMem_" ^ ty_to_string s + | TFSSubseteq s -> "TFSSubseteq_" ^ ty_to_string s + | TFSEmpty s -> "TFSEmpty_" ^ ty_to_string s + | TFSSingleton s -> "TFSSingleton_" ^ ty_to_string s + | TFSAdd s -> "TFSAdd_" ^ ty_to_string s + | TFSCup s -> "TFSCup_" ^ ty_to_string s + | TFSCap s -> "TFSCap_" ^ ty_to_string s + | TFSSetminus s -> "TFSSetminus_" ^ ty_to_string s + | Cast ty -> "Cast " ^ ty_to_string ty + | Proj ty -> "Proj " ^ ty_to_string ty + | True ty -> "True" ^ ty_to_string ty + | Anon (s, ty2) -> "Anon " ^ s ^ " " ^ ty2_to_string ty2 + | ExtTrigEq ty -> "ExtTrigEq " ^ ty_to_string ty + | ExtTrig -> "ExtTrig" + | IsSetOf -> "IsSetOf" + +let axm_desc = function + | ChooseDef -> "ChooseDef" + | ChooseExt -> "ChooseExt" + | SetExt -> "SetExt" + | SubsetEqDef -> "SubsetEqDef" + | SubsetEqIntro -> "SubsetEqIntro" + | SubsetEqElim -> "SubsetEqElim" + | EnumDef n -> Format.sprintf "EnumDef %d" n + | EnumDefIntro n -> Format.sprintf "EnumDefIntro %d" n + | EnumDefElim n -> Format.sprintf "EnumDefElim %d" n + | UnionDef -> "UnionDef" + | UnionIntro -> "UnionIntro" + | UnionElim -> "UnionElim" + | SubsetDef -> "SubsetDef" + | SubsetDefAlt -> "SubsetDefAlt" + | SubsetIntro -> "SubsetIntro" + | SubsetElim -> "SubsetElim" + | CupDef -> "CupDef" + | CapDef -> "CapDef" + | SetMinusDef -> "SetMinusDef" + | SetStDef -> "SetStDef" + | SetOfDef n -> Format.sprintf "SetOfDef %d" n + | SetOfIntro n -> Format.sprintf "SetOfIntro %d" n + | SetOfElim n -> Format.sprintf "SetOfElim %d" n + | StrLitIsstr s -> Format.sprintf "StrLitIsstr %s" s + | StrLitDistinct (s1, s2) -> Format.sprintf "StrLitDistinct %s %s" s1 s2 + | IntLitIsint n -> Format.sprintf "IntLitIsint %d" n + | IntLitDistinct (n1, n2) -> Format.sprintf "IntLitDistinct %d %d" n1 n2 + | IntLitZeroCmp n -> Format.sprintf "IntLitZeroCmp %d" n + | NatSetDef -> "NatSetDef" + | IntPlusTyping -> "IntPlusTyping" + | IntUminusTyping -> "IntUminusTyping" + | IntMinusTyping -> "IntMinusTyping" + | IntTimesTyping -> "IntTimesTyping" + | IntQuotientTyping -> "IntQuotientTyping" + | IntRemainderTyping -> "IntRemainderTyping" + | IntExpTyping -> "IntExpTyping" + | NatPlusTyping -> "NatPlusTyping" + | NatTimesTyping -> "NatTimesTyping" + | IntRangeDef -> "IntRangeDef" + | NonNegIsPos -> "NonNegIsPos" + | LteqReflexive -> "LteqReflexive" + | LteqTransitive -> "LteqTransitive" + | LteqAntisym -> "LteqAntisym" + | FunExt -> "FunExt" + | FunConstrIsafcn -> "FunConstrIsafcn" + | FunSetDef -> "FunSetDef" + | FunSetIntro -> "FunSetIntro" + | FunSetElim1 -> "FunSetElim1" + | FunSetElim2 -> "FunSetElim2" + | FunSetImIntro -> "FunSetImIntro" + | FunSetSubs -> "FunSetSubs" + | FunDomDef -> "FunDomDef" + | FunAppDef -> "FunAppDef" + | FunTyping -> "FunTyping" + | FunExceptIsafcn -> "FunExceptIsafcn" + | FunExceptDomDef -> "FunExceptDomDef" + | FunExceptAppDef1 -> "FunExceptAppDef1" + | FunExceptAppDef2 -> "FunExceptAppDef2" + | FunExceptTyping -> "FunExceptTyping" + | FunImDef -> "FunImDef" + | FunImIntro -> "FunImIntro" + | FunImElim -> "FunImElim" + | TupIsafcn n -> Format.sprintf "TupIsafcn %d" n + | TupDomDef n -> Format.sprintf "TupDomDef %d" n + | TupAppDef n -> Format.sprintf "TupAppDef %d" n + | TupExcept (n, i) -> Format.sprintf "TupExcept %d %d" n i + | ProductDef n -> Format.sprintf "ProductDef %d" n + | ProductIntro n -> Format.sprintf "ProductIntro %d" n + | ProductElim n -> Format.sprintf "ProductElim %d" n + | RecIsafcn fs -> String.concat " " ( "RecIsafcn" :: fs ) + | RecDomDef fs -> String.concat " " ( "RecDomDef" :: fs ) + | RecAppDef fs -> String.concat " " ( "RecAppDef" :: fs ) + | RecExcept (fs, i) -> String.concat " " ( "RecExcept" :: (fs @ [ string_of_int i ])) + | RecSetDef fs -> String.concat " " ( "RecSetDef" :: fs ) + | RecSetIntro fs -> String.concat " " ( "RecSetIntro" :: fs ) + | RecSetElim fs -> String.concat " " ( "RecSetElim" :: fs ) + | SeqSetIntro -> "SeqSetIntro" + | SeqSetElim1 -> "SetSetElim1" + | SeqSetElim2 -> "SetSetElim2" + | SeqLenDef -> "SeqLenDef" + | SeqCatTyping -> "SeqCatTyping" + | SeqCatLen -> "SeqCatLen" + | SeqCatApp1 -> "SeqCatApp1" + | SeqCatApp2 -> "SeqCatApp2" + | SeqAppendTyping -> "SeqAppendTyping" + | SeqAppendLen -> "SeqAppendLen" + | SeqAppendApp1 -> "SeqAppendApp1" + | SeqAppendApp2 -> "SeqAppendApp2" + | SeqHeadDef -> "SeqHeadDef" + | SeqTailTyping -> "SeqTailTyping" + | SeqTailLen -> "SeqTailLen" + | SeqTailApp -> "SeqTailApp" + | SeqSubseqTyping -> "SeqSubseqTyping" + | SeqSubseqLen -> "SeqSubseqLen" + | SeqSubseqApp -> "SeqSubseqApp" + | SeqSelectseqTyping -> "SeqSelectseqTyping" + | SeqSelectseqLen -> "SeqSelectseqLen" + | SeqSelectseqNil -> "SeqSelectseqNil" + | SeqSelectseqApp -> "SeqSelectseqApp" + | SeqSelectseqAppend -> "SeqSelectseqAppend" + | SeqTupTyping n -> Format.sprintf "SeqTupTyping %d" n + | SeqTupLen n -> Format.sprintf "SeqTupLen %d" n + + | CastInj ty -> "CastInj " ^ ty_to_string ty + | CastInjAlt ty -> "CastInjAlt " ^ ty_to_string ty + | TypeGuard ty -> "TypeGuard " ^ ty_to_string ty + | TypeGuardIntro ty -> "TypeGuardIntro " ^ ty_to_string ty + | TypeGuardElim ty -> "TypeGuardElim " ^ ty_to_string ty + | Typing tla_smb -> "Typing " ^ tla_smb_desc tla_smb + | ExtTrigEqDef ty -> "ExtTrigEqDef " ^ ty_to_string ty + | ExtTrigEqTrigger ty -> "ExtTrigEqTrigger " ^ ty_to_string ty + | DisjointTrigger -> "DisjointTrigger" + | EmptyComprehensionTrigger -> "EmptyComprehensionTrigger" + | AssertIsSetOf n -> Format.sprintf "AssertIsSetOf %d" n + | CompareSetOfTrigger -> "CompareSetOfTrigger" + | ExtTrigEqCardPropagate -> "ExtTrigEqCardPropagate" + diff --git a/src/encode/n_table.mli b/src/encode/n_table.mli new file mode 100644 index 00000000..13c64700 --- /dev/null +++ b/src/encode/n_table.mli @@ -0,0 +1,265 @@ +(* + * encode/table.mli --- table of symbols and axioms used to encode POs + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Type.T + +(** Inventory of all special operators that the encodings of TLA+ use to + translate expressions. + The backends that use the relevant encodings are: SMT, Zipper. + + This module was created because {!Builtin} doesn't include everthing. + Not included in {!Builtin} are: + - Second-order operators, like set-comprehension, CHOOSE... + - Invisible operators, like isafcn; + - Variants of the builtin operators with different types. For instance, + the '+' of TLA+ may have to be translated as a '+ : int * int -> int' + or a '+ : U * U -> U' (where 'U' is the universe of ZFC), depending + on the backend/context. +*) + + +(** Abstract type for builtin symbols. The list is divided into three parts: + - _UNTYPED_: The standard operators of TLA+; + - _TYPED_: Variants of the standard operators with types; + - _SPECIAL_: Others +*) +type tla_smb = + (* UNTYPED *) + (* Logic *) + | Choose + (* Set Theory *) + | Mem + | SubsetEq + | SetEnum of int + | Add (* unused *) + | Union + | Subset + | Cup + | Cap + | SetMinus + | SetSt + | SetOf of int + (* Booleans *) + | BoolSet + (* Strings *) + | StrSet + | StrLit of string + (* Arithmetic *) + | IntSet + | NatSet + | IntLit of int + | IntPlus + | IntUminus + | IntMinus + | IntTimes + | IntQuotient + | IntRemainder + | IntExp + | IntLteq + | IntLt + | IntGteq + | IntGt + | IntRange + (* Functions *) + | FunIsafcn + | FunSet + | FunConstr + | FunDom + | FunIm + | FunApp + | FunExcept + (* Tuples *) + | Tuple of int + | Product of int + (* Records *) + | Rec of string list + | RecSet of string list + (* Sequences *) + | SeqSeq + | SeqLen + | SeqBSeq + | SeqCat + | SeqAppend + | SeqHead + | SeqTail + | SeqSubSeq + | SeqSelectSeq + (* Finite Sets *) + | FSIsFiniteSet + | FSCard + + (* TYPED *) + (* Arithmetic *) + | TIntLit of int + | TIntPlus + | TIntUminus + | TIntMinus + | TIntTimes + | TIntQuotient + | TIntRemainder + (*| TIntExp*) (* disabled; no ^ in SMT-LIB *) + | TIntLteq + | TIntLt + | TIntGteq + | TIntGt + (* Finite Sets *) + | TFSCard of ty + | TFSMem of ty + | TFSSubseteq of ty + | TFSEmpty of ty + | TFSSingleton of ty + | TFSAdd of ty + | TFSCup of ty + | TFSCap of ty + | TFSSetminus of ty + + (* SPECIAL *) + | Cast of ty + | Proj of ty + | True of ty + | Anon of string * ty2 + | ExtTrigEq of ty + | ExtTrig + | IsSetOf + +(** Inventory of the axioms that may be used in the Zipperposition encoding. *) +type tla_axm = + (* UNTYPED *) + (* Logic *) + | ChooseDef + | ChooseExt + (* Set Theory *) + | SetExt + | SubsetEqDef + | SubsetEqIntro + | SubsetEqElim + | EnumDef of int + | EnumDefIntro of int + | EnumDefElim of int + | UnionDef + | UnionIntro + | UnionElim + | SubsetDef + | SubsetDefAlt + | SubsetIntro + | SubsetElim + | CupDef + | CapDef + | SetMinusDef + | SetStDef + | SetOfDef of int + | SetOfIntro of int + | SetOfElim of int + (* Strings *) + | StrLitIsstr of string + | StrLitDistinct of string * string + (* Arithmetic *) + | IntLitIsint of int + | IntLitDistinct of int * int + | IntLitZeroCmp of int + | NatSetDef + | IntPlusTyping + | IntUminusTyping + | IntMinusTyping + | IntTimesTyping + | IntQuotientTyping + | IntRemainderTyping + | IntExpTyping + | NatPlusTyping + | NatTimesTyping + | IntRangeDef + | NonNegIsPos + | LteqReflexive + | LteqTransitive + | LteqAntisym + (* Functions *) + | FunExt + | FunConstrIsafcn + | FunSetDef + | FunSetIntro + | FunSetElim1 + | FunSetElim2 + | FunSetImIntro + | FunSetSubs + | FunDomDef + | FunAppDef + | FunTyping + | FunExceptIsafcn + | FunExceptDomDef + | FunExceptAppDef1 + | FunExceptAppDef2 + | FunExceptTyping + | FunImDef + | FunImIntro + | FunImElim + (* Tuples *) + | TupIsafcn of int + | TupDomDef of int + | TupAppDef of int + | TupExcept of int * int + | ProductDef of int + | ProductIntro of int + | ProductElim of int + (* Records *) + | RecIsafcn of string list + | RecDomDef of string list + | RecAppDef of string list + | RecExcept of string list * int + | RecSetDef of string list + | RecSetIntro of string list + | RecSetElim of string list + (* Sequences *) + | SeqSetIntro + | SeqSetElim1 + | SeqSetElim2 + | SeqLenDef + | SeqCatTyping + | SeqCatLen + | SeqCatApp1 + | SeqCatApp2 + | SeqAppendTyping + | SeqAppendLen + | SeqAppendApp1 + | SeqAppendApp2 + | SeqHeadDef + | SeqTailTyping + | SeqTailLen + | SeqTailApp + | SeqSubseqTyping + | SeqSubseqLen + | SeqSubseqApp + | SeqSelectseqTyping + | SeqSelectseqLen + | SeqSelectseqNil + | SeqSelectseqApp + | SeqSelectseqAppend + | SeqTupTyping of int + | SeqTupLen of int + + (* SPECIAL *) + | CastInj of ty + | CastInjAlt of ty + | TypeGuard of ty + | TypeGuardIntro of ty + | TypeGuardElim of ty + | Typing of tla_smb (** Only for typed symbols *) + | ExtTrigEqDef of ty + | ExtTrigEqTrigger of ty + | DisjointTrigger + | EmptyComprehensionTrigger + | AssertIsSetOf of int + | CompareSetOfTrigger + | ExtTrigEqCardPropagate + + +(** Short description for primitive symbols *) +val tla_smb_desc : tla_smb -> string +(** FIXME Barely used, but handy for human-readable debug messages *) + +(** Short description for the axiom *) +val axm_desc : tla_axm -> string + diff --git a/src/encode/n_table.mlt b/src/encode/n_table.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/encode/n_table.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/expr.ml b/src/expr.ml index 30915dcd..121dcd53 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -6,6 +6,7 @@ module T = E_t module Fmt = E_fmt module Subst = E_subst module Visit = E_visit +module Collect = E_collect module Eq = E_eq module Deref = E_deref module Leibniz = E_leibniz diff --git a/src/expr.mli b/src/expr.mli index 0c5809ec..6ab1fa5a 100644 --- a/src/expr.mli +++ b/src/expr.mli @@ -180,6 +180,27 @@ module T: sig val bounds_of_parameters: (hint * shape) list -> bounds + (** Fact name and kind *) + type meta = { + hkind : hyp_kind ; + name : string ; + } + and hyp_kind = Axiom | Hypothesis | Goal + val meta_prop : meta pfuncs + + (** SMT-LIB patterns *) + type pat = expr list + val pattern_prop : + pat list pfuncs + val add_pats : + expr -> pat list -> expr + val remove_pats : + expr -> expr + val map_pats : + (pat -> pat) -> expr -> expr + val fold_pats : + (pat -> 'a -> 'a) -> expr -> 'a -> 'a + module type Node_factory_sig = sig @@ -332,6 +353,7 @@ module T: sig val get_val_from_id: 'hyp Deque.dq -> int -> 'hyp val name_of_ix: int -> ctx -> hint + val hyp_hint : hyp -> hint val hyp_name: hyp -> string val print_cx: ctx -> unit @@ -429,6 +451,9 @@ module Subst: sig val scons: expr -> sub -> sub + val ssnoc: + sub -> expr -> + sub val bumpn: int -> sub -> sub @@ -465,6 +490,9 @@ module Subst: sig val app_sequent: sub -> sequent -> sequent + val app_hyps: + sub -> hyp Deque.dq -> + sub * hyp Deque.dq val app_hyp: sub -> hyp -> hyp @@ -571,9 +599,38 @@ module Visit: sig method hyp : 's scx -> hyp -> 's scx method hyps : 's scx -> hyp Deque.dq -> 's scx end + class virtual ['s, 'a] foldmap : object + method expr : 's scx -> 'a -> expr -> 'a * expr + method pform : 's scx -> 'a -> pform -> 'a * pform + method sel : 's scx -> 'a -> sel -> 'a * sel + method sequent : 's scx -> 'a -> sequent -> 's scx * 'a * sequent + method defn : 's scx -> 'a -> defn -> 'a * defn + method defns : 's scx -> 'a -> defn list -> 's scx * 'a * defn list + method bounds : 's scx -> 'a -> bound list -> 's scx * 'a * bound list + method bound : 's scx -> 'a -> bound -> 's scx * 'a * bound + method exspec : 's scx -> 'a -> exspec -> 'a * exspec + method instance : 's scx -> 'a -> instance -> 'a * instance + method hyp : 's scx -> 'a -> hyp -> 's scx * 'a * hyp + method hyps : 's scx -> 'a -> hyp Deque.dq -> 's scx * 'a * hyp Deque.dq + end + class virtual ['s, 'a] fold : object + method expr : 's scx -> 'a -> expr -> 'a + method pform : 's scx -> 'a -> pform -> 'a + method sel : 's scx -> 'a -> sel -> 'a + method sequent : 's scx -> 'a -> sequent -> 's scx * 'a + method defn : 's scx -> 'a -> defn -> 'a + method defns : 's scx -> 'a -> defn list -> 's scx * 'a + method bounds : 's scx -> 'a -> bound list -> 's scx * 'a + method bound : 's scx -> 'a -> bound -> 's scx * 'a + method exspec : 's scx -> 'a -> exspec -> 'a + method instance : 's scx -> 'a -> instance -> 'a + method hyp : 's scx -> 'a -> hyp -> 's scx * 'a + method hyps : 's scx -> 'a -> hyp Deque.dq -> 's scx * 'a + end class virtual ['s] map_visible_hyp : ['s] map class virtual ['s] iter_visible_hyp : ['s] iter - + class virtual ['s, 'a] foldmap_visible_hyp : ['s, 'a] foldmap + class virtual ['s, 'a] fold_visible_hyp : ['s, 'a] fold class virtual ['s] map_rename : object inherit ['s] map method rename : ctx -> hyp -> Util.hint -> hyp * Util.hint @@ -581,6 +638,27 @@ module Visit: sig end end + +module Collect : sig + open T + open Util.Coll + type ctx = hyp Deque.dq + type var_set = Is.t + val get_hints : + ctx -> var_set -> Hs.t + val get_strings : + ctx -> var_set -> Ss.t + val vs_fold : + ctx -> (int -> hyp -> 'a -> 'a) -> var_set -> 'a -> 'a + val vs_partition : + ctx -> (int -> hyp -> bool) -> var_set -> var_set * var_set + val fvs : + ?ctx:ctx -> expr -> var_set + val opaques : + ?ctx:ctx -> expr -> Hs.t +end + + module Eq: sig open T val expr: diff --git a/src/expr/e_collect.ml b/src/expr/e_collect.ml new file mode 100644 index 00000000..1357998a --- /dev/null +++ b/src/expr/e_collect.ml @@ -0,0 +1,83 @@ +(* + * expr/collect.ml --- collect data from expressions + * + * + * Copyright (C) 2008-2010 INRIA and Microsoft Corporation + *) + +open E_t +open E_visit +open Property + +open Util.Coll + +type ctx = hyp Deque.dq + + +(* {3 Variables} *) + +type var_set = Is.t + +(* Methods of this class return two sets, holding respectively unbound and + * bound variables of the expression. The boundary is defined by the length of + * the context, so the methods are intended to be called with an empty context, + * in order to get the variables free relative to some local context. *) +let collect_vars = object (self : 'self) + inherit [unit, var_set] fold as super + + method expr (unit, hx as scx) s oe = + match oe.core with + | Ix n -> + let depth = Deque.size hx in + if n > depth then + Is.add (n - depth) s + else + s + | _ -> super#expr scx s oe + +end + +let vs_fold hx f is a = + Is.fold begin fun ix a -> + let hyp = get_val_from_id hx ix in + f ix hyp a + end is a + +let vs_partition hx f is = + Is.partition begin fun ix -> + let hyp = get_val_from_id hx ix in + f ix hyp + end is + +let get_hints hx is = + vs_fold hx begin fun ix hyp hs -> + let h = hyp_hint hyp in + Hs.add h hs + end is Hs.empty + +let get_strings hx is = + vs_fold hx begin fun ix hyp hs -> + let h = hyp_name hyp in + Ss.add h hs + end is Ss.empty + +let fvs ?ctx:(ctx=Deque.empty) e = + collect_vars#expr ((), ctx) Is.empty e + + +(* {3 Opaques} *) + +let collect_opaques = object (self : 'self) + inherit [unit, Hs.t] fold as super + + method expr (unit, hx as scx) os oe = + match oe.core with + | Opaque s -> + let h = s @@ oe in + Hs.add h os + | _ -> super#expr scx os oe + +end + +let opaques ?ctx:(ctx=Deque.empty) e = + collect_opaques#expr ((), ctx) Hs.empty e diff --git a/src/expr/e_collect.mli b/src/expr/e_collect.mli new file mode 100644 index 00000000..f2398d7e --- /dev/null +++ b/src/expr/e_collect.mli @@ -0,0 +1,46 @@ +(* + * expr/collect.mli --- collect data from expressions + * + * + * Copyright (C) 2008-2010 INRIA and Microsoft Corporation + *) + +open E_t +open Util.Coll + +type ctx = hyp Deque.dq + + +(* {3 Variables} *) + +(** We want to manipulate the indexes rather than strings or hints. *) +type var_set = Is.t + +val get_hints : ctx -> var_set -> Hs.t +val get_strings : ctx -> var_set -> Ss.t + +(** Helpers *) +val vs_fold : ctx -> (int -> hyp -> 'a -> 'a) -> var_set -> 'a -> 'a +val vs_partition : ctx -> (int -> hyp -> bool) -> var_set -> var_set * var_set + +(** [fvs ~ctx e] returns the set of free variables in [e] assuming the local + context [ctx]. That means the expression is virtually treated as if it was + '\A (vars in ctx) : e'. + + The returned variables are represented as their De Bruijn indexes. Default + [ctx] is the empty context. + + NOTE: The indexes are calibrated relative to [ctx]. So the index [1] is + not the variable at the rear of [ctx], but rather the lowest index that is + *not* bound in [ctx]. +*) +val fvs : ?ctx:ctx -> expr -> var_set + + +(* {3 Opaques} *) + +(** Get all opaque strings in expression. Context is irrelevant. + + The properties attached to a string s are those of the (Opaque s). +*) +val opaques : ?ctx:ctx -> expr -> Hs.t diff --git a/src/expr/e_collect.mlt b/src/expr/e_collect.mlt new file mode 100644 index 00000000..2c9c90a2 --- /dev/null +++ b/src/expr/e_collect.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2008-2013 INRIA and Microsoft Corporation + *) + diff --git a/src/expr/e_elab.ml b/src/expr/e_elab.ml index 13a42bc4..798f6d3a 100644 --- a/src/expr/e_elab.ml +++ b/src/expr/e_elab.ml @@ -277,7 +277,7 @@ let%test_module _ = (module struct let test_case = create_expression test_string in let target_case = create_expression "f'[x']" in (* let x = normalize Deque.empty test_case in - Printf.eprintf "compare: %d\n" (Pervasives.compare x target_case); *) + Printf.eprintf "compare: %d\n" (Stdlib.compare x target_case); *) [%test_eq: string] (prn_exp target_case) (prn_exp (normalize Deque.empty test_case)) *) diff --git a/src/expr/e_subst.ml b/src/expr/e_subst.ml index 66b5b307..a72e0db7 100644 --- a/src/expr/e_subst.ml +++ b/src/expr/e_subst.ml @@ -423,8 +423,8 @@ class map = object (self : 'self) Fresh (nm, shp, lc, dom) @@ h | Flex v -> Flex v @@ h | Defn (df, wd, vis, ex) -> - let (s, df) = self#defn s df in - assert (s = bump s); + let (s', df) = self#defn s df in + assert (s' = bump s); Defn (df, wd, vis, ex) @@ h | Fact (e, vis, tm) -> Fact (self#expr s e, vis, tm) @@ h diff --git a/src/expr/e_t.ml b/src/expr/e_t.ml index 620f3433..e1595963 100644 --- a/src/expr/e_t.ml +++ b/src/expr/e_t.ml @@ -402,6 +402,42 @@ let bounds_of_parameters List.map f param_names +type meta = { + hkind : hyp_kind ; + name : string ; +} +and hyp_kind = Axiom | Hypothesis | Goal + +let meta_prop = make "Expr.T.meta_prop" + + +type pat = expr list + +let pattern_prop = make "Expr.T.pattern_prop" + + +let add_pats oe pats = + match query oe pattern_prop with + | Some pats' -> assign oe pattern_prop (pats @ pats') + | None -> assign oe pattern_prop pats + + +let remove_pats oe = + remove oe pattern_prop + + +let map_pats f oe = + match query oe pattern_prop with + | None -> oe + | Some pats -> assign oe pattern_prop (List.map f pats) + + +let fold_pats f oe a = + match query oe pattern_prop with + | None -> a + | Some pats -> List.fold_right f pats a + + module type Name_type_sig = sig type t @@ -1313,7 +1349,7 @@ let name_of_ix that refers to Fact." -let hyp_name h = match h.core with +let hyp_hint h = match h.core with | Fresh (nm, _, _, _) | Flex nm | Defn ({core = @@ -1322,8 +1358,10 @@ let hyp_name h = match h.core with | Bpragma(nm,_,_) | Recursive (nm, _)}, _, _, _) - -> nm.core - | Fact (_, _,_) -> "??? FACT ???" + -> nm + | Fact (_, _,_) -> "??? FACT ???" %% [] + +let hyp_name h = (hyp_hint h).core let visibility_to_string = function diff --git a/src/expr/e_t.mli b/src/expr/e_t.mli index 5fb2b08c..ef9e71db 100644 --- a/src/expr/e_t.mli +++ b/src/expr/e_t.mli @@ -208,6 +208,33 @@ val bounds_of_parameters: (hint * shape) list -> bounds +(** Name and kind of a fact *) +type meta = { + hkind : hyp_kind ; + name : string ; +} +and hyp_kind = Axiom | Hypothesis | Goal + +(** Attached to the expression part of a fact, in a sequent *) +val meta_prop : meta pfuncs + +(** SMT-LIB pattern *) +type pat = expr list + +(** Attached to the body of a quantified expression *) +val pattern_prop : + pat list pfuncs + +val add_pats : + expr -> pat list -> expr +val remove_pats : + expr -> expr + +val map_pats : + (pat -> pat) -> expr -> expr +val fold_pats : + (pat -> 'a -> 'a) -> expr -> 'a -> 'a + module type Node_factory_sig = sig type t @@ -362,6 +389,8 @@ val name_of_ix: int -> ctx -> hint (* fmt.ml *) +val hyp_hint : + hyp_ Property.wrapped -> hint val hyp_name: hyp_ Property.wrapped -> string diff --git a/src/expr/e_visit.ml b/src/expr/e_visit.ml index 04142526..269f225f 100644 --- a/src/expr/e_visit.ml +++ b/src/expr/e_visit.ml @@ -602,6 +602,516 @@ class virtual ['s] iter = object (self : 'self) end +class virtual ['s, 'a] foldmap = object (self : 'self) + + method expr (scx : 's scx) a oe = + match oe.core with + | Ix n -> + a, Ix n @@ oe + | Internal b -> + a, Internal b @@ oe + | Opaque o -> + a, Opaque o @@ oe + | Bang (e, sels) -> + let a, e = self#expr scx a e in + let a, sels = List.fold_left begin fun (a, sels) sel -> + let a, sel = self#sel scx a sel in + a, sel :: sels + end (a, []) sels in + let sels = List.rev sels in + a, Bang (e, sels) @@ oe + | Lambda (vs, e) -> + let scx = adjs scx (List.map begin fun (v, shp) -> + Fresh (v, shp, Unknown, Unbounded) @@ v + end vs) in + let a, e = self#expr scx a e in + a, Lambda (vs, e) @@ oe + | String s -> + a, String s @@ oe + | Num (m, n) -> + a, Num (m, n) @@ oe + | Apply (op, es) -> + let a, op = self#expr scx a op in + let a, es = List.fold_left begin fun (a, es) e -> + let a, e = self#expr scx a e in + a, e :: es + end (a, []) es in + let es = List.rev es in + a, Apply (op, es) @@ oe + | Sequent sq -> + let _, a, sq = self#sequent scx a sq in + a, Sequent sq @@ oe + | With (e, m) -> + let a, e = self#expr scx a e in + a, With (e, m) @@ oe + | Let (ds, e) -> + let scx, a, ds = self#defns scx a ds in + let a, e = self#expr scx a e in + a, Let (ds, e) @@ oe + | If (e, f, g) -> + let a, e = self#expr scx a e in + let a, f = self#expr scx a f in + let a, g = self#expr scx a g in + a, If (e, f, g) @@ oe + | List (q, es) -> + let a, es = List.fold_left begin fun (a, es) e -> + let a, e = self#expr scx a e in + a, e :: es + end (a, []) es in + let es = List.rev es in + a, List (q, es) @@ oe + | Quant (q, bs, e) -> + let scx, a, bs = self#bounds scx a bs in + let a, e = self#expr scx a e in + a, Quant (q, bs, e) @@ oe + | Tquant (q, vs, e) -> + let scx = adjs scx (List.map begin fun v -> + Flex v @@ v + end vs) in + let a, e = self#expr scx a e in + a, Tquant (q, vs, e) @@ oe + | Choose (v, optdom, e) -> + let a, optdom, h = + match optdom with + | None -> + a, None, Fresh (v, Shape_expr, Constant, Unbounded) @@ v + | Some dom -> + let a, dom = self#expr scx a dom in + a, Some dom, Fresh (v, Shape_expr, Constant, Bounded (dom, Visible)) @@ v + in + let scx = adj scx h in + let a, e = self#expr scx a e in + a, Choose (v, optdom, e) @@ oe + | SetSt (v, dom, e) -> + let a, dom = self#expr scx a dom in + let scx = adj scx (Fresh (v, Shape_expr, Constant, Bounded (dom, Visible)) @@ v) in + let a, e = self#expr scx a e in + a, SetSt (v, dom, e) @@ oe + | SetOf (e, bs) -> + let scx, a, bs = self#bounds scx a bs in + let a, e = self#expr scx a e in + a, SetOf (e, bs) @@ oe + | SetEnum es -> + let a, es = List.fold_left begin fun (a, es) e -> + let a, e = self#expr scx a e in + a, e :: es + end (a, []) es in + let es = List.rev es in + a, SetEnum es @@ oe + | Fcn (bs, e) -> + let scx, a, bs = self#bounds scx a bs in + let a, e = self#expr scx a e in + a, Fcn (bs, e) @@ oe + | FcnApp (f, es) -> + let a, f = self#expr scx a f in + let a, es = List.fold_left begin fun (a, es) e -> + let a, e = self#expr scx a e in + a, e :: es + end (a, []) es in + let es = List.rev es in + a, FcnApp (f, es) @@ oe + | Arrow (e, f) -> + let a, e = self#expr scx a e in + let a, f = self#expr scx a f in + a, Arrow (e, f) @@ oe + | Product es -> + let a, es = List.fold_left begin fun (a, es) e -> + let a, e = self#expr scx a e in + a, e :: es + end (a, []) es in + let es = List.rev es in + a, Product es @@ oe + | Tuple es -> + let a, es = List.fold_left begin fun (a, es) e -> + let a, e = self#expr scx a e in + a, e :: es + end (a, []) es in + let es = List.rev es in + a, Tuple es @@ oe + | Rect fs -> + let a, fs = List.fold_left begin fun (a, fs) (s, e) -> + let a, e = self#expr scx a e in + a, (s, e) :: fs + end (a, []) fs in + let fs = List.rev fs in + a, Rect fs @@ oe + | Record fs -> + let a, fs = List.fold_left begin fun (a, fs) (s, e) -> + let a, e = self#expr scx a e in + a, (s, e) :: fs + end (a, []) fs in + let fs = List.rev fs in + a, Record fs @@ oe + | Except (e, xs) -> + let a, e = self#expr scx a e in + let a, xs = List.fold_left begin fun (a, xs) x -> + let a, x = self#exspec scx a x in + a, x :: xs + end (a, []) xs in + let xs = List.rev xs in + a, Except (e, xs) @@ oe + | Dot (e, f) -> + let a, e = self#expr scx a e in + a, Dot (e, f) @@ oe + | Sub (s, e, f) -> + let a, e = self#expr scx a e in + let a, f = self#expr scx a f in + a, Sub (s, e, f) @@ oe + | Tsub (s, e, f) -> + let a, e = self#expr scx a e in + let a, f = self#expr scx a f in + a, Tsub (s, e, f) @@ oe + | Fair (fop, e, f) -> + let a, e = self#expr scx a e in + let a, f = self#expr scx a f in + a, Fair (fop, e, f) @@ oe + | Case (arms, oth) -> + let a, arms = List.fold_left begin fun (a, arms) (e, f) -> + let a, e = self#expr scx a e in + let a, f = self#expr scx a f in + a, (e, f) :: arms + end (a, []) arms in + let arms = List.rev arms in + let a, oth = + match oth with + | None -> + a, None + | Some o -> + let a, o = self#expr scx a o in + a, Some o + in + a, Case (arms, oth) @@ oe + | At b -> + a, At b @@ oe + | Parens (e, pf) -> + let a, e = self#expr scx a e in + let a, pf = self#pform scx a pf in + a, Parens (e, pf) @@ oe + + method pform scx a pf = a, pf + + method sel scx a sel = + match sel with + | Sel_inst args -> + let a, e = List.fold_left begin fun (a, args) e -> + let a, e = self#expr scx a e in + a, e :: args + end (a, []) args in + let args = List.rev args in + a, Sel_inst args + | Sel_lab (l, args) -> + let a, e = List.fold_left begin fun (a, args) e -> + let a, e = self#expr scx a e in + a, e :: args + end (a, []) args in + let args = List.rev args in + a, Sel_lab (l, args) + | _ -> + a, sel + + method sequent scx a sq = + let scx, a, hyps = self#hyps scx a sq.context in + let a, act = self#expr scx a sq.active in + scx, a, { context = hyps ; active = act } + + method defn scx a df = + match df.core with + | Recursive (nm, shp) -> + a, Recursive (nm, shp) @@ df + | Operator (nm, e) -> + let a, e = self#expr scx a e in + a, Operator (nm, e) @@ df + | Instance (nm, i) -> + let a, i = self#instance scx a i in + a, Instance (nm, i) @@ df + | Bpragma(nm, e, l) -> + let a, e = self#expr scx a e in + a, Bpragma (nm, e, l) @@ df + + method defns scx a ds = + match ds with + | [] -> scx, a, [] + | df :: dfs -> + let a, df = self#defn scx a df in + let scx = adj scx (Defn (df, User, Visible, Local) @@ df) in + let scx, a, dfs = self#defns scx a dfs in + scx, a, df :: dfs + + method bounds scx a bs = + let a, bs = List.fold_left begin fun (a, bs) (v, k, dom) -> + match dom with + | Domain d -> + let a, d = self#expr scx a d in + a, (v, k, Domain d) :: bs + | _ -> + a, (v, k, dom) :: bs + end (a, []) bs in + let bs = List.rev bs in + let hs = List.map begin + fun (v, k, _) -> Fresh (v, Shape_expr, k, Unbounded) @@ v + end bs in + let scx = adjs scx hs in + scx, a, bs + + method bound scx (a : 'a) b = + match self#bounds scx a [b] with + | scx, a, [b] -> scx, a, b + | _ -> assert false + + method exspec scx a (trail, res) = + let a, trail = List.fold_left begin fun (a, trail) x -> + match x with + | Except_dot s -> + a, (Except_dot s) :: trail + | Except_apply e -> + let a, e = self#expr scx a e in + a, (Except_apply e) :: trail + end (a, []) trail in + let trail = List.rev trail in + let a, res = self#expr scx a res in + a, (trail, res) + + method instance scx a i = + let scx = List.fold_left begin fun scx v -> + adj scx (Fresh (v, Shape_expr, Unknown, Unbounded) @@ v) + end scx i.inst_args in + let a, sub = List.fold_left begin fun (a, sub) (v, e) -> + let a, e = self#expr scx a e in + a, (v, e) :: sub + end (a, []) i.inst_sub in + let sub = List.rev sub in + a, { i with inst_sub = sub } + + method hyp scx a h = + match h.core with + | Fresh (nm, shp, lc, dom) -> + let a, dom = + match dom with + | Unbounded -> + a, Unbounded + | Bounded (r, rvis) -> + let a, r = self#expr scx a r in + a, Bounded (r, rvis) + in + let h = Fresh (nm, shp, lc, dom) @@ h in + let scx = adj scx h in + scx, a, h + | Flex s -> + let h = Flex s @@ h in + let scx = adj scx h in + scx, a, h + | Defn (df, wd, vis, ex) -> + let a, df = self#defn scx a df in + let h = Defn (df, wd, vis, ex) @@ h in + let scx = adj scx h in + scx, a, h + | Fact (e, vis, tm) -> + let a, e = self#expr scx a e in + let h = Fact (e, vis, tm) @@ h in + let scx = adj scx h in + scx, a, h + + method hyps scx a hs = + match Dq.front hs with + | None -> scx, a, Dq.empty + | Some (h, hs) -> + let scx, a, h = self#hyp scx a h in + let scx, a, hs = self#hyps scx a hs in + scx, a, Dq.cons h hs + +end + +class virtual ['s, 'a] fold = object (self : 'self) + + method expr (scx : 's scx) a oe = + match oe.core with + | Ix _ + | Internal _ + | Opaque _ -> a + | Bang (e, sels) -> + let a = self#expr scx a e in + List.fold_left (self#sel scx) a sels + | Lambda (vs, e) -> + let scx = adjs scx (List.map begin fun (v, shp) -> + Fresh (v, shp, Unknown, Unbounded) @@ v + end vs) in + self#expr scx a e + | Apply (op, es) -> + List.fold_left (self#expr scx) a (op :: es) + | Sequent sq -> + snd (self#sequent scx a sq) + | With (e, _) -> + self#expr scx a e + | Let (ds, e) -> + let scx, a = self#defns scx a ds in + self#expr scx a e + | If (e, f, g) -> + let a = self#expr scx a e in + let a = self#expr scx a f in + self#expr scx a g + | List (_, es) -> + List.fold_left (self#expr scx) a es + | Quant (_, bs, e) -> + let scx, a = self#bounds scx a bs in + self#expr scx a e + | Tquant (_, vs, e) -> + let scx = adjs scx (List.map begin fun v -> + Flex v @@ v + end vs) in + self#expr scx a e + | Choose (v, optdom, e) -> + let a, h = + match optdom with + | None -> + a, Fresh (v, Shape_expr, Constant, Unbounded) @@ v + | Some dom -> + let a = self#expr scx a dom in + a, Fresh (v, Shape_expr, Constant, Bounded (dom, Visible)) @@ v + in + let scx = adj scx h in + self#expr scx a e + | SetSt (v, dom, e) -> + let a = self#expr scx a dom in + let scx = adj scx (Fresh (v, Shape_expr, Constant, Bounded (dom, Visible)) @@ v) in + self#expr scx a e + | SetOf (e, bs) -> + let scx, a = self#bounds scx a bs in + self#expr scx a e + | SetEnum es -> + List.fold_left (self#expr scx) a es + | Fcn (bs, e) -> + let scx, a = self#bounds scx a bs in + self#expr scx a e + | FcnApp (f, es) -> + List.fold_left (self#expr scx) a (f :: es) + | Arrow (e, f) -> + let a = self#expr scx a e in + self#expr scx a f + | Product es + | Tuple es -> + List.fold_left (self#expr scx) a es + | Rect fs + | Record fs -> + List.fold_left (fun a (_, e) -> self#expr scx a e) a fs + | Except (e, xs) -> + let a = self#expr scx a e in + List.fold_left (self#exspec scx) a xs + | Dot (e, _) -> + self#expr scx a e + | Sub (_, e, f) + | Tsub (_, e, f) + | Fair (_, e, f) -> + let a = self#expr scx a e in + self#expr scx a f + | Case (arms, oth) -> + let a = List.fold_left begin fun a (e, f) -> + let a = self#expr scx a e in + self#expr scx a f + end a arms in + begin match oth with + | None -> a + | Some o -> self#expr scx a o + end + | Parens (e, pf) -> + let a = self#expr scx a e in + self#pform scx a pf + | String _ + | Num _ + | At _ -> a + + method pform scx a pf = a + + method sel scx a sel = + match sel with + | Sel_inst args + | Sel_lab (_, args) -> List.fold_left (self#expr scx) a args + | _ -> a + + method sequent scx a sq = + let scx, a = self#hyps scx a sq.context in + let a = self#expr scx a sq.active in + scx, a + + method defn scx a df = + match df.core with + | Recursive _ -> a + | Operator (_, e) + | Bpragma(_, e, _) -> self#expr scx a e + | Instance (_, i) -> self#instance scx a i + + method defns scx a ds = + match ds with + | [] -> scx, a + | df :: dfs -> + let a = self#defn scx a df in + let scx = adj scx (Defn (df, User, Visible, Local) @@ df) in + self#defns scx a dfs + + method bounds scx a bs = + let a = List.fold_left begin fun a (v, k, dom) -> + match dom with + | Domain d -> self#expr scx a d + | _ -> a + end a bs in + let hs = List.map begin + fun (v, k, _) -> Fresh (v, Shape_expr, k, Unbounded) @@ v + end bs in + let scx = adjs scx hs in + scx, a + + method bound scx (a : 'a) b = + self#bounds scx a [b] + + method exspec scx a (trail, res) = + let a = List.fold_left begin fun a x -> + match x with + | Except_dot s -> a + | Except_apply e -> self#expr scx a e + end a trail in + self#expr scx a res + + method instance scx a i = + let scx = List.fold_left begin fun scx v -> + adj scx (Fresh (v, Shape_expr, Unknown, Unbounded) @@ v) + end scx i.inst_args in + List.fold_left (fun a (_, e) -> self#expr scx a e) a i.inst_sub + + method hyp scx a h = + match h.core with + | Fresh (nm, shp, lc, dom) -> + let a = + match dom with + | Unbounded -> a + | Bounded (r, rvis) -> self#expr scx a r + in + let h = Fresh (nm, shp, lc, dom) @@ h in + let scx = adj scx h in + scx, a + | Flex s -> + let h = Flex s @@ h in + let scx = adj scx h in + scx, a + | Defn (df, wd, vis, ex) -> + let a = self#defn scx a df in + let h = Defn (df, wd, vis, ex) @@ h in + let scx = adj scx h in + scx, a + | Fact (e, vis, tm) -> + let a = self#expr scx a e in + let h = Fact (e, vis, tm) @@ h in + let scx = adj scx h in + scx, a + + method hyps scx a hs = + match Dq.front hs with + | None -> scx, a + | Some (h, hs) -> + let scx, a = self#hyp scx a h in + self#hyps scx a hs + +end + + class virtual ['s] map_visible_hyp = object (self : 'self) (* Map expressions, visiting only visible hypotheses. *) inherit ['s] map as super @@ -651,6 +1161,66 @@ class virtual ['s] iter_visible_hyp = object (self : 'self) end ; adj scx h end +class virtual ['s, 'a] foldmap_visible_hyp = object (self : 'self) + (* Foldmap expressions, visiting only visible hypotheses. *) + inherit ['s, 'a] foldmap as super + + method hyp scx a h = match h.core with + | Fresh (nm, shp, lc, dom) -> + let a, dom = match dom with + | Unbounded -> a, Unbounded + | Bounded (r, rvis) -> + let a, e = self#expr scx a r in + a, Bounded (e, rvis) + in + let h = Fresh (nm, shp, lc, dom) @@ h in + (adj scx h, a, h) + | Flex s -> + let h = Flex s @@ h in + (adj scx h, a, h) + | Defn (_, _, Hidden, _) + | Fact (_, Hidden, _) -> + (* TODO: what about mutable properties of `h` ? *) + (adj scx h, a, h) + | Defn (df, wd, Visible, ex) -> + let a, df = self#defn scx a df in + let h = Defn (df, wd, Visible, ex) @@ h in + (adj scx h, a, h) + | Fact (e, Visible, tm) -> + let a, e = self#expr scx a e in + let h = Fact (e, Visible, tm) @@ h in + (adj scx h, a, h) +end + +class virtual ['s, 'a] fold_visible_hyp = object (self : 'self) + (* Fold expressions, visiting only visible hypotheses. *) + inherit ['s, 'a] fold as super + + method hyp scx a h = match h.core with + | Fresh (nm, shp, lc, dom) -> + let a = match dom with + | Unbounded -> a + | Bounded (r, rvis) -> self#expr scx a r + in + let h = Fresh (nm, shp, lc, dom) @@ h in + (adj scx h, a) + | Flex s -> + let h = Flex s @@ h in + (adj scx h, a) + | Defn (_, _, Hidden, _) + | Fact (_, Hidden, _) -> + (* TODO: what about mutable properties of `h` ? *) + (adj scx h, a) + | Defn (df, wd, Visible, ex) -> + let a = self#defn scx a df in + let h = Defn (df, wd, Visible, ex) @@ h in + (adj scx h, a) + | Fact (e, Visible, tm) -> + let a = self#expr scx a e in + let h = Fact (e, Visible, tm) @@ h in + (adj scx h, a) +end + let set_to_list table = (* `Hashtbl` keys to `List`. *) diff --git a/src/expr/e_visit.mli b/src/expr/e_visit.mli index 5e37fcd2..21edf711 100644 --- a/src/expr/e_visit.mli +++ b/src/expr/e_visit.mli @@ -56,8 +56,40 @@ class virtual ['s] iter : object method hyps : 's scx -> hyp Deque.dq -> 's scx end +class virtual ['s, 'a] foldmap : object + method expr : 's scx -> 'a -> expr -> 'a * expr + method pform : 's scx -> 'a -> pform -> 'a * pform + method sel : 's scx -> 'a -> sel -> 'a * sel + method sequent : 's scx -> 'a -> sequent -> 's scx * 'a * sequent + method defn : 's scx -> 'a -> defn -> 'a * defn + method defns : 's scx -> 'a -> defn list -> 's scx * 'a * defn list + method bounds : 's scx -> 'a -> bound list -> 's scx * 'a * bound list + method bound : 's scx -> 'a -> bound -> 's scx * 'a * bound + method exspec : 's scx -> 'a -> exspec -> 'a * exspec + method instance : 's scx -> 'a -> instance -> 'a * instance + method hyp : 's scx -> 'a -> hyp -> 's scx * 'a * hyp + method hyps : 's scx -> 'a -> hyp Deque.dq -> 's scx * 'a * hyp Deque.dq +end + +class virtual ['s, 'a] fold : object + method expr : 's scx -> 'a -> expr -> 'a + method pform : 's scx -> 'a -> pform -> 'a + method sel : 's scx -> 'a -> sel -> 'a + method sequent : 's scx -> 'a -> sequent -> 's scx * 'a + method defn : 's scx -> 'a -> defn -> 'a + method defns : 's scx -> 'a -> defn list -> 's scx * 'a + method bounds : 's scx -> 'a -> bound list -> 's scx * 'a + method bound : 's scx -> 'a -> bound -> 's scx * 'a + method exspec : 's scx -> 'a -> exspec -> 'a + method instance : 's scx -> 'a -> instance -> 'a + method hyp : 's scx -> 'a -> hyp -> 's scx * 'a + method hyps : 's scx -> 'a -> hyp Deque.dq -> 's scx * 'a +end + class virtual ['s] map_visible_hyp : ['s] map class virtual ['s] iter_visible_hyp : ['s] iter +class virtual ['s, 'a] foldmap_visible_hyp : ['s, 'a] foldmap +class virtual ['s, 'a] fold_visible_hyp : ['s, 'a] fold class virtual ['s] map_rename : object inherit ['s] map diff --git a/src/method.ml b/src/method.ml index b3b726dc..f2823b72 100644 --- a/src/method.ml +++ b/src/method.ml @@ -11,6 +11,7 @@ let default_z3_timeout = 5. let default_cvc3_timeout = 5. let default_smt_timeout = 5. let default_smt2_timeout = 5. +let default_zipper_timeout = 30. let default_spass_timeout = 5. let default_tptp_timeout = 5. @@ -31,6 +32,7 @@ type t = | Cvc33 of float | Yices3 of float | Verit of float + | Zipper of float | Spass of float | Tptp of float | ExpandENABLED @@ -59,6 +61,7 @@ let timeout m = | Cvc33 f -> f | Yices3 f -> f | Verit f -> f + | Zipper f -> f | Spass f -> f | Tptp f -> f | ExpandENABLED -> infinity @@ -92,6 +95,7 @@ let scale_time m s = | Cvc33 f -> Cvc33 (f *. s) | Yices3 f -> Yices3 (f *. s) | Verit f -> Verit (f *. s) + | Zipper f -> Zipper (f *. s) | Spass f -> Spass (f *. s) | Tptp f -> Tptp (f *. s) | ExpandENABLED -> ExpandENABLED @@ -123,6 +127,7 @@ let pp_print_tactic ff m = | Cvc33 f -> fprintf ff "(cvc4 %g s)" f | Yices3 f -> fprintf ff "(yices %g s)" f | Verit f -> fprintf ff "(verit %g s)" f + | Zipper f -> fprintf ff "(zipper %g s)" f | Spass f -> fprintf ff "(spass %g s)" f | Tptp f -> fprintf ff "(tptp %g s)" f | Cooper -> fprintf ff "(cooper)" @@ -156,6 +161,7 @@ let prover_meth_of_tac tac = | Cvc33 f -> (Some "cvc4", None) | Yices3 f -> (Some "yices", None) | Verit f -> (Some "verit", None) + | Zipper f -> (Some "zipper", None) | Spass f -> (Some "spass", None) | Tptp f -> (Some "tptp", None) | Cooper -> (Some "cooper", None) diff --git a/src/method.mli b/src/method.mli index 1565e714..c786655b 100644 --- a/src/method.mli +++ b/src/method.mli @@ -20,6 +20,7 @@ type t = | Cvc33 of float | Yices3 of float | Verit of float + | Zipper of float | Spass of float | Tptp of float | ExpandENABLED @@ -51,6 +52,7 @@ val default_z3_timeout: float val default_cvc3_timeout: float val default_smt_timeout: float val default_smt2_timeout: float +val default_zipper_timeout : float val default_spass_timeout: float val default_tptp_timeout: float diff --git a/src/method_prs.ml b/src/method_prs.ml index 7892d03d..33a85733 100644 --- a/src/method_prs.ml +++ b/src/method_prs.ml @@ -39,6 +39,7 @@ and isa_method = lazy begin isa_cvc33; isa_yices3; isa_verit; + isa_zipper; isa_spass; isa_tptp; isa_ls4; @@ -108,6 +109,8 @@ and isa_yices3 = ident "yices3" Yices3 default_smt2_timeout and isa_verit = ident "verit" Verit default_smt2_timeout +and isa_zipper = ident "zipper" Zipper default_zipper_timeout + and isa_spass = ident "spass" Spass default_spass_timeout and isa_tptp = ident "tptp" Tptp default_tptp_timeout diff --git a/src/params.ml b/src/params.ml index 483ee30a..c529cc95 100644 --- a/src/params.ml +++ b/src/params.ml @@ -193,6 +193,7 @@ let cvc4 = let yices = make_exec "yices" "yices -tc \"$file\"" "yices --version" + let z3 = if Sys.os_type = "Cygwin" then make_exec "z3" @@ -211,6 +212,11 @@ let verit = --disable-banner --disable-print-success \"$file\"" "echo unknown" +let zipper = + make_exec "zipperposition" + "zipperposition \"$file\"" + "zipperposition --version" + let spass_dfg = make_exec "SPASS" @@ -302,6 +308,9 @@ let mk_meth name timeout = | "verit" -> let timeout = Option.default Method.default_smt2_timeout timeout in Method.Verit timeout + | "zipper" -> + let timeout = Option.default Method.default_zipper_timeout timeout in + Method.Zipper timeout | "spass" -> let timeout = Option.default Method.default_spass_timeout timeout in Method.Spass timeout @@ -329,6 +338,7 @@ let parse_default_methods s = printf " yices -- Yices\n"; printf " verit -- VeriT\n"; printf " spass -- SPASS\n"; + printf " zipper -- Zipperposition\n"; printf " ls4 -- LS4\n"; printf "\n" ; printf " fail -- Dummy method that always fails\n" ; @@ -457,6 +467,7 @@ let configuration toolbox force = ("VeriT", verit); ("SMT", smt); ("Spass", spass_tptp); + ("Zipperposition", zipper); ("LS4", ls4); ]) @ [ "flatten_obligations == " ^ (if !ob_flatten then "TRUE" else "FALSE") diff --git a/src/params.mli b/src/params.mli index d125456c..1519b2e1 100644 --- a/src/params.mli +++ b/src/params.mli @@ -30,6 +30,7 @@ val cvc4: exec val yices: exec val z3: exec val verit: exec +val zipper : exec val spass_dfg: exec val spass_tptp: exec val eprover: exec diff --git a/src/smt/smtcommons.ml b/src/smt/smtcommons.ml index a10f8724..3a5105c8 100644 --- a/src/smt/smtcommons.ml +++ b/src/smt/smtcommons.ml @@ -258,7 +258,7 @@ let rec unroll_seq sq = in From_hint.make_forall [bound] ex | Fresh _ -> - failwith "smt/smtcommons.ml: encountered sequent-order sequent" + failwith "smt/smtcommons.ml: encountered second-order sequent" | Flex v -> let v_prime = (v.core ^ "'") @@ v in let bounds = From_hint.make_const_decls [v; v_prime] in diff --git a/src/type.ml b/src/type.ml new file mode 100644 index 00000000..bf418e60 --- /dev/null +++ b/src/type.ml @@ -0,0 +1,10 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +module T = T_t +module Visit = T_visit +module Collect = T_collect +module Hyps = T_hyps +module Synthesize = T_synth + diff --git a/src/type.mli b/src/type.mli new file mode 100644 index 00000000..4e146d79 --- /dev/null +++ b/src/type.mli @@ -0,0 +1,133 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +(** Packaging Module for TLA+'s Type System *) + + +(** Interface for the type and the constraint system *) +module T : sig + open Property + + type ty = + | TVar of string (** Type variable *) + | TAtm of atm (** Atomic type *) + | TSet of ty (** Set-type *) + | TFSet of ty (** Finite Set-type *) + | TFun of ty * ty (** Function-type *) + | TPrd of ty list (** Product-type *) + | TRec of (string * ty) list (** Record-type *) + and atm = + | TAIdv (** Individual *) + | TABol (** Boolean *) + | TAInt (** Integer *) + | TARel (** Real *) + | TAStr (** String *) + + and ty0 = ty (** Constant type *) + and ty1 = Ty1 of ty0 list * ty (** Fst-order operator type *) + and ty2 = Ty2 of ty1 list * ty (** Snd-order operator type *) + + module Ts : Set.S with type elt = ty + module Tm : Map.S with type key = ty + + val upcast_ty1 : ty0 -> ty1 + val upcast_ty2 : ty1 -> ty2 + + exception Invalid_type_downcast + val downcast_ty1 : ty2 -> ty1 + val downcast_ty0 : ty1 -> ty0 + + val safe_downcast_ty1 : ty2 -> ty1 option + val safe_downcast_ty0 : ty1 -> ty0 option + + type ty_sub = ty Util.Coll.Sm.t + + val apply_ty_sub : ty_sub -> ty0 -> ty0 + val apply_ty_sub1 : ty_sub -> ty1 -> ty1 + val apply_ty_sub2 : ty_sub -> ty2 -> ty2 + + exception Typechecking_error of ty0 * ty0 + exception Typechecking_op_error of ty2 * ty2 + + val typecheck : expected:ty0 -> actual:ty0 -> unit + val typecheck_op : expected:ty2 -> actual:ty2 -> unit + + val typecheck_error_mssg : expected:ty0 -> actual:ty0 -> string + val typecheck_op_error_mssg : expected:ty2 -> actual:ty2 -> string + + val erase0 : ty0 -> ty0 + val erase1 : ty1 -> ty1 + val erase2 : ty2 -> ty2 + + module Props : sig + val ty0_prop : ty0 pfuncs + val ty1_prop : ty1 pfuncs + val ty2_prop : ty2 pfuncs + + val tpars_prop : ty list pfuncs (** Type instances to polymorphics ops. *) + val mpars_prop : ty pfuncs (** Like tpars but for hidden Mem ops. *) + val icast_prop : ty pfuncs (** Forgetful injection into individuals *) + val sproj_prop : ty pfuncs (** Projection of individuals into sorts *) + val bproj_prop : ty pfuncs (** Expressions occurring in boolean ctxt *) + end + + val ty_to_string : ty -> string + val ty1_to_string : ty1 -> string + val ty2_to_string : ty2 -> string + + val pp_print_ty0 : Format.formatter -> ty0 -> unit + val pp_print_ty1 : Format.formatter -> ty1 -> unit + val pp_print_ty2 : Format.formatter -> ty2 -> unit + val pp_print_atm : Format.formatter -> atm -> unit +end + +module Visit : sig + open Expr.T + open T + + type 's scx = 's * hyp Deque.dq + + val adj : 's scx -> hyp -> 's scx + val adjs : 's scx -> hyp list -> 's scx + + val lookup_ty0 : 's scx -> int -> ty0 + val lookup_ty1 : 's scx -> int -> ty1 + val lookup_ty2 : 's scx -> int -> ty2 + + class virtual ['s, 'a] foldmap : object + method expr : 's scx -> 'a -> expr -> 'a * expr * ty0 + method earg : 's scx -> 'a -> expr -> 'a * expr * ty1 + method eopr : 's scx -> 'a -> expr -> 'a * expr * ty2 + method pform : 's scx -> 'a -> pform -> 'a * pform + method sel : 's scx -> 'a -> sel -> 'a * sel + method sequent : 's scx -> 'a -> sequent -> 's scx * 'a * sequent + method defn : 's scx -> 'a -> defn -> 'a * defn + method defns : 's scx -> 'a -> defn list -> 's scx * 'a * defn list + method bounds : 's scx -> 'a -> bound list -> 's scx * 'a * bound list + method bound : 's scx -> 'a -> bound -> 's scx * 'a * bound + method exspec : 's scx -> 'a -> exspec -> 'a * exspec * ty0 list + method instance : 's scx -> 'a -> instance -> 'a * instance + method hyp : 's scx -> 'a -> hyp -> 's scx * 'a * hyp + method hyps : 's scx -> 'a -> hyp Deque.dq -> 's scx * 'a * hyp Deque.dq + end +end + +module Collect : sig + open Expr.T + open T + val main : sequent -> Ts.t +end + +module Hyps : sig + open Expr.T + open T + type scx = hyp Deque.dq + val search_type_hyp : inferer:(scx -> expr -> ty0) -> pol:bool -> scx -> expr -> ty0 option +end + +module Synthesize : sig + open Expr.T + val main : ?typelvl:int -> sequent -> sequent +end + diff --git a/src/type.mlt b/src/type.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/type.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/type/t_collect.ml b/src/type/t_collect.ml new file mode 100644 index 00000000..4b95088d --- /dev/null +++ b/src/type/t_collect.ml @@ -0,0 +1,94 @@ +(* + * encode/coltypes.ml --- collect types in an expression + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Ext +open Property + +open Expr.T +open T_t + + +(* {3 Helpers} *) + +let add_ty ss ty = + Ts.add ty ss + +let add_from_ty1 ss = function + | Ty1 (ty0s, ty) -> + List.fold_left add_ty ss (ty :: ty0s) + +let add_from_ty2 ss = function + | Ty2 (ty1s, ty) -> + List.fold_left add_from_ty1 (add_ty ss ty) ty1s + + +(* Add to [ss] all types from annotations of [v] + * If no annotations then [ss] is unchanged *) +let gather_types ss v = + let ss = Option.fold add_ty ss (query v Props.ty0_prop) in + let ss = Option.fold add_from_ty1 ss (query v Props.ty1_prop) in + let ss = Option.fold add_from_ty2 ss (query v Props.ty2_prop) in + ss + + +(* {3 Main} *) + +let visitor = object (self : 'self) + inherit [unit, Ts.t] Expr.Visit.fold as super + + method expr scx ss oe = + match oe.core with + | Lambda (xs, _) -> + let ss = + List.fold_left begin fun ss (v, _) -> + gather_types ss v + end ss xs + in + super#expr scx ss oe + | Tquant (_, xs, _) -> + let ss = List.fold_left gather_types ss xs in + super#expr scx ss oe + | Choose (x, _, _) + | SetSt (x, _, _) -> + let ss = gather_types ss x in + super#expr scx ss oe + | _ -> + super#expr scx ss oe + + method bounds scx ss bs = + let ss = + List.fold_left begin fun ss (v, _, _) -> + gather_types ss v + end ss bs + in + super#bounds scx ss bs + + method defn scx ss df = + match df.core with + | Operator (v, _) -> + let ss = gather_types ss v in + super#defn scx ss df + | _ -> + super#defn scx ss df + + method hyp scx ss h = + match h.core with + | Fresh (v, _, _, _) -> + let ss = gather_types ss v in + super#hyp scx ss h + | Flex v -> + let ss = gather_types ss v in + super#hyp scx ss h + | _ -> + super#hyp scx ss h + +end + +let main sq = + let scx = (), Deque.empty in + snd (visitor#sequent scx Ts.empty sq) + diff --git a/src/type/t_collect.mli b/src/type/t_collect.mli new file mode 100644 index 00000000..04730a9c --- /dev/null +++ b/src/type/t_collect.mli @@ -0,0 +1,13 @@ +(* + * encode/coltypes.mli --- collect types in an expression + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open T_t + +(** Collect all constant types (also called "sorts") found in an expression *) +val main : sequent -> Ts.t + diff --git a/src/type/t_collect.mlt b/src/type/t_collect.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/type/t_collect.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/type/t_hyps.ml b/src/type/t_hyps.ml new file mode 100644 index 00000000..32e2548a --- /dev/null +++ b/src/type/t_hyps.ml @@ -0,0 +1,133 @@ +(* + * type/hyps.ml --- search for type hypotheses + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open Ext +open Property + +open T_t + +module B = Builtin + + +let error ?at mssg = + let mssg = "Type.Hyps: " ^ mssg in + failwith mssg + +type 'a ret = 'a option Lazy.t + +let (||>) (f : 'a option) (g : 'a ret) : 'a option = + match f with + | Some x -> Some x + | None -> Lazy.force g + +let (&&>) (f : 'a option) (g : 'a ret) : 'a option = + match f with + | None -> None + | Some x -> begin + match Lazy.force g with + | Some y when x = y -> Some y + | _ -> None + end + + +type scx = hyp Deque.dq + +let search_type_hyp ~inferer ~pol scx oe = + let rec visit ~pol ix scx oe = + match oe.core with + | Apply ({ core = Internal (B.Mem | B.Notmem as b) }, [ { core = Ix n } ; e ]) + when n = ix && ((pol && b = B.Notmem) || (not pol && b = B.Mem)) -> + begin try + begin + match inferer scx e with + | TSet ty0 -> Some ty0 + | _ -> None + end + with _ -> None + end + + | Apply ({ core = Internal (B.Eq | B.Neq as b) }, [ { core = Ix n } ; e ]) + when n = ix && ((pol && b = B.Neq) || (not pol && b = B.Eq)) -> + begin try + Some (inferer scx e) + with _ -> None + end + + | Apply ({ core = Internal (B.Eq | B.Neq as b) }, [ e ; { core = Ix n } ]) + when n = ix && ((pol && b = B.Neq) || (not pol && b = B.Eq)) -> + begin try + Some (inferer scx e) + with _ -> None + end + + | Apply ({ core = Internal (B.Disj | B.Conj as b) }, [ e ; f ]) + when (pol && b = B.Disj) || (not pol && b = B.Conj) -> + visit ~pol ix scx e ||> + lazy (visit ~pol ix scx f) + + | Apply ({ core = Internal (B.Disj | B.Conj as b) }, [ e ; f ]) + when (not pol && b = B.Disj) || (pol && b = B.Conj) -> + visit ~pol ix scx e &&> + lazy (visit ~pol ix scx f) + + | List ((Or | And as b), es) + when (pol && b = Or) || (not pol && b = And) -> + List.fold_left begin fun r e -> + r ||> lazy (visit ~pol ix scx e) + end None es + + | List ((Or | And as b), es) + when (not pol && b = Or) || (pol && b = And) -> + List.fold_left begin fun r e -> + r &&> lazy (visit ~pol ix scx e) + end None es + + | Apply ({ core = Internal B.Neg }, [ e ]) -> + visit ~pol:(not pol) ix scx e + + | Apply ({ core = Internal B.Implies }, [ e ; f ]) -> + visit ~pol:(not pol) ix scx e ||> + lazy (visit ~pol ix scx f) + + | Quant (q, bs, e) + when (pol && q = Forall) || (not pol && q = Exists) -> + let n = List.length bs in + let scx = + List.fold_left begin fun scx (v, _, _) -> + (* This is *probably* unsafe, so I'm disabling it for now *) + (*let v = assign v Props.ty0_prop (TAtm TAIdv) in*) + let h = Fresh (v, Shape_expr, Constant, Unbounded) %% [] in + Deque.snoc scx h + end scx bs + in + visit ~pol (ix + n) scx e + + | Sequent sq when pol -> + visit_sq ix scx sq + + | _ -> None + + and visit_sq ix scx sq = + let rec spin ix scx hs = + match Deque.front hs with + | Some ({ core = Fact (e, Visible, _) } as h, hs) -> + visit ~pol:false ix scx e ||> + lazy (spin (ix + 1) (Deque.snoc scx h) hs) + | Some (h, hs) -> + spin (ix + 1) (Deque.snoc scx h) hs + | None -> + None + in + spin ix scx sq.context ||> + lazy (visit ~pol:true (ix + Deque.size sq.context) scx sq.active) + in + + let dummy = Fact (Internal B.TRUE %% [], Visible, NotSet) %% [] in + let scx = Deque.snoc scx dummy in + visit ~pol 1 scx oe + diff --git a/src/type/t_hyps.mli b/src/type/t_hyps.mli new file mode 100644 index 00000000..3698fd68 --- /dev/null +++ b/src/type/t_hyps.mli @@ -0,0 +1,32 @@ +(* + * type/hyps.mli --- search for type hypotheses + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T + +open T_t + +type scx = hyp Deque.dq + +(** Suppose [e] is an expression in the context [scx, NEW x]. + If [search_type_hyp ~inferer ~pol:true scx e] returns some [ty], then: + + [scx, NEW x |= P_ty(x) \/ e] + + where [P_ty] is the type predicate of [ty]. This implies that: + + [scx, NEW x |= e <=> ( P_ty(x) => e )] + + which means that the type [ty] can be safely assumed for [x]. + + Setting [pol] to [false] amounts to call the function on [~ e] instead, + and can be used to find type hypotheses for existentials. +*) +val search_type_hyp : + inferer:(scx -> expr -> ty0) -> + pol:bool -> + scx -> expr -> ty0 option + diff --git a/src/type/t_hyps.mlt b/src/type/t_hyps.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/type/t_hyps.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/type/t_synth.ml b/src/type/t_synth.ml new file mode 100644 index 00000000..95b7c3de --- /dev/null +++ b/src/type/t_synth.ml @@ -0,0 +1,1539 @@ +(* + * type/synth.ml --- decorate TLA+ expressions with types + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open Util +open Property +open Ext + +open T_t + +module B = Builtin + +let error ?at mssg = + let mssg = "Type.Synthesize: " ^ mssg in + (*Errors.bug ?at mssg*) + failwith mssg + + +(* {3 Context} *) + +type options = + { typelvl : int + } + +type scx = options * hyp Deque.dq + +let init = { typelvl = 0 }, Deque.empty + +let typelvl (ops, _ : scx) = ops.typelvl + +let adj_ty0 (ops, hx : scx) v ty0 = + let v = assign v Props.ty0_prop ty0 in + let h = Fresh (v, Shape_expr, Constant, Unbounded) %% [] in + let hx = Deque.snoc hx h in + (v, (ops, hx)) + +let adj_ty1 (ops, hx : scx) v ty1 = + let v = assign v Props.ty1_prop ty1 in + let h = Fresh (v, Shape_op 0, Constant, Unbounded) %% [] in + let hx = Deque.snoc hx h in + (v, (ops, hx)) + +let adj_ty2 (ops, hx : scx) v ty2 = + let v = assign v Props.ty2_prop ty2 in + let h = Fresh (v, Shape_op 0, Constant, Unbounded) %% [] in + let hx = Deque.snoc hx h in + (v, (ops, hx)) + +let bump (ops, hx : scx) = + let h = Fact (Internal B.TRUE %% [], Hidden, NotSet) %% [] in + let hx = Deque.snoc hx h in + (ops, hx) + +let lookup (_, hx : scx) n = + let h = Option.get (Deque.nth ~backwards:true hx (n - 1)) in + let v = hyp_hint h in + v + +let lookup_ty0 scx n = + let v = lookup scx n in + match query v Props.ty0_prop with + | Some ty0 -> ty0 + | None -> begin + match query v Props.ty1_prop with + | Some ty1 -> downcast_ty0 ty1 + | None -> begin + match query v Props.ty2_prop with + | Some ty2 -> downcast_ty0 (downcast_ty1 ty2) + | None -> error ~at:v ("Missing type (ord 0) on \ + '" ^ v.core ^ "'") + end + end + +let lookup_ty1 scx n = + let v = lookup scx n in + match query v Props.ty0_prop with + | Some ty0 -> upcast_ty1 ty0 + | None -> begin + match query v Props.ty1_prop with + | Some ty1 -> ty1 + | None -> begin + match query v Props.ty2_prop with + | Some ty2 -> downcast_ty1 ty2 + | None -> error ~at:v ("Missing type (ord 1) on \ + '" ^ v.core ^ "'") + end + end + +let lookup_ty2 scx n = + let v = lookup scx n in + match query v Props.ty0_prop with + | Some ty0 -> upcast_ty2 (upcast_ty1 ty0) + | None -> begin + match query v Props.ty1_prop with + | Some ty1 -> upcast_ty2 ty1 + | None -> begin + match query v Props.ty2_prop with + | Some ty2 -> ty2 + | None -> error ~at:v ("Missing type (ord 2) on \ + '" ^ v.core ^ "'") + end + end + + +(* {3 Helpers} *) + +let force_idv ~typelvl ty0 e = + if typelvl = 2 then + match ty0, query e Props.sproj_prop with + | TAtm TAIdv, _ -> e + | TAtm (TAInt | TABol), Some ty0' when ty0 = ty0' -> + remove e Props.sproj_prop + | TAtm (TAInt | TABol), _ -> + assign e Props.icast_prop ty0 + | _ -> e + else + match ty0, query e Props.sproj_prop with + | TAtm TAIdv, _ -> e + | _, Some ty0' when ty0 = ty0' -> + remove e Props.sproj_prop + | _ -> + assign e Props.icast_prop ty0 + +let force_bool ty0 e = + match ty0 with + | TAtm TABol -> e + | _ -> assign e Props.bproj_prop ty0 + +let force ~typelvl = function + | TAtm TAIdv -> force_idv ~typelvl + | TAtm TABol -> force_bool + | _ -> failwith "Bad argument to force" + +let idv_or_bol = function TAtm (TAIdv | TABol) -> true | _ -> false + +let force_arg ~typelvl ty11 ty12 ea = + match ty11, ty12 with + | Ty1 ([], ty01), Ty1 ([], ty02) + when idv_or_bol ty01 -> + force ~typelvl ty01 ty02 ea + | Ty1 (ty01s, ty02), Ty1 (ty03s, ty04) + when List.length ty01s = List.length ty03s + && List.for_all idv_or_bol ty03s && idv_or_bol ty02 -> + let n = List.length ty01s in + let vs = + List.mapi begin fun i ty01 -> + let v = ("x" ^ string_of_int (i + 1)) %% [] in + (assign v Props.ty0_prop ty01, Shape_expr) + end ty01s + in + let ea = + Apply ( + Expr.Subst.app_expr (Expr.Subst.shift n) ea, + List.mapi begin fun i (ty01, ty03) -> + force ~typelvl ty03 ty01 (Ix (n - i) %% []) + end (List.combine ty01s ty03s) + ) %% [] |> + Expr.Subst.app_expr (Expr.Subst.shift 0) (* force normalize *) + in + Lambda (vs, force ~typelvl ty02 ty04 ea) %% [] + | _ -> + error ~at:ea "Impossible operator conversion" + +(* Expressions for which a sort was infered but that cannot be encoded + * into an expression of that sort (for some reason) need to be marked + * as 'projected' into that sort. *) +let proj ~typelvl ty0 e = + if typelvl = 2 then + match ty0 with + | TAtm (TAInt) -> + assign e Props.sproj_prop ty0 + | _ -> e + else + assign e Props.sproj_prop ty0 + + +let shp_to_ty1 = function + | Shape_expr -> Ty1 ([], TAtm TAIdv) + | Shape_op n -> Ty1 (List.init n (fun _ -> TAtm TAIdv), TAtm TAIdv) + +let is_lambda = function + | Lambda _ -> true + | _ -> false + +let map3 f l1 l2 l3 = + List.map2 f l1 l2 |> + List.map2 (|>) l3 + +let rec fold_left3 f a l1 l2 l3 = + match l1, l2, l3 with + | [], [], [] -> a + | b :: l1, c :: l2, d :: l3 -> + fold_left3 f (f a b c d) l1 l2 l3 + | _, _, _ -> + failwith "fold_left3" + + +(* {3 Main} *) + +let rec expr scx oe = + let oe, ty0 = expr_aux scx oe in + let oe = map_pats (List.map (fun e -> expr scx e |> fst)) oe in + (oe, ty0) + +and expr_aux scx oe = + let force_idv ty x = force_idv ~typelvl:(typelvl scx) ty x in + let force_arg ty x = force_arg ~typelvl:(typelvl scx) ty x in + let proj ty x = proj ~typelvl:(typelvl scx) ty x in + match oe.core with + | Ix n -> + let ty0 = lookup_ty0 scx n in + (Ix n @@ oe, ty0) + + | Opaque s -> + (Opaque s @@ oe, TAtm TAIdv) + + | Apply ({ core = Opaque s } as op, es) -> + let es, ty0s = List.map (expr scx) es |> List.split in + let es = + List.map2 begin fun e ty0 -> + force_idv ty0 e + end es ty0s + in + (Apply (op, es) @@ oe, TAtm TAIdv) + + | Apply ({ core = Internal B.Unprimable } as op, [ e ]) -> + let e, ty0 = expr scx e in + let ret = Apply (op, [ e ]) @@ oe in + (ret, ty0) + + | Internal (B.TRUE | B.FALSE as b) -> + (Internal b @@ oe, TAtm TABol) + + | Apply ({ core = Internal (B.Implies | B.Equiv | B.Conj | B.Disj) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + let ret = Apply (op, [ force_bool ty01 e ; force_bool ty02 f ]) @@ oe in + (ret, TAtm TABol) + + | Apply ({ core = Internal B.Neg } as op, [ e ]) -> + let e, ty0 = expr scx e in + let ret = Apply (op, [ force_bool ty0 e ]) @@ oe in + (ret, TAtm TABol) + + | Apply ({ core = Internal (B.Eq | B.Neq) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + if ty01 = ty02 && typelvl scx > 1 then + let op = assign op Props.tpars_prop [ ty01 ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TAtm TABol) + else + let op = assign op Props.tpars_prop [ TAtm TAIdv ] in + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TABol) + + | List (Refs, [ e ]) -> + let e, ty0 = expr scx e in + let ret = List (Refs, [ e ]) @@ oe in + (ret, ty0) + + | List (bl, es) -> + let es, ty0s = List.map (expr scx) es |> List.split in + let ret = List (bl, List.map2 force_bool ty0s es) @@ oe in + (ret, TAtm TABol) + + | If (e, f, g) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + let g, ty03 = expr scx g in + if ty02 = ty03 then + let ret = If (force_bool ty01 e, f, g) @@ oe in + let ret = assign ret Props.tpars_prop [ ty02 ] in + (ret, ty02) + else + let ret = If (force_bool ty01 e, force_idv ty02 f, force_idv ty03 g) @@ oe in + let ret = assign ret Props.tpars_prop [ TAtm TAIdv ] in + (ret, TAtm TAIdv) + + | Case (ps, Some o) -> + let ps, ty01s = + List.map begin fun (p, e) -> + let p, ty01 = expr scx p in + let e, ty02 = expr scx e in + ((force_bool ty01 p, e), ty02) + end ps |> + List.split + in + let o, ty02 = expr scx o in + if List.for_all ((=) ty02) ty01s then + let ret = Case (ps, Some o) @@ oe in + let ret = assign ret Props.tpars_prop [ ty02 ] in + (ret, ty02) + else + let ps = + List.map2 begin fun (p, e) ty0 -> + (p, force_idv ty0 e) + end ps ty01s + in + let o = force_idv ty02 o in + let ret = Case (ps, Some o) @@ oe in + let ret = assign ret Props.tpars_prop [ TAtm TAIdv ] in + (ret, TAtm TAIdv) + + | Case (ps, None) -> + let ps = + List.map begin fun (p, e) -> + let p, ty01 = expr scx p in + let e, ty02 = expr scx e in + (force_bool ty01 p, force_idv ty02 e) + end ps + in + let ret = Case (ps, None) @@ oe in + let ret = assign ret Props.tpars_prop [ TAtm TAIdv ] in + (ret, TAtm TAIdv) + + | Quant (q, bs, e) -> + let scx, bs, _ = + List.fold_left begin fun (scx', r_bs, last_ty0) (v, k, dom) -> + match dom, last_ty0 with + | Domain e, _ -> + let e, ty01 = expr scx e in (* eval in top context *) + begin match ty01 with + | TSet ty02 when typelvl scx = 3 -> + let v, scx' = adj_ty0 scx' v ty02 in + let dom = Domain (assign e Props.mpars_prop ty02) in + (scx', (v, k, dom) :: r_bs, Some ty02) + | TSet (TAtm _ as ty02) when typelvl scx = 2 -> + let v, scx' = adj_ty0 scx' v ty02 in + let dom = Domain (force_idv ty01 e) in + let v = force_idv ty02 v in + (scx', (v, k, dom) :: r_bs, Some ty02) + | TSet ty02 when typelvl scx = 2 -> + let _, scx' = adj_ty0 scx' v ty02 in + let v = assign v Props.ty0_prop (TAtm TAIdv) in + let dom = Domain (force_idv ty01 e) in + (scx', (v, k, dom) :: r_bs, Some ty02) + | _ -> + let v, scx' = adj_ty0 scx' v (TAtm TAIdv) in + let dom = Domain (force_idv ty01 e) in + (scx', (v, k, dom) :: r_bs, None) + end + | Ditto, Some ty0 -> + let v, scx' = adj_ty0 scx' v ty0 in + (scx', (v, k, Ditto) :: r_bs, Some ty0) + | Ditto, None + | No_domain, _ when typelvl scx = 2 -> + let pol = + match q with + | Forall -> true + | Exists -> false + in + let e' = + let n = List.length r_bs + 1 in + if n = List.length bs then e + else + let bs' = snd (List.split_nth (List.length r_bs + 1) bs) in + Quant (q, bs', e) %% [] + in + let inferer = fun hx e -> snd (expr (fst scx, hx) e) in + begin match T_hyps.search_type_hyp ~inferer ~pol:pol (snd scx') e' with + | Some (TAtm _ as ty02) -> + let v, scx' = adj_ty0 scx' v ty02 in + let v = force_idv ty02 v in + (scx', (v, k, dom) :: r_bs, Some ty02) + | Some ty02 -> + let _, scx' = adj_ty0 scx' v ty02 in + let v = assign v Props.ty0_prop (TAtm TAIdv) in + (scx', (v, k, dom) :: r_bs, Some ty02) + | None -> + let v, scx' = adj_ty0 scx' v (TAtm TAIdv) in + (scx', (v, k, dom) :: r_bs, None) + end + | Ditto, None + | No_domain, _ -> + let v, scx' = adj_ty0 scx' v (TAtm TAIdv) in + (scx', (v, k, dom) :: r_bs, None) + end (scx, [], None) bs |> + fun (scx, r_bs, last_ty0) -> (scx, List.rev r_bs, last_ty0) + in + let e, ty0 = expr scx e in + (Quant (q, bs, force_bool ty0 e) @@ oe, TAtm TABol) + + | Sequent sq -> + let _, sq = sequent scx sq in + (Sequent sq @@ oe, TAtm TABol) + + | Let (dfs, e) -> + let scx, dfs = defns scx dfs in + let e, ty0 = expr scx e in + (Let (dfs, e) @@ oe, ty0) + + | Choose (v, Some d, e) -> + let d, ty01 = expr scx d in + begin match ty01 with + | TSet ty02 when typelvl scx = 3 -> + let v, scx = adj_ty0 scx v ty02 in + let e, ty03 = expr scx e in + let ret = Choose (v, Some d, force_bool ty03 e) @@ oe in + let ret = assign ret Props.mpars_prop ty02 in + (ret, TAtm TAIdv) + | TSet (TAtm _ as ty02) when typelvl scx = 2 -> + let v, scx = adj_ty0 scx v ty02 in + let e, ty03 = expr scx e in + let v = force_idv ty02 v in + let ret = Choose (v, Some d, force_bool ty03 e) @@ oe in + (ret, TAtm TAIdv) + | _ -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let e, ty03 = expr scx e in + let ret = Choose (v, Some (force_idv ty01 d), force_bool ty03 e) @@ oe in + (ret, TAtm TAIdv) + end + + | Choose (v, None, e) -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let e, ty0 = expr scx e in + let ret = Choose (v, None, force_bool ty0 e) @@ oe in + (ret, TAtm TAIdv) + + | Apply ({ core = Internal (B.Mem | B.Notmem) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + | ty03, TSet ty04 when typelvl scx = 3 && ty03 = ty04-> + let op = assign op Props.tpars_prop [ ty03 ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TAtm TABol) + | _, _ -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TABol) + end + + | Apply ({ core = Internal B.Subseteq } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + | TSet ty03, TSet ty04 when typelvl scx = 3 && ty03 = ty04 -> + let op = assign op Props.tpars_prop [ ty03 ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TAtm TABol) + | TSet ty03, TSet ty04 when typelvl scx = 2 && ty03 = ty04 -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TABol) + | _, _ -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TABol) + end + + | SetEnum es -> + let es, ty01s = List.map (expr scx) es |> List.split in + begin match ty01s with + | [] when typelvl scx = 3 -> + let ret = SetEnum es @@ oe in + let ret = assign ret Props.tpars_prop [ TAtm TAIdv ] in + (ret, TSet (TAtm TAIdv)) + | [] when typelvl scx = 2 -> + let ret = SetEnum es @@ oe in + (ret, TSet (TAtm TAIdv)) + | ty03 :: ty04s when typelvl scx = 3 && List.for_all ((=) ty03) ty04s -> + let ret = SetEnum es @@ oe in + let ret = assign ret Props.tpars_prop [ ty03 ] in + (ret, TSet ty03) + | ty03 :: ty04s when typelvl scx = 2 && List.for_all ((=) ty03) ty04s -> + let ret = SetEnum (List.map2 force_idv ty01s es) @@ oe in + (ret, TSet ty03) + | _ -> + let ret = SetEnum (List.map2 force_idv ty01s es) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal B.UNION } as op, [ e ]) -> + let e, ty01 = expr scx e in + begin match ty01 with + | TSet (TSet ty02) when typelvl scx = 3 -> + let op = assign op Props.tpars_prop [ ty02 ] in + let ret = Apply (op, [ e ]) @@ oe in + (ret, TSet ty02) + | TSet (TSet ty02) when typelvl scx = 2 -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TSet ty02) + | _ -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal B.SUBSET } as op, [ e ]) -> + let e, ty01 = expr scx e in + begin match ty01 with + | TSet ty02 when typelvl scx = 3 -> + let op = assign op Props.tpars_prop [ ty02 ] in + let ret = Apply (op, [ e ]) @@ oe in + (ret, TSet (TSet ty02)) + | TSet ty02 when typelvl scx = 2 -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TSet (TSet ty02)) + | _ -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TAtm TAIdv) + end + + | SetSt (v, e, f) -> + let e, ty01 = expr scx e in + begin match ty01 with + | TSet ty02 when typelvl scx = 3 -> + let v, scx = adj_ty0 scx v ty02 in + let f, ty03 = expr scx f in + let ret = SetSt (v, e, force_bool ty03 f) @@ oe in + let ret = assign ret Props.tpars_prop [ ty02 ] in + (ret, TSet ty02) + | TSet ty02 when typelvl scx = 2 -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let f, ty03 = expr scx f in + let ret = SetSt (v, force_idv ty01 e, force_bool ty03 f) @@ oe in + (ret, TSet ty02) + | _ -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let f, ty03 = expr scx f in + let ret = SetSt (v, force_idv ty01 e, force_bool ty03 f) @@ oe in + (ret, TAtm TAIdv) + end + + | SetOf (e, bs) -> + (* Either all domains are sets and none is converted, or one is not a set + * and all are converted. *) + let doms, ty01s, _ = + List.fold_left begin fun (r_doms, r_ty01s, last_ty0) (v, _, dom) -> + match dom, last_ty0 with + | Domain e, _ -> + let e, ty0 = expr scx e in + (Domain e :: r_doms, ty0 :: r_ty01s, Some ty0) + | Ditto, Some ty0 -> + (Ditto :: r_doms, ty0 :: r_ty01s, Some ty0) + | No_domain, _ + | Ditto, None -> + error ~at:v "Missing domain (constructor SetOf)" + end ([], [], None) bs |> + fun (r_doms, r_ty01s, last_ty0) -> (List.rev r_doms, List.rev r_ty01s, last_ty0) + in + let oty02s = + if typelvl scx > 1 then try + Some (List.map (function TSet ty0 -> ty0 | _ -> raise Exit) ty01s) + with Exit -> None + else None + in + begin match oty02s with + | Some ty03s when typelvl scx = 3 -> + let scx, bs = + fold_left3 begin fun (scx, r_bs) (v, k, _) dom ty03 -> + let v, scx = adj_ty0 scx v ty03 in + let dom = + match dom with + | Domain e -> Domain (assign e Props.tpars_prop [ ty03 ]) + | _ -> dom + in + (scx, (v, k, dom) :: r_bs) + end (scx, []) bs doms ty03s |> + fun (scx, r_bs) -> (scx, List.rev r_bs) + in + let e, ty04 = expr scx e in + let ret = SetOf (e, bs) @@ oe in + let ret = assign ret Props.tpars_prop (ty04 :: ty03s) in + (ret, TSet ty04) + | Some ty03s when typelvl scx = 2 -> + let scx, bs = + fold_left3 begin fun (scx, r_bs) (v, k, _) dom ty03 -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let dom = + match dom with + | Domain e -> Domain (force_idv ty03 e) + | _ -> dom + in + (scx, (v, k, dom) :: r_bs) + end (scx, []) bs doms ty01s |> + fun (scx, r_bs) -> (scx, List.rev r_bs) + in + let e, ty04 = expr scx e in + let ret = SetOf (force_idv ty04 e, bs) @@ oe in + let ret = assign ret Props.tpars_prop (ty04 :: ty03s) in + (ret, TSet ty04) + | _ -> + let scx, bs = + fold_left3 begin fun (scx, r_bs) (v, k, _) dom ty03 -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let dom = + match dom with + | Domain e -> Domain (force_idv ty03 e) + | _ -> dom + in + (scx, (v, k, dom) :: r_bs) + end (scx, []) bs doms ty01s |> + fun (scx, r_bs) -> (scx, List.rev r_bs) + in + let e, ty04 = expr scx e in + let ret = SetOf (force_idv ty04 e, bs) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal (B.Cap | B.Cup | B.Setminus) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + | TSet ty03, TSet ty04 when typelvl scx = 3 && ty03 = ty04 -> + let op = assign op Props.tpars_prop [ ty03 ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TSet ty03) + | TSet ty03, TSet ty04 when typelvl scx = 2 && ty03 = ty04 -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TSet ty03) + | _, _ -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TAIdv) + end + + | Internal B.BOOLEAN -> + if typelvl scx >= 2 then + let ret = Internal B.BOOLEAN @@ oe in + (ret, TSet (TAtm TABol)) + else + let ret = Internal B.BOOLEAN @@ oe in + (ret, TAtm TAIdv) + + | Internal B.STRING -> + if typelvl scx >= 2 then + let ret = Internal B.STRING @@ oe in + (ret, TSet (TAtm TAStr)) + else + let ret = Internal B.STRING @@ oe in + (ret, TAtm TAIdv) + + | String s -> + if typelvl scx >= 2 then + let ret = String s @@ oe in + (ret, TAtm TAStr) + else + let ret = String s @@ oe in + (ret, TAtm TAIdv) + + | Fcn (bs, e) -> + (* copypasted from SetOf case; same principle *) + let doms, ty01s, _ = + List.fold_left begin fun (r_doms, r_ty01s, last_ty0) (v, _, dom) -> + match dom, last_ty0 with + | Domain e, _ -> + let e, ty0 = expr scx e in + (Domain e :: r_doms, ty0 :: r_ty01s, Some ty0) + | Ditto, Some ty0 -> + (Ditto :: r_doms, ty0 :: r_ty01s, Some ty0) + | No_domain, _ + | Ditto, None -> + error ~at:v "Missing domain (constructor Fcn)" + end ([], [], None) bs |> + fun (r_doms, r_ty01s, last_ty0) -> (List.rev r_doms, List.rev r_ty01s, last_ty0) + in + let oty02s = + if typelvl scx > 1 then try + Some (List.map (function TSet ty0 -> ty0 | _ -> raise Exit) ty01s) + with Exit -> None + else None + in + begin match oty02s with + | Some ty03s when typelvl scx = 3 -> + let scx, bs = + fold_left3 begin fun (scx, r_bs) (v, k, _) dom ty03 -> + let v, scx = adj_ty0 scx v ty03 in + let dom = + match dom with + | Domain e -> Domain (assign e Props.tpars_prop [ ty03 ]) + | _ -> dom + in + (scx, (v, k, dom) :: r_bs) + end (scx, []) bs doms ty03s |> + fun (scx, r_bs) -> (scx, List.rev r_bs) + in + let e, ty04 = expr scx e in + let ret = Fcn (bs, e) @@ oe in + let ty0 = + match ty03s with + | [ ty05 ] -> TFun (ty05, ty04) + | _ -> TFun (TPrd ty03s, ty04) + in + let ret = assign ret Props.tpars_prop (ty03s @ [ ty04 ]) in + (ret, ty0) + | Some ty03s when typelvl scx = 2 -> + let scx, bs = + fold_left3 begin fun (scx, r_bs) (v, k, _) dom ty03 -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let dom = + match dom with + | Domain e -> Domain (force_idv ty03 e) + | _ -> dom + in + (scx, (v, k, dom) :: r_bs) + end (scx, []) bs doms ty01s |> + fun (scx, r_bs) -> (scx, List.rev r_bs) + in + let e, ty04 = expr scx e in + let ret = Fcn (bs, force_idv ty04 e) @@ oe in + let ty0 = + match ty03s with + | [ ty05 ] -> TFun (ty05, ty04) + | _ -> TFun (TPrd ty03s, ty04) + in + (ret, ty0) + | _ -> + let scx, bs = + fold_left3 begin fun (scx, r_bs) (v, k, _) dom ty03 -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let dom = + match dom with + | Domain e -> Domain (force_idv ty03 e) + | _ -> dom + in + (scx, (v, k, dom) :: r_bs) + end (scx, []) bs doms ty01s |> + fun (scx, r_bs) -> (scx, List.rev r_bs) + in + let e, ty04 = expr scx e in + let ret = Fcn (bs, force_idv ty04 e) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal B.DOMAIN } as op, [ e ]) -> + let e, ty01 = expr scx e in + begin match ty01 with + | TFun (ty02, ty03) when typelvl scx = 3 -> + let op = assign op Props.tpars_prop [ ty01 ] in + let ret = Apply (op, [ e ]) @@ oe in + (ret, TSet ty02) + | TPrd ty02s when typelvl scx = 3 -> + let op = assign op Props.tpars_prop [ ty01 ] in + let ret = Apply (op, [ e ]) @@ oe in + (ret, TSet (TAtm TAInt)) + | TRec fty0s when typelvl scx = 3 -> + let op = assign op Props.tpars_prop [ ty01 ] in + let ret = Apply (op, [ e ]) @@ oe in + (ret, TSet (TAtm TAStr)) + | TFun (ty02, ty03) when typelvl scx = 2 -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TSet ty02) + | TPrd ty02s when typelvl scx = 2 -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TSet (TAtm TAInt)) + | TRec fty0s when typelvl scx = 2 -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TSet (TAtm TAStr)) + | _ -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TAtm TAIdv) + end + + | FcnApp (e1, [{ core = Num (n, "") } as e2]) -> + let e1, ty01 = expr scx e1 in + let n = int_of_string n in + begin match ty01 with + | TPrd ty03s when typelvl scx = 3 && List.length ty03s >= n -> + let ret = FcnApp (e1, [ e2 ]) @@ oe in + let ret = assign ret Props.tpars_prop [ ty01 ] in + (ret, List.nth ty03s (n-1)) + | TPrd ty03s when typelvl scx = 2 && List.length ty03s >= n -> + let e2 = assign e2 Props.tpars_prop [ ] in + let ret = FcnApp (force_idv ty01 e1, [ force_idv (TAtm TAInt) e2 ]) @@ oe in + let ty04 = List.nth ty03s (n-1) in + let ret = proj ty04 ret in + (ret, ty04) + | _ -> + let oe = FcnApp (e1, [ Apply (e2, []) %% [] ]) @@ oe in + expr scx oe + end + + | FcnApp (e1, [{ core = String s } as e2]) -> + let e1, ty01 = expr scx e1 in + begin match ty01 with + | TRec fty0s when typelvl scx = 3 && List.exists (fun (f, _) -> f = s) fty0s -> + let ret = FcnApp (e1, [ e2 ]) @@ oe in + let ret = assign ret Props.tpars_prop [ ty01 ] in + let ty02 = List.find (fun (f, _) -> f = s) fty0s |> snd in + (ret, ty02) + | TRec fty0s when typelvl scx = 2 && List.exists (fun (f, _) -> f = s) fty0s -> + let ret = FcnApp (force_idv ty01 e1, [ e2 ]) @@ oe in + let ty02 = List.find (fun (f, _) -> f = s) fty0s |> snd in + let ret = proj ty02 ret in + (ret, ty02) + | _ -> + let oe = FcnApp (e1, [ Apply (e2, []) %% [] ]) @@ oe in + expr scx oe + end + + | FcnApp (e, es) -> + let e, ty01 = expr scx e in + let es, ty02s = List.map (expr scx) es |> List.split in + begin match ty01 with + | TFun (TPrd ty03s, ty04) when typelvl scx = 3 && List.for_all2 (=) ty02s ty03s -> + let ret = FcnApp (e, es) @@ oe in + let ret = assign ret Props.tpars_prop [ ty01 ] in + (*(ret, ty04)*) + (ret, TAtm TAIdv) + | TFun (ty03, ty04) when typelvl scx = 3 && List.length es = 1 && List.hd ty02s = ty03 -> + let ret = FcnApp (e, es) @@ oe in + let ret = assign ret Props.tpars_prop [ ty01 ] in + (*(ret, ty04)*) + (ret, TAtm TAIdv) + | TFun (TPrd ty03s, ty04) when typelvl scx = 2 && List.for_all2 (=) ty02s ty03s -> + let ret = FcnApp (force_idv ty01 e, List.map2 force_idv ty02s es) @@ oe in + (*(ret, ty04)*) + (ret, TAtm TAIdv) + | TFun (ty03, ty04) when typelvl scx = 2 && List.length es = 1 && List.hd ty02s = ty03 -> + let ret = FcnApp (force_idv ty01 e, List.map2 force_idv ty02s es) @@ oe in + (*(ret, ty04)*) + (ret, TAtm TAIdv) + | _ -> + let ret = FcnApp (force_idv ty01 e, List.map2 force_idv ty02s es) @@ oe in + (ret, TAtm TAIdv) + end + + | Dot (e, s) -> + let e, ty01 = expr scx e in + begin match ty01 with + | TFun (TAtm TAStr, ty02) when typelvl scx = 3 -> + let ret = Dot (e, s) @@ oe in + let ret = assign ret Props.tpars_prop [ ty01 ] in + (ret, ty02) + | TRec fty0s when typelvl scx = 3 && List.exists (fun (f, _) -> f = s) fty0s -> + let ret = Dot (e, s) @@ oe in + let ret = assign ret Props.tpars_prop [ ty01 ] in + let ty02 = List.find (fun (f, _) -> f = s) fty0s |> snd in + (ret, ty02) + | TFun (TAtm TAStr, ty02) when typelvl scx = 2 -> + let ret = Dot (force_idv ty01 e, s) @@ oe in + let ret = proj ty02 ret in + (ret, ty02) + | TRec fty0s when typelvl scx = 2 && List.exists (fun (f, _) -> f = s) fty0s -> + let ret = Dot (force_idv ty01 e, s) @@ oe in + let ty02 = List.find (fun (f, _) -> f = s) fty0s |> snd in + let ret = proj ty02 ret in + (ret, ty02) + | _ -> + let ret = Dot (force_idv ty01 e, s) @@ oe in + (ret, TAtm TAIdv) + end + + | Product es -> + let es, ty01s = List.map (expr scx) es |> List.split in + let oty02s = + if typelvl scx > 1 then try + Some (List.map (function TSet ty0 -> ty0 | _ -> raise Exit) ty01s) + with Exit -> None + else None + in + begin match oty02s with + | Some ty02s when typelvl scx = 3 -> + let ret = Product es @@ oe in + let ret = assign ret Props.tpars_prop ty02s in + (ret, TSet (TPrd ty02s)) + | Some ty02s when typelvl scx = 2 -> + let ret = Product (List.map2 force_idv ty01s es) @@ oe in + (ret, TSet (TPrd ty02s)) + | _ -> + let ret = Product (List.map2 force_idv ty01s es) @@ oe in + (ret, TAtm TAIdv) + end + + | Tuple es -> + let es, ty0s = List.map (expr scx) es |> List.split in + if typelvl scx = 3 then + let ret = Tuple es @@ oe in + let ret = assign ret Props.tpars_prop ty0s in + (ret, TPrd ty0s) + else if typelvl scx = 2 then + let ret = Tuple (List.map2 force_idv ty0s es) @@ oe in + (ret, TPrd ty0s) + else + let ret = Tuple (List.map2 force_idv ty0s es) @@ oe in + (ret, TAtm TAIdv) + + | Arrow (e, f) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + | TSet ty03, TSet ty04 when typelvl scx = 3 -> + let ret = Arrow (e, f) @@ oe in + let ret = assign ret Props.tpars_prop [ ty03 ; ty04 ] in + (ret, TSet (TFun (ty03, ty04))) + | TSet ty03, TSet ty04 when typelvl scx = 2 -> + let ret = Arrow (force_idv ty01 e, force_idv ty02 f) @@ oe in + (ret, TSet (TFun (ty03, ty04))) + | _, _ -> + let ret = Arrow (force_idv ty01 e, force_idv ty02 f) @@ oe in + (ret, TAtm TAIdv) + end + + | Rect fs -> + let fs, ty01s = + List.map begin fun (f, e) -> + let e, ty0 = expr scx e in + (f, e), ty0 + end fs |> + List.split + in + let oty02s = + if typelvl scx > 1 then try + Some (List.map (function TSet ty0 -> ty0 | _ -> raise Exit) ty01s) + with Exit -> None + else None + in + begin match oty02s with + | Some ty02s when typelvl scx = 3 -> + let ret = Rect fs @@ oe in + let ret = assign ret Props.tpars_prop ty02s in + let fty0s = List.map2 (fun (f, _) ty0 -> (f, ty0)) fs ty02s in + (ret, TSet (TRec fty0s)) + | Some ty02s when typelvl scx = 3 -> + let fs = List.map2 (fun (f, e) ty0 -> (f, force_idv ty0 e)) fs ty01s in + let ret = Rect fs @@ oe in + let fty0s = List.map2 (fun (f, _) ty0 -> (f, ty0)) fs ty02s in + (ret, TSet (TRec fty0s)) + | _ -> + let fs = List.map2 (fun (f, e) ty0 -> (f, force_idv ty0 e)) fs ty01s in + let ret = Rect fs @@ oe in + (ret, TAtm TAIdv) + end + + | Record fs -> + let fs, ty0s = + List.map begin fun (f, e) -> + let e, ty0 = expr scx e in + (f, e), ty0 + end fs |> + List.split + in + if typelvl scx = 3 then + let ret = Record fs @@ oe in + let ret = assign ret Props.tpars_prop ty0s in + let fty0s = List.map2 (fun (f, _) ty0 -> (f, ty0)) fs ty0s in + (ret, TRec fty0s) + else if typelvl scx = 2 then + let fs = List.map2 (fun (f, e) ty0 -> (f, force_idv ty0 e)) fs ty0s in + let ret = Record fs @@ oe in + let fty0s = List.map2 (fun (f, _) ty0 -> (f, ty0)) fs ty0s in + (ret, TRec fty0s) + else + let fs = List.map2 (fun (f, e) ty0 -> (f, force_idv ty0 e)) fs ty0s in + let ret = Record fs @@ oe in + (ret, TAtm TAIdv) + + | Except (e, exps) -> + (* FIXME implement for the simplest case, overloaded for functions and records *) + let e, ty01 = expr scx e in + let exps, exp_ty0s = + List.map begin fun (expts, a) -> + let expts, ty02s = + List.map begin function + | Except_dot s -> + (Except_dot s, TAtm TAStr) + | Except_apply u -> + let u, ty02 = expr scx u in + (Except_apply u, ty02) + end expts |> + List.split + in + let a, ty03 = expr scx a in + (expts, a), (ty02s, ty03) + end exps |> + List.split + in + let oty04s = + if typelvl scx = 3 then begin + (* In `[ f EXCEPT ![d1]..[dn] = a, .. ]` the function `f` + * is expected to be a currified function, `d1` to have the + * type of the first argument, `d2` the second etc. + * The longest chain of expoints contains all the relevant types; + * all other chains are verified in comparison with those types. *) + let mk_fcn_ty ty0s ty0 = + List.fold_right (fun ty01 ty02 -> TFun (ty01, ty02)) ty0s ty0 + in + let ty04s, ty05 = + List.fold_left begin fun (max, ty0s, ty0 as last) (ty02s, ty03) -> + let n = List.length ty02s in + if n > max then (n, ty02s, ty03) else last + end (0, [], TAtm TAIdv) exp_ty0s |> + fun (_, ty02s, ty03) -> + (ty02s, ty03) + in + if ty01 <> mk_fcn_ty ty04s ty05 then None + else + let check_exp (ty02s, ty03) = + let rec spin = function + | [], ty04s -> + Some ty04s + | ty02 :: ty02s, ty04 :: ty04s -> + if ty02 = ty04 then + spin (ty02s, ty04s) + else + None + | _, [] -> + assert false + in + match spin (ty02s, ty04s) with + | Some ty06s -> ty05 = mk_fcn_ty ty06s ty03 + | None -> false + in + if List.for_all check_exp exp_ty0s then + Some (ty04s @ [ ty05 ]) + else None + end else None + in + begin match oty04s with + | Some ty04s when typelvl scx = 3 -> + let ret = Except (e, exps) @@ oe in + let ret = assign ret Props.tpars_prop ty04s in + (ret, ty01) + (* FIXME typelvl = 2 missing *) + | _ -> + let e = force_idv ty01 e in + let exps = + List.map2 begin fun (expts, a) (ty02s, ty03) -> + let expts = + List.map2 begin fun expt ty02 -> + match expt with + | Except_dot s -> Except_dot s + | Except_apply u -> Except_apply (force_idv ty02 u) + end expts ty02s + in + let a = force_idv ty03 a in + (expts, a) + end exps exp_ty0s + in + let ret = Except (e, exps) @@ oe in + (ret, TAtm TAIdv) + end + + | Internal B.Nat -> + (* NOTE Same behavior for typelvl = 2, 3 + * but axioms will differ *) + if typelvl scx > 1 then + let ret = Internal B.Nat @@ oe in + (ret, TSet (TAtm TAInt)) + else + let ret = Internal B.Nat @@ oe in + (ret, TAtm TAIdv) + + | Internal B.Int -> + (* NOTE Same behavior for typelvl = 2, 3 + * but axioms will differ *) + if typelvl scx > 1 then + let ret = Internal B.Int @@ oe in + (ret, TSet (TAtm TAInt)) + else + let ret = Internal B.Int @@ oe in + (ret, TAtm TAIdv) + + | Internal B.Real -> + if typelvl scx = 3 then + let ret = Internal B.Real @@ oe in + let ret = assign ret Props.tpars_prop [ ] in + (ret, TSet (TAtm TARel)) + else if typelvl scx = 2 then + let ret = Internal B.Real @@ oe in + (ret, TSet (TAtm TARel)) + else + let ret = Internal B.Real @@ oe in + (ret, TAtm TAIdv) + + | Num (s, "") -> + if typelvl scx > 0 then + let ret = Num (s, "") @@ oe in + let ret = assign ret Props.tpars_prop [ ] in + (ret, TAtm TAInt) + else + let ret = Num (s, "") @@ oe in + (ret, TAtm TAIdv) + + | Num (s1, s2) -> + if typelvl scx > 0 then + let ret = Num (s1, s2) @@ oe in + let ret = assign ret Props.tpars_prop [ ] in + (ret, TAtm TARel) + else + let ret = Num (s1, s2) @@ oe in + (ret, TAtm TAIdv) + + | Internal B.Infinity -> + let ret = Internal B.Infinity @@ oe in + (ret, TAtm TAIdv) + + | Apply ({ core = Internal (B.Plus | B.Minus | B.Times) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + | TAtm TAInt, TAtm TAInt when typelvl scx > 1 -> + let op = assign op Props.tpars_prop [ TAtm TAInt ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TAtm TAInt) + | TAtm TARel, TAtm TARel when typelvl scx > 1 -> + let op = assign op Props.tpars_prop [ TAtm TARel ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TAtm TARel) + | _, _ -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal B.Uminus } as op, [ e ]) -> + let e, ty01 = expr scx e in + begin match ty01 with + | TAtm TAInt when typelvl scx > 1 -> + let op = assign op Props.tpars_prop [ TAtm TAInt ] in + let ret = Apply (op, [ e ]) @@ oe in + (ret, TAtm TAInt) + | TAtm TARel when typelvl scx <> 1 -> + let op = assign op Props.tpars_prop [ TAtm TARel ] in + let ret = Apply (op, [ e ]) @@ oe in + (ret, TAtm TARel) + | _ -> + let ret = Apply (op, [ force_idv ty01 e ]) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal (B.Exp | B.Quotient | B.Remainder) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + (* FIXME Check conditions for when Exp, Quotient and Remainder are specified in TLA+ *) + (*| TAtm TAInt, TAtm TAInt when typelvl scx > 1 -> + let op = assign op Props.tpars_prop [ ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TAtm TAInt)*) + | _, _ -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal B.Range } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + | _, _ when typelvl scx > 1 -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (* NOTE Intervals are always sets of integers *) + (ret, TSet (TAtm TAInt)) + | _, _ -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TAIdv) + end + + | Apply ({ core = Internal (B.Lteq | B.Lt | B.Gteq | B.Gt) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + begin match ty01, ty02 with + | TAtm TAInt, TAtm TAInt when typelvl scx > 1 -> + let op = assign op Props.tpars_prop [ TAtm TAInt ] in + let ret = Apply (op, [ e ; f ]) @@ oe in + (ret, TAtm TABol) + | _, _ -> + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TABol) + end + + (* NOTE Sequences implemented as untyped operators only *) + + | Apply ({ core = Internal (B.Seq | B.Len | B.BSeq | B.Head | B.Tail) } as op, [ e ]) -> + let e, ty0 = expr scx e in + let ret = Apply (op, [ force_idv ty0 e ]) @@ oe in + (ret, TAtm TAIdv) + + | Apply ({ core = Internal (B.Cat | B.Append) } as op, [ e ; f ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ]) @@ oe in + (ret, TAtm TAIdv) + + | Apply ({ core = Internal B.SubSeq } as op, [ e ; f ; g ]) -> + let e, ty01 = expr scx e in + let f, ty02 = expr scx f in + let g, ty03 = expr scx g in + let ret = Apply (op, [ force_idv ty01 e ; force_idv ty02 f ; force_idv ty03 g ]) @@ oe in + (ret, TAtm TAIdv) + + | Apply ({ core = Internal B.SelectSeq } as op, [ e ; f ]) -> + let e, ty0 = expr scx e in + let f, ty1 = earg scx f in + let ret = Apply (op, [ force_idv ty0 e ; force_arg (Ty1 ([ TAtm TAIdv ], TAtm TABol)) ty1 f ]) @@ oe in + (ret, TAtm TAIdv) + + (* The code may wrap `e` like this to prevent infinite loops. + * Do not remove! *) + | Apply (e, []) -> + expr scx e + + | Apply (op, es) -> + (* no type synthesis in this case, only typechecking *) + let op, Ty2 (ty11s, ty01) = eopr scx op in + let es, ty12s = List.map (earg scx) es |> List.split in + let es = + map3 begin fun e ty11 ty12 -> + if ty11 = ty12 then + e + else + force_arg ty11 ty12 e + end es ty11s ty12s + in + (Apply (op, es) @@ oe, ty01) + + | With (e, m) -> + let e, ty0 = expr scx e in + (With (e, m) @@ oe, ty0) + + | Parens (e, pf) -> + let e, ty0 = expr scx e in + (Parens (e, pf) @@ oe, ty0) + + | Tquant (q, vs, e) -> + let scx, vs = + List.fold_left begin fun (scx, r_vs) v -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + (scx, v :: r_vs) + end (scx, []) vs |> + fun (scx, r_vs) -> (scx, List.rev r_vs) + in + let e, ty0 = expr scx e in + (Tquant (q, vs, force_bool ty0 e) @@ oe, TAtm TABol) + + | Sub (m, e, f) -> + let e, ty0 = expr scx e in + let f, _ = expr scx f in + (Sub (m, force_bool ty0 e, f) @@ oe, TAtm TABol) + + | Tsub (m, e, f) -> + let e, ty0 = expr scx e in + let f, _ = expr scx f in + (Tsub (m, force_bool ty0 e, f) @@ oe, TAtm TABol) + + | Fair (m, e, f) -> + let e, ty0 = expr scx e in + let f, _ = expr scx f in + (Fair (m, force_bool ty0 e, f) @@ oe, TAtm TABol) + + | Lambda _ -> + error ~at:oe "Unexpected Lambda constructor" + | Bang _ -> + error ~at:oe "Unexpected Bang constructor" + | At _ -> + error ~at:oe "Unexpected At constructor" + + | Internal _ -> + error ~at:oe "Unexpected builtin" + +and earg scx oa = + match oa.core with + | Ix n -> + let ty1 = lookup_ty1 scx n in + (Ix n @@ oa, ty1) + + | Lambda (xs, e) -> + let scx, xs, ty0s = + List.fold_left begin fun (scx, r_xs, r_ty0s) (v, shp) -> + begin match shp with + | Shape_expr -> () + | Shape_op _ -> error ~at:oa "Expected a first-order operator" + end; + let ty0 = TAtm TAIdv in + let v, scx = adj_ty0 scx v ty0 in + let x = (v, shp) in + (scx, x :: r_xs, ty0 :: r_ty0s) + end (scx, [], []) xs |> + fun (scx, r_xs, r_ty0s) -> (scx, List.rev r_xs, List.rev r_ty0s) + in + let e, ty0 = expr scx e in + let ty1 = Ty1 (ty0s, ty0) in + (Lambda (xs, e) @@ oa, ty1) + + | _ -> + let e, ty0 = expr scx oa in + (e $$ oa, upcast_ty1 ty0) + +and eopr scx op = + match op.core with + | Ix n -> + let ty2 = lookup_ty2 scx n in + (Ix n @@ op, ty2) + + | Lambda (xs, e) -> + let scx, xs, ty1s = + List.fold_left begin fun (scx, r_xs, r_ty1s) (v, shp) -> + let ty1 = shp_to_ty1 shp in + let v, scx = adj_ty1 scx v ty1 in + let x = (v, shp) in + (scx, x :: r_xs, ty1 :: r_ty1s) + end (scx, [], []) xs |> + fun (scx, r_xs, r_ty1s) -> (scx, List.rev r_xs, List.rev r_ty1s) + in + let e, ty0 = expr scx e in + let ty2 = Ty2 (ty1s, ty0) in + (Lambda (xs, e) @@ op, ty2) + + | Internal B.Prime -> + error ~at:op "Unsupported builtin Prime" + | Internal B.StrongPrime -> + error ~at:op "Unsupported builtin StrongPrime" + | Internal B.Leadsto -> + error ~at:op "Unsupported builtin Leadsto" + | Internal B.ENABLED -> + error ~at:op "Unsupported builtin ENABLED" + | Internal B.UNCHANGED -> + error ~at:op "Unsupported builtin UNCHANGED" + | Internal B.Cdot -> + error ~at:op "Unsupported builtin Cdot" + | Internal B.Actplus -> + error ~at:op "Unsupported builtin Actplus" + | Internal (B.Box _)-> + error ~at:op "Unsupported builtin Box" + | Internal B.Diamond -> + error ~at:op "Unsupported builtin Diamond" + + | Internal B.Divides -> + error ~at:op "Unsupported builtin Divides" + + | Internal B.Irregular -> + error ~at:op "Unsupported builtin Irregular" + + | _ -> + error ~at:op "Unexpected left operand" + +and defn ?(ignore=false) scx df = + match df.core with + | Recursive (v, shp) -> + let ty1 = shp_to_ty1 shp in + let v, scx = adj_ty1 scx v ty1 in + (scx, Recursive (v, shp) @@ df) + + | Operator (v, ({ core = Lambda (xs, e) } as oe)) when ignore -> + let xs, ty1s = + List.map begin fun (v, shp) -> + let ty1 = shp_to_ty1 shp in + let v, _ = adj_ty1 scx v ty1 in (* ctx doesn't matter *) + (v, shp), ty1 + end xs |> + List.split + in + let ty2 = Ty2 (ty1s, TAtm TAIdv) in + let v, scx = adj_ty2 scx v ty2 in + (scx, Operator (v, (Lambda (xs, e) @@ oe)) @@ df) + + | Operator (v, e) when ignore -> + let ty0 = TAtm TAIdv in + let v, scx = adj_ty0 scx v ty0 in + (scx, Operator (v, e) @@ df) + + | Operator (v, ({ core = Lambda (xs, e) } as oe)) (*when not ignore*) -> + let scx', xs, ty1s = + List.fold_left begin fun (scx', r_xs, r_ty1s) (v, shp) -> + let ty1 = shp_to_ty1 shp in + let v, scx' = adj_ty1 scx' v ty1 in + let x = (v, shp) in + (scx', x :: r_xs, ty1 :: r_ty1s) + end (scx, [], []) xs |> + fun (scx', r_xs, r_ty1s) -> (scx', List.rev r_xs, List.rev r_ty1s) + in + let e, ty0 = expr scx' e in + let ty2 = Ty2 (ty1s, ty0) in + let v, scx = adj_ty2 scx v ty2 in + (scx, Operator (v, (Lambda (xs, e) @@ oe)) @@ df) + + | Operator (v, e) (*when not ignore*) -> + let e, ty0 = expr scx e in + let v, scx = adj_ty0 scx v ty0 in + (scx, Operator (v, e) @@ df) + + | Instance _ + | Bpragma _ when ignore -> + let scx = bump scx in + (scx, df) + + | Instance _ -> + error ~at:df "Unsupported constructor Instance" + | Bpragma _ -> + error ~at:df "Unsupported constructor Bpragma" + +and defns scx dfs = + match dfs with + | [] -> (scx, []) + | df :: dfs -> + let scx, df = defn scx df in + let scx, dfs = defns scx dfs in + (scx, df :: dfs) + +and sequent scx sq = + let force_idv ty x = force_idv ~typelvl:(typelvl scx) ty x in + + let rec hyps scx hs = + match Deque.front hs with + | None -> + (scx, Deque.empty) + + | Some ({ core = Fresh (v, Shape_expr, k, b) } as h, hs) -> + let v, scx, b = + match b with + | Bounded (e, Visible) -> + let e, ty0 = expr scx e in + begin match ty0 with + | TSet ty01 when typelvl scx = 3 -> + let v, scx = adj_ty0 scx v ty01 in + let b = Bounded (assign e Props.mpars_prop ty01, Visible) in + (v, scx, b) + | TSet (TAtm _ as ty01) when typelvl scx = 2 -> + let v, scx = adj_ty0 scx v ty01 in + let b = Bounded (force_idv ty0 e, Visible) in + let v = force_idv ty01 v in + (v, scx, b) + | TSet ty01 when typelvl scx = 2 -> + let _, scx = adj_ty0 scx v ty01 in + let v = assign v Props.ty0_prop (TAtm TAIdv) in + let b = Bounded (force_idv ty0 e, Visible) in + (v, scx, b) + | _ -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let b = Bounded (force_idv ty0 e, Visible) in + (v, scx, b) + end + | _ when typelvl scx = 2 -> + let inferer = fun hx e -> snd (expr (fst scx, hx) e) in + begin match T_hyps.search_type_hyp ~inferer ~pol:true (snd scx) (Sequent { context = hs ; active = sq.active } %% []) with + | Some (TAtm _ as ty01) -> + let v, scx = adj_ty0 scx v ty01 in + let v = force_idv ty01 v in + (v, scx, b) + | Some ty01 -> + let _, scx = adj_ty0 scx v ty01 in + let v = assign v Props.ty0_prop (TAtm TAIdv) in + (v, scx, b) + | None -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + (v, scx, b) + end + | _ -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + (v, scx, b) + in + let h = Fresh (v, Shape_expr, k, b) @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + + | Some ({ core = Fresh (v, shp, k, Unbounded) } as h, hs) -> + let ty1 = shp_to_ty1 shp in + let v, scx = adj_ty1 scx v ty1 in + let h = Fresh (v, shp, k, Unbounded) @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + + | Some ({ core = Fresh (_, Shape_op n, _, Bounded _) } as h, hs) -> + error ~at:h "Fresh operator cannot be bounded" + + | Some ({ core = Flex v } as h, hs) -> + if typelvl scx = 2 then + let inferer = fun hx e -> snd (expr (fst scx, hx) e) in + begin match T_hyps.search_type_hyp ~inferer ~pol:true (snd scx) (Sequent { context = hs ; active = sq.active } %% []) with + | Some (TAtm _ as ty01) -> + let v, scx = adj_ty0 scx v ty01 in + let v = force_idv ty01 v in + let h = Flex (force_idv ty01 v) @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + | Some ty01 -> + let _, scx = adj_ty0 scx v ty01 in + let v = assign v Props.ty0_prop (TAtm TAIdv) in + let h = Flex v @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + | None -> + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let h = Flex v @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + end + else + let v, scx = adj_ty0 scx v (TAtm TAIdv) in + let h = Flex v @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + + (* Special case: Type inference is activated for hidden constant defns *) + | Some ({ core = Defn ({ core = Operator (v, e) } as df, wd, Hidden, ex) } as h, hs) + when typelvl scx = 2 && not (is_lambda e.core) -> + let inferer = fun hx e -> snd (expr (fst scx, hx) e) in + let scx, df = + match T_hyps.search_type_hyp ~inferer ~pol:true (snd scx) (Sequent { context = hs ; active = sq.active } %% []) with + | Some (TAtm _ as ty0) -> + let v, scx = adj_ty0 scx v ty0 in + let v = force_idv ty0 v in + (scx, Operator (v, e) @@ df) + | Some ty0 -> + let _, scx = adj_ty0 scx v ty0 in + let v = assign v Props.ty0_prop (TAtm TAIdv) in + (scx, Operator (v, e) @@ df) + | None -> + defn ~ignore:true scx df + in + let h = Defn (df, wd, Hidden, ex) @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + + | Some ({ core = Defn (df, wd, vis, ex) } as h, hs) -> + let ignore = match vis with Hidden -> true | _ -> false in + let scx, df = defn ~ignore scx df in + let h = Defn (df, wd, vis, ex) @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + + | Some ({ core = Fact (e, Visible, tm) } as h, hs) -> + let e, ty0 = expr scx e in + let scx = bump scx in + let h = Fact (force_bool ty0 e, Visible, tm) @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + + | Some ({ core = Fact (e, Hidden, tm) } as h, hs) -> + let scx = bump scx in + let h = Fact (e, Hidden, tm) @@ h in + let scx, hs = hyps scx hs in + (scx, Deque.cons h hs) + in + + let scx, hs = hyps scx sq.context in + let e, ty0 = expr scx sq.active in + (scx, { context = hs ; active = force_bool ty0 e }) + + +let main ?(typelvl=1) sq = + let ops, cx = init in + let ops = + { typelvl = typelvl + } + in + snd (sequent (ops, cx) sq) + diff --git a/src/type/t_synth.mli b/src/type/t_synth.mli new file mode 100644 index 00000000..dae13c3e --- /dev/null +++ b/src/type/t_synth.mli @@ -0,0 +1,92 @@ +(* + * type/synth.mli --- decorate TLA+ expressions with types + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open Util + +open T_t + +(** This module implements Type Synthesis for non-temporal expressions. + + TS will decorate expressions with type annotations. The expressions + themselves are not modified. See {!Type.T} for a presentation of the type + system and the relevant annotations. + + Annotations are placed in different places. + - All {!Util.hint} may receive a {!Type.T.ty0_prop}, {!Type.T.ty1_prop} or a + {!Type.T.ty2_prop} annotation. The last two are reserved for operator + variables (on fresh variables, defined operators, arguments to second- + order lambda-terms). + - Many TLA+ builtins exist in an untyped version, and a number of + typed versions. + Expressions built from the constructor {!Expr.T.Internal} may receive the + annotation {!Type.T.tpars_prop} to indicate which type version is the + correct one. No annotation means untyped version. + - For TLA+ primitives that do not have a builtin, like {!Expr.T.SetSt}, the + annotation is placed on the expression itself. + - Some operators are overloaded and follow special conventions. + * Operators that are overloaded for functions, tuples or records can have + one type annotation. That annotation should be either a function-type, + tuple-type or record-type, depending on the right version. + Functional application is overloaded for functions, tuples and records. + For tuples, the right operand must be a literal integer. For records, + it must be a literal string. + Dot application is overloaded for functions and records. + The domain operator is overloaded for functions, tuples, and records. + - Bounds imply a hidden [\\in]. The optional annotation for it may be found + on the domain of the bound as a {!Type.T.mpars_prop}. + - Some expressions must be cast from some type [ty] to the domain of + individuals. The annotation {!Type.T.icast_prop} with parameter [ty] + decorates these expressions. + - Some expressions must be projected from some type [ty] into the domain of + booleans. The annotation {!Type.T.bproj_prop} with parameter [ty] + decorates these expressions. + NOTE This effectively makes TLAPS conform with the so-called liberal + interpretation for TLA+ boolean operators. +*) + + +(* {3 Context} *) + +type scx + +val init : scx + +val adj_ty0 : scx -> hint -> ty0 -> hint * scx +val adj_ty1 : scx -> hint -> ty1 -> hint * scx +val adj_ty2 : scx -> hint -> ty2 -> hint * scx + +val bump : scx -> scx + +val lookup_ty0 : scx -> int -> ty0 +val lookup_ty1 : scx -> int -> ty1 +val lookup_ty2 : scx -> int -> ty2 + + +(* {3 Main} *) + +val expr : scx -> expr -> expr * ty0 (** Called on constant expressions *) +val earg : scx -> expr -> expr * ty1 (** Called on application arguments *) +val eopr : scx -> expr -> expr * ty2 (** Called on applied operators *) + +(** @param ignore disables parsing, infers a generic type from the shape *) +val defn : ?ignore:bool -> scx -> defn -> scx * defn +val defns : scx -> defn list -> scx * defn list + +val sequent : scx -> sequent -> scx * sequent + +(** Main function, only use this one. + @param typelvl set the level of typing. + typelvl=0: only Idv and Bool (pure TLA+) + typelvl=1: allow Int for constants, insert casts + typelvl=2: allow Int for all operators, try to simplify casts + typelvl=3: allow all types and casts +*) +val main : + ?typelvl:int -> + sequent -> sequent + diff --git a/src/type/t_synth.mlt b/src/type/t_synth.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/type/t_synth.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/type/t_t.ml b/src/type/t_t.ml new file mode 100644 index 00000000..b77560b0 --- /dev/null +++ b/src/type/t_t.ml @@ -0,0 +1,250 @@ +(* + * type/t.ml --- type system + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Property +open Format + + +(* {3 Generalities} *) + +type ty = + | TVar of string (** Type variable *) + | TAtm of atm (** Atomic type *) + | TSet of ty (** Set-type *) + | TFSet of ty (** Finite Set-type *) + | TFun of ty * ty (** Function-type *) + | TPrd of ty list (** Product-type *) + | TRec of (string * ty) list (** Record-type *) +and atm = + | TAIdv (** Individual *) + | TABol (** Boolean *) + | TAInt (** Integer *) + | TARel (** Real *) + | TAStr (** String *) + +and ty0 = ty +and ty1 = Ty1 of ty0 list * ty (** Fst-order operator type *) +and ty2 = Ty2 of ty1 list * ty (** Snd-order operator type *) + +module Ts = Set.Make (struct + type t = ty + let compare = Stdlib.compare +end) + +module Tm = Map.Make (struct + type t = ty + let compare = Stdlib.compare +end) + +let upcast_ty1 ty = Ty1 ([], ty) +let upcast_ty2 (Ty1 (ty0s, ty)) = Ty2 (List.map upcast_ty1 ty0s, ty) + +exception Invalid_type_downcast + +let downcast_ty0 = function + | Ty1 ([], ty) -> ty + | _ -> raise Invalid_type_downcast + +let downcast_ty1 (Ty2 (ty1s, ty)) = Ty1 (List.map downcast_ty0 ty1s, ty) + +let safe_downcast_ty0 ty1 = + try Some (downcast_ty0 ty1) + with Invalid_type_downcast -> None + +let safe_downcast_ty1 ty2 = + try Some (downcast_ty1 ty2) + with Invalid_type_downcast -> None + + +(* {3 Type Substitutions} *) + +module Sm = Util.Coll.Sm + +type ty_sub = ty Sm.t + +let rec apply_ty_sub m ty = + match ty with + | TVar a when Sm.mem a m -> + Sm.find a m + | TSet ty -> + TSet (apply_ty_sub m ty) + | TFun (ty1, ty2) -> + TFun (apply_ty_sub m ty1, apply_ty_sub m ty2) + | TPrd tys -> + TPrd (List.map (apply_ty_sub m) tys) + | _ -> ty + +let apply_ty_sub1 m ty1 = + match ty1 with + | Ty1 (ty0s, ty) -> + Ty1 (List.map (apply_ty_sub m) ty0s, apply_ty_sub m ty) + +let apply_ty_sub2 m ty2 = + match ty2 with + | Ty2 (ty1s, ty) -> + Ty2 (List.map (apply_ty_sub1 m) ty1s, apply_ty_sub m ty) + + +(* {3 Type Erasure} *) + +let erase0 ty0 = + match ty0 with + | TAtm TABol -> TAtm TABol + | _ -> TAtm TAIdv + +let erase1 (Ty1 (ty0s, ty)) = + Ty1 (List.map erase0 ty0s, erase0 ty) + +let erase2 (Ty2 (ty1s, ty)) = + Ty2 (List.map erase1 ty1s, erase0 ty) + + +(* {3 Type Annotations} *) + +module Props = struct + let ty0_prop = make "Type.T.Props.ty0_prop" + let ty1_prop = make "Type.T.Props.ty1_prop" + let ty2_prop = make "Type.T.Props.ty2_prop" + + let tpars_prop = make "Type.T.Props.tpars_prop" + let mpars_prop = make "Type.T.Props.mpars_prop" + let icast_prop = make "Type.T.Props.icast_prop" + let sproj_prop = make "Type.T.Props.sproj_prop" + let bproj_prop = make "Type.T.Props.bproj_prop" +end + + +(* {3 Pretty-printing} *) + +let rec ty_to_string ty = + match ty with + | TVar a -> "Var$" ^ a ^ "$" + | TAtm a -> tyatom_to_string a + | TSet ty -> "Set$" ^ ty_to_string ty ^ "$" + | TFSet ty -> "FSet$" ^ ty_to_string ty ^ "$" + | TFun (ty1, ty2) -> "Fun$" ^ ty_to_string ty1 ^ ty_to_string ty2 ^ "$" + | TPrd tys -> ( List.fold_left (fun s ty -> s ^ ty_to_string ty) "Prd$" tys ) ^ "$" + | TRec ftys -> ( List.fold_left (fun s (f, ty) -> s ^ "!" ^ f ^ ty_to_string ty) "Rec" ftys ) ^ "$" +and tyatom_to_string a = + match a with + | TAIdv -> "Idv" + | TABol -> "Bool" + | TAInt -> "Int" + | TARel -> "Real" + | TAStr -> "String" + +let ty1_to_string (Ty1 (tys, ty)) = + "Ty1[" ^ String.concat "_" (List.map ty_to_string tys) ^ ty_to_string ty ^ "]" + +let ty2_to_string (Ty2 (tys, ty)) = + "Ty2[" ^ String.concat " " (List.map ty1_to_string tys) ^ ty_to_string ty ^ "]" + + +let rec pp_print_ty0 ff ty = + pp_print_tyarrow ff ty + +and pp_print_tyarrow ff ty = + match ty with + | TFun (ty1, ty2) -> + fprintf ff "@[fun(%a,@ %a@])" + pp_print_ty0 ty1 + pp_print_ty0 ty2 + | _ -> pp_print_typrod ff ty + +and pp_print_typrod ff ty = + match ty with + | TPrd tys -> + fprintf ff "@[prod(%a@])" + (Fmtutil.pp_print_delimited pp_print_ty0) tys + | _ -> pp_print_tyrecord ff ty + +and pp_print_tyrecord ff ty = + match ty with + | TRec ftys -> + let pp_print_fty ff (f, ty) = + fprintf ff "%s:%a" f pp_print_ty0 ty + in + fprintf ff "@[rec(%a@])" + (Fmtutil.pp_print_delimited pp_print_fty) ftys + | _ -> pp_print_tyset ff ty + +and pp_print_tyset ff ty = + match ty with + | TSet ty -> + fprintf ff "@[set(%a@])" + pp_print_ty0 ty + | _ -> pp_print_tyatom ff ty + +and pp_print_tyatom ff ty = + match ty with + | TVar x -> pp_print_string ff x + | TAtm a -> pp_print_atm ff a + | _ -> fprintf ff "@[(%a@])" pp_print_ty0 ty + +and pp_print_atm ff a = + match a with + | TAIdv -> pp_print_string ff "iota" + | TABol -> pp_print_string ff "bool" + | TAInt -> pp_print_string ff "int" + | TARel -> pp_print_string ff "real" + | TAStr -> pp_print_string ff "string" + + +let pp_print_times ff () = + fprintf ff "@ * " + +let pp_print_ty1 ff ty1 = + match ty1 with + | Ty1 (ty0s, ty) -> + fprintf ff "%a@ -> %a" + (Fmtutil.pp_print_delimited ~sep:pp_print_times pp_print_ty0) ty0s + pp_print_ty0 ty + +let pp_print_ty1_parens ff ty1 = + match ty1 with + | Ty1 ([], ty) -> pp_print_ty0 ff ty + | _ -> Fmtutil.pp_print_with_parens pp_print_ty1 ff ty1 + +let pp_print_ty2 ff ty2 = + match ty2 with + | Ty2 (ty1s, ty) -> + fprintf ff "%a@ -> %a" + (Fmtutil.pp_print_delimited ~sep:pp_print_times pp_print_ty1_parens) ty1s + pp_print_ty0 ty + + +(* {3 Typechecking} *) + +exception Typechecking_error of ty0 * ty0 +exception Typechecking_op_error of ty2 * ty2 + +let typecheck ~expected:ty01 ~actual:ty02 = + if ty01 <> ty02 then begin + raise (Typechecking_error (ty01, ty02)) + end + +let typecheck_op ~expected:ty21 ~actual:ty22 = + if ty21 <> ty22 then begin + raise (Typechecking_op_error (ty21, ty22)) + end + +let typecheck_error_mssg ~expected:ty01 ~actual:ty02 = + Format.fprintf Format.str_formatter + "expression is of type %a, expected type %a" + pp_print_ty0 ty02 + pp_print_ty0 ty01; + let mssg = Format.flush_str_formatter () in + mssg + +let typecheck_op_error_mssg ~expected:ty21 ~actual:ty22 = + Format.fprintf Format.str_formatter + "operator expression is of type %a, expected type %a" + pp_print_ty2 ty22 + pp_print_ty2 ty21; + let mssg = Format.flush_str_formatter () in + mssg + diff --git a/src/type/t_t.mli b/src/type/t_t.mli new file mode 100644 index 00000000..19a1b063 --- /dev/null +++ b/src/type/t_t.mli @@ -0,0 +1,106 @@ +(* + * type/t.mli --- type system + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Property + + +(* {3 Types} *) + +type ty = + | TVar of string (** Type variable *) + | TAtm of atm (** Atomic type *) + | TSet of ty (** Set-type *) + | TFSet of ty (** Finite Set-type *) + | TFun of ty * ty (** Function-type *) + | TPrd of ty list (** Product-type *) + | TRec of (string * ty) list (** Record-type *) +and atm = + | TAIdv (** Individual *) + | TABol (** Boolean *) + | TAInt (** Integer *) + | TARel (** Real *) + | TAStr (** String *) + +and ty0 = ty (** Constant type *) +and ty1 = Ty1 of ty0 list * ty (** Fst-order operator type *) +and ty2 = Ty2 of ty1 list * ty (** Snd-order operator type *) + +module Ts : Set.S with type elt = ty +module Tm : Map.S with type key = ty + +val upcast_ty1 : ty0 -> ty1 +val upcast_ty2 : ty1 -> ty2 + +exception Invalid_type_downcast +val downcast_ty1 : ty2 -> ty1 +val downcast_ty0 : ty1 -> ty0 + +val safe_downcast_ty1 : ty2 -> ty1 option +val safe_downcast_ty0 : ty1 -> ty0 option + + +(* {3 Type Substitution} *) + +type ty_sub = ty Util.Coll.Sm.t + +(** Apply subst to type *) +val apply_ty_sub : ty_sub -> ty0 -> ty0 +val apply_ty_sub1 : ty_sub -> ty1 -> ty1 +val apply_ty_sub2 : ty_sub -> ty2 -> ty2 + + +(* {3 Typechecking} *) + +exception Typechecking_error of ty0 * ty0 +exception Typechecking_op_error of ty2 * ty2 + +val typecheck : expected:ty0 -> actual:ty0 -> unit +val typecheck_op : expected:ty2 -> actual:ty2 -> unit + +val typecheck_error_mssg : expected:ty0 -> actual:ty0 -> string +val typecheck_op_error_mssg : expected:ty2 -> actual:ty2 -> string + + +(* {Type Erasure} *) + +(** Type erasure maps each type [t] to a type [t'] with the same structure, but + all sorts different than Idv replaced with Idv. Bool is special, it is + preserved by type erasure. +*) +val erase0 : ty0 -> ty0 +val erase1 : ty1 -> ty1 +val erase2 : ty2 -> ty2 + + +(* {3 Type Annotations} *) + +module Props : sig + val ty0_prop : ty0 pfuncs + val ty1_prop : ty1 pfuncs + val ty2_prop : ty2 pfuncs + + val tpars_prop : ty list pfuncs (** Type instances to polymorphics ops. *) + val mpars_prop : ty pfuncs (** Like tpars but for hidden Mem ops. *) + val icast_prop : ty pfuncs (** Forgetful injection into individuals *) + val sproj_prop : ty pfuncs (** Projection of individuals into sorts *) + val bproj_prop : ty pfuncs (** Expressions occurring in boolean ctxt *) +end + + +(* {3 Pretty-printing} *) + +(** String representation used for identifiers (no whitespaces) *) +val ty_to_string : ty -> string +val ty1_to_string : ty1 -> string +val ty2_to_string : ty2 -> string + +(** Human-readable representation *) +val pp_print_ty0 : Format.formatter -> ty0 -> unit +val pp_print_ty1 : Format.formatter -> ty1 -> unit +val pp_print_ty2 : Format.formatter -> ty2 -> unit +val pp_print_atm : Format.formatter -> atm -> unit + diff --git a/src/type/t_t.mlt b/src/type/t_t.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/type/t_t.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/type/t_visit.ml b/src/type/t_visit.ml new file mode 100644 index 00000000..0a28ba74 --- /dev/null +++ b/src/type/t_visit.ml @@ -0,0 +1,786 @@ +(* + * type/visit.ml --- visitors with syntactic typecheck + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Ext +open Property + +open Expr.T +open T_t + +module B = Builtin + + +(* {3 Helpers} *) + +let error ?at mssg = + let mssg = "Type.Visit: " ^ mssg in + Errors.bug ?at mssg + +let check0 ?at ty01 ty02 = + try typecheck ~expected:ty01 ~actual:ty01 + with Typechecking_error (ty01, ty02) -> + let mssg = typecheck_error_mssg ~expected:ty01 ~actual:ty02 in + error ?at mssg + +let check2 ?at ty21 ty22 = + try typecheck_op ~expected:ty21 ~actual:ty21 + with Typechecking_op_error (ty21, ty22) -> + let mssg = typecheck_op_error_mssg ~expected:ty21 ~actual:ty22 in + error ?at mssg + +let check1 ?at ty11 ty12 = + match safe_downcast_ty0 ty11, safe_downcast_ty0 ty12 with + | Some ty01, Some ty02 -> + check0 ?at ty01 ty02 + | _, _ -> + check2 ?at (upcast_ty2 ty11) (upcast_ty2 ty12) + +let iter3 f l1 l2 l3 = + List.iter2 (fun a (b, c) -> f a b c) + l1 (List.combine l2 l3) + + +(* {3 Context} *) + +type 's scx = 's * hyp Deque.dq + +let adj (s, cx) h = + (s, Deque.snoc cx h) + +let rec adjs scx = function + | [] -> scx + | h :: hs -> + adjs (adj scx h) hs + + +let lookup_hint (_, hx) n = + let h = Option.get (Deque.nth ~backwards:true hx (n - 1)) in + hyp_hint h + +let lookup_ty0 scx n = + let v = lookup_hint scx n in + if has v Props.ty0_prop then + get v Props.ty0_prop + else if has v Props.ty1_prop then + downcast_ty0 (get v Props.ty1_prop) + else if has v Props.ty2_prop then + downcast_ty0 (downcast_ty1 (get v Props.ty2_prop)) + else + error ~at:v "Cannot find type0 annotation" + +(* Get the n last ty0s *) +let lookup_ty0_mult scx n = + List.init n (lookup_ty0 scx) + +let lookup_ty1 scx n = + let v = lookup_hint scx n in + if has v Props.ty1_prop then + get v Props.ty1_prop + else if has v Props.ty0_prop then + upcast_ty1 (get v Props.ty0_prop) + else if has v Props.ty2_prop then + downcast_ty1 (get v Props.ty2_prop) + else + error ~at:v "Cannot find type1 annotation" + +let lookup_ty2 scx n = + let v = lookup_hint scx n in + if has v Props.ty2_prop then + get v Props.ty2_prop + else if has v Props.ty0_prop then + upcast_ty2 (upcast_ty1 (get v Props.ty0_prop)) + else if has v Props.ty1_prop then + upcast_ty2 (get v Props.ty1_prop) + else + error ~at:v "Cannot find type2 annotation" + + +class virtual ['s, 'a] foldmap = object (self : 'self) + + method expr (scx : 's scx) a oe = + + if has oe Props.icast_prop then + let ty01 = get oe Props.icast_prop in + let oe = remove oe Props.icast_prop in + let a, oe, ty02 = self#expr scx a oe in + check0 ~at:oe ty01 ty02; + (a, assign oe Props.icast_prop ty02, TAtm TAIdv) + else + + if has oe Props.bproj_prop then + let ty01 = get oe Props.bproj_prop in + let oe = remove oe Props.bproj_prop in + let a, oe, ty02 = self#expr scx a oe in + check0 ~at:oe ty01 ty02; + (a, assign oe Props.bproj_prop ty02, TAtm TABol) + else + + match oe.core with + | Ix n -> + let ty0 = lookup_ty0 scx n in + (a, Ix n @@ oe, ty0) + | Opaque o -> + let ty0 = + if has oe Props.ty0_prop then + get oe Props.ty0_prop + else if has oe Props.ty2_prop then try + get oe Props.ty2_prop |> + downcast_ty1 |> + downcast_ty0 + with Invalid_type_downcast -> + let mssg = "Expected constant opaque opaque '" ^ o ^ "'" in + error ~at:oe mssg + else + let mssg = "Missing annotation on opaque '" ^ o ^ "'" in + error ~at:oe mssg + in + (a, Opaque o @@ oe, ty0) + | Internal b -> + let a, oe, ty2 = self#eopr scx a oe in + let ty0 = + try downcast_ty0 (downcast_ty1 ty2) + with Invalid_type_downcast -> + error ~at:oe "Expected constant builtin" + in + (a, Internal b @@ oe, ty0) + | String s -> + (a, String s @@ oe, TAtm TAStr) + | Num (m, "") -> + (a, Num (m, "") @@ oe, TAtm TAInt) + | Num (m, n) -> + (a, Num (m, n) @@ oe, TAtm TARel) + | Apply (op, es) -> + let a, op, Ty2 (ty11s, ty0) = self#eopr scx a op in + let a, es, ty12s = + List.fold_left begin fun (a, r_es, r_ty1s) e -> + let a, e, ty1 = self#earg scx a e in + (a, e :: r_es, ty1 :: r_ty1s) + end (a, [], []) es |> + fun (a, r_es, r_ty1s) -> (a, List.rev r_es, List.rev r_ty1s) + in + iter3 (fun e -> check1 ~at:e) es ty11s ty12s; + (a, Apply (op, es) @@ oe, ty0) + | Sequent sq -> + let _, a, sq = self#sequent scx a sq in + (a, Sequent sq @@ oe, TAtm TABol) + | With (e, m) -> + let a, e, ty0 = self#expr scx a e in + (a, With (e, m) @@ oe, ty0) + | Let (ds, e) -> + let scx, a, ds = self#defns scx a ds in + let a, e, ty0 = self#expr scx a e in + (a, Let (ds, e) @@ oe, ty0) + | If (e, f, g) -> + let a, e, ty01 = self#expr scx a e in + let a, f, ty02 = self#expr scx a f in + let a, g, ty03 = self#expr scx a g in + begin match query oe Props.tpars_prop with + | None -> + check0 ~at:e (TAtm TABol) ty01; + check0 ~at:g ty02 ty03; + (a, If (e, f, g) @@ oe, ty02) + | Some ([ ty04 ]) -> + check0 ~at:e (TAtm TABol) ty01; + check0 ~at:f ty04 ty02; + check0 ~at:g ty04 ty03; + (a, If (e, f, g) @@ oe, ty04) + | _ -> + error ~at:oe "Bad type annotation" + end + | List (Refs, [e]) -> + let a, e, ty0 = self#expr scx a e in + (a, List (Refs, [e]) @@ oe, ty0) + | List (q, es) -> + let a, es = + List.fold_left begin fun (a, r_es) e -> + let a, e, ty0 = self#expr scx a e in + check0 ~at:e (TAtm TABol) ty0; + (a, e :: r_es) + end (a, []) es |> + fun (a, r_es) -> (a, List.rev r_es) + in + (a, List (q, es) @@ oe, TAtm TABol) + | Quant (q, bs, e) -> + let scx, a, bs = self#bounds scx a bs in + let a, e, ty0 = self#expr scx a e in + check0 ~at:e (TAtm TABol) ty0; + (a, Quant (q, bs, e) @@ oe, TAtm TABol) + | Tquant (q, vs, e) -> + let scx = adjs scx (List.map begin fun v -> + Flex v @@ v + end vs) in + let a, e, ty0 = self#expr scx a e in + check0 ~at:e (TAtm TABol) ty0; + (a, Tquant (q, vs, e) @@ oe, TAtm TABol) + | Choose (v, optdom, e) -> + let a, optdom, h = + match optdom with + | None -> + (a, None, Fresh (v, Shape_expr, Constant, Unbounded) @@ v) + | Some dom -> + let ty01 = get v Props.ty0_prop in + let a, dom, ty02 = self#expr scx a dom in + begin match query v Props.mpars_prop with + | None -> + check0 ~at:v (TAtm TAIdv) ty01; + check0 ~at:dom (TAtm TAIdv) ty02; + (a, Some dom, Fresh (v, Shape_expr, Constant, Bounded (dom, Visible)) @@ v) + | Some ty03 -> + check0 ~at:v ty03 ty01; + check0 ~at:dom (TSet ty03) ty02; + (a, Some dom, Fresh (v, Shape_expr, Constant, Bounded (dom, Visible)) @@ v) + end + in + let scx = adj scx h in + let a, e, ty0 = self#expr scx a e in + check0 ~at:e (TAtm TABol) ty0; + (a, Choose (v, optdom, e) @@ oe, TAtm TAIdv) + | SetSt (v, dom, e) -> + let ty01 = get v Props.ty0_prop in + let a, dom, ty02 = self#expr scx a dom in + let scx = adj scx (Fresh (v, Shape_expr, Constant, Bounded (dom, Visible)) @@ v) in + let a, e, ty03 = self#expr scx a e in + begin match query oe Props.tpars_prop with + | None -> + check0 ~at:v (TAtm TAIdv) ty01; + check0 ~at:dom (TAtm TAIdv) ty02; + check0 ~at:e (TAtm TABol) ty03; + (a, SetSt (v, dom, e) @@ oe, TAtm TAIdv) + | Some ([ ty04 ]) -> + check0 ~at:v ty04 ty01; + check0 ~at:dom (TSet ty04) ty02; + check0 ~at:e (TAtm TABol) ty03; + (a, SetSt (v, dom, e) @@ oe, TSet ty04) + | _ -> + error ~at:oe "Bad type annotation" + end + | SetOf (e, bs) -> + let scx, a, bs = self#bounds scx a bs in + let n = List.length bs in + let ty01s = lookup_ty0_mult scx n in + (* /!\ Check bound types BEFORE the body *) + begin match query oe Props.tpars_prop with + | None -> + List.iter2 (fun v -> check0 ~at:v (TAtm TAIdv)) (List.map (fun (v, _, _) -> v) bs) ty01s; + let a, e, ty02 = self#expr scx a e in + check0 ~at:e (TAtm TAIdv) ty02; + (a, SetOf (e, bs) @@ oe, TAtm TAIdv) + | Some (ty04 :: ty03s) -> + iter3 (fun (v, _, _) -> check0 ~at:v) bs ty03s ty01s; + let a, e, ty02 = self#expr scx a e in + check0 ~at:e ty04 ty02; + (a, SetOf (e, bs) @@ oe, TSet ty04) + | _ -> + error ~at:oe "Bad type annotation" + end + | SetEnum es -> + let a, es, ty01s = + List.fold_left begin fun (a, r_es, r_ty0s) e -> + let a, e, ty0 = self#expr scx a e in + (a, e :: r_es, ty0 :: r_ty0s) + end (a, [], []) es |> + fun (a, r_es, r_ty0s) -> (a, List.rev r_es, List.rev r_ty0s) + in + begin match query oe Props.tpars_prop with + | None -> + List.iter2 (fun e -> check0 ~at:e (TAtm TAIdv)) es ty01s; + (a, SetEnum es @@ oe, TAtm TAIdv) + | Some ([ ty02 ]) -> + List.iter2 (fun e -> check0 ~at:e ty02) es ty01s; + (a, SetEnum es @@ oe, TSet ty02) + | _ -> + error ~at:oe "Bad type annotation" + end + | Fcn (bs, e) -> + let scx, a, bs = self#bounds scx a bs in + let n = List.length bs in + let ty01s = lookup_ty0_mult scx n in + (* /!\ Check bound types BEFORE the body *) + begin match query oe Props.tpars_prop with + | None -> + List.iter2 (fun (v, _, _) -> check0 ~at:v (TAtm TAIdv)) bs ty01s; + let a, e, ty02 = self#expr scx a e in + check0 (TAtm TAIdv) ty02; + (a, Fcn (bs, e) @@ oe, TAtm TAIdv) + | Some ([ ty03 ; ty04 ]) when n = 1 -> + let v, _, _ = List.hd bs in + check0 ~at:v ty03 (List.hd ty01s); + let a, e, ty02 = self#expr scx a e in + check0 ty04 ty02; + (a, Fcn (bs, e) @@ oe, TFun (ty03, ty04)) + | Some (ty03s) when List.length ty03s = n+1 && n > 1 -> + let ty04s, ty05 = + match List.rev ty03s with + | ty05 :: r_ty04s -> List.rev r_ty04s, ty05 + | _ -> error ~at:oe "Bat type annotation" + in + iter3 (fun (v, _, _) -> check0 ~at:v) bs ty04s ty01s; + let a, e, ty02 = self#expr scx a e in + check0 ty05 ty02; + (a, Fcn (bs, e) @@ oe, TFun (TPrd ty04s, ty05)) + | _ -> + error ~at:oe "Bad type annotation" + end + | FcnApp (f, es) -> + let a, f, ty01 = self#expr scx a f in + let a, es, ty02s = + List.fold_left begin fun (a, r_es, r_ty0s) e -> + let a, e, ty0 = self#expr scx a e in + (a, e :: r_es, ty0 :: r_ty0s) + end (a, [], []) es |> + fun (a, r_es, r_ty0s) -> (a, List.rev r_es, List.rev r_ty0s) + in + let n = List.length es in + begin match query oe Props.tpars_prop with + | None -> + check0 (TAtm TAIdv) ty01; + List.iter2 (fun e -> check0 ~at:e (TAtm TAIdv)) es ty02s; + (a, FcnApp (f, es) @@ oe, TAtm TAIdv) + | Some ([ ty03 ; ty04 ]) when n = 1 -> + check0 (TFun (ty03, ty04)) ty01; + List.iter2 (fun e -> check0 ~at:e ty03) es ty02s; + (a, FcnApp (f, es) @@ oe, ty04) + | Some (ty03s) when List.length ty03s = n+1 && n > 1 -> + let ty04s, ty05 = + match List.rev ty03s with + | ty05 :: r_ty04s -> List.rev r_ty04s, ty05 + | _ -> error ~at:oe "Bad type annotation" + in + check0 (TFun (TPrd ty04s, ty05)) ty01; + iter3 (fun e -> check0 ~at:e) es ty04s ty02s; + (a, FcnApp (f, es) @@ oe, ty05) + | _ -> + error ~at:oe "Bad type annotation" + end + | Arrow (e, f) -> + let a, e, ty01 = self#expr scx a e in + let a, f, ty02 = self#expr scx a f in + begin match query oe Props.tpars_prop with + | None -> + check0 (TAtm TAIdv) ty01; + check0 (TAtm TAIdv) ty02; + (a, Arrow (e, f) @@ oe, TAtm TAIdv) + | Some ([ ty03 ; ty04 ]) -> + check0 (TSet ty03) ty01; + check0 (TSet ty04) ty02; + (a, Arrow (e, f) @@ oe, TSet (TFun (ty03, ty04))) + | _ -> + error ~at:oe "Bad type annotation" + end + | Product es -> + let a, es, ty01s = + List.fold_left begin fun (a, r_es, r_ty0s) e -> + let a, e, ty0 = self#expr scx a e in + (a, e :: r_es, ty0 :: r_ty0s) + end (a, [], []) es |> + fun (a, r_es, r_ty0s) -> (a, List.rev r_es, List.rev r_ty0s) + in + begin match query oe Props.tpars_prop with + | None -> + List.iter2 (fun e -> check0 ~at:e (TAtm TAIdv)) es ty01s; + (a, Product es @@ oe, TAtm TAIdv) + | Some ty02s -> + iter3 (fun e -> check0 ~at:e) es ty02s ty01s; + (a, Product es @@ oe, TSet (TPrd ty02s)) + end + | Tuple es -> + let a, es, ty01s = + List.fold_left begin fun (a, r_es, r_ty0s) e -> + let a, e, ty0 = self#expr scx a e in + (a, e :: r_es, ty0 :: r_ty0s) + end (a, [], []) es |> + fun (a, r_es, r_ty0s) -> (a, List.rev r_es, List.rev r_ty0s) + in + begin match query oe Props.tpars_prop with + | None -> + List.iter2 (fun e -> check0 ~at:e (TAtm TAIdv)) es ty01s; + (a, Product es @@ oe, TAtm TAIdv) + | Some ty02s -> + iter3 (fun e -> check0 ~at:e) es ty02s ty01s; + (a, Product es @@ oe, TPrd ty02s) + end + | Except (e, xs) -> + let a, e, ty01 = self#expr scx a e in + let a, xs, exty02ss = + List.fold_left begin fun (a, r_xs, r_exty02ss) x -> + let a, x, exty02s = self#exspec scx a x in + (a, x :: r_xs, exty02s :: r_exty02ss) + end (a, [], []) xs |> + fun (a, r_xs, r_exty02s) -> + (a, List.rev r_xs, List.rev r_exty02s) + in + begin match query oe Props.tpars_prop with + | None -> + (a, Except (e, xs) @@ oe, TAtm TAIdv) + | Some ty03s when List.length ty03s > 0 -> + let mk_fcn_ty = List.fold_right (fun ty01 ty02 -> TFun (ty01, ty02)) in + let split_last l = + match List.rev l with + | a :: r_l -> List.rev r_l, a + | _ -> failwith "" + in + let ty04s, ty05 = split_last ty03s in + check0 (mk_fcn_ty ty04s ty05) ty01; + List.iter begin fun ty02s -> + let ty06s, ty07 = split_last ty02s in + let rec spin = function + | [], ty04s -> ty04s + | ty06 :: ty06s, ty04 :: ty04s -> + check0 ty04 ty06; + spin (ty06s, ty04s) + | _ -> + failwith "" + in + let ty08s = spin (ty06s, ty04s) in + check0 (mk_fcn_ty ty08s ty05) ty07 + end exty02ss; + (a, Except (e, xs) @@ oe, ty01) + | _ -> + error ~at:oe "Bad type annotation" + end + | Dot (e, f) -> + let a, e, ty01 = self#expr scx a e in + begin match query oe Props.tpars_prop with + | None -> + (a, Dot (e, f) @@ oe, TAtm TAIdv) + | Some [ ty02 ] -> + check0 (TFun (TAtm TAStr, ty02)) ty01; + (a, Dot (e, f) @@ oe, ty02) + | _ -> + error ~at:oe "Bad type annotation" + end + | Case (arms, oth) -> + let a, arms, ty01s = + List.fold_left begin fun (a, r_arms, r_ty0s) (e, f) -> + let a, e, ty01 = self#expr scx a e in + let a, f, ty02 = self#expr scx a f in + check0 (TAtm TABol) ty01; + (a, (e, f) :: r_arms, ty02 :: r_ty0s) + end (a, [], []) arms |> + fun (a, r_arms, r_ty0s) -> (a, List.rev r_arms, List.rev r_ty0s) + in + let a, oth, oty02 = + match oth with + | None -> + (a, None, None) + | Some o -> + let a, o, ty02 = self#expr scx a o in + (a, Some o, Some ty02) + in + begin match query oe Props.tpars_prop with + | None -> + (a, Case (arms, oth) @@ oe, TAtm TAIdv) + | Some ([ ty03 ]) -> + List.iter2 (fun (_, e) -> check0 ~at:e ty03) arms ty01s; + (* if a type is present then oth is some expression *) + Option.iter (check0 ~at:(Option.get oth) ty03) oty02; + (a, Case (arms, oth) @@ oe, ty03) + | _ -> + error ~at:oe "Bad type annotation" + end + | Parens (e, pf) -> + let a, e, ty0 = self#expr scx a e in + let a, pf = self#pform scx a pf in + (a, Parens (e, pf) @@ oe, ty0) + | _ -> + error ~at:oe "Not supported" + + method earg scx a ea = + match ea.core with + | Ix n -> + let ty1 = lookup_ty1 scx n in + (a, Ix n @@ ea, ty1) + | Lambda (vs, e) -> + let scx = adjs scx (List.map begin fun (v, shp) -> + Fresh (v, shp, Unknown, Unbounded) @@ v + end vs) in + let ty01s = + let n = List.length vs in + List.init n (fun i -> lookup_ty0 scx (n - i)) + in + let a, e, ty02 = self#expr scx a e in + (a, Lambda (vs, e) @@ ea, Ty1 (ty01s, ty02)) + | _ -> + let a, ea, ty0 = self#expr scx a ea in + (a, ea, upcast_ty1 ty0) + + method eopr scx a ep = + match ep.core with + | Ix n -> + let ty2 = lookup_ty2 scx n in + (a, Ix n @@ ep, ty2) + | Opaque o -> + let ty2 = + if has ep Props.ty2_prop then + get ep Props.ty2_prop + else + let mssg = "Missing annotation on opaque '" ^ o ^ "'" in + error ~at:ep mssg + in + (a, Opaque o @@ ep, ty2) + | Lambda (vs, e) -> + let scx = adjs scx (List.map begin fun (v, shp) -> + Fresh (v, shp, Unknown, Unbounded) @@ v + end vs) in + let ty1s = + let n = List.length vs in + List.init n (fun i -> lookup_ty1 scx (n - i - 1)) + in + let a, e, ty0 = self#expr scx a e in + (a, Lambda (vs, e) @@ ep, Ty2 (ty1s, ty0)) + | Internal b -> + (* all builtins are first-order *) + let mk_ty2 ty0s ty0 = Ty1 (ty0s, ty0) |> upcast_ty2 in + let ty2 = + match b, query ep Props.tpars_prop with + | B.TRUE, _ -> mk_ty2 [] (TAtm TABol) + | B.FALSE, _ -> mk_ty2 [] (TAtm TABol) + | B.Implies, _ -> mk_ty2 [TAtm TABol; TAtm TABol] (TAtm TABol) + | B.Equiv, _ -> mk_ty2 [TAtm TABol; TAtm TABol] (TAtm TABol) + | B.Conj, _ -> mk_ty2 [TAtm TABol; TAtm TABol] (TAtm TABol) + | B.Disj, _ -> mk_ty2 [TAtm TABol; TAtm TABol] (TAtm TABol) + | B.Neg, _ -> mk_ty2 [TAtm TABol] (TAtm TABol) + | B.Eq, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Neq, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Eq, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + | B.Neq, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + + | B.STRING, None -> mk_ty2 [] (TAtm TAIdv) + | B.BOOLEAN, None -> mk_ty2 [] (TAtm TAIdv) + | B.SUBSET, None -> mk_ty2 [TAtm TAIdv] (TAtm TAIdv) + | B.UNION, None -> mk_ty2 [TAtm TAIdv] (TAtm TAIdv) + | B.DOMAIN, None -> mk_ty2 [TAtm TAIdv] (TAtm TAIdv) + | B.Subseteq, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Mem, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Notmem, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Setminus, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Cap, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Cup, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.STRING, Some ([]) -> mk_ty2 [] (TSet (TAtm TAStr)) + | B.BOOLEAN, Some ([]) -> mk_ty2 [] (TSet (TAtm TABol)) + | B.SUBSET, Some ([ty0]) -> mk_ty2 [TSet ty0] (TSet (TSet ty0)) + | B.UNION, Some ([ty0]) -> mk_ty2 [TSet (TSet ty0)] (TSet ty0) + | B.DOMAIN, Some ([ty01; ty02]) -> mk_ty2 [TFun (ty01, ty02)] (TSet ty01) + | B.Subseteq, Some ([ty0]) -> mk_ty2 [TSet ty0; TSet ty0] (TAtm TABol) + | B.Mem, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + | B.Notmem, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + | B.Setminus, Some ([ty0]) -> mk_ty2 [TSet ty0; TSet ty0] (TSet ty0) + | B.Cap, Some ([ty0]) -> mk_ty2 [TSet ty0; TSet ty0] (TSet ty0) + | B.Cup, Some ([ty0]) -> mk_ty2 [TSet ty0; TSet ty0] (TSet ty0) + + | B.Nat, None -> mk_ty2 [] (TAtm TAIdv) + | B.Int, None -> mk_ty2 [] (TAtm TAIdv) + | B.Real, None -> mk_ty2 [] (TAtm TAIdv) + | B.Plus, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Minus, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Uminus, None -> mk_ty2 [TAtm TAIdv] (TAtm TAIdv) + | B.Times, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Ratio, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Quotient, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Remainder, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Exp, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Infinity, None -> mk_ty2 [] (TAtm TAIdv) + | B.Lteq, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Lt, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Gteq, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Gt, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TABol) + | B.Range, None -> mk_ty2 [TAtm TAIdv; TAtm TAIdv] (TAtm TAIdv) + | B.Nat, Some ([]) -> mk_ty2 [] (TSet (TAtm TAInt)) + | B.Int, Some ([]) -> mk_ty2 [] (TSet (TAtm TAInt)) + | B.Real, Some ([]) -> mk_ty2 [] (TSet (TAtm TARel)) + | B.Plus, Some ([ty0]) -> mk_ty2 [ty0; ty0] ty0 + | B.Minus, Some ([ty0]) -> mk_ty2 [ty0; ty0] ty0 + | B.Uminus, Some ([ty0]) -> mk_ty2 [ty0] ty0 + | B.Times, Some ([ty0]) -> mk_ty2 [ty0; ty0] ty0 + | B.Ratio, Some ([ty0]) -> mk_ty2 [ty0; ty0] ty0 + | B.Quotient, Some ([ty0]) -> mk_ty2 [ty0; ty0] ty0 + | B.Remainder, Some ([ty0]) -> mk_ty2 [ty0; ty0] ty0 + | B.Exp, Some ([ty0]) -> mk_ty2 [ty0; ty0] ty0 + | B.Infinity, Some ([]) -> mk_ty2 [] (TAtm TARel) + | B.Lteq, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + | B.Lt, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + | B.Gteq, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + | B.Gt, Some ([ty0]) -> mk_ty2 [ty0; ty0] (TAtm TABol) + | B.Range, Some ([]) -> mk_ty2 [TAtm TAInt; TAtm TAInt] (TSet (TAtm TAInt)) + + | _, _ -> error "Builtin not supported" + in + (a, Internal b @@ ep, ty2) + | _ -> + let a, ep, ty0 = self#expr scx a ep in + (a, ep, Ty2 ([], ty0)) + + method pform scx a pf = + (a, pf) + + method sel scx a sel = + match sel with + | Sel_inst args -> + let a, args = + List.fold_left begin fun (a, r_args) e -> + let a, e, _ = self#expr scx a e in + (a, e :: r_args) + end (a, []) args |> + fun (a, r_args) -> (a, List.rev r_args) + in + (a, Sel_inst args) + | Sel_lab (l, args) -> + let a, e = + List.fold_left begin fun (a, r_args) e -> + let a, e, _ = self#expr scx a e in + (a, e :: r_args) + end (a, []) args |> + fun (a, r_args) -> (a, List.rev r_args) + in + (a, Sel_lab (l, args)) + | _ -> + (a, sel) + + method sequent scx a sq = + let scx, a, hyps = self#hyps scx a sq.context in + let a, act, ty0 = self#expr scx a sq.active in + check0 (TAtm TABol) ty0; + (scx, a, { context = hyps ; active = act }) + + method defn scx a df = + match df.core with + | Recursive (v, shp) -> + (a, Recursive (v, shp) @@ df) + | Operator (v, e) -> + let ty21 = get v Props.ty2_prop in + let a, e, ty22 = self#eopr scx a e in + check2 ~at:df ty21 ty22; + (a, Operator (v, e) @@ df) + | Instance (v, i) -> + let a, i = self#instance scx a i in + (a, Instance (v, i) @@ df) + | Bpragma (v, e, l) -> + let a, e, _ = self#expr scx a e in + (a, Bpragma (v, e, l) @@ df) + + method defns scx a ds = + match ds with + | [] -> scx, a, [] + | df :: dfs -> + let a, df = self#defn scx a df in + let scx = adj scx (Defn (df, User, Visible, Local) @@ df) in + let scx, a, dfs = self#defns scx a dfs in + (scx, a, df :: dfs) + + method bounds scx a bs = + let a, bs = + List.fold_left begin fun (a, r_bs) (v, k, dom) -> + match dom with + | Domain d -> + let ty01 = get v Props.ty0_prop in + let a, d, ty02 = self#expr scx a d in + begin match query d Props.mpars_prop with + | None -> + check0 (TAtm TAIdv) ty01; + check0 (TAtm TAIdv) ty02; + (a, (v, k, Domain d) :: r_bs) + | Some ty03 -> + check0 ty03 ty01; + check0 (TSet ty03) ty02; + (a, (v, k, Domain d) :: r_bs) + end + | _ -> + (a, (v, k, dom) :: r_bs) + end (a, []) bs |> + fun (a, r_bs) -> (a, List.rev r_bs) + in + let hs = List.map begin + fun (v, k, _) -> Fresh (v, Shape_expr, k, Unbounded) @@ v + end bs in + let scx = adjs scx hs in + (scx, a, bs) + + method bound scx (a : 'a) b = + match self#bounds scx a [b] with + | scx, a, [b] -> (scx, a, b) + | _ -> assert false + + method exspec scx a (trail, res) = + let a, trail, ty01s = + List.fold_left begin fun (a, r_trail, r_ty0s) x -> + match x with + | Except_dot s -> + (a, (Except_dot s) :: r_trail, TAtm TAStr :: r_ty0s) + | Except_apply e -> + let a, e, ty0 = self#expr scx a e in + (a, (Except_apply e) :: r_trail, ty0 :: r_ty0s) + end (a, [], []) trail |> + fun (a, r_trail, r_ty0s) -> + (a, List.rev r_trail, List.rev r_ty0s) + in + let a, res, ty02 = self#expr scx a res in + (a, (trail, res), ty01s @ [ ty02 ]) + + method instance scx a i = + let scx = List.fold_left begin fun scx v -> + adj scx (Fresh (v, Shape_expr, Unknown, Unbounded) @@ v) + end scx i.inst_args in + let a, sub = List.fold_left begin fun (a, sub) (v, e) -> + let a, e, _ = self#expr scx a e in + (a, (v, e) :: sub) + end (a, []) i.inst_sub in + let sub = List.rev sub in + (a, { i with inst_sub = sub }) + + method hyp scx a h = + match h.core with + | Fresh (v, shp, lc, dom) -> + let a, dom = + match dom with + | Unbounded -> + (a, Unbounded) + | Bounded (e, rvis) -> + let ty01 = get v Props.ty0_prop in + let a, e, ty02 = self#expr scx a e in + begin match query e Props.mpars_prop with + | None -> + check0 (TAtm TAIdv) ty01; + check0 (TAtm TAIdv) ty02; + (a, Bounded (e, rvis)) + | Some ty03 -> + check0 ty03 ty01; + check0 (TSet ty03) ty02; + (a, Bounded (e, rvis)) + end + in + let h = Fresh (v, shp, lc, dom) @@ h in + let scx = adj scx h in + (scx, a, h) + | Flex s -> + let h = Flex s @@ h in + let scx = adj scx h in + (scx, a, h) + | Defn (_, _, Hidden, _) + | Fact (_, Hidden, _) -> + let scx = adj scx h in + (scx, a, h) + | Defn (df, wd, vis, ex) -> + let a, df = self#defn scx a df in + let h = Defn (df, wd, vis, ex) @@ h in + let scx = adj scx h in + (scx, a, h) + | Fact (e, vis, tm) -> + let a, e, ty0 = self#expr scx a e in + check0 (TAtm TABol) ty0; + let h = Fact (e, vis, tm) @@ h in + let scx = adj scx h in + (scx, a, h) + + method hyps scx a hs = + match Deque.front hs with + | None -> scx, a, Deque.empty + | Some (h, hs) -> + let scx, a, h = self#hyp scx a h in + let scx, a, hs = self#hyps scx a hs in + (scx, a, Deque.cons h hs) +end + diff --git a/src/type/t_visit.mli b/src/type/t_visit.mli new file mode 100644 index 00000000..625f44ef --- /dev/null +++ b/src/type/t_visit.mli @@ -0,0 +1,38 @@ +(* + * type/visit.mli --- visitors with syntactic typechecking + * + * + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + +open Expr.T +open T_t + +type 's scx = 's * hyp Deque.dq + +val adj : 's scx -> hyp -> 's scx +val adjs : 's scx -> hyp list -> 's scx + +val lookup_ty0 : 's scx -> int -> ty0 +val lookup_ty1 : 's scx -> int -> ty1 +val lookup_ty2 : 's scx -> int -> ty2 + +(* FIXME implement map, iter and fold *) + +class virtual ['s, 'a] foldmap : object + method expr : 's scx -> 'a -> expr -> 'a * expr * ty0 + method earg : 's scx -> 'a -> expr -> 'a * expr * ty1 + method eopr : 's scx -> 'a -> expr -> 'a * expr * ty2 + method pform : 's scx -> 'a -> pform -> 'a * pform + method sel : 's scx -> 'a -> sel -> 'a * sel + method sequent : 's scx -> 'a -> sequent -> 's scx * 'a * sequent + method defn : 's scx -> 'a -> defn -> 'a * defn + method defns : 's scx -> 'a -> defn list -> 's scx * 'a * defn list + method bounds : 's scx -> 'a -> bound list -> 's scx * 'a * bound list + method bound : 's scx -> 'a -> bound -> 's scx * 'a * bound + method exspec : 's scx -> 'a -> exspec -> 'a * exspec * ty0 list + method instance : 's scx -> 'a -> instance -> 'a * instance + method hyp : 's scx -> 'a -> hyp -> 's scx * 'a * hyp + method hyps : 's scx -> 'a -> hyp Deque.dq -> 's scx * 'a * hyp Deque.dq +end + diff --git a/src/type/t_visit.mlt b/src/type/t_visit.mlt new file mode 100644 index 00000000..98159baa --- /dev/null +++ b/src/type/t_visit.mlt @@ -0,0 +1,4 @@ +(* + * Copyright (C) 2022 INRIA and Microsoft Corporation + *) + diff --git a/src/util/ext.ml b/src/util/ext.ml index c27019b7..d85d6b62 100644 --- a/src/util/ext.ml +++ b/src/util/ext.ml @@ -10,6 +10,10 @@ module Option = struct fun fn -> function | Some x -> fn x | None -> () + let fold : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b = + fun fn x -> function + | Some y -> fn x y + | None -> x let map : ('a -> 'b) -> 'a option -> 'b option = fun fn -> function | Some x -> Some (fn x) diff --git a/src/util/ext.mli b/src/util/ext.mli index b990c6d1..9df20c84 100644 --- a/src/util/ext.mli +++ b/src/util/ext.mli @@ -58,6 +58,7 @@ end module Option : sig val get : 'a option -> 'a + val fold : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b val map : ('a -> 'b) -> 'a option -> 'b option val iter : ('a -> unit) -> 'a option -> unit val default : 'a -> 'a option -> 'a diff --git a/src/util/property.mli b/src/util/property.mli index 57d63b7e..8973d0a5 100644 --- a/src/util/property.mli +++ b/src/util/property.mli @@ -19,7 +19,7 @@ *) (** Property identifiers. They may be safely compared using - [Pervasives.compare]. *) + [Stdlib.compare]. *) type pid (** The abstract type of "properties". All types can be injected and diff --git a/src/util/util.ml b/src/util/util.ml index 274926d1..031f8d01 100644 --- a/src/util/util.ml +++ b/src/util/util.ml @@ -19,7 +19,14 @@ module HC = struct let compare x y = Stdlib.compare x.core y.core end +module IC = struct + type t = int + let compare x y = Stdlib.compare x y +end + module Coll = struct + module Im = Map.Make (IC) + module Is = Set.Make (IC) module Sm = Map.Make (String) module Ss = Set.Make (String) module Sh = Weak.Make (struct diff --git a/src/util/util.mli b/src/util/util.mli index 72bb5ac7..1572e0fb 100644 --- a/src/util/util.mli +++ b/src/util/util.mli @@ -26,9 +26,11 @@ type hints = hint list val pp_print_hint : Format.formatter -> hint -> unit module Coll : sig + module Im : Map.S with type key = int module Sm : Map.S with type key = string module Hm : Map.S with type key = hint + module Is : Set.S with type elt = int module Ss : Set.S with type elt = string module Hs : Set.S with type elt = hint diff --git a/test/TOOLS/time_one_test b/test/TOOLS/time_one_test index 5498321d..c9685c80 100755 --- a/test/TOOLS/time_one_test +++ b/test/TOOLS/time_one_test @@ -3,6 +3,18 @@ FILE="$1" TOOLDIR="$2" -exec "$TOOLDIR"/do_one_test "$FILE" "$TOOLDIR/separator" \ +"$TOOLDIR"/do_one_test "$FILE" "$TOOLDIR/separator" \ "$FILE.out" "$FILE.err" \ >"$FILE.out" 2>"$FILE.err" +retcode=$? +case $retcode in + 0) ;; + *) + printf "failed with return code %d\n" $retcode + printf "#### stdout:\n" + cat "$FILE.out" + printf "#### stderr:\n" + cat "$FILE.err" + exit $retcode + ;; +esac diff --git a/test/bugs/README.md b/test/bugs/README.md new file mode 100644 index 00000000..60f281b0 --- /dev/null +++ b/test/bugs/README.md @@ -0,0 +1,3 @@ +Like the unit/ directory, this directory is for unit tests (one PO per test), but it is for negative tests. A test succeeds if the test script returns the message 'FAILED' + +(Note: Currently it does not seem possible to change the test script so that a test succeeds if the provers fail to prove something. In the case of SMT solvers, the intented output for these unit tests is SAT, because the theorems are effectively unprovable.) diff --git a/test/bugs/constantfcn_test.tla b/test/bugs/constantfcn_test.tla new file mode 100644 index 00000000..68050872 --- /dev/null +++ b/test/bugs/constantfcn_test.tla @@ -0,0 +1,35 @@ +---- MODULE constantfcn_test ---- + +EXTENDS TLAPS + +(* This is proved by SMT (Hernan Vanzetto's version) with `--debug types2`, + * most likely because the domain condition is not checked in function + * applications. *) + +F == [ y \in { 1 } |-> 0 ] + +THEOREM Thm1 == + F[0] = 0 + BY DEF F + +(* Here is how this can be exploited to derive a contradiction. + * It suffices to define functions F and G that are equal (same domain + * and same values on that domain), but with expressions that do not + * match for values outside their domain. *) + +G == [ y \in { 1 } |-> IF y = 1 THEN 0 ELSE 1 ] + +THEOREM Thm2 == + G[0] = 1 + (* Same method than Thm1 *) + (*BY DEF G*) + +THEOREM 0 = 1 +<1>1 F = G (*BY DEF F, G*) +<1>2 0 = F[0] (*BY Thm1*) +<1>3 @ = G[0] (*BY <1>1*) +<1>4 @ = 1 (*BY Thm2*) +<1> QED (*BY ONLY <1>2, <1>3, <1>4*) + +==== +stderr: status:failed diff --git a/test/bugs/everythingisafcn_test.tla b/test/bugs/everythingisafcn_test.tla new file mode 100644 index 00000000..410199be --- /dev/null +++ b/test/bugs/everythingisafcn_test.tla @@ -0,0 +1,26 @@ +---- MODULE everythingisafcn_test ---- + +EXTENDS TLAPS + +(** Functions in TLA+ are guarded by a predicate IsAFcn to separate them from + other values. IsAFcn occurs in the axioms of TLA+ only. If the condition + IsAFcn is dropped, the theory of TLA+ makes the statement "Everything is a + function" valid. +*) + +THEOREM \A f : \E a, b : f \in [ a -> b ] +<1> TAKE f +<1> DEFINE a == DOMAIN f +<1> DEFINE b == { f[x] : x \in a } +<1>1 f \in [ a -> b ] + <2>1 DOMAIN f = a + (*OBVIOUS*) + <2>2 \A x \in a : f[x] \in b + (*OBVIOUS*) + <2> QED + BY ONLY <2>1, <2>2 +<1> QED + (*BY ONLY <1>1*) + +==== +stderr: status:failed diff --git a/test/bugs/excappbad_test.tla b/test/bugs/excappbad_test.tla new file mode 100644 index 00000000..93863b0b --- /dev/null +++ b/test/bugs/excappbad_test.tla @@ -0,0 +1,17 @@ +---- MODULE excapp3_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW f \in [ A -> B ], + NEW x \in A, + NEW y \in A, + NEW a, + NEW b + PROVE LET g == [ f EXCEPT ![x] = a, ![y] = b ] IN + g[x] = a + OBVIOUS + +==== +stderr: status:failed diff --git a/test/bugs/hidedef_test.tla b/test/bugs/hidedef_test.tla new file mode 100644 index 00000000..9726ffba --- /dev/null +++ b/test/bugs/hidedef_test.tla @@ -0,0 +1,12 @@ +---- MODULE hidedef_test ---- + +EXTENDS TLAPS + +C == TRUE +HIDE DEF C + +THEOREM C + OBVIOUS + +==== +stderr: status:failed diff --git a/test/bugs/hidedefpred_test.tla b/test/bugs/hidedefpred_test.tla new file mode 100644 index 00000000..63459125 --- /dev/null +++ b/test/bugs/hidedefpred_test.tla @@ -0,0 +1,15 @@ +---- MODULE hidedefpred_test ---- + +EXTENDS TLAPS + +C == TRUE +HIDE DEF C + +(** The following result might be solved if C is given the type bool. + This must not happen, as C's defn is hidden. +*) +THEOREM C = TRUE \/ C = FALSE + OBVIOUS + +==== +stderr: status:failed diff --git a/test/bugs/noteqfalse_test.tla b/test/bugs/noteqfalse_test.tla new file mode 100644 index 00000000..031bf8b2 --- /dev/null +++ b/test/bugs/noteqfalse_test.tla @@ -0,0 +1,15 @@ +---- MODULE noteqfalse_test ---- + +EXTENDS TLAPS + +(** 'x \/ ~ x' is a theorem of TLA+, but 'x = TRUE \/ x = FALSE' is + inconsistent, because it would imply that BOOLEAN is the set of all sets. + Thus the theorem below cannot be true. +*) + +THEOREM ASSUME NEW x + PROVE ~ x => x = FALSE + OBVIOUS + +==== +stderr: status:failed diff --git a/test/bugs/sndord_bis_test.tla b/test/bugs/sndord_bis_test.tla new file mode 100644 index 00000000..ceffe616 --- /dev/null +++ b/test/bugs/sndord_bis_test.tla @@ -0,0 +1,31 @@ +---- MODULE sndord_bis_test ---- + +EXTENDS TLAPS + +(** A simpler variant of sndord_test *) + +C == {} + +G(F(_)) == F(C) + +THEOREM Thm == + ASSUME NEW F(_) + PROVE G(F) = F(C) + (*BY DEF G*) + +THEOREM Cor == + ASSUME NEW F1(_), + NEW F2(_) + PROVE G(F1) = G(F2) + BY Thm + +Z(x) == 0 +S(x) == 1 + +THEOREM 0 = 1 +<1>1 G(Z) = 0 (*BY DEF G, Z*) +<1>2 G(S) = 1 (*BY DEF G, S*) +<1> QED (*BY ONLY Cor, <1>1, <1>2*) + +==== +stderr: status:failed diff --git a/test/bugs/sndord_test.tla b/test/bugs/sndord_test.tla new file mode 100644 index 00000000..66f90ef0 --- /dev/null +++ b/test/bugs/sndord_test.tla @@ -0,0 +1,35 @@ +---- MODULE sndord_test ---- + +EXTENDS TLAPS + +(** Usable theorems quantify on fst-order operators. This may become a problem + for encodings into a fst-order logic like SMT-LIB. This test reveals a + flaw in the current SMT encoding that relies on the treatment of fst-order + and snd-order operators. +*) + +G(F(_), x) == F(x) + +THEOREM Thm == + ASSUME NEW F(_), + NEW a + PROVE G(F, a) = F(a) + (*BY DEF G*) + +THEOREM Cor == + ASSUME NEW F1(_), + NEW F2(_), + NEW a + PROVE G(F1, a) = G(F2, a) + BY Thm + +Z(x) == 0 +S(x) == 1 + +THEOREM 0 = 1 +<1>1 G(Z, 0) = 0 (*BY DEF G, Z*) +<1>2 G(S, 0) = 1 (*BY DEF G, S*) +<1> QED (*BY ONLY Cor, <1>1, <1>2*) + +==== +stderr: status:failed diff --git a/test/fast/russell_test.tla b/test/fast/russell_test.tla deleted file mode 100644 index 8d326ec1..00000000 --- a/test/fast/russell_test.tla +++ /dev/null @@ -1,27 +0,0 @@ ------- MODULE russell_test ------ - -(*****************************************************************************) -(* Name: russell_test *) -(* Author: Antoine Defourné *) -(* Date: 16/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW V, - \A x : x \in V - PROVE FALSE -<1> DEFINE R == { x \in V : x \notin x } -<1> HIDE DEF R -<1>1 R \in R <=> R \notin R - <2>1 R \in R => R \notin R - BY Zenon DEF R - <2>2 R \notin R => R \in R - BY Zenon DEF R - <2> QED - BY ONLY <2>1, <2>2 -<1> QED - BY ONLY <1>1 - -==== - diff --git a/test/fast/smt_tests/README.md b/test/fast/smt_tests/README.md deleted file mode 100644 index 4dee3d6d..00000000 --- a/test/fast/smt_tests/README.md +++ /dev/null @@ -1,8 +0,0 @@ -All files ending in `_test.tla` in this subdirectory are unit tests for the SMT-LIB encoding of TLA+1 proof obligations. There are to be executed by `tlapm` with the option `--method smt`. - -- `basic` contains very basic tests that merely check if a feature is present; -- `advanced` contains more advanced problems; -- `bools` contains tests about the ambiguity of terms and formulas; -- `epsilon` contains tests about the `CHOOSE` operator; -- `lang` contains tests that check if a language feature of TLA+1 is supported; -- `lang2` contains tests that check if a language feature of TLA+2 is supported diff --git a/test/fast/smt_tests/advanced/functions/bijection_thm_test.tla b/test/fast/smt_tests/advanced/functions/bijection_thm_test.tla deleted file mode 100644 index 62d3acc6..00000000 --- a/test/fast/smt_tests/advanced/functions/bijection_thm_test.tla +++ /dev/null @@ -1,79 +0,0 @@ ------- MODULE bijection_thm_test ------ - -(*****************************************************************************) -(* Name: bijection_thm_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -IsId(f) == \A x \in DOMAIN f : f[x] = x - -g \o f == [ x \in DOMAIN f |-> g[f[x]] ] - -Injective(f, A, B) == - /\ f \in [ A -> B ] - /\ \A x, y \in A : f[x] = f[y] => x = y - -Surjective(f, A, B) == - /\ f \in [ A -> B ] - /\ \A z \in B : \E x \in A : f[x] = z - -Bijective(f, A, B) == - /\ f \in [ A -> B ] - /\ \E g \in [ B -> A ] : IsId(f \o g) /\ IsId(g \o f) - -THEOREM ASSUME NEW A, - NEW B, - NEW f \in [ A -> B ] - PROVE Injective(f, - A, B) /\ Surjective(f, A, B) <=> Bijective(f, A, B) - -<1>1 ASSUME Injective(f, A, B), - Surjective(f, A, B) - PROVE Bijective(f, A, B) - <2>1 \A y \in B : \E x \in A : f[x] = y - BY <1>1 DEF Surjective - <2> DEFINE g == [ y \in B |-> CHOOSE x \in A : f[x] = y ] - <2>2 \A y \in B : \A x \in A : f[x] = y => x = g[y] - BY <1>1 DEF Injective - <2>3 IsId(f \o g) - BY <2>1 DEF IsId, \o - <2>4 IsId(g \o f) - BY <2>2 DEF IsId, \o - <2> QED - BY <2>1, <2>3, <2>4 DEF Bijective - -<1>2 ASSUME Bijective(f, A, B) - PROVE Injective(f, A, B) /\ Surjective(f, A, B) - <2>1 PICK g \in [ B -> A ] : IsId(f \o g) /\ IsId(g \o f) - BY <1>2 DEF Bijective - <2>2 Injective(f, A, B) - <3>1 SUFFICES ASSUME NEW x \in A, - NEW y \in A, - f[x] = f[y] - PROVE x = y - BY DEF Injective - <3>2 x = (g \o f)[x] BY <2>1 DEF IsId, \o - <3>3 @ = g[ f[x] ] BY DEF \o - <3>4 @ = g[ f[y] ] BY <3>1 - <3>5 @ = (g \o f)[y] BY DEF \o - <3>6 @ = y BY <2>1 DEF IsId, \o - <3> QED - BY ONLY <3>2, <3>3, <3>4, <3>5, <3>6 - <2>3 Surjective(f, A, B) - <3>1 SUFFICES ASSUME NEW y \in B - PROVE \E x \in A : f[x] = y - BY DEF Surjective - <3>2 WITNESS g[y] \in A - <3> QED - BY <2>1 DEF IsId, \o - <2> QED - BY ONLY <2>2, <2>3 - -<1> QED - BY ONLY <1>1, <1>2 - -==== - diff --git a/test/fast/smt_tests/advanced/functions/composition_test.tla b/test/fast/smt_tests/advanced/functions/composition_test.tla deleted file mode 100644 index 47e1e611..00000000 --- a/test/fast/smt_tests/advanced/functions/composition_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE composition_test ------ - -(*****************************************************************************) -(* Name: composition_test *) -(* Author: Antoine Defourné *) -(* Date: 19/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -g \o f == [ x \in DOMAIN f |-> g[f[x]] ] - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW f \in [ A -> B ], - NEW g \in [ B -> C ] - PROVE g \o f \in [ A -> C ] - BY DEF \o - -==== - diff --git a/test/fast/smt_tests/advanced/functions/identity1_test.tla b/test/fast/smt_tests/advanced/functions/identity1_test.tla deleted file mode 100644 index 7d3c3c54..00000000 --- a/test/fast/smt_tests/advanced/functions/identity1_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE identity1_test ------ - -(*****************************************************************************) -(* Name: identity1_test *) -(* Author: Antoine Defourné *) -(* Date: 16/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -Id(S) == [ x \in S |-> x ] - -THEOREM ASSUME NEW S - PROVE \A x \in S : Id([S -> S])[ Id(S) ][x] = x - BY DEF Id - -==== - diff --git a/test/fast/smt_tests/advanced/functions/identity2_test.tla b/test/fast/smt_tests/advanced/functions/identity2_test.tla deleted file mode 100644 index 9385736e..00000000 --- a/test/fast/smt_tests/advanced/functions/identity2_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE identity2_test ------ - -(*****************************************************************************) -(* Name: identity2_test *) -(* Author: Antoine Defourné *) -(* Date: 16/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW Id(_), - \A S : Id(S) = [ x \in S |-> x ], - NEW S - PROVE \A x \in S : Id([S -> S])[ Id(S) ][x] = x - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/advanced/set_theory/cantor1_test.tla b/test/fast/smt_tests/advanced/set_theory/cantor1_test.tla deleted file mode 100644 index d8eccd20..00000000 --- a/test/fast/smt_tests/advanced/set_theory/cantor1_test.tla +++ /dev/null @@ -1,34 +0,0 @@ ------- MODULE cantor1_test ------ - -(*****************************************************************************) -(* Name: cantor1 *) -(* Author: Antoine Defourné *) -(* Date: 12/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -Surjective(f, A, B) == - /\ f \in [ A -> B ] - /\ \A y \in B : \E x \in A : f[x] = y - -THEOREM \A E : ~ \E f : Surjective(f, E, SUBSET E) -<1>1 SUFFICES ASSUME NEW E, - NEW f \in [ E -> SUBSET E ], - \A P \in SUBSET E : \E x \in E : f[x] = P - PROVE FALSE - BY DEF Surjective -<1> DEFINE D == { x \in E : x \notin f[x] } -<1> D \in SUBSET E - OBVIOUS -<1>2 PICK d \in E : f[d] = D - BY <1>1 -<1>3 d \in f[d] <=> d \in D - BY <1>2 -<1>4 @ <=> d \notin f[d] - OBVIOUS -<1> QED - BY ONLY <1>3, <1>4 - -==== - diff --git a/test/fast/smt_tests/advanced/set_theory/choice_axiom2_test.tla b/test/fast/smt_tests/advanced/set_theory/choice_axiom2_test.tla deleted file mode 100644 index 7400077e..00000000 --- a/test/fast/smt_tests/advanced/set_theory/choice_axiom2_test.tla +++ /dev/null @@ -1,28 +0,0 @@ ------- MODULE choice_axiom2_test ------ - -(*****************************************************************************) -(* Name: choice_axiom2_test *) -(* Author: Antoine Defourné *) -(* Date: 16/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW I, NEW X, - NEW a \in [ I -> X ], - \A i \in I : a[i] /= {} - PROVE LET Y == UNION { a[i] : i \in I } IN - { f \in [ I -> Y ] : \A i \in I : f[i] \in a[i] } - /= {} -<1> DEFINE Y == UNION { a[i] : i \in I } -<1> SUFFICES \E f \in [ I -> Y ] : \A i \in I : f[i] \in a[i] - OBVIOUS -<1> DEFINE f == [ i \in I |-> CHOOSE x \in a[i] : x = x ] -<1> \A i \in I : f[i] \in a[i] - OBVIOUS -<1> WITNESS f \in [ I -> Y ] -<1> QED - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/advanced/set_theory/choice_axiom_test.tla b/test/fast/smt_tests/advanced/set_theory/choice_axiom_test.tla deleted file mode 100644 index e0a40d68..00000000 --- a/test/fast/smt_tests/advanced/set_theory/choice_axiom_test.tla +++ /dev/null @@ -1,26 +0,0 @@ ------- MODULE choice_axiom_test ------ - -(*****************************************************************************) -(* Name: choice_axiom_test *) -(* Author: Antoine Defourné *) -(* Date: 13/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A a : {} \notin a => \E f \in [ a -> UNION a ] : \A x \in a : f[x] \in x -<1> TAKE a -<1>1 HAVE {} \notin a -<1> DEFINE f == [ x \in a |-> CHOOSE y : y \in x ] -<1>2 DOMAIN f = a - OBVIOUS -<1>3 \A x \in a : f[x] \in UNION a - BY <1>1 -<1> WITNESS f \in [ a -> UNION a ] -<1>4 \A x \in a : f[x] \in x - BY <1>1 -<1> QED - BY <1>4 - -==== - diff --git a/test/fast/smt_tests/advanced/set_theory/section_test.tla b/test/fast/smt_tests/advanced/set_theory/section_test.tla deleted file mode 100644 index 9f57227e..00000000 --- a/test/fast/smt_tests/advanced/set_theory/section_test.tla +++ /dev/null @@ -1,29 +0,0 @@ ------- MODULE section_test ------ - -(*****************************************************************************) -(* Name: section_test *) -(* Author: Antoine Defourné *) -(* Date: 16/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -Surjective(f, A, B) == - /\ f \in [ A -> B ] - /\ \A y \in B : \E x \in A : y = f[x] - -THEOREM ASSUME NEW A, NEW B, - NEW f \in [ A -> B ], - Surjective(f, A, B) - PROVE \E g \in [ B -> A ] : \A y \in B : f[g[y]] = y -<1> DEFINE g == [ y \in B |-> CHOOSE x \in A : y = f[x] ] -<1> DOMAIN g = B - OBVIOUS -<1> \A y \in B : g[y] \in A /\ f[g[y]] = y - BY DEF Surjective -<1> WITNESS g \in [ B -> A ] -<1> QED - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/advanced/tuples/tuple_as_function1_test.tla b/test/fast/smt_tests/advanced/tuples/tuple_as_function1_test.tla deleted file mode 100644 index 145afe39..00000000 --- a/test/fast/smt_tests/advanced/tuples/tuple_as_function1_test.tla +++ /dev/null @@ -1,30 +0,0 @@ ------- MODULE tuple_as_function1_test ------ - -(*****************************************************************************) -(* Name: tuple_as_function1_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS, Naturals - -THEOREM ASSUME NEW A, NEW B, NEW C - PROVE A \X B \X C \subseteq [ 1..3 -> UNION { A, B, C } ] -<1>1 SUFFICES ASSUME NEW x \in A \X B \X C - PROVE x \in [ 1..3 -> UNION { A, B, C } ] - OBVIOUS -<1>2 DOMAIN x = 1..3 - OBVIOUS -<1>3 \A i \in 1..3 : x[i] \in UNION { A, B, C } - <2> TAKE i \in 1..3 - <2>1 i = 1 \/ i = 2 \/ i = 3 OBVIOUS - <2>2 CASE i = 1 BY <2>2 - <2>3 CASE i = 2 BY <2>3 - <2>4 CASE i = 3 BY <2>4 - <2> QED - BY ONLY <2>1, <2>2, <2>3, <2>4 -<1> QED - BY <1>2, <1>3 - -==== - diff --git a/test/fast/smt_tests/advanced/tuples/tuple_as_function2_test.tla b/test/fast/smt_tests/advanced/tuples/tuple_as_function2_test.tla deleted file mode 100644 index 3afb5693..00000000 --- a/test/fast/smt_tests/advanced/tuples/tuple_as_function2_test.tla +++ /dev/null @@ -1,41 +0,0 @@ ------- MODULE tuple_as_function2_test ------ - -(*****************************************************************************) -(* Name: tuple_as_function2_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS, Naturals - -THEOREM ASSUME NEW A, NEW B, - A /= B - PROVE A \X B /= [ 1..2 -> A \cup B ] -<1>1 CASE A = {} /\ B = {} - BY <1>1 -<1>2 CASE A /= {} \/ B /= {} - <2>1 A \cup B /= {} - BY <1>2 - <2>2 PICK x \in A \cup B : - \/ x \in A \ B - \/ x \in B \ A - BY <1>2, <2>1 - <2> DEFINE f == [ i \in 1..2 |-> x ] - <2>3 f \in [ 1..2 -> A \cup B ] - OBVIOUS - <2>4 f \notin A \X B - <3>1 CASE x \in A \ B - <4>1 f[2] \notin B BY <3>1 - <4> QED BY <4>1 - <3>2 CASE x \in B \ A - <4>1 f[1] \notin A BY <3>2 - <4> QED BY <4>1 - <3> QED - BY ONLY <2>2, <3>1, <3>1 - <2> QED - BY ONLY <2>3, <2>4 -<1> QED - BY ONLY <1>1, <1>2 - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith10_test.tla b/test/fast/smt_tests/basic/arith/arith10_test.tla deleted file mode 100644 index c7765bd9..00000000 --- a/test/fast/smt_tests/basic/arith/arith10_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith10_test ------ - -(*****************************************************************************) -(* Name: arith10_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM \A m, n \in Int : m + n = n + m - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith11_test.tla b/test/fast/smt_tests/basic/arith/arith11_test.tla deleted file mode 100644 index dd3f5ab9..00000000 --- a/test/fast/smt_tests/basic/arith/arith11_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith11_test ------ - -(*****************************************************************************) -(* Name: arith11_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM \A m, n \in Int : m * n = n * m - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith12_test.tla b/test/fast/smt_tests/basic/arith/arith12_test.tla deleted file mode 100644 index 880629ee..00000000 --- a/test/fast/smt_tests/basic/arith/arith12_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith12_test ------ - -(*****************************************************************************) -(* Name: arith12_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM \A m, n, p \in Int : m < n /\ n <= p => m < p - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith13_test.tla b/test/fast/smt_tests/basic/arith/arith13_test.tla deleted file mode 100644 index 7d6c7f92..00000000 --- a/test/fast/smt_tests/basic/arith/arith13_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith13_test ------ - -(*****************************************************************************) -(* Name: arith13_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM \A m, n \in Int : m <= n /\ m >= n => m = n - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith14_test.tla b/test/fast/smt_tests/basic/arith/arith14_test.tla deleted file mode 100644 index 9ef5553a..00000000 --- a/test/fast/smt_tests/basic/arith/arith14_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith14_test ------ - -(*****************************************************************************) -(* Name: arith14_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM \A m, n, p \in Int : (m + n) * p = (m * p) + (n * p) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith15_test.tla b/test/fast/smt_tests/basic/arith/arith15_test.tla deleted file mode 100644 index eba72393..00000000 --- a/test/fast/smt_tests/basic/arith/arith15_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith16_test ------ - -(*****************************************************************************) -(* Name: arith16_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM \A n \in Int : n + 0 = n - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith16_test.tla b/test/fast/smt_tests/basic/arith/arith16_test.tla deleted file mode 100644 index 3fd7c861..00000000 --- a/test/fast/smt_tests/basic/arith/arith16_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith15_test ------ - -(*****************************************************************************) -(* Name: arith15_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 0 = 0 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith17_test.tla b/test/fast/smt_tests/basic/arith/arith17_test.tla deleted file mode 100644 index c1ee7ac1..00000000 --- a/test/fast/smt_tests/basic/arith/arith17_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith17_test ------ - -(*****************************************************************************) -(* Name: arith17_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 0 /= 1 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith18_test.tla b/test/fast/smt_tests/basic/arith/arith18_test.tla deleted file mode 100644 index 6117ac9d..00000000 --- a/test/fast/smt_tests/basic/arith/arith18_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith18_test ------ - -(*****************************************************************************) -(* Name: arith18_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 0 \in (-1) .. 1 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith19_test.tla b/test/fast/smt_tests/basic/arith/arith19_test.tla deleted file mode 100644 index d3f8c14a..00000000 --- a/test/fast/smt_tests/basic/arith/arith19_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith19_test ------ - -(*****************************************************************************) -(* Name: arith19_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 6 \notin 1 .. 4 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith1_test.tla b/test/fast/smt_tests/basic/arith/arith1_test.tla deleted file mode 100644 index 2bb56c95..00000000 --- a/test/fast/smt_tests/basic/arith/arith1_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith1_test ------ - -(*****************************************************************************) -(* Name: arith1_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 1 + 1 = 2 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith2_test.tla b/test/fast/smt_tests/basic/arith/arith2_test.tla deleted file mode 100644 index 693d6a90..00000000 --- a/test/fast/smt_tests/basic/arith/arith2_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith2_test ------ - -(*****************************************************************************) -(* Name: arith2_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 1 - 1 = 0 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith3_test.tla b/test/fast/smt_tests/basic/arith/arith3_test.tla deleted file mode 100644 index 414c4d92..00000000 --- a/test/fast/smt_tests/basic/arith/arith3_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith3_test ------ - -(*****************************************************************************) -(* Name: arith3_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 2 * 3 = 6 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith4_test.tla b/test/fast/smt_tests/basic/arith/arith4_test.tla deleted file mode 100644 index 9f55c59e..00000000 --- a/test/fast/smt_tests/basic/arith/arith4_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith4_test ------ - -(*****************************************************************************) -(* Name: arith4_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 4 \div 2 = 2 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith5_test.tla b/test/fast/smt_tests/basic/arith/arith5_test.tla deleted file mode 100644 index fb6cd71d..00000000 --- a/test/fast/smt_tests/basic/arith/arith5_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith5_test ------ - -(*****************************************************************************) -(* Name: arith5_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 5 % 3 = 2 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith6_test.tla b/test/fast/smt_tests/basic/arith/arith6_test.tla deleted file mode 100644 index f589330e..00000000 --- a/test/fast/smt_tests/basic/arith/arith6_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith6_test ------ - -(*****************************************************************************) -(* Name: arith6_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 2 < 4 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith7_test.tla b/test/fast/smt_tests/basic/arith/arith7_test.tla deleted file mode 100644 index 5aa83820..00000000 --- a/test/fast/smt_tests/basic/arith/arith7_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith7_test ------ - -(*****************************************************************************) -(* Name: arith7_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 3 <= 3 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith8_test.tla b/test/fast/smt_tests/basic/arith/arith8_test.tla deleted file mode 100644 index b61dfad0..00000000 --- a/test/fast/smt_tests/basic/arith/arith8_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith8_test ------ - -(*****************************************************************************) -(* Name: arith8_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 8 > 1 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/arith/arith9_test.tla b/test/fast/smt_tests/basic/arith/arith9_test.tla deleted file mode 100644 index 3b7a07bf..00000000 --- a/test/fast/smt_tests/basic/arith/arith9_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE arith9_test ------ - -(*****************************************************************************) -(* Name: arith9_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 7 >= 5 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/epsilon/epsilon1_test.tla b/test/fast/smt_tests/basic/epsilon/epsilon1_test.tla deleted file mode 100644 index 97bd36ed..00000000 --- a/test/fast/smt_tests/basic/epsilon/epsilon1_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE epsilon1_test ------ - -(*****************************************************************************) -(* Name: epsilon1_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), - \E x : P(x) - PROVE P(CHOOSE x : P(x)) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/epsilon/epsilon2_test.tla b/test/fast/smt_tests/basic/epsilon/epsilon2_test.tla deleted file mode 100644 index 69fddaf4..00000000 --- a/test/fast/smt_tests/basic/epsilon/epsilon2_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE epsilon2_test ------ - -(*****************************************************************************) -(* Name: epsilon2_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), NEW S, - \E x \in S : P(x) - PROVE P(CHOOSE x \in S : P(x)) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/epsilon/epsilon3_test.tla b/test/fast/smt_tests/basic/epsilon/epsilon3_test.tla deleted file mode 100644 index 312bbf4f..00000000 --- a/test/fast/smt_tests/basic/epsilon/epsilon3_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE epsilon3_test ------ - -(*****************************************************************************) -(* Name: epsilon3_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), - ~ P(CHOOSE x : P(x)) - PROVE \A x : ~ P(x) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/epsilon/epsilon4_test.tla b/test/fast/smt_tests/basic/epsilon/epsilon4_test.tla deleted file mode 100644 index ab5c50ac..00000000 --- a/test/fast/smt_tests/basic/epsilon/epsilon4_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE epsilon4_test ------ - -(*****************************************************************************) -(* Name: epsilon4_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), NEW S, - ~ P(CHOOSE x \in S : P(x)) - PROVE \A x \in S : ~ P(x) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/extensionality/empty_set_ext_test.tla b/test/fast/smt_tests/basic/extensionality/empty_set_ext_test.tla deleted file mode 100644 index 075f3b6f..00000000 --- a/test/fast/smt_tests/basic/extensionality/empty_set_ext_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE empty_set_ext_test ------ - -(*****************************************************************************) -(* Name: empty_set_ext_test *) -(* Author: Antoine Defourné *) -(* Date: 22/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW S, - \A x : x \notin S - PROVE S = {} - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/extensionality/enum_ext_test.tla b/test/fast/smt_tests/basic/extensionality/enum_ext_test.tla deleted file mode 100644 index e3e6b1c5..00000000 --- a/test/fast/smt_tests/basic/extensionality/enum_ext_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE mytest_test ------ - -(*****************************************************************************) -(* Name: mytest_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW x, NEW y, NEW S, - \A z : z \in S <=> z = x \/ z = y - PROVE S = {x, y} - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/extensionality/fun_ext_test.tla b/test/fast/smt_tests/basic/extensionality/fun_ext_test.tla deleted file mode 100644 index 0d0ef70f..00000000 --- a/test/fast/smt_tests/basic/extensionality/fun_ext_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE fun_ext_test ------ - -(*****************************************************************************) -(* Name: fun_ext_test *) -(* Author: Antoine Defourné *) -(* Date: 22/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW f \in [ A -> B ] - PROVE f = [ x \in DOMAIN f |-> f[x] ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/extensionality/set_ext_test.tla b/test/fast/smt_tests/basic/extensionality/set_ext_test.tla deleted file mode 100644 index 5df792e2..00000000 --- a/test/fast/smt_tests/basic/extensionality/set_ext_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE set_ext_test ------ - -(*****************************************************************************) -(* Name: set_ext_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW x, NEW y, - \A z : z \in x <=> z \in y - PROVE x = y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/extensionality/tup_ext_test.tla b/test/fast/smt_tests/basic/extensionality/tup_ext_test.tla deleted file mode 100644 index d16f2d4a..00000000 --- a/test/fast/smt_tests/basic/extensionality/tup_ext_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE tup_ext_test ------ - -(*****************************************************************************) -(* Name: tup_ext_test *) -(* Author: Antoine Defourné *) -(* Date: 22/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW t \in A \X B - PROVE t = <> - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder1_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder1_test.tla deleted file mode 100644 index 56647219..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder1_test.tla +++ /dev/null @@ -1,20 +0,0 @@ ------- MODULE firstorder1_test ------ - -(*****************************************************************************) -(* Name: firstorder1_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_, _), - NEW a, - NEW b, - \A x, y : P(x, y) => P(y, a), - P(b, a) - PROVE P(a, a) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder1_wproof_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder1_wproof_test.tla deleted file mode 100644 index dcbb1fc6..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder1_wproof_test.tla +++ /dev/null @@ -1,25 +0,0 @@ ------- MODULE firstorder1_test ------ - -(*****************************************************************************) -(* Name: firstorder1_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_, _), - NEW a, - NEW b, - \A x, y : P(x, y) => P(y, a), - P(b, a) - PROVE P(a, a) -<1>1 P(b, a) - OBVIOUS -<1>2 P(b, a) => P(a, a) - OBVIOUS -<1> QED - BY ONLY <1>1, <1>2 - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder2_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder2_test.tla deleted file mode 100644 index 059d4047..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder2_test.tla +++ /dev/null @@ -1,21 +0,0 @@ ------- MODULE firstorder2_test ------ - -(*****************************************************************************) -(* Name: firstorder2_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), - NEW f(_, _), - NEW g(_), - NEW a, - \A x : f(x, x) = g(x), - P(f(a, a)) - PROVE P(g(a)) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder2_wproof_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder2_wproof_test.tla deleted file mode 100644 index cbaf5c05..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder2_wproof_test.tla +++ /dev/null @@ -1,26 +0,0 @@ ------- MODULE firstorder2_test ------ - -(*****************************************************************************) -(* Name: firstorder2_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), - NEW f(_, _), - NEW g(_), - NEW a, - \A x : f(x, x) = g(x), - P(f(a, a)) - PROVE P(g(a)) -<1>1 P(f(a, a)) - OBVIOUS -<1>2 f(a, a) = g(a) - OBVIOUS -<1>3 QED - BY ONLY <1>1, <1>2 - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder3_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder3_test.tla deleted file mode 100644 index 10bdcea7..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder3_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE firstorder3_test ------ - -(*****************************************************************************) -(* Name: firstorder3_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_, _), - NEW f(_), - \A x : P(x, f(x)) - PROVE \A x : \E y : P(x, y) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder3_wproof_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder3_wproof_test.tla deleted file mode 100644 index ba35ef13..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder3_wproof_test.tla +++ /dev/null @@ -1,21 +0,0 @@ ------- MODULE firstorder3_test ------ - -(*****************************************************************************) -(* Name: firstorder3_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_, _), - NEW f(_), - \A x : P(x, f(x)) - PROVE \A x : \E y : P(x, y) -<1> TAKE x -<1> WITNESS f(x) -<1> QED - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder4_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder4_test.tla deleted file mode 100644 index 0407c641..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder4_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE firstorder4_test ------ - -(*****************************************************************************) -(* Name: firstorder4_test *) -(* Author: Antoine Defourné *) -(* Date: 15/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW D(_) - PROVE \E x : D(x) => \A y : D(y) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder4_wproof_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder4_wproof_test.tla deleted file mode 100644 index e3251204..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder4_wproof_test.tla +++ /dev/null @@ -1,24 +0,0 @@ ------- MODULE firstorder4_test ------ - -(*****************************************************************************) -(* Name: firstorder4_test *) -(* Author: Antoine Defourné *) -(* Date: 15/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW D(_) - PROVE \E x : D(x) => \A y : D(y) -<1>1 SUFFICES ASSUME \A x : D(x) /\ \E y : ~ D(y) - PROVE FALSE - OBVIOUS -<1>2 PICK y : ~ D(y) - BY <1>1 -<1>3 D(y) - BY <1>1 -<1> QED - BY ONLY <1>2, <1>3 - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder5_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder5_test.tla deleted file mode 100644 index 7bab02e8..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder5_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE firstorder5_test ------ - -(*****************************************************************************) -(* Name: firstorder5_test *) -(* Author: Antoine Defourné *) -(* Date: 15/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), - NEW a, - NEW b - PROVE \E x : P(x) => P(a) /\ P(b) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder5_wproof_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder5_wproof_test.tla deleted file mode 100644 index 92b7806d..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder5_wproof_test.tla +++ /dev/null @@ -1,25 +0,0 @@ ------- MODULE firstorder5_test ------ - -(*****************************************************************************) -(* Name: firstorder5_test *) -(* Author: Antoine Defourné *) -(* Date: 15/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_), - NEW a, - NEW b - PROVE \E x : P(x) => P(a) /\ P(b) -<1>1 CASE P(a) /\ P(b) - BY <1>1 -<1>2 CASE ~ P(a) - BY <1>2 -<1>3 CASE ~ P(b) - BY <1>3 -<1> QED - BY ONLY <1>1, <1>2, <1>3 - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder6_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder6_test.tla deleted file mode 100644 index c2c7afcc..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder6_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE firstorder6_test ------ - -(*****************************************************************************) -(* Name: firstorder6_test *) -(* Author: Antoine Defourné *) -(* Date: 15/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_, _), - \E x : \A y : P(x, y) - PROVE \A z : \E w : P(w, z) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/firstorder/firstorder6_wproof_test.tla b/test/fast/smt_tests/basic/firstorder/firstorder6_wproof_test.tla deleted file mode 100644 index e3ec0555..00000000 --- a/test/fast/smt_tests/basic/firstorder/firstorder6_wproof_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE firstorder6_test ------ - -(*****************************************************************************) -(* Name: firstorder6_test *) -(* Author: Antoine Defourné *) -(* Date: 15/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW P(_, _), - \E x : \A y : P(x, y) - PROVE \A z : \E w : P(w, z) -<1>1 PICK x : \A y : P(x, y) - OBVIOUS -<1>2 TAKE z -<1>3 WITNESS x -<1> QED - BY ONLY <1>1 - -==== - diff --git a/test/fast/smt_tests/basic/function/function10_test.tla b/test/fast/smt_tests/basic/function/function10_test.tla deleted file mode 100644 index b7fbe627..00000000 --- a/test/fast/smt_tests/basic/function/function10_test.tla +++ /dev/null @@ -1,21 +0,0 @@ ------- MODULE function10_test ------ - -(*****************************************************************************) -(* Name: function10_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW f \in [ A -> B ], - NEW x \in A, - NEW E(_), - E(x) \in B - PROVE DOMAIN [ f EXCEPT ![x] = E(x) ] = A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function11_test.tla b/test/fast/smt_tests/basic/function/function11_test.tla deleted file mode 100644 index 5f99462a..00000000 --- a/test/fast/smt_tests/basic/function/function11_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function11_test ------ - -(*****************************************************************************) -(* Name: function11_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW f \in [ A -> B ], - NEW x \in A, - NEW y \in A, - NEW E(_), - E(x) \in B - PROVE [ f EXCEPT ![x] = E(x) ][y] \in B - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function12_test.tla b/test/fast/smt_tests/basic/function/function12_test.tla deleted file mode 100644 index bcc821c7..00000000 --- a/test/fast/smt_tests/basic/function/function12_test.tla +++ /dev/null @@ -1,23 +0,0 @@ ------- MODULE function12_test ------ - -(*****************************************************************************) -(* Name: function12_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW f, - DOMAIN f = A, - \A x \in A : f[x] \in B, - NEW x \in A, - NEW E(_), - E(x) \in B - PROVE [ f EXCEPT ![x] = E(x) ] \in [ A -> B ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function13_test.tla b/test/fast/smt_tests/basic/function/function13_test.tla deleted file mode 100644 index 21df5af9..00000000 --- a/test/fast/smt_tests/basic/function/function13_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE function13_test ------ - -(*****************************************************************************) -(* Name: function13_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW f, - NEW x \in DOMAIN f, - NEW E(_) - PROVE [ f EXCEPT ![x] = E(x) ][x] = E(x) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function14_test.tla b/test/fast/smt_tests/basic/function/function14_test.tla deleted file mode 100644 index 230c3590..00000000 --- a/test/fast/smt_tests/basic/function/function14_test.tla +++ /dev/null @@ -1,20 +0,0 @@ ------- MODULE function14_test ------ - -(*****************************************************************************) -(* Name: function14_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW f, - NEW x \in DOMAIN f, - NEW y, - y /= x, - NEW E(_) - PROVE [ f EXCEPT ![y] = E(y) ][x] = f[x] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function15_test.tla b/test/fast/smt_tests/basic/function/function15_test.tla deleted file mode 100644 index 09f7da4b..00000000 --- a/test/fast/smt_tests/basic/function/function15_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function15_test ------ - -(*****************************************************************************) -(* Name: function15_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW f, - NEW x \in DOMAIN f, - NEW y \in DOMAIN f[x], - NEW u \in DOMAIN f, - NEW v \in DOMAIN f[u], - NEW z, - NEW w - PROVE DOMAIN [ f EXCEPT ![x][y] = z, ![u][v] = w ] = DOMAIN f - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function16_test.tla b/test/fast/smt_tests/basic/function/function16_test.tla deleted file mode 100644 index 52a1f407..00000000 --- a/test/fast/smt_tests/basic/function/function16_test.tla +++ /dev/null @@ -1,24 +0,0 @@ ------- MODULE function16_test ------ - -(*****************************************************************************) -(* Name: function16_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW f, - NEW x \in DOMAIN f, - NEW y \in DOMAIN f[x], - NEW u \in DOMAIN f, - NEW v \in DOMAIN f[u], - NEW z, - NEW w, - u /= x - PROVE [ f EXCEPT ![x][y] = z, ![u][v] = w ][x] = - [ f[x] EXCEPT ![y] = z ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function17_test.tla b/test/fast/smt_tests/basic/function/function17_test.tla deleted file mode 100644 index 37e4bb3c..00000000 --- a/test/fast/smt_tests/basic/function/function17_test.tla +++ /dev/null @@ -1,24 +0,0 @@ ------- MODULE function17_test ------ - -(*****************************************************************************) -(* Name: function17_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW f, - NEW x \in DOMAIN f, - NEW y \in DOMAIN f[x], - NEW u \in DOMAIN f, - NEW v \in DOMAIN f[u], - NEW z, - NEW w, - x /= u - PROVE [ f EXCEPT ![x][y] = z, ![u][v] = w ][u] = - [ f[u] EXCEPT ![v] = w ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function18_test.tla b/test/fast/smt_tests/basic/function/function18_test.tla deleted file mode 100644 index 85ab954f..00000000 --- a/test/fast/smt_tests/basic/function/function18_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function18_test ------ - -(*****************************************************************************) -(* Name: function18_test *) -(* Author: Antoine Defourné *) -(* Date: 17/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW f, - NEW x \in DOMAIN f, - NEW y \in DOMAIN f[x], - NEW v \in DOMAIN f[x], - NEW z, - NEW w - PROVE [ f EXCEPT ![x][y] = z, ![x][v] = w ][x] = - [ [ f[x] EXCEPT ![y] = z ] EXCEPT ![v] = w ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function1_test.tla b/test/fast/smt_tests/basic/function/function1_test.tla deleted file mode 100644 index b339ff3a..00000000 --- a/test/fast/smt_tests/basic/function/function1_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE function1_test ------ - -(*****************************************************************************) -(* Name: function1_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW f \in [ A -> B ] - PROVE DOMAIN f = A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function20_test.tla b/test/fast/smt_tests/basic/function/function20_test.tla deleted file mode 100644 index 55806552..00000000 --- a/test/fast/smt_tests/basic/function/function20_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function20_test ------ - -(*****************************************************************************) -(* Name: function20_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW r \in [ foo : A, bar : B ], - NEW a \in A - PROVE DOMAIN [ r EXCEPT !.foo = a ] = { "foo", "bar" } - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function21_test.tla b/test/fast/smt_tests/basic/function/function21_test.tla deleted file mode 100644 index fc0596c9..00000000 --- a/test/fast/smt_tests/basic/function/function21_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function21_test ------ - -(*****************************************************************************) -(* Name: function21_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW r \in [ foo : A, bar : B ], - NEW a \in A - PROVE [ r EXCEPT !.foo = a ].foo \in A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function22_test.tla b/test/fast/smt_tests/basic/function/function22_test.tla deleted file mode 100644 index 62ac4ffc..00000000 --- a/test/fast/smt_tests/basic/function/function22_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function22_test ------ - -(*****************************************************************************) -(* Name: function22_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW r \in [ foo : A, bar : B ], - NEW a \in A - PROVE [ r EXCEPT !.foo = a ].bar \in B - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function23_test.tla b/test/fast/smt_tests/basic/function/function23_test.tla deleted file mode 100644 index ffdd028b..00000000 --- a/test/fast/smt_tests/basic/function/function23_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function23_test ------ - -(*****************************************************************************) -(* Name: function23_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW r \in [ foo : A, bar : B ], - NEW a \in A - PROVE [ r EXCEPT !.foo = a ] \in [ foo : A, bar : B ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function24_test.tla b/test/fast/smt_tests/basic/function/function24_test.tla deleted file mode 100644 index 382d8efa..00000000 --- a/test/fast/smt_tests/basic/function/function24_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function24_test ------ - -(*****************************************************************************) -(* Name: function24_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW r \in [ foo : A, bar : B ], - NEW a \in A - PROVE [ r EXCEPT !.foo = a ].foo = a - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function25_test.tla b/test/fast/smt_tests/basic/function/function25_test.tla deleted file mode 100644 index cacbec0f..00000000 --- a/test/fast/smt_tests/basic/function/function25_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function25_test ------ - -(*****************************************************************************) -(* Name: function25_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW r \in [ foo : A, bar : B ], - NEW a \in A - PROVE [ r EXCEPT !.foo = a ].bar = r.bar - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function26_test.tla b/test/fast/smt_tests/basic/function/function26_test.tla deleted file mode 100644 index 4ee993cc..00000000 --- a/test/fast/smt_tests/basic/function/function26_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function26_test ------ - -(*****************************************************************************) -(* Name: function26_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW f \in [ A -> [ foo : B, bar : C ] ], - NEW x \in A, - NEW E(_), - E(x) \in C - PROVE DOMAIN [ f EXCEPT ![x].bar = E(x) ] = A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function27_test.tla b/test/fast/smt_tests/basic/function/function27_test.tla deleted file mode 100644 index f681ba24..00000000 --- a/test/fast/smt_tests/basic/function/function27_test.tla +++ /dev/null @@ -1,23 +0,0 @@ ------- MODULE function27_test ------ - -(*****************************************************************************) -(* Name: function27_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW f \in [ A -> [ foo : B, bar : C ] ], - NEW x \in A, - NEW y \in A, - NEW E(_), - E(x) \in B - PROVE [ f EXCEPT ![x].foo = E(x) ][y] \in [ foo : B, bar : C ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function28_test.tla b/test/fast/smt_tests/basic/function/function28_test.tla deleted file mode 100644 index c813e0a9..00000000 --- a/test/fast/smt_tests/basic/function/function28_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function26_test ------ - -(*****************************************************************************) -(* Name: function26_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW f \in [ A -> [ foo : B, bar : C ] ], - NEW x \in A, - NEW E(_), - E(x) \in B - PROVE [ f EXCEPT ![x].foo = E(x) ] \in [ A -> [ foo : B, bar : C ] ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function29_test.tla b/test/fast/smt_tests/basic/function/function29_test.tla deleted file mode 100644 index e96ada07..00000000 --- a/test/fast/smt_tests/basic/function/function29_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function29_test ------ - -(*****************************************************************************) -(* Name: function29_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW f \in [ A -> [ foo : B, bar : C ] ], - NEW x \in A, - NEW E(_), - E(x) \in B - PROVE [ f EXCEPT ![x].foo = E(x) ][x].foo = E(x) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function2_test.tla b/test/fast/smt_tests/basic/function/function2_test.tla deleted file mode 100644 index 936b7c24..00000000 --- a/test/fast/smt_tests/basic/function/function2_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function2_test ------ - -(*****************************************************************************) -(* Name: function2_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW f \in [ A -> B ], - NEW x \in A - PROVE f[x] \in B - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function30_test.tla b/test/fast/smt_tests/basic/function/function30_test.tla deleted file mode 100644 index ac7b2318..00000000 --- a/test/fast/smt_tests/basic/function/function30_test.tla +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function29_test ------ - -(*****************************************************************************) -(* Name: function29_test *) -(* Author: Antoine Defourné *) -(* Date: 18/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW f \in [ A -> [ foo : B, bar : C ] ], - NEW x \in A, - NEW E(_), - E(x) \in B - PROVE [ f EXCEPT ![x].foo = E(x) ][x].bar = f[x].bar - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function3_test.tla b/test/fast/smt_tests/basic/function/function3_test.tla deleted file mode 100644 index c217a2a6..00000000 --- a/test/fast/smt_tests/basic/function/function3_test.tla +++ /dev/null @@ -1,20 +0,0 @@ ------- MODULE function3_test ------ - -(*****************************************************************************) -(* Name: function3_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW f, - DOMAIN f = A, - \A x \in A : f[x] \in B - PROVE f \in [ A -> B ] - OBVIOUS - -==== -stderr: status:failed diff --git a/test/fast/smt_tests/basic/function/function5_test.tla b/test/fast/smt_tests/basic/function/function5_test.tla deleted file mode 100644 index 1f2d6675..00000000 --- a/test/fast/smt_tests/basic/function/function5_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function5_test ------ - -(*****************************************************************************) -(* Name: function5_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - B \subseteq C - PROVE [ A -> B ] \subseteq [ A -> C ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function6_test.tla b/test/fast/smt_tests/basic/function/function6_test.tla deleted file mode 100644 index ec4bbc74..00000000 --- a/test/fast/smt_tests/basic/function/function6_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE function6_test ------ - -(*****************************************************************************) -(* Name: function6_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW F(_), - NEW x \in A - PROVE [ y \in A |-> F(y) ][x] = F(x) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function7_test.tla b/test/fast/smt_tests/basic/function/function7_test.tla deleted file mode 100644 index 9272aef3..00000000 --- a/test/fast/smt_tests/basic/function/function7_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE function7_test ------ - -(*****************************************************************************) -(* Name: function7_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW F(_) - PROVE DOMAIN [ x \in A |-> F(x) ] = A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function8_test.tla.disabled b/test/fast/smt_tests/basic/function/function8_test.tla.disabled deleted file mode 100644 index de59e700..00000000 --- a/test/fast/smt_tests/basic/function/function8_test.tla.disabled +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE function8_test ------ - -(*****************************************************************************) -(* Name: function8_test *) -(* Author: Antoine Defourné *) -(* Date: 26/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW F(_, _, _, _) - PROVE DOMAIN [ x \in A, y, z \in B, u \in C |-> F(x, y, z, u) ] = A \X B \X B \X C - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/function/function9_test.tla.disabled b/test/fast/smt_tests/basic/function/function9_test.tla.disabled deleted file mode 100644 index 11396280..00000000 --- a/test/fast/smt_tests/basic/function/function9_test.tla.disabled +++ /dev/null @@ -1,22 +0,0 @@ ------- MODULE function9_test ------ - -(*****************************************************************************) -(* Name: function9_test *) -(* Author: Antoine Defourné *) -(* Date: 16/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW F(_, _, _), - NEW x \in A, - NEW y \in B, - NEW z \in C - PROVE [ u \in A, v \in B, w \in C |-> F(x, y, z) ][x, y, z] = F(x, y, z) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/basic_test.tla b/test/fast/smt_tests/basic/prop/basic_test.tla deleted file mode 100644 index e0315655..00000000 --- a/test/fast/smt_tests/basic/prop/basic_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE basic_test ------ - -(*****************************************************************************) -(* Name: basic_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM TRUE - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop10_test.tla b/test/fast/smt_tests/basic/prop/prop10_test.tla deleted file mode 100644 index c7b0090c..00000000 --- a/test/fast/smt_tests/basic/prop/prop10_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE prop10_test ------ - -(*****************************************************************************) -(* Name: prop10_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN, - NEW B \in BOOLEAN - PROVE (A \/ B) /\ ~ A => B - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop11_test.tla b/test/fast/smt_tests/basic/prop/prop11_test.tla deleted file mode 100644 index 25e31159..00000000 --- a/test/fast/smt_tests/basic/prop/prop11_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE prop11_test ------ - -(*****************************************************************************) -(* Name: prop11_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN, - NEW B \in BOOLEAN, - NEW C \in BOOLEAN - PROVE (A /\ B) \/ C <=> (A \/ C) /\ (B \/ C) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop12_test.tla b/test/fast/smt_tests/basic/prop/prop12_test.tla deleted file mode 100644 index 0a6d6197..00000000 --- a/test/fast/smt_tests/basic/prop/prop12_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE prop12_test ------ - -(*****************************************************************************) -(* Name: prop12_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN, - NEW B \in BOOLEAN, - NEW C \in BOOLEAN - PROVE (A \/ B) /\ C <=> (A /\ C) \/ (B /\ C) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop1_test.tla b/test/fast/smt_tests/basic/prop/prop1_test.tla deleted file mode 100644 index d0a17399..00000000 --- a/test/fast/smt_tests/basic/prop/prop1_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE prop1_test ------ - -(*****************************************************************************) -(* Name: prop1_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM TRUE /\ ~ FALSE - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop2_test.tla b/test/fast/smt_tests/basic/prop/prop2_test.tla deleted file mode 100644 index 859795fd..00000000 --- a/test/fast/smt_tests/basic/prop/prop2_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE prop2_test ------ - -(*****************************************************************************) -(* Name: prop2_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN - PROVE A \/ ~ A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop3_test.tla b/test/fast/smt_tests/basic/prop/prop3_test.tla deleted file mode 100644 index 6bb5dc09..00000000 --- a/test/fast/smt_tests/basic/prop/prop3_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE prop3_test ------ - -(*****************************************************************************) -(* Name: prop3_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN - PROVE ~ ~ A <=> A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop4_test.tla b/test/fast/smt_tests/basic/prop/prop4_test.tla deleted file mode 100644 index 0d47fbb1..00000000 --- a/test/fast/smt_tests/basic/prop/prop4_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE prop4_test ------ - -(*****************************************************************************) -(* Name: prop4_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN, - NEW B \in BOOLEAN - PROVE ((A => B) => A) => A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop5_test.tla b/test/fast/smt_tests/basic/prop/prop5_test.tla deleted file mode 100644 index 4eaa2173..00000000 --- a/test/fast/smt_tests/basic/prop/prop5_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE prop5_test ------ - -(*****************************************************************************) -(* Name: prop5_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN - PROVE FALSE => A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop6_test.tla b/test/fast/smt_tests/basic/prop/prop6_test.tla deleted file mode 100644 index 92e0650a..00000000 --- a/test/fast/smt_tests/basic/prop/prop6_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE prop6_test ------ - -(*****************************************************************************) -(* Name: prop6_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN - PROVE A => TRUE - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop7_test.tla b/test/fast/smt_tests/basic/prop/prop7_test.tla deleted file mode 100644 index 3f242009..00000000 --- a/test/fast/smt_tests/basic/prop/prop7_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE prop7_test ------ - -(*****************************************************************************) -(* Name: prop7_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN, - NEW B \in BOOLEAN - PROVE ~ (A /\ B) <=> ~ A \/ ~ B - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop8_test.tla b/test/fast/smt_tests/basic/prop/prop8_test.tla deleted file mode 100644 index e4df114c..00000000 --- a/test/fast/smt_tests/basic/prop/prop8_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE prop8_test ------ - -(*****************************************************************************) -(* Name: prop8_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN, - NEW B \in BOOLEAN - PROVE ~ (A \/ B) <=> ~ A /\ ~ B - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/prop/prop9_test.tla b/test/fast/smt_tests/basic/prop/prop9_test.tla deleted file mode 100644 index 4fc6cc58..00000000 --- a/test/fast/smt_tests/basic/prop/prop9_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE prop9_test ------ - -(*****************************************************************************) -(* Name: prop9_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A \in BOOLEAN, - NEW B \in BOOLEAN, - NEW C \in BOOLEAN - PROVE (A /\ B) => C <=> A => (B => C) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/record/record1_test.tla b/test/fast/smt_tests/basic/record/record1_test.tla deleted file mode 100644 index a3b0aaae..00000000 --- a/test/fast/smt_tests/basic/record/record1_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE record1_test ------ - -(*****************************************************************************) -(* Name: record1_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW C, - NEW r \in [ foo : A, bar : B, baz : C ] - PROVE r.foo \in A /\ r.bar \in B /\ r.baz \in C - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/record/record2_test.tla b/test/fast/smt_tests/basic/record/record2_test.tla deleted file mode 100644 index 979835c3..00000000 --- a/test/fast/smt_tests/basic/record/record2_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE record2_test ------ - -(*****************************************************************************) -(* Name: record2_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW a \in A, - NEW b \in B - PROVE [ foo |-> a, bar |-> b ] \in [ foo : A, bar : B ] - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/record/record3_test.tla b/test/fast/smt_tests/basic/record/record3_test.tla deleted file mode 100644 index 46880c23..00000000 --- a/test/fast/smt_tests/basic/record/record3_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE record3_test ------ - -(*****************************************************************************) -(* Name: record3_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW a, - NEW b - PROVE DOMAIN [ foo |-> a, bar |-> b ] = { "foo", "bar" } - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set10_test.tla b/test/fast/smt_tests/basic/set/set10_test.tla deleted file mode 100644 index 7062b588..00000000 --- a/test/fast/smt_tests/basic/set/set10_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set10_test ------ - -(*****************************************************************************) -(* Name: set10_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y : x \in UNION y <=> \E z \in y : x \in z - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set11_test.tla b/test/fast/smt_tests/basic/set/set11_test.tla deleted file mode 100644 index ff020099..00000000 --- a/test/fast/smt_tests/basic/set/set11_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set11_test ------ - -(*****************************************************************************) -(* Name: set11_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y : x \in SUBSET y <=> x \subseteq y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set12_test.tla b/test/fast/smt_tests/basic/set/set12_test.tla deleted file mode 100644 index 9ab3a0fa..00000000 --- a/test/fast/smt_tests/basic/set/set12_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE set12_test ------ - -(*****************************************************************************) -(* Name: set12_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A(_), - NEW z - PROVE \A x : x \in { y \in z : A(y) } <=> x \in z /\ A(x) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set13_test.tla b/test/fast/smt_tests/basic/set/set13_test.tla deleted file mode 100644 index ebd1ccab..00000000 --- a/test/fast/smt_tests/basic/set/set13_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE set13_test ------ - -(*****************************************************************************) -(* Name: set13_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW E(_), - NEW z - PROVE \A x : x \in { E(y) : y \in z } <=> \E y \in z : x = E(y) - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set14_test.tla b/test/fast/smt_tests/basic/set/set14_test.tla deleted file mode 100644 index 8e776a92..00000000 --- a/test/fast/smt_tests/basic/set/set14_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set14_test ------ - -(*****************************************************************************) -(* Name: set14_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y, z : x \in [y -> z] => DOMAIN x = y /\ \A s \in y : x[s] \in z - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set15_test.tla b/test/fast/smt_tests/basic/set/set15_test.tla deleted file mode 100644 index 3686d5d5..00000000 --- a/test/fast/smt_tests/basic/set/set15_test.tla +++ /dev/null @@ -1,18 +0,0 @@ ------- MODULE set15_test ------ - -(*****************************************************************************) -(* Name: set15_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW S, - \A y \in S : { x \in S : x /= y } /= {}, - \A z, y \in S : { x \in S : x /= y } /= {} - PROVE S = S - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set16_test.tla b/test/fast/smt_tests/basic/set/set16_test.tla deleted file mode 100644 index df892f7d..00000000 --- a/test/fast/smt_tests/basic/set/set16_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set16_test ------ - -(*****************************************************************************) -(* Name: set16_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y \in { {} } : x = y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set17_test.tla b/test/fast/smt_tests/basic/set/set17_test.tla deleted file mode 100644 index 6c0341be..00000000 --- a/test/fast/smt_tests/basic/set/set17_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE set17_test ------ - -(*****************************************************************************) -(* Name: set17_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW S - PROVE \A x, y \in S : x = y \/ x /= y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set18_test.tla b/test/fast/smt_tests/basic/set/set18_test.tla deleted file mode 100644 index 80419dd6..00000000 --- a/test/fast/smt_tests/basic/set/set18_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE set18_test ------ - -(*****************************************************************************) -(* Name: set18_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW S, - S = { {} } - PROVE \A x, y \in S : x = y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set19_test.tla b/test/fast/smt_tests/basic/set/set19_test.tla deleted file mode 100644 index 9c56f54f..00000000 --- a/test/fast/smt_tests/basic/set/set19_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE set19_test ------ - -(*****************************************************************************) -(* Name: set19_test *) -(* Author: Antoine Defourné *) -(* Date: 16/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW S - PROVE S \subseteq { x \in S : x \in S } - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set1_test.tla b/test/fast/smt_tests/basic/set/set1_test.tla deleted file mode 100644 index 084b3181..00000000 --- a/test/fast/smt_tests/basic/set/set1_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set1_test ------ - -(*****************************************************************************) -(* Name: set1_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y : x \subseteq y => \A z : z \in x => z \in y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set2_test.tla b/test/fast/smt_tests/basic/set/set2_test.tla deleted file mode 100644 index 97587541..00000000 --- a/test/fast/smt_tests/basic/set/set2_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set2_test ------ - -(*****************************************************************************) -(* Name: set2_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x : x \notin {} - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set3_test.tla b/test/fast/smt_tests/basic/set/set3_test.tla deleted file mode 100644 index 7713180c..00000000 --- a/test/fast/smt_tests/basic/set/set3_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set3_test ------ - -(*****************************************************************************) -(* Name: set3_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y : x \in {y} <=> x = y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set4_test.tla b/test/fast/smt_tests/basic/set/set4_test.tla deleted file mode 100644 index e349bacd..00000000 --- a/test/fast/smt_tests/basic/set/set4_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set4_test ------ - -(*****************************************************************************) -(* Name: set4_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y, z : x \in {y, z} <=> x = y \/ x = z - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set5_test.tla b/test/fast/smt_tests/basic/set/set5_test.tla deleted file mode 100644 index 43946ec6..00000000 --- a/test/fast/smt_tests/basic/set/set5_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set5_test ------ - -(*****************************************************************************) -(* Name: set5_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y, z : z \in x \cup y <=> z \in y \cup x - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set6_test.tla b/test/fast/smt_tests/basic/set/set6_test.tla deleted file mode 100644 index 634141ce..00000000 --- a/test/fast/smt_tests/basic/set/set6_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set6_test ------ - -(*****************************************************************************) -(* Name: set6_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y, z : z \in x \cap y <=> z \in y \cap x - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set7_test.tla b/test/fast/smt_tests/basic/set/set7_test.tla deleted file mode 100644 index 87da8091..00000000 --- a/test/fast/smt_tests/basic/set/set7_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set7_test ------ - -(*****************************************************************************) -(* Name: set7_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y : y \notin x \cap {} - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set8_test.tla b/test/fast/smt_tests/basic/set/set8_test.tla deleted file mode 100644 index ec56456d..00000000 --- a/test/fast/smt_tests/basic/set/set8_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set8_test ------ - -(*****************************************************************************) -(* Name: set8_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y, z : z \subseteq x /\ z \subseteq y => z \subseteq x \cap y - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/set/set9_test.tla b/test/fast/smt_tests/basic/set/set9_test.tla deleted file mode 100644 index 8ed6ca69..00000000 --- a/test/fast/smt_tests/basic/set/set9_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE set9_test ------ - -(*****************************************************************************) -(* Name: set9_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y, z : x \subseteq z /\ y \subseteq z => x \cup y \subseteq z - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/string/strings1_test.tla b/test/fast/smt_tests/basic/string/strings1_test.tla deleted file mode 100644 index 9b22b06b..00000000 --- a/test/fast/smt_tests/basic/string/strings1_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE strings1_test ------ - -(*****************************************************************************) -(* Name: strings1_test *) -(* Author: Antoine Defourné *) -(* Date: 23/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM "Hello World!" = "Hello World!" - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/string/strings2_test.tla b/test/fast/smt_tests/basic/string/strings2_test.tla deleted file mode 100644 index f111a938..00000000 --- a/test/fast/smt_tests/basic/string/strings2_test.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE strings2_test ------ - -(*****************************************************************************) -(* Name: strings2_test *) -(* Author: Antoine Defourné *) -(* Date: 23/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM "Hello World!" /= "Goodbye World!" - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/string/strings3_test.tla.disabled b/test/fast/smt_tests/basic/string/strings3_test.tla.disabled deleted file mode 100644 index cc662916..00000000 --- a/test/fast/smt_tests/basic/string/strings3_test.tla.disabled +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE strings3_test ------ - -(*****************************************************************************) -(* Name: string3_test *) -(* Author: Antoine Defourné *) -(* Date: 24/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM "foo" \in STRING - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/basic/tuple/tuple1_test.tla b/test/fast/smt_tests/basic/tuple/tuple1_test.tla deleted file mode 100644 index 916a124d..00000000 --- a/test/fast/smt_tests/basic/tuple/tuple1_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE tuple1_test ------ - -(*****************************************************************************) -(* Name: tuple1_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x, y : <>[1] = x /\ <>[2] = y - OBVIOUS - -==== - - diff --git a/test/fast/smt_tests/basic/tuple/tuple2_test.tla b/test/fast/smt_tests/basic/tuple/tuple2_test.tla deleted file mode 100644 index b7054b9f..00000000 --- a/test/fast/smt_tests/basic/tuple/tuple2_test.tla +++ /dev/null @@ -1,20 +0,0 @@ ------- MODULE tuple2_test ------ - -(*****************************************************************************) -(* Name: tuple2_test *) -(* Author: Antoine Defourné *) -(* Date: 24/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW x \in A, - NEW y \in B - PROVE <> \in A \X B - OBVIOUS - -==== - - diff --git a/test/fast/smt_tests/basic/tuple/tuple3_test.tla b/test/fast/smt_tests/basic/tuple/tuple3_test.tla deleted file mode 100644 index 8ff13de0..00000000 --- a/test/fast/smt_tests/basic/tuple/tuple3_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE tuple3_test ------ - -(*****************************************************************************) -(* Name: tuple3_test *) -(* Author: Antoine Defourné *) -(* Date: 24/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, - NEW B, - NEW s \in A \X B - PROVE s[1] \in A /\ s[2] \in B - OBVIOUS - -==== - - diff --git a/test/fast/smt_tests/basic/tuple/tuple4_test.tla b/test/fast/smt_tests/basic/tuple/tuple4_test.tla deleted file mode 100644 index c1b3e96e..00000000 --- a/test/fast/smt_tests/basic/tuple/tuple4_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE tuple4_test ------ - -(*****************************************************************************) -(* Name: tuple4_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW x - PROVE <> = <> - OBVIOUS - -==== - - diff --git a/test/fast/smt_tests/basic/tuple/tuple5_test.tla b/test/fast/smt_tests/basic/tuple/tuple5_test.tla deleted file mode 100644 index 2e78a43d..00000000 --- a/test/fast/smt_tests/basic/tuple/tuple5_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE tuple5_test ------ - -(*****************************************************************************) -(* Name: tuple5_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW x, - NEW y, - x /= y - PROVE <> /= <> - OBVIOUS - -==== - - diff --git a/test/fast/smt_tests/basic/tuple/tuple6_test.tla b/test/fast/smt_tests/basic/tuple/tuple6_test.tla deleted file mode 100644 index c62e3847..00000000 --- a/test/fast/smt_tests/basic/tuple/tuple6_test.tla +++ /dev/null @@ -1,21 +0,0 @@ ------- MODULE tuple6_test ------ - -(*****************************************************************************) -(* Name: tuple6_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW x, - NEW y, - NEW u, - NEW v, - <> = <> - PROVE x = u /\ y = v - OBVIOUS - -==== - - diff --git a/test/fast/smt_tests/basic/tuple/tuple7_test.tla b/test/fast/smt_tests/basic/tuple/tuple7_test.tla deleted file mode 100644 index bbc05595..00000000 --- a/test/fast/smt_tests/basic/tuple/tuple7_test.tla +++ /dev/null @@ -1,23 +0,0 @@ ------- MODULE tuple7_test ------ - -(*****************************************************************************) -(* Name: tuple7_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW x, - NEW y, - NEW z, - NEW u, - NEW v, - NEW w, - NEW t - PROVE <> /= <> - OBVIOUS - -==== - - diff --git a/test/fast/smt_tests/negative/one_div_zero_test.tla b/test/fast/smt_tests/negative/one_div_zero_test.tla deleted file mode 100644 index be2797eb..00000000 --- a/test/fast/smt_tests/negative/one_div_zero_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE one_div_zero_test ------ - -(*****************************************************************************) -(* Name: one_div_zero *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS, Integers - -THEOREM 1 \div 0 \in Int - OBVIOUS - -==== -stretch: 1 -stderr: status:failed diff --git a/test/fast/smt_tests/negative/zero_in_one_test.tla b/test/fast/smt_tests/negative/zero_in_one_test.tla deleted file mode 100644 index 4eee2702..00000000 --- a/test/fast/smt_tests/negative/zero_in_one_test.tla +++ /dev/null @@ -1,17 +0,0 @@ ------- MODULE zero_in_one_test ------ - -(*****************************************************************************) -(* Name: Zero In One *) -(* Author: Antoine Defourné *) -(* a non-sensical formula. *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 0 \in 1 - OBVIOUS - -==== -stretch: 1 -stderr: status:failed diff --git a/test/fast/smt_tests/rewriting_rules/quantifiers_test.tla b/test/fast/smt_tests/rewriting_rules/quantifiers_test.tla deleted file mode 100644 index 2c988141..00000000 --- a/test/fast/smt_tests/rewriting_rules/quantifiers_test.tla +++ /dev/null @@ -1,29 +0,0 @@ ------- MODULE quantifiers_test ------ - -(*****************************************************************************) -(* Name: quantifiers_test *) -(* Author: Hernán Vanzetto *) -(* Date: 26/02/2020 *) -(*****************************************************************************) - -EXTENDS TLAPS - -LEMMA ASSUME NEW S PROVE \A x \in S: TRUE -OBVIOUS - -LEMMA (\A x: FALSE) = FALSE -OBVIOUS - -LEMMA ASSUME NEW S PROVE (\E x \in S: FALSE) = FALSE -OBVIOUS - -LEMMA \E x: TRUE -OBVIOUS - -LEMMA ASSUME NEW P PROVE (\E x \in {}: P) = FALSE -OBVIOUS - -LEMMA ASSUME NEW P PROVE \A x \in {}: P -OBVIOUS - -==== diff --git a/test/fast/smt_tests/silly_theorems/app_ambiguity_test.tla b/test/fast/smt_tests/silly_theorems/app_ambiguity_test.tla deleted file mode 100644 index 77a5c208..00000000 --- a/test/fast/smt_tests/silly_theorems/app_ambiguity_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE app_ambiguity_test ------ - -(*****************************************************************************) -(* Name: app_ambiguity_test *) -(* Author: Antoine Defourné *) -(* Date: 22/10/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM ASSUME NEW A, NEW B - PROVE \A h : h \in (A \X B) \cup [ {1, 2} -> A ] => h[1] \in A - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/silly_theorems/nonempty_integer_test.tla b/test/fast/smt_tests/silly_theorems/nonempty_integer_test.tla deleted file mode 100644 index c6cc9d7a..00000000 --- a/test/fast/smt_tests/silly_theorems/nonempty_integer_test.tla +++ /dev/null @@ -1,23 +0,0 @@ ------- MODULE nonempty_integer_test ------ - -(*****************************************************************************) -(* Name: nonempty_integer_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS, Integers - -THEOREM \E z \in Int : \E x : x \in z -<1>1 SUFFICES ASSUME \A z \in Int : z = {} - PROVE FALSE - OBVIOUS -<1>2 0 = {} - BY <1>1 -<1>3 @ = 1 - BY <1>1 -<1> QED - BY ONLY <1>2, <1>3 - -==== - diff --git a/test/fast/smt_tests/silly_theorems/one_implies_one_test.tla b/test/fast/smt_tests/silly_theorems/one_implies_one_test.tla deleted file mode 100644 index 04095d1d..00000000 --- a/test/fast/smt_tests/silly_theorems/one_implies_one_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE one_implies_one_test ------ - -(*****************************************************************************) -(* Name: One Implies One *) -(* Author: Antoine Defourné *) -(* a non-sensical formula. *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS Integers, TLAPS - -THEOREM 1 => 1 - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/silly_theorems/record_as_function_test.tla b/test/fast/smt_tests/silly_theorems/record_as_function_test.tla deleted file mode 100644 index 3f70b509..00000000 --- a/test/fast/smt_tests/silly_theorems/record_as_function_test.tla +++ /dev/null @@ -1,19 +0,0 @@ ------- MODULE record_as_function_test ------ - -(*****************************************************************************) -(* Name: record_as_function_test *) -(* Author: Antoine Defourné *) -(* Date: 25/09/19 *) -(*****************************************************************************) - -EXTENDS TLAPS, Integers - -R == [ foo : Int, - bar : Int - ] - -THEOREM \A r \in R : \A s \in { "foo", "bar" } : r[s] \in Int - BY DEF R - -==== - diff --git a/test/fast/smt_tests/silly_theorems/x_implies_x_test.tla b/test/fast/smt_tests/silly_theorems/x_implies_x_test.tla deleted file mode 100644 index f9f0a7b3..00000000 --- a/test/fast/smt_tests/silly_theorems/x_implies_x_test.tla +++ /dev/null @@ -1,16 +0,0 @@ ------- MODULE x_implies_x_test ------ - -(*****************************************************************************) -(* Name: X Implies X *) -(* Author: Antoine Defourné *) -(* a non-sensical formula. *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM \A x : x => x - OBVIOUS - -==== - diff --git a/test/fast/smt_tests/template.tla b/test/fast/smt_tests/template.tla deleted file mode 100644 index dd8008a7..00000000 --- a/test/fast/smt_tests/template.tla +++ /dev/null @@ -1,15 +0,0 @@ ------- MODULE mytest_test ------ - -(*****************************************************************************) -(* Name: mytest_test *) -(* Author: Antoine Defourné *) -(* Date: 01/07/19 *) -(*****************************************************************************) - -EXTENDS TLAPS - -THEOREM TRUE - OBVIOUS - -==== - diff --git a/test/medium/regression/snapshot/GFX_test.tla b/test/medium/regression/snapshot/GFX_test.tla index 704221cb..06d007ff 100644 --- a/test/medium/regression/snapshot/GFX_test.tla +++ b/test/medium/regression/snapshot/GFX_test.tla @@ -520,7 +520,7 @@ THEOREM Invariance == Spec => []Inv BY DEF PA1 <8>1. \A i \in Nat : wa[i] # p BY NotAProcProp, SMT DEF PV - <8>2. \A i \in Nat : PV(wa)' = PV(wa) + <8>2. PV(wa)' = PV(wa) BY <8>1, <5>3, SMT DEF TypeOK, PV, WriterAssignment \* DEF PV added 31 May 2013 \** DEF WriterAssignment added 2013-06-25 diff --git a/test/medium/regression/snapshot/SnapShot_test.tla b/test/medium/regression/snapshot/SnapShot_test.tla index 3c502ea3..555f0791 100644 --- a/test/medium/regression/snapshot/SnapShot_test.tla +++ b/test/medium/regression/snapshot/SnapShot_test.tla @@ -704,7 +704,7 @@ THEOREM Invariance == Spec => []Inv <4>1. ASSUME NEW q \in Proc PROVE Inv1!1!(q)' <5>1. Inv1!1!(q)!1' - BY SMT DEF Inv1, TypeOK, b, PUnion + BY Z3T(10) DEF Inv1, TypeOK, b, PUnion <5>2. Inv1!1!(q)!2' BY SMT DEF Inv1, TypeOK, b <5>3. Inv1!1!(q)!3' @@ -2057,6 +2057,7 @@ THEOREM Spec => S!BigSpec (*************************************************************************)OMITTED ============================================================================= \* Modification History +\* Last modified Wed Jan 18 08:51:11 CET 2023 by rosalied \* Last modified Tue Apr 14 16:42:06 CEST 2020 by doligez \* Last modified Tue Jun 25 15:13:49 CEST 2013 by hernanv \* Last modified Sat Jun 01 10:16:42 CEST 2013 by merz diff --git a/test/unit/README.md b/test/unit/README.md new file mode 100644 index 00000000..36547f37 --- /dev/null +++ b/test/unit/README.md @@ -0,0 +1 @@ +This directory contains unit tests. A unit test is a module from which a single PO is generated. The PO should be elementary, provable, and require one basic functionality of the language to be supported by the backends. diff --git a/test/unit/a_lang/binary_test.tla b/test/unit/a_lang/binary_test.tla new file mode 100644 index 00000000..51466788 --- /dev/null +++ b/test/unit/a_lang/binary_test.tla @@ -0,0 +1,11 @@ +---- MODULE binary_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW F(_, _), + NEW a, + NEW b + PROVE F(a, b) = F(a, b) + OBVIOUS + +==== diff --git a/test/unit/a_lang/bounded_test.tla b/test/unit/a_lang/bounded_test.tla new file mode 100644 index 00000000..6b83591d --- /dev/null +++ b/test/unit/a_lang/bounded_test.tla @@ -0,0 +1,10 @@ +---- MODULE bounded_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW b \in a + PROVE b \in a + OBVIOUS + +==== diff --git a/test/unit/a_lang/constant_test.tla b/test/unit/a_lang/constant_test.tla new file mode 100644 index 00000000..f32d01c3 --- /dev/null +++ b/test/unit/a_lang/constant_test.tla @@ -0,0 +1,9 @@ +---- MODULE constant_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a + PROVE a = a + OBVIOUS + +==== diff --git a/test/unit/a_lang/ditto_test.tla b/test/unit/a_lang/ditto_test.tla new file mode 100644 index 00000000..3c96c09a --- /dev/null +++ b/test/unit/a_lang/ditto_test.tla @@ -0,0 +1,9 @@ +---- MODULE ditto_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A + PROVE \A x, y \in A : x \in A /\ y \in A + OBVIOUS + +==== diff --git a/test/unit/a_lang/extends_test.tla b/test/unit/a_lang/extends_test.tla new file mode 100644 index 00000000..73eda9c7 --- /dev/null +++ b/test/unit/a_lang/extends_test.tla @@ -0,0 +1,8 @@ +---- MODULE extends_test ---- + +EXTENDS TLAPS, Integers + +THEOREM Nat = Nat + OBVIOUS + +==== diff --git a/test/unit/a_lang/hidedef_test.tla b/test/unit/a_lang/hidedef_test.tla new file mode 100644 index 00000000..ae100d82 --- /dev/null +++ b/test/unit/a_lang/hidedef_test.tla @@ -0,0 +1,11 @@ +---- MODULE hidedef_test ---- + +EXTENDS TLAPS + +C == TRUE +HIDE DEF C + +THEOREM TRUE + BY C = C + +==== diff --git a/test/unit/a_lang/letchain_test.tla b/test/unit/a_lang/letchain_test.tla new file mode 100644 index 00000000..6a0cbaf8 --- /dev/null +++ b/test/unit/a_lang/letchain_test.tla @@ -0,0 +1,12 @@ +---- MODULE letchain_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a + PROVE LET b == a + c == b + IN + a = c + OBVIOUS + +==== diff --git a/test/unit/a_lang/letconstant_test.tla b/test/unit/a_lang/letconstant_test.tla new file mode 100644 index 00000000..82d58da2 --- /dev/null +++ b/test/unit/a_lang/letconstant_test.tla @@ -0,0 +1,9 @@ +---- MODULE letconstant_test ---- + +EXTENDS TLAPS + +THEOREM LET C == TRUE IN + C + OBVIOUS + +==== diff --git a/test/unit/a_lang/letfunction_test.tla b/test/unit/a_lang/letfunction_test.tla new file mode 100644 index 00000000..4f3e1a73 --- /dev/null +++ b/test/unit/a_lang/letfunction_test.tla @@ -0,0 +1,10 @@ +---- MODULE letfunction_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a + PROVE LET F(x) == TRUE IN + F(a) + OBVIOUS + +==== diff --git a/test/unit/a_lang/letsndord_test.tla b/test/unit/a_lang/letsndord_test.tla new file mode 100644 index 00000000..14503523 --- /dev/null +++ b/test/unit/a_lang/letsndord_test.tla @@ -0,0 +1,10 @@ +---- MODULE letsndord_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW H(_) + PROVE LET G(F(_)) == TRUE IN + G(H) + OBVIOUS + +==== diff --git a/test/unit/a_lang/nothing_test.tla b/test/unit/a_lang/nothing_test.tla new file mode 100644 index 00000000..2a197b15 --- /dev/null +++ b/test/unit/a_lang/nothing_test.tla @@ -0,0 +1,3 @@ +---- MODULE nothing_test ---- + +==== diff --git a/test/unit/a_lang/nusedef_test.tla b/test/unit/a_lang/nusedef_test.tla new file mode 100644 index 00000000..e5b4f571 --- /dev/null +++ b/test/unit/a_lang/nusedef_test.tla @@ -0,0 +1,10 @@ +---- MODULE nusedef_test ---- + +EXTENDS TLAPS + +C == TRUE + +THEOREM TRUE + OBVIOUS + +==== diff --git a/test/unit/a_lang/nusefact_test.tla b/test/unit/a_lang/nusefact_test.tla new file mode 100644 index 00000000..c27a0b49 --- /dev/null +++ b/test/unit/a_lang/nusefact_test.tla @@ -0,0 +1,10 @@ +---- MODULE usedef_test ---- + +EXTENDS TLAPS + +ASSUME F == FALSE + +THEOREM TRUE + OBVIOUS + +==== diff --git a/test/unit/a_lang/nusesndord_test.tla b/test/unit/a_lang/nusesndord_test.tla new file mode 100644 index 00000000..ae0d72db --- /dev/null +++ b/test/unit/a_lang/nusesndord_test.tla @@ -0,0 +1,11 @@ +---- MODULE nusesndord_test ---- + +EXTENDS TLAPS + +G(F(_)) == TRUE + +THEOREM TRUE + OBVIOUS + +==== + diff --git a/test/unit/a_lang/predarg_test.tla b/test/unit/a_lang/predarg_test.tla new file mode 100644 index 00000000..5c01b2ff --- /dev/null +++ b/test/unit/a_lang/predarg_test.tla @@ -0,0 +1,20 @@ +---- MODULE predarg_test ---- + +(* NOTE: Requires higher-order unification *) + +EXTENDS TLAPS + +F(P(_), x) == P(x) + +THEOREM DefF == + ASSUME NEW P(_), + NEW x, + P(x) + PROVE F(P, x) + (*BY DEF F*) + +THEOREM ASSUME NEW x + PROVE F(LAMBDA y : y = y, x) + BY DefF + +==== diff --git a/test/unit/a_lang/prime_test.tla b/test/unit/a_lang/prime_test.tla new file mode 100644 index 00000000..420a92ef --- /dev/null +++ b/test/unit/a_lang/prime_test.tla @@ -0,0 +1,10 @@ +---- MODULE prime_test ---- + +EXTENDS TLAPS + +VARIABLE x + +THEOREM x' = x' + OBVIOUS + +==== diff --git a/test/unit/a_lang/secondord_test.tla b/test/unit/a_lang/secondord_test.tla new file mode 100644 index 00000000..45066ce1 --- /dev/null +++ b/test/unit/a_lang/secondord_test.tla @@ -0,0 +1,13 @@ +---- MODULE secondord_test ---- + +EXTENDS TLAPS + +F(x, G(_), y) == TRUE + +THEOREM ASSUME NEW a, + NEW G(_), + NEW b + PROVE F(a, G, b) = F(a, G, b) + OBVIOUS + +==== diff --git a/test/unit/a_lang/sndordthm_test.tla b/test/unit/a_lang/sndordthm_test.tla new file mode 100644 index 00000000..bb73390c --- /dev/null +++ b/test/unit/a_lang/sndordthm_test.tla @@ -0,0 +1,17 @@ +---- MODULE sndordthm_test ---- + +(* NOTE: Requires higher-order unification *) + +EXTENDS TLAPS + +THEOREM Thm == + ASSUME NEW F(_), + NEW a + PROVE F(a) + +THEOREM ASSUME NEW F(_), + NEW a + PROVE F(a) + BY Thm + +==== diff --git a/test/unit/a_lang/tempop_test.tla b/test/unit/a_lang/tempop_test.tla new file mode 100644 index 00000000..6a4b17d9 --- /dev/null +++ b/test/unit/a_lang/tempop_test.tla @@ -0,0 +1,14 @@ +---- MODULE tempop_test ---- + +EXTENDS TLAPS + +VARIABLE v + +F(x) == x = v + +THEOREM ASSUME NEW x, + F(x)' + PROVE TRUE + OBVIOUS + +==== diff --git a/test/unit/a_lang/unary_test.tla b/test/unit/a_lang/unary_test.tla new file mode 100644 index 00000000..90596cbd --- /dev/null +++ b/test/unit/a_lang/unary_test.tla @@ -0,0 +1,10 @@ +---- MODULE unary_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW F(_), + NEW a + PROVE F(a) = F(a) + OBVIOUS + +==== diff --git a/test/unit/a_lang/usedef_test.tla b/test/unit/a_lang/usedef_test.tla new file mode 100644 index 00000000..ede00599 --- /dev/null +++ b/test/unit/a_lang/usedef_test.tla @@ -0,0 +1,10 @@ +---- MODULE usedef_test ---- + +EXTENDS TLAPS + +C == TRUE + +THEOREM C + BY DEF C + +==== diff --git a/test/unit/a_lang/usefact_test.tla b/test/unit/a_lang/usefact_test.tla new file mode 100644 index 00000000..5215a1c5 --- /dev/null +++ b/test/unit/a_lang/usefact_test.tla @@ -0,0 +1,10 @@ +---- MODULE usedef_test ---- + +EXTENDS TLAPS + +ASSUME F == FALSE + +THEOREM FALSE + BY F + +==== diff --git a/test/fast/smt_tests/lang/user_ops_test.tla b/test/unit/a_lang/userops_test.tla similarity index 89% rename from test/fast/smt_tests/lang/user_ops_test.tla rename to test/unit/a_lang/userops_test.tla index 888fc032..a2be1605 100644 --- a/test/fast/smt_tests/lang/user_ops_test.tla +++ b/test/unit/a_lang/userops_test.tla @@ -1,10 +1,4 @@ ------- MODULE user_ops_test ------ - -(*****************************************************************************) -(* Name: user_ops_test *) -(* Author: Antoine Defourné *) -(* Date: 20/09/19 *) -(*****************************************************************************) +------ MODULE userops_test ------ EXTENDS TLAPS diff --git a/test/unit/a_lang/usethm_test.tla b/test/unit/a_lang/usethm_test.tla new file mode 100644 index 00000000..6e3535ea --- /dev/null +++ b/test/unit/a_lang/usethm_test.tla @@ -0,0 +1,10 @@ +---- MODULE usethm_test ---- + +EXTENDS TLAPS + +THEOREM Thm == FALSE + +THEOREM FALSE + BY Thm + +==== diff --git a/test/unit/a_lang/variable_test.tla b/test/unit/a_lang/variable_test.tla new file mode 100644 index 00000000..c0363a9d --- /dev/null +++ b/test/unit/a_lang/variable_test.tla @@ -0,0 +1,10 @@ +---- MODULE variable_test ---- + +EXTENDS TLAPS + +VARIABLE x + +THEOREM x = x + OBVIOUS + +==== diff --git a/test/unit/a_lang/witness_bounded_test.tla b/test/unit/a_lang/witness_bounded_test.tla new file mode 100644 index 00000000..c0ce64e6 --- /dev/null +++ b/test/unit/a_lang/witness_bounded_test.tla @@ -0,0 +1,13 @@ +---- MODULE witness_bounded_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW s, + NEW a \in s, + P(a) + PROVE \E x \in s : P(x) +<1> WITNESS a \in s +<1> QED (*OBVIOUS*) + +==== diff --git a/test/unit/a_lang/witness_test.tla b/test/unit/a_lang/witness_test.tla new file mode 100644 index 00000000..20a4f08a --- /dev/null +++ b/test/unit/a_lang/witness_test.tla @@ -0,0 +1,12 @@ +---- MODULE witness_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW a, + P(a) + PROVE \E x : P(x) +<1> WITNESS a +<1> QED (*OBVIOUS*) + +==== diff --git a/test/unit/b_logic/critical_bounded_test.tla b/test/unit/b_logic/critical_bounded_test.tla new file mode 100644 index 00000000..671847a7 --- /dev/null +++ b/test/unit/b_logic/critical_bounded_test.tla @@ -0,0 +1,12 @@ +---- MODULE critical_bounded_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW s, + NEW a \in s, + P(a) + PROVE P(CHOOSE x \in s : P(x)) + OBVIOUS + +==== diff --git a/test/unit/b_logic/critical_test.tla b/test/unit/b_logic/critical_test.tla new file mode 100644 index 00000000..ae4cbfe8 --- /dev/null +++ b/test/unit/b_logic/critical_test.tla @@ -0,0 +1,11 @@ +---- MODULE critical_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW a, + P(a) + PROVE P(CHOOSE x : P(x)) + OBVIOUS + +==== diff --git a/test/unit/b_logic/existential_bounded_test.tla b/test/unit/b_logic/existential_bounded_test.tla new file mode 100644 index 00000000..987532ec --- /dev/null +++ b/test/unit/b_logic/existential_bounded_test.tla @@ -0,0 +1,12 @@ +---- MODULE existential_bounded_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW s, + NEW a \in s, + P(a) + PROVE \E x \in s : P(x) + OBVIOUS + +==== diff --git a/test/unit/b_logic/existential_test.tla b/test/unit/b_logic/existential_test.tla new file mode 100644 index 00000000..e162f81a --- /dev/null +++ b/test/unit/b_logic/existential_test.tla @@ -0,0 +1,11 @@ +---- MODULE existential_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW a, + P(a) + PROVE \E x : P(x) + OBVIOUS + +==== diff --git a/test/unit/b_logic/notfalse_test.tla b/test/unit/b_logic/notfalse_test.tla new file mode 100644 index 00000000..9f980a07 --- /dev/null +++ b/test/unit/b_logic/notfalse_test.tla @@ -0,0 +1,8 @@ +---- MODULE notfalse_test ---- + +EXTENDS TLAPS + +THEOREM ~ FALSE + OBVIOUS + +==== diff --git a/test/unit/b_logic/predicate_test.tla b/test/unit/b_logic/predicate_test.tla new file mode 100644 index 00000000..61653add --- /dev/null +++ b/test/unit/b_logic/predicate_test.tla @@ -0,0 +1,10 @@ +---- MODULE predicate_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW a + PROVE P(a) => P(a) + OBVIOUS + +==== diff --git a/test/unit/b_logic/props_test.tla b/test/unit/b_logic/props_test.tla new file mode 100644 index 00000000..a3bb00e8 --- /dev/null +++ b/test/unit/b_logic/props_test.tla @@ -0,0 +1,8 @@ +---- MODULE props_test ---- + +EXTENDS TLAPS + +THEOREM FALSE => (TRUE /\ (TRUE \/ FALSE)) + OBVIOUS + +==== diff --git a/test/unit/b_logic/true_test.tla b/test/unit/b_logic/true_test.tla new file mode 100644 index 00000000..c9f40ff8 --- /dev/null +++ b/test/unit/b_logic/true_test.tla @@ -0,0 +1,8 @@ +---- MODULE true_test ---- + +EXTENDS TLAPS + +THEOREM TRUE + OBVIOUS + +==== diff --git a/test/unit/b_logic/universal_bounded_test.tla b/test/unit/b_logic/universal_bounded_test.tla new file mode 100644 index 00000000..e332bf4f --- /dev/null +++ b/test/unit/b_logic/universal_bounded_test.tla @@ -0,0 +1,10 @@ +---- MODULE universal_bounded_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_), + NEW s + PROVE \A x \in s : P(x) => P(x) + OBVIOUS + +==== diff --git a/test/unit/b_logic/universal_test.tla b/test/unit/b_logic/universal_test.tla new file mode 100644 index 00000000..f97aa18e --- /dev/null +++ b/test/unit/b_logic/universal_test.tla @@ -0,0 +1,9 @@ +---- MODULE universal_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW P(_) + PROVE \A x : P(x) => P(x) + OBVIOUS + +==== diff --git a/test/unit/c_sets/cap_test.tla b/test/unit/c_sets/cap_test.tla new file mode 100644 index 00000000..6561383f --- /dev/null +++ b/test/unit/c_sets/cap_test.tla @@ -0,0 +1,10 @@ +---- MODULE cap_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW b + PROVE \A x : x \in a \cap b <=> x \in a /\ x \in b + OBVIOUS + +==== diff --git a/test/unit/c_sets/cup_test.tla b/test/unit/c_sets/cup_test.tla new file mode 100644 index 00000000..43469dbf --- /dev/null +++ b/test/unit/c_sets/cup_test.tla @@ -0,0 +1,10 @@ +---- MODULE cup_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW b + PROVE \A x : x \in a \cup b <=> x \in a \/ x \in b + OBVIOUS + +==== diff --git a/test/unit/c_sets/empty_test.tla b/test/unit/c_sets/empty_test.tla new file mode 100644 index 00000000..979b201d --- /dev/null +++ b/test/unit/c_sets/empty_test.tla @@ -0,0 +1,8 @@ +---- MODULE empty_test ---- + +EXTENDS TLAPS + +THEOREM \A x : x \notin {} + OBVIOUS + +==== diff --git a/test/unit/c_sets/pair_test.tla b/test/unit/c_sets/pair_test.tla new file mode 100644 index 00000000..c35a0942 --- /dev/null +++ b/test/unit/c_sets/pair_test.tla @@ -0,0 +1,10 @@ +---- MODULE pair_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW b + PROVE \A x : x \in { a, b } <=> x = a \/ x = b + OBVIOUS + +==== diff --git a/test/unit/c_sets/power_test.tla b/test/unit/c_sets/power_test.tla new file mode 100644 index 00000000..60bf165f --- /dev/null +++ b/test/unit/c_sets/power_test.tla @@ -0,0 +1,9 @@ +---- MODULE power_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a + PROVE \A x : x \in SUBSET a <=> \A y : y \in x => y \in a + OBVIOUS + +==== diff --git a/test/unit/c_sets/setext_test.tla b/test/unit/c_sets/setext_test.tla new file mode 100644 index 00000000..e7620251 --- /dev/null +++ b/test/unit/c_sets/setext_test.tla @@ -0,0 +1,10 @@ +---- MODULE setext_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + \A x : x \notin a + PROVE a = {} + OBVIOUS + +==== diff --git a/test/unit/c_sets/setminus_test.tla b/test/unit/c_sets/setminus_test.tla new file mode 100644 index 00000000..9b54409f --- /dev/null +++ b/test/unit/c_sets/setminus_test.tla @@ -0,0 +1,10 @@ +---- MODULE setminus_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW b + PROVE \A x : x \in a \ b <=> x \in a /\ x \notin b + OBVIOUS + +==== diff --git a/test/unit/c_sets/setof_test.tla b/test/unit/c_sets/setof_test.tla new file mode 100644 index 00000000..e74373ad --- /dev/null +++ b/test/unit/c_sets/setof_test.tla @@ -0,0 +1,10 @@ +---- MODULE setof_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW F(_) + PROVE \A x : x \in { F(y) : y \in a } <=> \E y : y \in a /\ x = F(y) + OBVIOUS + +==== diff --git a/test/unit/c_sets/setst_test.tla b/test/unit/c_sets/setst_test.tla new file mode 100644 index 00000000..5273a5a0 --- /dev/null +++ b/test/unit/c_sets/setst_test.tla @@ -0,0 +1,10 @@ +---- MODULE setst_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW P(_) + PROVE \A x : x \in { y \in a : P(y) } <=> x \in a /\ P(x) + OBVIOUS + +==== diff --git a/test/unit/c_sets/singleton_test.tla b/test/unit/c_sets/singleton_test.tla new file mode 100644 index 00000000..ac6301e0 --- /dev/null +++ b/test/unit/c_sets/singleton_test.tla @@ -0,0 +1,9 @@ +---- MODULE singleton_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a + PROVE \A x : x \in { a } <=> x = a + OBVIOUS + +==== diff --git a/test/unit/c_sets/subset_test.tla b/test/unit/c_sets/subset_test.tla new file mode 100644 index 00000000..ec1cc5ad --- /dev/null +++ b/test/unit/c_sets/subset_test.tla @@ -0,0 +1,10 @@ +---- MODULE subset_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a, + NEW b + PROVE a \subseteq b <=> \A x : x \in a => x \in b + OBVIOUS + +==== diff --git a/test/unit/c_sets/union_test.tla b/test/unit/c_sets/union_test.tla new file mode 100644 index 00000000..a269db24 --- /dev/null +++ b/test/unit/c_sets/union_test.tla @@ -0,0 +1,9 @@ +---- MODULE union_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW a + PROVE \A x : x \in UNION a <=> \E y : y \in a /\ x \in y + OBVIOUS + +==== diff --git a/test/unit/d_funcs/arrow_test.tla b/test/unit/d_funcs/arrow_test.tla new file mode 100644 index 00000000..199f4225 --- /dev/null +++ b/test/unit/d_funcs/arrow_test.tla @@ -0,0 +1,14 @@ +---- MODULE arrow_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW C, + NEW F(_) + PROVE [ x \in C |-> F(x) ] \in [ A -> B ] <=> + /\ A = C + /\ \A x \in A : F(x) \in B + OBVIOUS + +==== diff --git a/test/unit/d_funcs/domain_test.tla b/test/unit/d_funcs/domain_test.tla new file mode 100644 index 00000000..347d02b2 --- /dev/null +++ b/test/unit/d_funcs/domain_test.tla @@ -0,0 +1,10 @@ +---- MODULE domain_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW F(_) + PROVE DOMAIN [ x \in A |-> F(x) ] = A + OBVIOUS + +==== diff --git a/test/unit/d_funcs/excapp1_test.tla b/test/unit/d_funcs/excapp1_test.tla new file mode 100644 index 00000000..60298853 --- /dev/null +++ b/test/unit/d_funcs/excapp1_test.tla @@ -0,0 +1,14 @@ +---- MODULE excapp1_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW f \in [ A -> B ], + NEW x \in A, + NEW a + PROVE LET g == [ f EXCEPT ![x] = a ] IN + g[x] = a + OBVIOUS + +==== diff --git a/test/unit/d_funcs/excapp2_test.tla b/test/unit/d_funcs/excapp2_test.tla new file mode 100644 index 00000000..b60303be --- /dev/null +++ b/test/unit/d_funcs/excapp2_test.tla @@ -0,0 +1,16 @@ +---- MODULE excapp_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW f \in [ A -> B ], + NEW x \in A, + NEW a, + NEW y \in A, + y # x + PROVE LET g == [ f EXCEPT ![x] = a ] IN + g[y] = f[y] + OBVIOUS + +==== diff --git a/test/unit/d_funcs/excapp3_test.tla b/test/unit/d_funcs/excapp3_test.tla new file mode 100644 index 00000000..e9f40b56 --- /dev/null +++ b/test/unit/d_funcs/excapp3_test.tla @@ -0,0 +1,17 @@ +---- MODULE excapp3_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW f \in [ A -> B ], + NEW x \in A, + NEW y \in A, + x # y, + NEW a, + NEW b + PROVE LET g == [ f EXCEPT ![x] = a, ![y] = b ] IN + g[x] = a + OBVIOUS + +==== diff --git a/test/unit/d_funcs/excapp4_test.tla b/test/unit/d_funcs/excapp4_test.tla new file mode 100644 index 00000000..7aed12c6 --- /dev/null +++ b/test/unit/d_funcs/excapp4_test.tla @@ -0,0 +1,16 @@ +---- MODULE excapp4_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW C, + NEW f \in [ A -> [ B -> C ] ], + NEW x \in A, + NEW y \in B, + NEW a + PROVE LET g == [ f EXCEPT ![x][y] = a ] IN + g[x][y] = a + OBVIOUS + +==== diff --git a/test/unit/d_funcs/excdom_test.tla b/test/unit/d_funcs/excdom_test.tla new file mode 100644 index 00000000..1239c04d --- /dev/null +++ b/test/unit/d_funcs/excdom_test.tla @@ -0,0 +1,14 @@ +---- MODULE excdom_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW f \in [ A -> B ], + NEW x, + NEW a + PROVE LET g == [ f EXCEPT ![x] = a ] IN + DOMAIN g = DOMAIN f + OBVIOUS + +==== diff --git a/test/unit/d_funcs/fcnapp_test.tla b/test/unit/d_funcs/fcnapp_test.tla new file mode 100644 index 00000000..8364ec4a --- /dev/null +++ b/test/unit/d_funcs/fcnapp_test.tla @@ -0,0 +1,11 @@ +---- MODULE fcnapp_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW F(_), + NEW z + PROVE z \in A => [ x \in A |-> F(x) ][z] = F(z) + OBVIOUS + +==== diff --git a/test/unit/d_funcs/funext_test.tla b/test/unit/d_funcs/funext_test.tla new file mode 100644 index 00000000..0e7fcf2b --- /dev/null +++ b/test/unit/d_funcs/funext_test.tla @@ -0,0 +1,14 @@ +---- MODULE funext_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW C, + NEW f \in [ A -> B ], + NEW g \in [ A -> C ], + \A x \in A : f[x] = g[x] + PROVE f = g + OBVIOUS + +==== diff --git a/test/unit/e_arith/intlit0_test.tla b/test/unit/e_arith/intlit0_test.tla new file mode 100644 index 00000000..19841d02 --- /dev/null +++ b/test/unit/e_arith/intlit0_test.tla @@ -0,0 +1,8 @@ +---- MODULE intlit_test ---- + +EXTENDS TLAPS, Integers + +THEOREM 0 \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/intlit1_test.tla b/test/unit/e_arith/intlit1_test.tla new file mode 100644 index 00000000..fdd6eae4 --- /dev/null +++ b/test/unit/e_arith/intlit1_test.tla @@ -0,0 +1,8 @@ +---- MODULE intlit_test ---- + +EXTENDS TLAPS, Integers + +THEOREM 1 \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/intlitminus1_test.tla b/test/unit/e_arith/intlitminus1_test.tla new file mode 100644 index 00000000..1413e371 --- /dev/null +++ b/test/unit/e_arith/intlitminus1_test.tla @@ -0,0 +1,8 @@ +---- MODULE intlit_test ---- + +EXTENDS TLAPS, Integers + +THEOREM -1 \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/nat_test.tla b/test/unit/e_arith/nat_test.tla new file mode 100644 index 00000000..47c303b4 --- /dev/null +++ b/test/unit/e_arith/nat_test.tla @@ -0,0 +1,9 @@ +---- MODULE nat_test ---- + +EXTENDS TLAPS, Integers, Naturals + +THEOREM ASSUME NEW n + PROVE n \in Nat <=> n \in Int /\ n >= 0 + OBVIOUS + +==== diff --git a/test/unit/e_arith/range_test.tla b/test/unit/e_arith/range_test.tla new file mode 100644 index 00000000..c103611d --- /dev/null +++ b/test/unit/e_arith/range_test.tla @@ -0,0 +1,11 @@ +---- MODULE range_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW m \in Int, + NEW n \in Int, + NEW p + PROVE p \in m..n <=> p \in Int /\ m <= p /\ p <= n + OBVIOUS + +==== diff --git a/test/unit/e_arith/typingexp_test.tla b/test/unit/e_arith/typingexp_test.tla new file mode 100644 index 00000000..7360618e --- /dev/null +++ b/test/unit/e_arith/typingexp_test.tla @@ -0,0 +1,11 @@ +---- MODULE typingexp_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW m \in Int, + NEW n \in Int, + m # 0 \/ n > 0 + PROVE (m ^ n) \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/typingminus_test.tla b/test/unit/e_arith/typingminus_test.tla new file mode 100644 index 00000000..02750724 --- /dev/null +++ b/test/unit/e_arith/typingminus_test.tla @@ -0,0 +1,10 @@ +---- MODULE typingminus_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW m \in Int, + NEW n \in Int + PROVE (m - n) \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/typingplus_test.tla b/test/unit/e_arith/typingplus_test.tla new file mode 100644 index 00000000..22a4cb43 --- /dev/null +++ b/test/unit/e_arith/typingplus_test.tla @@ -0,0 +1,10 @@ +---- MODULE typingplus_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW m \in Int, + NEW n \in Int + PROVE (m + n) \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/typingquotient_test.tla b/test/unit/e_arith/typingquotient_test.tla new file mode 100644 index 00000000..1cd65dbb --- /dev/null +++ b/test/unit/e_arith/typingquotient_test.tla @@ -0,0 +1,11 @@ +---- MODULE typingquotient_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW m \in Int, + NEW n \in Int, + n > 0 + PROVE (m \div n) \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/typingremainder_test.tla b/test/unit/e_arith/typingremainder_test.tla new file mode 100644 index 00000000..7604373e --- /dev/null +++ b/test/unit/e_arith/typingremainder_test.tla @@ -0,0 +1,11 @@ +---- MODULE typingremainder_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW m \in Int, + NEW n \in Int, + n > 0 + PROVE (m % n) \in 0..(n-1) + OBVIOUS + +==== diff --git a/test/unit/e_arith/typingtimes_test.tla b/test/unit/e_arith/typingtimes_test.tla new file mode 100644 index 00000000..2d4f183e --- /dev/null +++ b/test/unit/e_arith/typingtimes_test.tla @@ -0,0 +1,10 @@ +---- MODULE typingtimes_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW m \in Int, + NEW n \in Int + PROVE (m * n) \in Int + OBVIOUS + +==== diff --git a/test/unit/e_arith/typinguminus_test.tla b/test/unit/e_arith/typinguminus_test.tla new file mode 100644 index 00000000..87b2eb85 --- /dev/null +++ b/test/unit/e_arith/typinguminus_test.tla @@ -0,0 +1,9 @@ +---- MODULE typinguminus_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW n \in Int + PROVE (-n) \in Int + OBVIOUS + +==== diff --git a/test/unit/f_data/boolcar_test.tla b/test/unit/f_data/boolcar_test.tla new file mode 100644 index 00000000..2f7e9791 --- /dev/null +++ b/test/unit/f_data/boolcar_test.tla @@ -0,0 +1,8 @@ +---- MODULE boolcar_test ---- + +EXTENDS TLAPS + +THEOREM \A x : x \in BOOLEAN <=> x = TRUE \/ x = FALSE + OBVIOUS + +==== diff --git a/test/unit/f_data/booldistinct_test.tla b/test/unit/f_data/booldistinct_test.tla new file mode 100644 index 00000000..1af5de31 --- /dev/null +++ b/test/unit/f_data/booldistinct_test.tla @@ -0,0 +1,8 @@ +---- MODULE booldistinct_test ---- + +EXTENDS TLAPS + +THEOREM TRUE /= FALSE + OBVIOUS + +==== diff --git a/test/unit/f_data/boolean_test.tla b/test/unit/f_data/boolean_test.tla new file mode 100644 index 00000000..294fbe47 --- /dev/null +++ b/test/unit/f_data/boolean_test.tla @@ -0,0 +1,8 @@ +---- MODULE boolean_test ---- + +EXTENDS TLAPS + +THEOREM TRUE \in BOOLEAN /\ FALSE \in BOOLEAN + OBVIOUS + +==== diff --git a/test/unit/f_data/string_test.tla b/test/unit/f_data/string_test.tla new file mode 100644 index 00000000..80ef3914 --- /dev/null +++ b/test/unit/f_data/string_test.tla @@ -0,0 +1,8 @@ +---- MODULE string_test ---- + +EXTENDS TLAPS + +THEOREM "foo" \in STRING /\ "bar" \in STRING /\ "baz" \in STRING + OBVIOUS + +==== diff --git a/test/unit/f_data/stringdistinct_test.tla b/test/unit/f_data/stringdistinct_test.tla new file mode 100644 index 00000000..f5895d6e --- /dev/null +++ b/test/unit/f_data/stringdistinct_test.tla @@ -0,0 +1,8 @@ +---- MODULE stringdistinct_test ---- + +EXTENDS TLAPS + +THEOREM "foo" /= "bar" + OBVIOUS + +==== diff --git a/test/unit/g_tuples/productset_test.tla b/test/unit/g_tuples/productset_test.tla new file mode 100644 index 00000000..a238d656 --- /dev/null +++ b/test/unit/g_tuples/productset_test.tla @@ -0,0 +1,14 @@ +---- MODULE productset_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW t + PROVE t \in A \X B <=> + \E x, y : /\ x \in A + /\ y \in B + /\ t = << x, y >> + OBVIOUS + +==== diff --git a/test/unit/g_tuples/tupleapp_test.tla b/test/unit/g_tuples/tupleapp_test.tla new file mode 100644 index 00000000..7b6f7f6b --- /dev/null +++ b/test/unit/g_tuples/tupleapp_test.tla @@ -0,0 +1,11 @@ +---- MODULE tupleapp_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW x, + NEW y + PROVE /\ << x, y >>[1] = x + /\ << x, y >>[2] = y + OBVIOUS + +==== diff --git a/test/unit/g_tuples/tupledom_test.tla b/test/unit/g_tuples/tupledom_test.tla new file mode 100644 index 00000000..37a12326 --- /dev/null +++ b/test/unit/g_tuples/tupledom_test.tla @@ -0,0 +1,10 @@ +---- MODULE tupledom_test ---- + +EXTENDS TLAPS, Integers + +THEOREM ASSUME NEW x, + NEW y + PROVE DOMAIN << x, y >> = 1..2 + OBVIOUS + +==== diff --git a/test/unit/g_tuples/tupleext_test.tla b/test/unit/g_tuples/tupleext_test.tla new file mode 100644 index 00000000..140951a3 --- /dev/null +++ b/test/unit/g_tuples/tupleext_test.tla @@ -0,0 +1,14 @@ +---- MODULE tupleext_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW x, + NEW y, + NEW u, + NEW v + PROVE << x, y >> = << u, v >> + <=> /\ x = u + /\ y = v + OBVIOUS + +==== diff --git a/test/unit/h_records/recorddom_test.tla b/test/unit/h_records/recorddom_test.tla new file mode 100644 index 00000000..637c9e46 --- /dev/null +++ b/test/unit/h_records/recorddom_test.tla @@ -0,0 +1,10 @@ +---- MODULE recorddom_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW x, + NEW y + PROVE DOMAIN [ foo |-> x, bar |-> y ] = { "foo", "bar" } + OBVIOUS + +==== diff --git a/test/unit/h_records/recorddot_test.tla b/test/unit/h_records/recorddot_test.tla new file mode 100644 index 00000000..3c1b6a8b --- /dev/null +++ b/test/unit/h_records/recorddot_test.tla @@ -0,0 +1,11 @@ +---- MODULE recorddot_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW x, + NEW y + PROVE /\ [ foo |-> x, bar |-> y ].foo = x + /\ [ foo |-> x, bar |-> y ].bar = y + OBVIOUS + +==== diff --git a/test/unit/h_records/recordext_test.tla b/test/unit/h_records/recordext_test.tla new file mode 100644 index 00000000..7445d5d2 --- /dev/null +++ b/test/unit/h_records/recordext_test.tla @@ -0,0 +1,14 @@ +---- MODULE recorddom_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW x, + NEW y, + NEW u, + NEW v + PROVE [ foo |-> x, bar |-> y ] = [ foo |-> u, bar |-> v ] + <=> /\ x = u + /\ y = v + OBVIOUS + +==== diff --git a/test/unit/h_records/rectset_test.tla b/test/unit/h_records/rectset_test.tla new file mode 100644 index 00000000..5e0c47bc --- /dev/null +++ b/test/unit/h_records/rectset_test.tla @@ -0,0 +1,14 @@ +---- MODULE rectset_test ---- + +EXTENDS TLAPS + +THEOREM ASSUME NEW A, + NEW B, + NEW r + PROVE r \in [ foo : A, bar : B ] <=> + \E x, y : /\ x \in A + /\ y \in B + /\ r = [ foo |-> x, bar |-> y ] + OBVIOUS + +==== diff --git a/test/unit/i_sequences/sequences_test.tla b/test/unit/i_sequences/sequences_test.tla new file mode 100644 index 00000000..1a74e032 --- /dev/null +++ b/test/unit/i_sequences/sequences_test.tla @@ -0,0 +1,30 @@ +---- MODULE sequences_test ---- + +EXTENDS TLAPS, Sequences + +(* NOTE Sequences are supported to the extent that the operators + are declared in the result problem. No axioms for sequences + are provided. +*) + +Triv(x) == x = x + +THEOREM ASSUME NEW S, + NEW s, + NEW t, + NEW e, + NEW m, + NEW n, + NEW Test(_), + Triv(Seq(S)), + Triv(Len(s)), + Triv(s \o t), + Triv(Append(s, e)), + Triv(Head(s)), + Triv(Tail(s)), + Triv(SubSeq(s, m, n)), + Triv(SelectSeq(s, Test)) + PROVE TRUE + BY DEF Triv + +==== diff --git a/tools/newversion.ml b/tools/newversion.ml index 8973d03b..47b21d9c 100644 --- a/tools/newversion.ml +++ b/tools/newversion.ml @@ -105,6 +105,6 @@ let () = let ret = Sys.command ("autoconf -I tools -o configure " ^ acf) in if ret <> 0 then failwith "calling autoconf" ; if !loud then printf "Created configure\n%!" ; - flush Pervasives.stdout ; + flush Stdlib.stdout ; if !loud then printf "Now run ./configure to rebuild the Makefile\n%!" ;;