(*  Title:      HOL/HOL.thy
    Author:     Tobias Nipkow, Markus Wenzel, and Larry Paulson
*)

section {* The basis of Higher-Order Logic *}

theory HOL
imports Pure "~~/src/Tools/Code_Generator"
keywords
  "try" "solve_direct" "quickcheck" "print_coercions" "print_claset"
    "print_induct_rules" :: diag and
  "quickcheck_params" :: thy_decl
begin

ML_file "~~/src/Tools/misc_legacy.ML"
ML_file "~~/src/Tools/try.ML"
ML_file "~~/src/Tools/quickcheck.ML"
ML_file "~~/src/Tools/solve_direct.ML"
ML_file "~~/src/Tools/IsaPlanner/zipper.ML"
ML_file "~~/src/Tools/IsaPlanner/isand.ML"
ML_file "~~/src/Tools/IsaPlanner/rw_inst.ML"
ML_file "~~/src/Provers/hypsubst.ML"
ML_file "~~/src/Provers/splitter.ML"
ML_file "~~/src/Provers/classical.ML"
ML_file "~~/src/Provers/blast.ML"
ML_file "~~/src/Provers/clasimp.ML"
ML_file "~~/src/Tools/eqsubst.ML"
ML_file "~~/src/Provers/quantifier1.ML"
ML_file "~~/src/Tools/atomize_elim.ML"
ML_file "~~/src/Tools/cong_tac.ML"
ML_file "~~/src/Tools/intuitionistic.ML" setup \<open>Intuitionistic.method_setup @{binding iprover}\<close>
ML_file "~~/src/Tools/project_rule.ML"
ML_file "~~/src/Tools/subtyping.ML"
ML_file "~~/src/Tools/case_product.ML"

ML \<open>Plugin_Name.declare_setup @{binding extraction}\<close>

ML \<open>
  Plugin_Name.declare_setup @{binding quickcheck_random};
  Plugin_Name.declare_setup @{binding quickcheck_exhaustive};
  Plugin_Name.declare_setup @{binding quickcheck_bounded_forall};
  Plugin_Name.declare_setup @{binding quickcheck_full_exhaustive};
  Plugin_Name.declare_setup @{binding quickcheck_narrowing};
\<close>
ML \<open>
  Plugin_Name.define_setup @{binding quickcheck}
   [@{plugin quickcheck_exhaustive},
    @{plugin quickcheck_random},
    @{plugin quickcheck_bounded_forall},
    @{plugin quickcheck_full_exhaustive},
    @{plugin quickcheck_narrowing}]
\<close>

subsection {* Primitive logic *}

subsubsection {* Core syntax *}

setup {* Axclass.class_axiomatization (@{binding type}, []) *}
default_sort type
setup {* Object_Logic.add_base_sort @{sort type} *}

axiomatization where fun_arity: "OFCLASS('a \<Rightarrow> 'b, type_class)"
instance "fun" :: (type, type) type by (rule fun_arity)

axiomatization where itself_arity: "OFCLASS('a itself, type_class)"
instance itself :: (type) type by (rule itself_arity)

typedecl bool

judgment
  Trueprop      :: "bool => prop"                   ("(_)" 5)

axiomatization
  implies       :: "[bool, bool] => bool"           (infixr "-->" 25)  and
  eq            :: "['a, 'a] => bool"               (infixl "=" 50)  and
  The           :: "('a => bool) => 'a"

consts
  True          :: bool
  False         :: bool
  Not           :: "bool => bool"                   ("~ _" [40] 40)

  conj          :: "[bool, bool] => bool"           (infixr "&" 35)
  disj          :: "[bool, bool] => bool"           (infixr "|" 30)

  All           :: "('a => bool) => bool"           (binder "ALL " 10)
  Ex            :: "('a => bool) => bool"           (binder "EX " 10)
  Ex1           :: "('a => bool) => bool"           (binder "EX! " 10)

subsubsection {* Additional concrete syntax *}

notation (output)
  eq  (infix "=" 50)

abbreviation
  not_equal :: "['a, 'a] => bool"  (infixl "~=" 50) where
  "x ~= y == ~ (x = y)"

notation (output)
  not_equal  (infix "~=" 50)

notation (xsymbols)
  Not  ("\<not> _" [40] 40) and
  conj  (infixr "\<and>" 35) and
  disj  (infixr "\<or>" 30) and
  implies  (infixr "\<longrightarrow>" 25) and
  not_equal  (infixl "\<noteq>" 50)

notation (xsymbols output)
  not_equal  (infix "\<noteq>" 50)

notation (HTML output)
  Not  ("\<not> _" [40] 40) and
  conj  (infixr "\<and>" 35) and
  disj  (infixr "\<or>" 30) and
  not_equal  (infix "\<noteq>" 50)

abbreviation (iff)
  iff :: "[bool, bool] => bool"  (infixr "<->" 25) where
  "A <-> B == A = B"

notation (xsymbols)
  iff  (infixr "\<longleftrightarrow>" 25)

syntax "_The" :: "[pttrn, bool] => 'a"  ("(3THE _./ _)" [0, 10] 10)
translations "THE x. P" == "CONST The (%x. P)"
print_translation {*
  [(@{const_syntax The}, fn _ => fn [Abs abs] =>
      let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
      in Syntax.const @{syntax_const "_The"} $ x $ t end)]
*}  -- {* To avoid eta-contraction of body *}

nonterminal letbinds and letbind
syntax
  "_bind"       :: "[pttrn, 'a] => letbind"              ("(2_ =/ _)" 10)
  ""            :: "letbind => letbinds"                 ("_")
  "_binds"      :: "[letbind, letbinds] => letbinds"     ("_;/ _")
  "_Let"        :: "[letbinds, 'a] => 'a"                ("(let (_)/ in (_))" [0, 10] 10)

nonterminal case_syn and cases_syn
syntax
  "_case_syntax" :: "['a, cases_syn] => 'b"  ("(case _ of/ _)" 10)
  "_case1" :: "['a, 'b] => case_syn"  ("(2_ =>/ _)" 10)
  "" :: "case_syn => cases_syn"  ("_")
  "_case2" :: "[case_syn, cases_syn] => cases_syn"  ("_/ | _")
syntax (xsymbols)
  "_case1" :: "['a, 'b] => case_syn"  ("(2_ \<Rightarrow>/ _)" 10)

notation (xsymbols)
  All  (binder "\<forall>" 10) and
  Ex  (binder "\<exists>" 10) and
  Ex1  (binder "\<exists>!" 10)

notation (HTML output)
  All  (binder "\<forall>" 10) and
  Ex  (binder "\<exists>" 10) and
  Ex1  (binder "\<exists>!" 10)

notation (HOL)
  All  (binder "! " 10) and
  Ex  (binder "? " 10) and
  Ex1  (binder "?! " 10)

subsubsection {* Axioms and basic definitions *}

axiomatization where
  refl: "t = (t::'a)" and
  subst: "s = t \<Longrightarrow> P s \<Longrightarrow> P t" and
  ext: "(!!x::'a. (f x ::'b) = g x) ==> (%x. f x) = (%x. g x)"
    -- {*Extensionality is built into the meta-logic, and this rule expresses
         a related property.  It is an eta-expanded version of the traditional
         rule, and similar to the ABS rule of HOL*} and

  the_eq_trivial: "(THE x. x = a) = (a::'a)"

axiomatization where
  impI: "(P ==> Q) ==> P-->Q" and
  mp: "[| P-->Q;  P |] ==> Q" and

  iff: "(P-->Q) --> (Q-->P) --> (P=Q)" and
  True_or_False: "(P=True) | (P=False)"

defs
  True_def:     "True      == ((%x::bool. x) = (%x. x))"
  All_def:      "All(P)    == (P = (%x. True))"
  Ex_def:       "Ex(P)     == !Q. (!x. P x --> Q) --> Q"
  False_def:    "False     == (!P. P)"
  not_def:      "~ P       == P-->False"
  and_def:      "P & Q     == !R. (P-->Q-->R) --> R"
  or_def:       "P | Q     == !R. (P-->R) --> (Q-->R) --> R"
  Ex1_def:      "Ex1(P)    == ? x. P(x) & (! y. P(y) --> y=x)"

definition If :: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(if (_)/ then (_)/ else (_))" [0, 0, 10] 10)
  where "If P x y \<equiv> (THE z::'a. (P=True --> z=x) & (P=False --> z=y))"

definition Let :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b"
  where "Let s f \<equiv> f s"

translations
  "_Let (_binds b bs) e"  == "_Let b (_Let bs e)"
  "let x = a in e"        == "CONST Let a (%x. e)"

axiomatization undefined :: 'a

class default = fixes default :: 'a

subsection {* Fundamental rules *}

subsubsection {* Equality *}

lemma sym: "s = t ==> t = s"
  by (erule subst) (rule refl)

lemma ssubst: "t = s ==> P s ==> P t"
  by (drule sym) (erule subst)

lemma trans: "[| r=s; s=t |] ==> r=t"
  by (erule subst)

lemma trans_sym [Pure.elim?]: "r = s ==> t = s ==> r = t"
  by (rule trans [OF _ sym])

lemma meta_eq_to_obj_eq:
  assumes meq: "A == B"
  shows "A = B"
  by (unfold meq) (rule refl)

text {* Useful with @{text erule} for proving equalities from known equalities. *}
     (* a = b
        |   |
        c = d   *)
lemma box_equals: "[| a=b;  a=c;  b=d |] ==> c=d"
apply (rule trans)
apply (rule trans)
apply (rule sym)
apply assumption+
done

text {* For calculational reasoning: *}

lemma forw_subst: "a = b ==> P b ==> P a"
  by (rule ssubst)

lemma back_subst: "P a ==> a = b ==> P b"
  by (rule subst)

subsubsection {* Congruence rules for application *}

text {* Similar to @{text AP_THM} in Gordon's HOL. *}
lemma fun_cong: "(f::'a=>'b) = g ==> f(x)=g(x)"
apply (erule subst)
apply (rule refl)
done

text {* Similar to @{text AP_TERM} in Gordon's HOL and FOL's @{text subst_context}. *}
lemma arg_cong: "x=y ==> f(x)=f(y)"
apply (erule subst)
apply (rule refl)
done

lemma arg_cong2: "\<lbrakk> a = b; c = d \<rbrakk> \<Longrightarrow> f a c = f b d"
apply (erule ssubst)+
apply (rule refl)
done

lemma cong: "[| f = g; (x::'a) = y |] ==> f x = g y"
apply (erule subst)+
apply (rule refl)
done

ML {* fun cong_tac ctxt = Cong_Tac.cong_tac ctxt @{thm cong} *}

subsubsection {* Equality of booleans -- iff *}

lemma iffI: assumes "P ==> Q" and "Q ==> P" shows "P=Q"
  by (iprover intro: iff [THEN mp, THEN mp] impI assms)

lemma iffD2: "[| P=Q; Q |] ==> P"
  by (erule ssubst)

lemma rev_iffD2: "[| Q; P=Q |] ==> P"
  by (erule iffD2)

lemma iffD1: "Q = P \<Longrightarrow> Q \<Longrightarrow> P"
  by (drule sym) (rule iffD2)

lemma rev_iffD1: "Q \<Longrightarrow> Q = P \<Longrightarrow> P"
  by (drule sym) (rule rev_iffD2)

lemma iffE:
  assumes major: "P=Q"
    and minor: "[| P --> Q; Q --> P |] ==> R"
  shows R
  by (iprover intro: minor impI major [THEN iffD2] major [THEN iffD1])

subsubsection {*True*}

lemma TrueI: "True"
  unfolding True_def by (rule refl)

lemma eqTrueI: "P ==> P = True"
  by (iprover intro: iffI TrueI)

lemma eqTrueE: "P = True ==> P"
  by (erule iffD2) (rule TrueI)

subsubsection {*Universal quantifier*}

lemma allI: assumes "!!x::'a. P(x)" shows "ALL x. P(x)"
  unfolding All_def by (iprover intro: ext eqTrueI assms)

lemma spec: "ALL x::'a. P(x) ==> P(x)"
apply (unfold All_def)
apply (rule eqTrueE)
apply (erule fun_cong)
done

lemma allE:
  assumes major: "ALL x. P(x)"
    and minor: "P(x) ==> R"
  shows R
  by (iprover intro: minor major [THEN spec])

lemma all_dupE:
  assumes major: "ALL x. P(x)"
    and minor: "[| P(x); ALL x. P(x) |] ==> R"
  shows R
  by (iprover intro: minor major major [THEN spec])

subsubsection {* False *}

text {*
  Depends upon @{text spec}; it is impossible to do propositional
  logic before quantifiers!
*}

lemma FalseE: "False ==> P"
  apply (unfold False_def)
  apply (erule spec)
  done

lemma False_neq_True: "False = True ==> P"
  by (erule eqTrueE [THEN FalseE])

subsubsection {* Negation *}

lemma notI:
  assumes "P ==> False"
  shows "~P"
  apply (unfold not_def)
  apply (iprover intro: impI assms)
  done

lemma False_not_True: "False ~= True"
  apply (rule notI)
  apply (erule False_neq_True)
  done

lemma True_not_False: "True ~= False"
  apply (rule notI)
  apply (drule sym)
  apply (erule False_neq_True)
  done

lemma notE: "[| ~P;  P |] ==> R"
  apply (unfold not_def)
  apply (erule mp [THEN FalseE])
  apply assumption
  done

lemma notI2: "(P \<Longrightarrow> \<not> Pa) \<Longrightarrow> (P \<Longrightarrow> Pa) \<Longrightarrow> \<not> P"
  by (erule notE [THEN notI]) (erule meta_mp)

subsubsection {*Implication*}

lemma impE:
  assumes "P-->Q" "P" "Q ==> R"
  shows "R"
by (iprover intro: assms mp)

(* Reduces Q to P-->Q, allowing substitution in P. *)
lemma rev_mp: "[| P;  P --> Q |] ==> Q"
by (iprover intro: mp)

lemma contrapos_nn:
  assumes major: "~Q"
      and minor: "P==>Q"
  shows "~P"
by (iprover intro: notI minor major [THEN notE])

(*not used at all, but we already have the other 3 combinations *)
lemma contrapos_pn:
  assumes major: "Q"
      and minor: "P ==> ~Q"
  shows "~P"
by (iprover intro: notI minor major notE)

lemma not_sym: "t ~= s ==> s ~= t"
  by (erule contrapos_nn) (erule sym)

lemma eq_neq_eq_imp_neq: "[| x = a ; a ~= b; b = y |] ==> x ~= y"
  by (erule subst, erule ssubst, assumption)

subsubsection {*Existential quantifier*}

lemma exI: "P x ==> EX x::'a. P x"
apply (unfold Ex_def)
apply (iprover intro: allI allE impI mp)
done

lemma exE:
  assumes major: "EX x::'a. P(x)"
      and minor: "!!x. P(x) ==> Q"
  shows "Q"
apply (rule major [unfolded Ex_def, THEN spec, THEN mp])
apply (iprover intro: impI [THEN allI] minor)
done

subsubsection {*Conjunction*}

lemma conjI: "[| P; Q |] ==> P&Q"
apply (unfold and_def)
apply (iprover intro: impI [THEN allI] mp)
done

lemma conjunct1: "[| P & Q |] ==> P"
apply (unfold and_def)
apply (iprover intro: impI dest: spec mp)
done

lemma conjunct2: "[| P & Q |] ==> Q"
apply (unfold and_def)
apply (iprover intro: impI dest: spec mp)
done

lemma conjE:
  assumes major: "P&Q"
      and minor: "[| P; Q |] ==> R"
  shows "R"
apply (rule minor)
apply (rule major [THEN conjunct1])
apply (rule major [THEN conjunct2])
done

lemma context_conjI:
  assumes "P" "P ==> Q" shows "P & Q"
by (iprover intro: conjI assms)

subsubsection {*Disjunction*}

lemma disjI1: "P ==> P|Q"
apply (unfold or_def)
apply (iprover intro: allI impI mp)
done

lemma disjI2: "Q ==> P|Q"
apply (unfold or_def)
apply (iprover intro: allI impI mp)
done

lemma disjE:
  assumes major: "P|Q"
      and minorP: "P ==> R"
      and minorQ: "Q ==> R"
  shows "R"
by (iprover intro: minorP minorQ impI
                 major [unfolded or_def, THEN spec, THEN mp, THEN mp])

subsubsection {*Classical logic*}

lemma classical:
  assumes prem: "~P ==> P"
  shows "P"
apply (rule True_or_False [THEN disjE, THEN eqTrueE])
apply assumption
apply (rule notI [THEN prem, THEN eqTrueI])
apply (erule subst)
apply assumption
done

lemmas ccontr = FalseE [THEN classical]

(*notE with premises exchanged; it discharges ~R so that it can be used to
  make elimination rules*)
lemma rev_notE:
  assumes premp: "P"
      and premnot: "~R ==> ~P"
  shows "R"
apply (rule ccontr)
apply (erule notE [OF premnot premp])
done

(*Double negation law*)
lemma notnotD: "~~P ==> P"
apply (rule classical)
apply (erule notE)
apply assumption
done

lemma contrapos_pp:
  assumes p1: "Q"
      and p2: "~P ==> ~Q"
  shows "P"
by (iprover intro: classical p1 p2 notE)

subsubsection {*Unique existence*}

lemma ex1I:
  assumes "P a" "!!x. P(x) ==> x=a"
  shows "EX! x. P(x)"
by (unfold Ex1_def, iprover intro: assms exI conjI allI impI)

text{*Sometimes easier to use: the premises have no shared variables.  Safe!*}
lemma ex_ex1I:
  assumes ex_prem: "EX x. P(x)"
      and eq: "!!x y. [| P(x); P(y) |] ==> x=y"
  shows "EX! x. P(x)"
by (iprover intro: ex_prem [THEN exE] ex1I eq)

lemma ex1E:
  assumes major: "EX! x. P(x)"
      and minor: "!!x. [| P(x);  ALL y. P(y) --> y=x |] ==> R"
  shows "R"
apply (rule major [unfolded Ex1_def, THEN exE])
apply (erule conjE)
apply (iprover intro: minor)
done

lemma ex1_implies_ex: "EX! x. P x ==> EX x. P x"
apply (erule ex1E)
apply (rule exI)
apply assumption
done

subsubsection {*THE: definite description operator*}

lemma the_equality:
  assumes prema: "P a"
      and premx: "!!x. P x ==> x=a"
  shows "(THE x. P x) = a"
apply (rule trans [OF _ the_eq_trivial])
apply (rule_tac f = "The" in arg_cong)
apply (rule ext)
apply (rule iffI)
 apply (erule premx)
apply (erule ssubst, rule prema)
done

lemma theI:
  assumes "P a" and "!!x. P x ==> x=a"
  shows "P (THE x. P x)"
by (iprover intro: assms the_equality [THEN ssubst])

lemma theI': "EX! x. P x ==> P (THE x. P x)"
apply (erule ex1E)
apply (erule theI)
apply (erule allE)
apply (erule mp)
apply assumption
done

(*Easier to apply than theI: only one occurrence of P*)
lemma theI2:
  assumes "P a" "!!x. P x ==> x=a" "!!x. P x ==> Q x"
  shows "Q (THE x. P x)"
by (iprover intro: assms theI)

lemma the1I2: assumes "EX! x. P x" "\<And>x. P x \<Longrightarrow> Q x" shows "Q (THE x. P x)"
by(iprover intro:assms(2) theI2[where P=P and Q=Q] ex1E[OF assms(1)]
           elim:allE impE)

lemma the1_equality [elim?]: "[| EX!x. P x; P a |] ==> (THE x. P x) = a"
apply (rule the_equality)
apply  assumption
apply (erule ex1E)
apply (erule all_dupE)
apply (drule mp)
apply  assumption
apply (erule ssubst)
apply (erule allE)
apply (erule mp)
apply assumption
done

lemma the_sym_eq_trivial: "(THE y. x=y) = x"
apply (rule the_equality)
apply (rule refl)
apply (erule sym)
done

subsubsection {*Classical intro rules for disjunction and existential quantifiers*}

lemma disjCI:
  assumes "~Q ==> P" shows "P|Q"
apply (rule classical)
apply (iprover intro: assms disjI1 disjI2 notI elim: notE)
done

lemma excluded_middle: "~P | P"
by (iprover intro: disjCI)

text {*
  case distinction as a natural deduction rule.
  Note that @{term "~P"} is the second case, not the first
*}
lemma case_split [case_names True False]:
  assumes prem1: "P ==> Q"
      and prem2: "~P ==> Q"
  shows "Q"
apply (rule excluded_middle [THEN disjE])
apply (erule prem2)
apply (erule prem1)
done

(*Classical implies (-->) elimination. *)
lemma impCE:
  assumes major: "P-->Q"
      and minor: "~P ==> R" "Q ==> R"
  shows "R"
apply (rule excluded_middle [of P, THEN disjE])
apply (iprover intro: minor major [THEN mp])+
done

(*This version of --> elimination works on Q before P.  It works best for
  those cases in which P holds "almost everywhere".  Can't install as
  default: would break old proofs.*)
lemma impCE':
  assumes major: "P-->Q"
      and minor: "Q ==> R" "~P ==> R"
  shows "R"
apply (rule excluded_middle [of P, THEN disjE])
apply (iprover intro: minor major [THEN mp])+
done

(*Classical <-> elimination. *)
lemma iffCE:
  assumes major: "P=Q"
      and minor: "[| P; Q |] ==> R"  "[| ~P; ~Q |] ==> R"
  shows "R"
apply (rule major [THEN iffE])
apply (iprover intro: minor elim: impCE notE)
done

lemma exCI:
  assumes "ALL x. ~P(x) ==> P(a)"
  shows "EX x. P(x)"
apply (rule ccontr)
apply (iprover intro: assms exI allI notI notE [of "\<exists>x. P x"])
done

subsubsection {* Intuitionistic Reasoning *}

lemma impE':
  assumes 1: "P --> Q"
    and 2: "Q ==> R"
    and 3: "P --> Q ==> P"
  shows R
proof -
  from 3 and 1 have P .
  with 1 have Q by (rule impE)
  with 2 show R .
qed

lemma allE':
  assumes 1: "ALL x. P x"
    and 2: "P x ==> ALL x. P x ==> Q"
  shows Q
proof -
  from 1 have "P x" by (rule spec)
  from this and 1 show Q by (rule 2)
qed

lemma notE':
  assumes 1: "~ P"
    and 2: "~ P ==> P"
  shows R
proof -
  from 2 and 1 have P .
  with 1 show R by (rule notE)
qed

lemma TrueE: "True ==> P ==> P" .
lemma notFalseE: "~ False ==> P ==> P" .

lemmas [Pure.elim!] = disjE iffE FalseE conjE exE TrueE notFalseE
  and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
  and [Pure.elim 2] = allE notE' impE'
  and [Pure.intro] = exI disjI2 disjI1

lemmas [trans] = trans
  and [sym] = sym not_sym
  and [Pure.elim?] = iffD1 iffD2 impE

subsubsection {* Atomizing meta-level connectives *}

axiomatization where
  eq_reflection: "x = y \<Longrightarrow> x \<equiv> y" (*admissible axiom*)

lemma atomize_all [atomize]: "(!!x. P x) == Trueprop (ALL x. P x)"
proof
  assume "!!x. P x"
  then show "ALL x. P x" ..
next
  assume "ALL x. P x"
  then show "!!x. P x" by (rule allE)
qed

lemma atomize_imp [atomize]: "(A ==> B) == Trueprop (A --> B)"
proof
  assume r: "A ==> B"
  show "A --> B" by (rule impI) (rule r)
next
  assume "A --> B" and A
  then show B by (rule mp)
qed

lemma atomize_not: "(A ==> False) == Trueprop (~A)"
proof
  assume r: "A ==> False"
  show "~A" by (rule notI) (rule r)
next
  assume "~A" and A
  then show False by (rule notE)
qed

lemma atomize_eq [atomize, code]: "(x == y) == Trueprop (x = y)"
proof
  assume "x == y"
  show "x = y" by (unfold `x == y`) (rule refl)
next
  assume "x = y"
  then show "x == y" by (rule eq_reflection)
qed

lemma atomize_conj [atomize]: "(A &&& B) == Trueprop (A & B)"
proof
  assume conj: "A &&& B"
  show "A & B"
  proof (rule conjI)
    from conj show A by (rule conjunctionD1)
    from conj show B by (rule conjunctionD2)
  qed
next
  assume conj: "A & B"
  show "A &&& B"
  proof -
    from conj show A ..
    from conj show B ..
  qed
qed

lemmas [symmetric, rulify] = atomize_all atomize_imp
  and [symmetric, defn] = atomize_all atomize_imp atomize_eq

subsubsection {* Atomizing elimination rules *}

lemma atomize_exL[atomize_elim]: "(!!x. P x ==> Q) == ((EX x. P x) ==> Q)"
  by rule iprover+

lemma atomize_conjL[atomize_elim]: "(A ==> B ==> C) == (A & B ==> C)"
  by rule iprover+

lemma atomize_disjL[atomize_elim]: "((A ==> C) ==> (B ==> C) ==> C) == ((A | B ==> C) ==> C)"
  by rule iprover+

lemma atomize_elimL[atomize_elim]: "(!!B. (A ==> B) ==> B) == Trueprop A" ..

subsection {* Package setup *}

ML_file "Tools/hologic.ML"

subsubsection {* Sledgehammer setup *}

text {*
Theorems blacklisted to Sledgehammer. These theorems typically produce clauses
that are prolific (match too many equality or membership literals) and relate to
seldom-used facts. Some duplicate other rules.
*}

named_theorems no_atp "theorems that should be filtered out by Sledgehammer"

subsubsection {* Classical Reasoner setup *}

lemma imp_elim: "P --> Q ==> (~ R ==> P) ==> (Q ==> R) ==> R"
  by (rule classical) iprover

lemma swap: "~ P ==> (~ R ==> P) ==> R"
  by (rule classical) iprover

lemma thin_refl:
  "\<And>X. \<lbrakk> x=x; PROP W \<rbrakk> \<Longrightarrow> PROP W" .

ML {*
structure Hypsubst = Hypsubst
(
  val dest_eq = HOLogic.dest_eq
  val dest_Trueprop = HOLogic.dest_Trueprop
  val dest_imp = HOLogic.dest_imp
  val eq_reflection = @{thm eq_reflection}
  val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
  val imp_intr = @{thm impI}
  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl};
);
open Hypsubst;

structure Classical = Classical
(
  val imp_elim = @{thm imp_elim}
  val not_elim = @{thm notE}
  val swap = @{thm swap}
  val classical = @{thm classical}
  val sizef = Drule.size_of_thm
  val hyp_subst_tacs = [Hypsubst.hyp_subst_tac]
);

structure Basic_Classical: BASIC_CLASSICAL = Classical;
open Basic_Classical;
*}

setup {*
  (*prevent substitution on bool*)
  let
    fun non_bool_eq (@{const_name HOL.eq}, Type (_, [T, _])) = T <> @{typ bool}
      | non_bool_eq _ = false;
    fun hyp_subst_tac' ctxt =
      SUBGOAL (fn (goal, i) =>
        if Term.exists_Const non_bool_eq goal
        then Hypsubst.hyp_subst_tac ctxt i
        else no_tac);
  in
    Context_Rules.addSWrapper (fn ctxt => fn tac => hyp_subst_tac' ctxt ORELSE' tac)
  end
*}

declare iffI [intro!]
  and notI [intro!]
  and impI [intro!]
  and disjCI [intro!]
  and conjI [intro!]
  and TrueI [intro!]
  and refl [intro!]

declare iffCE [elim!]
  and FalseE [elim!]
  and impCE [elim!]
  and disjE [elim!]
  and conjE [elim!]

declare ex_ex1I [intro!]
  and allI [intro!]
  and the_equality [intro]
  and exI [intro]

declare exE [elim!]
  allE [elim]

ML {* val HOL_cs = claset_of @{context} *}

lemma contrapos_np: "~ Q ==> (~ P ==> Q) ==> P"
  apply (erule swap)
  apply (erule (1) meta_mp)
  done

declare ex_ex1I [rule del, intro! 2]
  and ex1I [intro]

declare ext [intro]

lemmas [intro?] = ext
  and [elim?] = ex1_implies_ex

(*Better then ex1E for classical reasoner: needs no quantifier duplication!*)
lemma alt_ex1E [elim!]:
  assumes major: "\<exists>!x. P x"
      and prem: "\<And>x. \<lbrakk> P x; \<forall>y y'. P y \<and> P y' \<longrightarrow> y = y' \<rbrakk> \<Longrightarrow> R"
  shows R
apply (rule ex1E [OF major])
apply (rule prem)
apply (tactic {* ares_tac @{thms allI} 1 *})+
apply (tactic {* eresolve_tac [Classical.dup_elim NONE @{thm allE}] 1 *})
apply iprover
done

ML {*
  structure Blast = Blast
  (
    structure Classical = Classical
    val Trueprop_const = dest_Const @{const Trueprop}
    val equality_name = @{const_name HOL.eq}
    val not_name = @{const_name Not}
    val notE = @{thm notE}
    val ccontr = @{thm ccontr}
    val hyp_subst_tac = Hypsubst.blast_hyp_subst_tac
  );
  val blast_tac = Blast.blast_tac;
*}

subsubsection {* Simplifier *}

lemma eta_contract_eq: "(%s. f s) = f" ..

lemma simp_thms:
  shows not_not: "(~ ~ P) = P"
  and Not_eq_iff: "((~P) = (~Q)) = (P = Q)"
  and
    "(P ~= Q) = (P = (~Q))"
    "(P | ~P) = True"    "(~P | P) = True"
    "(x = x) = True"
  and not_True_eq_False [code]: "(\<not> True) = False"
  and not_False_eq_True [code]: "(\<not> False) = True"
  and
    "(~P) ~= P"  "P ~= (~P)"
    "(True=P) = P"
  and eq_True: "(P = True) = P"
  and "(False=P) = (~P)"
  and eq_False: "(P = False) = (\<not> P)"
  and
    "(True --> P) = P"  "(False --> P) = True"
    "(P --> True) = True"  "(P --> P) = True"
    "(P --> False) = (~P)"  "(P --> ~P) = (~P)"
    "(P & True) = P"  "(True & P) = P"
    "(P & False) = False"  "(False & P) = False"
    "(P & P) = P"  "(P & (P & Q)) = (P & Q)"
    "(P & ~P) = False"    "(~P & P) = False"
    "(P | True) = True"  "(True | P) = True"
    "(P | False) = P"  "(False | P) = P"
    "(P | P) = P"  "(P | (P | Q)) = (P | Q)" and
    "(ALL x. P) = P"  "(EX x. P) = P"  "EX x. x=t"  "EX x. t=x"
  and
    "!!P. (EX x. x=t & P(x)) = P(t)"
    "!!P. (EX x. t=x & P(x)) = P(t)"
    "!!P. (ALL x. x=t --> P(x)) = P(t)"
    "!!P. (ALL x. t=x --> P(x)) = P(t)"
  by (blast, blast, blast, blast, blast, iprover+)

lemma disj_absorb: "(A | A) = A"
  by blast

lemma disj_left_absorb: "(A | (A | B)) = (A | B)"
  by blast

lemma conj_absorb: "(A & A) = A"
  by blast

lemma conj_left_absorb: "(A & (A & B)) = (A & B)"
  by blast

lemma eq_ac:
  shows eq_commute: "a = b \<longleftrightarrow> b = a"
    and iff_left_commute: "(P \<longleftrightarrow> (Q \<longleftrightarrow> R)) \<longleftrightarrow> (Q \<longleftrightarrow> (P \<longleftrightarrow> R))"
    and iff_assoc: "((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longleftrightarrow> (P \<longleftrightarrow> (Q \<longleftrightarrow> R))" by (iprover, blast+)
lemma neq_commute: "a \<noteq> b \<longleftrightarrow> b \<noteq> a" by iprover

lemma conj_comms:
  shows conj_commute: "(P&Q) = (Q&P)"
    and conj_left_commute: "(P&(Q&R)) = (Q&(P&R))" by iprover+
lemma conj_assoc: "((P&Q)&R) = (P&(Q&R))" by iprover

lemmas conj_ac = conj_commute conj_left_commute conj_assoc

lemma disj_comms:
  shows disj_commute: "(P|Q) = (Q|P)"
    and disj_left_commute: "(P|(Q|R)) = (Q|(P|R))" by iprover+
lemma disj_assoc: "((P|Q)|R) = (P|(Q|R))" by iprover

lemmas disj_ac = disj_commute disj_left_commute disj_assoc

lemma conj_disj_distribL: "(P&(Q|R)) = (P&Q | P&R)" by iprover
lemma conj_disj_distribR: "((P|Q)&R) = (P&R | Q&R)" by iprover

lemma disj_conj_distribL: "(P|(Q&R)) = ((P|Q) & (P|R))" by iprover
lemma disj_conj_distribR: "((P&Q)|R) = ((P|R) & (Q|R))" by iprover

lemma imp_conjR: "(P --> (Q&R)) = ((P-->Q) & (P-->R))" by iprover
lemma imp_conjL: "((P&Q) -->R)  = (P --> (Q --> R))" by iprover
lemma imp_disjL: "((P|Q) --> R) = ((P-->R)&(Q-->R))" by iprover

text {* These two are specialized, but @{text imp_disj_not1} is useful in @{text "Auth/Yahalom"}. *}
lemma imp_disj_not1: "(P --> Q | R) = (~Q --> P --> R)" by blast
lemma imp_disj_not2: "(P --> Q | R) = (~R --> P --> Q)" by blast

lemma imp_disj1: "((P-->Q)|R) = (P--> Q|R)" by blast
lemma imp_disj2: "(Q|(P-->R)) = (P--> Q|R)" by blast

lemma imp_cong: "(P = P') ==> (P' ==> (Q = Q')) ==> ((P --> Q) = (P' --> Q'))"
  by iprover

lemma de_Morgan_disj: "(~(P | Q)) = (~P & ~Q)" by iprover
lemma de_Morgan_conj: "(~(P & Q)) = (~P | ~Q)" by blast
lemma not_imp: "(~(P --> Q)) = (P & ~Q)" by blast
lemma not_iff: "(P~=Q) = (P = (~Q))" by blast
lemma disj_not1: "(~P | Q) = (P --> Q)" by blast
lemma disj_not2: "(P | ~Q) = (Q --> P)"  -- {* changes orientation :-( *}
  by blast
lemma imp_conv_disj: "(P --> Q) = ((~P) | Q)" by blast

lemma iff_conv_conj_imp: "(P = Q) = ((P --> Q) & (Q --> P))" by iprover

lemma cases_simp: "((P --> Q) & (~P --> Q)) = Q"
  -- {* Avoids duplication of subgoals after @{text split_if}, when the true and false *}
  -- {* cases boil down to the same thing. *}
  by blast

lemma not_all: "(~ (! x. P(x))) = (? x.~P(x))" by blast
lemma imp_all: "((! x. P x) --> Q) = (? x. P x --> Q)" by blast
lemma not_ex: "(~ (? x. P(x))) = (! x.~P(x))" by iprover
lemma imp_ex: "((? x. P x) --> Q) = (! x. P x --> Q)" by iprover
lemma all_not_ex: "(ALL x. P x) = (~ (EX x. ~ P x ))" by blast

declare All_def [no_atp]

lemma ex_disj_distrib: "(? x. P(x) | Q(x)) = ((? x. P(x)) | (? x. Q(x)))" by iprover
lemma all_conj_distrib: "(!x. P(x) & Q(x)) = ((! x. P(x)) & (! x. Q(x)))" by iprover

text {*
  \medskip The @{text "&"} congruence rule: not included by default!
  May slow rewrite proofs down by as much as 50\% *}

lemma conj_cong:
    "(P = P') ==> (P' ==> (Q = Q')) ==> ((P & Q) = (P' & Q'))"
  by iprover

lemma rev_conj_cong:
    "(Q = Q') ==> (Q' ==> (P = P')) ==> ((P & Q) = (P' & Q'))"
  by iprover

text {* The @{text "|"} congruence rule: not included by default! *}

lemma disj_cong:
    "(P = P') ==> (~P' ==> (Q = Q')) ==> ((P | Q) = (P' | Q'))"
  by blast

text {* \medskip if-then-else rules *}

lemma if_True [code]: "(if True then x else y) = x"
  by (unfold If_def) blast

lemma if_False [code]: "(if False then x else y) = y"
  by (unfold If_def) blast

lemma if_P: "P ==> (if P then x else y) = x"
  by (unfold If_def) blast

lemma if_not_P: "~P ==> (if P then x else y) = y"
  by (unfold If_def) blast

lemma split_if: "P (if Q then x else y) = ((Q --> P(x)) & (~Q --> P(y)))"
  apply (rule case_split [of Q])
   apply (simplesubst if_P)
    prefer 3 apply (simplesubst if_not_P, blast+)
  done

lemma split_if_asm: "P (if Q then x else y) = (~((Q & ~P x) | (~Q & ~P y)))"
by (simplesubst split_if, blast)

lemmas if_splits [no_atp] = split_if split_if_asm

lemma if_cancel: "(if c then x else x) = x"
by (simplesubst split_if, blast)

lemma if_eq_cancel: "(if x = y then y else x) = x"
by (simplesubst split_if, blast)

lemma if_bool_eq_conj:
"(if P then Q else R) = ((P-->Q) & (~P-->R))"
  -- {* This form is useful for expanding @{text "if"}s on the RIGHT of the @{text "==>"} symbol. *}
  by (rule split_if)

lemma if_bool_eq_disj: "(if P then Q else R) = ((P&Q) | (~P&R))"
  -- {* And this form is useful for expanding @{text "if"}s on the LEFT. *}
  apply (simplesubst split_if, blast)
  done

lemma Eq_TrueI: "P ==> P == True" by (unfold atomize_eq) iprover
lemma Eq_FalseI: "~P ==> P == False" by (unfold atomize_eq) iprover

text {* \medskip let rules for simproc *}

lemma Let_folded: "f x \<equiv> g x \<Longrightarrow>  Let x f \<equiv> Let x g"
  by (unfold Let_def)

lemma Let_unfold: "f x \<equiv> g \<Longrightarrow>  Let x f \<equiv> g"
  by (unfold Let_def)

text {*
  The following copy of the implication operator is useful for
  fine-tuning congruence rules.  It instructs the simplifier to simplify
  its premise.
*}

definition simp_implies :: "[prop, prop] => prop"  (infixr "=simp=>" 1) where
  "simp_implies \<equiv> op ==>"

lemma simp_impliesI:
  assumes PQ: "(PROP P \<Longrightarrow> PROP Q)"
  shows "PROP P =simp=> PROP Q"
  apply (unfold simp_implies_def)
  apply (rule PQ)
  apply assumption
  done

lemma simp_impliesE:
  assumes PQ: "PROP P =simp=> PROP Q"
  and P: "PROP P"
  and QR: "PROP Q \<Longrightarrow> PROP R"
  shows "PROP R"
  apply (rule QR)
  apply (rule PQ [unfolded simp_implies_def])
  apply (rule P)
  done

lemma simp_implies_cong:
  assumes PP' :"PROP P == PROP P'"
  and P'QQ': "PROP P' ==> (PROP Q == PROP Q')"
  shows "(PROP P =simp=> PROP Q) == (PROP P' =simp=> PROP Q')"
proof (unfold simp_implies_def, rule equal_intr_rule)
  assume PQ: "PROP P \<Longrightarrow> PROP Q"
  and P': "PROP P'"
  from PP' [symmetric] and P' have "PROP P"
    by (rule equal_elim_rule1)
  then have "PROP Q" by (rule PQ)
  with P'QQ' [OF P'] show "PROP Q'" by (rule equal_elim_rule1)
next
  assume P'Q': "PROP P' \<Longrightarrow> PROP Q'"
  and P: "PROP P"
  from PP' and P have P': "PROP P'" by (rule equal_elim_rule1)
  then have "PROP Q'" by (rule P'Q')
  with P'QQ' [OF P', symmetric] show "PROP Q"
    by (rule equal_elim_rule1)
qed

lemma uncurry:
  assumes "P \<longrightarrow> Q \<longrightarrow> R"
  shows "P \<and> Q \<longrightarrow> R"
  using assms by blast

lemma iff_allI:
  assumes "\<And>x. P x = Q x"
  shows "(\<forall>x. P x) = (\<forall>x. Q x)"
  using assms by blast

lemma iff_exI:
  assumes "\<And>x. P x = Q x"
  shows "(\<exists>x. P x) = (\<exists>x. Q x)"
  using assms by blast

lemma all_comm:
  "(\<forall>x y. P x y) = (\<forall>y x. P x y)"
  by blast

lemma ex_comm:
  "(\<exists>x y. P x y) = (\<exists>y x. P x y)"
  by blast

ML_file "Tools/simpdata.ML"
ML {* open Simpdata *}

setup {*
  map_theory_simpset (put_simpset HOL_basic_ss) #>
  Simplifier.method_setup Splitter.split_modifiers
*}

simproc_setup defined_Ex ("EX x. P x") = {* fn _ => Quantifier1.rearrange_ex *}
simproc_setup defined_All ("ALL x. P x") = {* fn _ => Quantifier1.rearrange_all *}

text {* Simproc for proving @{text "(y = x) == False"} from premise @{text "~(x = y)"}: *}

simproc_setup neq ("x = y") = {* fn _ =>
let
  val neq_to_EQ_False = @{thm not_sym} RS @{thm Eq_FalseI};
  fun is_neq eq lhs rhs thm =
    (case Thm.prop_of thm of
      _ $ (Not $ (eq' $ l' $ r')) =>
        Not = HOLogic.Not andalso eq' = eq andalso
        r' aconv lhs andalso l' aconv rhs
    | _ => false);
  fun proc ss ct =
    (case Thm.term_of ct of
      eq $ lhs $ rhs =>
        (case find_first (is_neq eq lhs rhs) (Simplifier.prems_of ss) of
          SOME thm => SOME (thm RS neq_to_EQ_False)
        | NONE => NONE)
     | _ => NONE);
in proc end;
*}

simproc_setup let_simp ("Let x f") = {*
let
  val (f_Let_unfold, x_Let_unfold) =
    let val [(_ $ (f $ x) $ _)] = prems_of @{thm Let_unfold}
    in (cterm_of @{theory} f, cterm_of @{theory} x) end
  val (f_Let_folded, x_Let_folded) =
    let val [(_ $ (f $ x) $ _)] = prems_of @{thm Let_folded}
    in (cterm_of @{theory} f, cterm_of @{theory} x) end;
  val g_Let_folded =
    let val [(_ $ _ $ (g $ _))] = prems_of @{thm Let_folded}
    in cterm_of @{theory} g end;
  fun count_loose (Bound i) k = if i >= k then 1 else 0
    | count_loose (s $ t) k = count_loose s k + count_loose t k
    | count_loose (Abs (_, _, t)) k = count_loose  t (k + 1)
    | count_loose _ _ = 0;
  fun is_trivial_let (Const (@{const_name Let}, _) $ x $ t) =
   case t
    of Abs (_, _, t') => count_loose t' 0 <= 1
     | _ => true;
in fn _ => fn ctxt => fn ct => if is_trivial_let (Thm.term_of ct)
  then SOME @{thm Let_def} (*no or one ocurrence of bound variable*)
  else let (*Norbert Schirmer's case*)
    val thy = Proof_Context.theory_of ctxt;
    val t = Thm.term_of ct;
    val ([t'], ctxt') = Variable.import_terms false [t] ctxt;
  in Option.map (hd o Variable.export ctxt' ctxt o single)
    (case t' of Const (@{const_name Let},_) $ x $ f => (* x and f are already in normal form *)
      if is_Free x orelse is_Bound x orelse is_Const x
      then SOME @{thm Let_def}
      else
        let
          val n = case f of (Abs (x, _, _)) => x | _ => "x";
          val cx = cterm_of thy x;
          val {T = xT, ...} = rep_cterm cx;
          val cf = cterm_of thy f;
          val fx_g = Simplifier.rewrite ctxt (Thm.apply cf cx);
          val (_ $ _ $ g) = prop_of fx_g;
          val g' = abstract_over (x,g);
          val abs_g'= Abs (n,xT,g');
        in (if (g aconv g')
             then
                let
                  val rl =
                    cterm_instantiate [(f_Let_unfold, cf), (x_Let_unfold, cx)] @{thm Let_unfold};
                in SOME (rl OF [fx_g]) end
             else if (Envir.beta_eta_contract f) aconv (Envir.beta_eta_contract abs_g') then NONE (*avoid identity conversion*)
             else let
                   val g'x = abs_g'$x;
                   val g_g'x = Thm.symmetric (Thm.beta_conversion false (cterm_of thy g'x));
                   val rl = cterm_instantiate
                             [(f_Let_folded, cterm_of thy f), (x_Let_folded, cx),
                              (g_Let_folded, cterm_of thy abs_g')]
                             @{thm Let_folded};
                 in SOME (rl OF [Thm.transitive fx_g g_g'x])
                 end)
        end
    | _ => NONE)
  end
end *}

lemma True_implies_equals: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
proof
  assume "True \<Longrightarrow> PROP P"
  from this [OF TrueI] show "PROP P" .
next
  assume "PROP P"
  then show "PROP P" .
qed

lemma ex_simps:
  "!!P Q. (EX x. P x & Q)   = ((EX x. P x) & Q)"
  "!!P Q. (EX x. P & Q x)   = (P & (EX x. Q x))"
  "!!P Q. (EX x. P x | Q)   = ((EX x. P x) | Q)"
  "!!P Q. (EX x. P | Q x)   = (P | (EX x. Q x))"
  "!!P Q. (EX x. P x --> Q) = ((ALL x. P x) --> Q)"
  "!!P Q. (EX x. P --> Q x) = (P --> (EX x. Q x))"
  -- {* Miniscoping: pushing in existential quantifiers. *}
  by (iprover | blast)+

lemma all_simps:
  "!!P Q. (ALL x. P x & Q)   = ((ALL x. P x) & Q)"
  "!!P Q. (ALL x. P & Q x)   = (P & (ALL x. Q x))"
  "!!P Q. (ALL x. P x | Q)   = ((ALL x. P x) | Q)"
  "!!P Q. (ALL x. P | Q x)   = (P | (ALL x. Q x))"
  "!!P Q. (ALL x. P x --> Q) = ((EX x. P x) --> Q)"
  "!!P Q. (ALL x. P --> Q x) = (P --> (ALL x. Q x))"
  -- {* Miniscoping: pushing in universal quantifiers. *}
  by (iprover | blast)+

lemmas [simp] =
  triv_forall_equality (*prunes params*)
  True_implies_equals  (*prune asms `True'*)
  if_True
  if_False
  if_cancel
  if_eq_cancel
  imp_disjL
  (*In general it seems wrong to add distributive laws by default: they
    might cause exponential blow-up.  But imp_disjL has been in for a while
    and cannot be removed without affecting existing proofs.  Moreover,
    rewriting by "(P|Q --> R) = ((P-->R)&(Q-->R))" might be justified on the
    grounds that it allows simplification of R in the two cases.*)
  conj_assoc
  disj_assoc
  de_Morgan_conj
  de_Morgan_disj
  imp_disj1
  imp_disj2
  not_imp
  disj_not1
  not_all
  not_ex
  cases_simp
  the_eq_trivial
  the_sym_eq_trivial
  ex_simps
  all_simps
  simp_thms

lemmas [cong] = imp_cong simp_implies_cong
lemmas [split] = split_if

ML {* val HOL_ss = simpset_of @{context} *}

text {* Simplifies x assuming c and y assuming ~c *}
lemma if_cong:
  assumes "b = c"
      and "c \<Longrightarrow> x = u"
      and "\<not> c \<Longrightarrow> y = v"
  shows "(if b then x else y) = (if c then u else v)"
  using assms by simp

text {* Prevents simplification of x and y:
  faster and allows the execution of functional programs. *}
lemma if_weak_cong [cong]:
  assumes "b = c"
  shows "(if b then x else y) = (if c then x else y)"
  using assms by (rule arg_cong)

text {* Prevents simplification of t: much faster *}
lemma let_weak_cong:
  assumes "a = b"
  shows "(let x = a in t x) = (let x = b in t x)"
  using assms by (rule arg_cong)

text {* To tidy up the result of a simproc.  Only the RHS will be simplified. *}
lemma eq_cong2:
  assumes "u = u'"
  shows "(t \<equiv> u) \<equiv> (t \<equiv> u')"
  using assms by simp

lemma if_distrib:
  "f (if c then x else y) = (if c then f x else f y)"
  by simp

text{*As a simplification rule, it replaces all function equalities by
  first-order equalities.*}
lemma fun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f x = g x)"
  by auto

subsubsection {* Generic cases and induction *}

text {* Rule projections: *}

ML {*
structure Project_Rule = Project_Rule
(
  val conjunct1 = @{thm conjunct1}
  val conjunct2 = @{thm conjunct2}
  val mp = @{thm mp}
)
*}

definition induct_forall where
  "induct_forall P == \<forall>x. P x"

definition induct_implies where
  "induct_implies A B == A \<longrightarrow> B"

definition induct_equal where
  "induct_equal x y == x = y"

definition induct_conj where
  "induct_conj A B == A \<and> B"

definition induct_true where
  "induct_true == True"

definition induct_false where
  "induct_false == False"

lemma induct_forall_eq: "(!!x. P x) == Trueprop (induct_forall (\<lambda>x. P x))"
  by (unfold atomize_all induct_forall_def)

lemma induct_implies_eq: "(A ==> B) == Trueprop (induct_implies A B)"
  by (unfold atomize_imp induct_implies_def)

lemma induct_equal_eq: "(x == y) == Trueprop (induct_equal x y)"
  by (unfold atomize_eq induct_equal_def)

lemma induct_conj_eq: "(A &&& B) == Trueprop (induct_conj A B)"
  by (unfold atomize_conj induct_conj_def)

lemmas induct_atomize' = induct_forall_eq induct_implies_eq induct_conj_eq
lemmas induct_atomize = induct_atomize' induct_equal_eq
lemmas induct_rulify' [symmetric] = induct_atomize'
lemmas induct_rulify [symmetric] = induct_atomize
lemmas induct_rulify_fallback =
  induct_forall_def induct_implies_def induct_equal_def induct_conj_def
  induct_true_def induct_false_def

lemma induct_forall_conj: "induct_forall (\<lambda>x. induct_conj (A x) (B x)) =
    induct_conj (induct_forall A) (induct_forall B)"
  by (unfold induct_forall_def induct_conj_def) iprover

lemma induct_implies_conj: "induct_implies C (induct_conj A B) =
    induct_conj (induct_implies C A) (induct_implies C B)"
  by (unfold induct_implies_def induct_conj_def) iprover

lemma induct_conj_curry: "(induct_conj A B ==> PROP C) == (A ==> B ==> PROP C)"
proof
  assume r: "induct_conj A B ==> PROP C" and A B
  show "PROP C" by (rule r) (simp add: induct_conj_def `A` `B`)
next
  assume r: "A ==> B ==> PROP C" and "induct_conj A B"
  show "PROP C" by (rule r) (simp_all add: `induct_conj A B` [unfolded induct_conj_def])
qed

lemmas induct_conj = induct_forall_conj induct_implies_conj induct_conj_curry

lemma induct_trueI: "induct_true"
  by (simp add: induct_true_def)

text {* Method setup. *}

ML_file "~~/src/Tools/induct.ML"
ML {*
structure Induct = Induct
(
  val cases_default = @{thm case_split}
  val atomize = @{thms induct_atomize}
  val rulify = @{thms induct_rulify'}
  val rulify_fallback = @{thms induct_rulify_fallback}
  val equal_def = @{thm induct_equal_def}
  fun dest_def (Const (@{const_name induct_equal}, _) $ t $ u) = SOME (t, u)
    | dest_def _ = NONE
  fun trivial_tac ctxt = match_tac ctxt @{thms induct_trueI}
)
*}

ML_file "~~/src/Tools/induction.ML"

setup {*
  Context.theory_map (Induct.map_simpset (fn ss => ss
    addsimprocs
      [Simplifier.simproc_global @{theory} "swap_induct_false"
         ["induct_false ==> PROP P ==> PROP Q"]
         (fn _ =>
            (fn _ $ (P as _ $ @{const induct_false}) $ (_ $ Q $ _) =>
                  if P <> Q then SOME Drule.swap_prems_eq else NONE
              | _ => NONE)),
       Simplifier.simproc_global @{theory} "induct_equal_conj_curry"
         ["induct_conj P Q ==> PROP R"]
         (fn _ =>
            (fn _ $ (_ $ P) $ _ =>
                let
                  fun is_conj (@{const induct_conj} $ P $ Q) =
                        is_conj P andalso is_conj Q
                    | is_conj (Const (@{const_name induct_equal}, _) $ _ $ _) = true
                    | is_conj @{const induct_true} = true
                    | is_conj @{const induct_false} = true
                    | is_conj _ = false
                in if is_conj P then SOME @{thm induct_conj_curry} else NONE end
              | _ => NONE))]
    |> Simplifier.set_mksimps (fn ctxt =>
        Simpdata.mksimps Simpdata.mksimps_pairs ctxt #>
        map (rewrite_rule ctxt (map Thm.symmetric @{thms induct_rulify_fallback})))))
*}

text {* Pre-simplification of induction and cases rules *}

lemma [induct_simp]: "(!!x. induct_equal x t ==> PROP P x) == PROP P t"
  unfolding induct_equal_def
proof
  assume R: "!!x. x = t ==> PROP P x"
  show "PROP P t" by (rule R [OF refl])
next
  fix x assume "PROP P t" "x = t"
  then show "PROP P x" by simp
qed

lemma [induct_simp]: "(!!x. induct_equal t x ==> PROP P x) == PROP P t"
  unfolding induct_equal_def
proof
  assume R: "!!x. t = x ==> PROP P x"
  show "PROP P t" by (rule R [OF refl])
next
  fix x assume "PROP P t" "t = x"
  then show "PROP P x" by simp
qed

lemma [induct_simp]: "(induct_false ==> P) == Trueprop induct_true"
  unfolding induct_false_def induct_true_def
  by (iprover intro: equal_intr_rule)

lemma [induct_simp]: "(induct_true ==> PROP P) == PROP P"
  unfolding induct_true_def
proof
  assume R: "True \<Longrightarrow> PROP P"
  from TrueI show "PROP P" by (rule R)
next
  assume "PROP P"
  then show "PROP P" .
qed

lemma [induct_simp]: "(PROP P ==> induct_true) == Trueprop induct_true"
  unfolding induct_true_def
  by (iprover intro: equal_intr_rule)

lemma [induct_simp]: "(!!x. induct_true) == Trueprop induct_true"
  unfolding induct_true_def
  by (iprover intro: equal_intr_rule)

lemma [induct_simp]: "induct_implies induct_true P == P"
  by (simp add: induct_implies_def induct_true_def)

lemma [induct_simp]: "(x = x) = True"
  by (rule simp_thms)

hide_const induct_forall induct_implies induct_equal induct_conj induct_true induct_false

ML_file "~~/src/Tools/induct_tacs.ML"

subsubsection {* Coherent logic *}

ML_file "~~/src/Tools/coherent.ML"
ML {*
structure Coherent = Coherent
(
  val atomize_elimL = @{thm atomize_elimL};
  val atomize_exL = @{thm atomize_exL};
  val atomize_conjL = @{thm atomize_conjL};
  val atomize_disjL = @{thm atomize_disjL};
  val operator_names = [@{const_name HOL.disj}, @{const_name HOL.conj}, @{const_name Ex}];
);
*}

subsubsection {* Reorienting equalities *}

ML {*
signature REORIENT_PROC =
sig
  val add : (term -> bool) -> theory -> theory
  val proc : morphism -> Proof.context -> cterm -> thm option
end;

structure Reorient_Proc : REORIENT_PROC =
struct
  structure Data = Theory_Data
  (
    type T = ((term -> bool) * stamp) list;
    val empty = [];
    val extend = I;
    fun merge data : T = Library.merge (eq_snd op =) data;
  );
  fun add m = Data.map (cons (m, stamp ()));
  fun matches thy t = exists (fn (m, _) => m t) (Data.get thy);

  val meta_reorient = @{thm eq_commute [THEN eq_reflection]};
  fun proc phi ctxt ct =
    let
      val thy = Proof_Context.theory_of ctxt;
    in
      case Thm.term_of ct of
        (_ $ t $ u) => if matches thy u then NONE else SOME meta_reorient
      | _ => NONE
    end;
end;
*}

subsection {* Other simple lemmas and lemma duplicates *}

lemma ex1_eq [iff]: "EX! x. x = t" "EX! x. t = x"
  by blast+

lemma choice_eq: "(ALL x. EX! y. P x y) = (EX! f. ALL x. P x (f x))"
  apply (rule iffI)
  apply (rule_tac a = "%x. THE y. P x y" in ex1I)
  apply (fast dest!: theI')
  apply (fast intro: the1_equality [symmetric])
  apply (erule ex1E)
  apply (rule allI)
  apply (rule ex1I)
  apply (erule spec)
  apply (erule_tac x = "%z. if z = x then y else f z" in allE)
  apply (erule impE)
  apply (rule allI)
  apply (case_tac "xa = x")
  apply (drule_tac [3] x = x in fun_cong, simp_all)
  done

lemmas eq_sym_conv = eq_commute

lemma nnf_simps:
  "(\<not>(P \<and> Q)) = (\<not> P \<or> \<not> Q)" "(\<not> (P \<or> Q)) = (\<not> P \<and> \<not>Q)" "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
  "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not>(P = Q)) = ((P \<and> \<not> Q) \<or> (\<not>P \<and> Q))"
  "(\<not> \<not>(P)) = P"
by blast+

subsection {* Basic ML bindings *}

ML {*
val FalseE = @{thm FalseE}
val Let_def = @{thm Let_def}
val TrueI = @{thm TrueI}
val allE = @{thm allE}
val allI = @{thm allI}
val all_dupE = @{thm all_dupE}
val arg_cong = @{thm arg_cong}
val box_equals = @{thm box_equals}
val ccontr = @{thm ccontr}
val classical = @{thm classical}
val conjE = @{thm conjE}
val conjI = @{thm conjI}
val conjunct1 = @{thm conjunct1}
val conjunct2 = @{thm conjunct2}
val disjCI = @{thm disjCI}
val disjE = @{thm disjE}
val disjI1 = @{thm disjI1}
val disjI2 = @{thm disjI2}
val eq_reflection = @{thm eq_reflection}
val ex1E = @{thm ex1E}
val ex1I = @{thm ex1I}
val ex1_implies_ex = @{thm ex1_implies_ex}
val exE = @{thm exE}
val exI = @{thm exI}
val excluded_middle = @{thm excluded_middle}
val ext = @{thm ext}
val fun_cong = @{thm fun_cong}
val iffD1 = @{thm iffD1}
val iffD2 = @{thm iffD2}
val iffI = @{thm iffI}
val impE = @{thm impE}
val impI = @{thm impI}
val meta_eq_to_obj_eq = @{thm meta_eq_to_obj_eq}
val mp = @{thm mp}
val notE = @{thm notE}
val notI = @{thm notI}
val not_all = @{thm not_all}
val not_ex = @{thm not_ex}
val not_iff = @{thm not_iff}
val not_not = @{thm not_not}
val not_sym = @{thm not_sym}
val refl = @{thm refl}
val rev_mp = @{thm rev_mp}
val spec = @{thm spec}
val ssubst = @{thm ssubst}
val subst = @{thm subst}
val sym = @{thm sym}
val trans = @{thm trans}
*}

ML_file "Tools/cnf.ML"

section {* @{text NO_MATCH} simproc *}

text {*
 The simplification procedure can be used to avoid simplification of terms of a certain form
*}

definition NO_MATCH :: "'a \<Rightarrow> 'b \<Rightarrow> bool" where "NO_MATCH val pat \<equiv> True"

lemma NO_MATCH_cong[cong]: "NO_MATCH val pat = NO_MATCH val pat" by (rule refl)

declare [[coercion_args NO_MATCH - -]]

simproc_setup NO_MATCH ("NO_MATCH val pat") = {* fn _ => fn ctxt => fn ct =>
  let
    val thy = Proof_Context.theory_of ctxt
    val dest_binop = Term.dest_comb #> apfst (Term.dest_comb #> snd)
    val m = Pattern.matches thy (dest_binop (Thm.term_of ct))
  in if m then NONE else SOME @{thm NO_MATCH_def} end
*}

text {*
  This setup ensures that a rewrite rule of the form @{term "NO_MATCH val pat \<Longrightarrow> t"}
  is only applied, if the pattern @{term pat} does not match the value @{term val}.
*}

subsection {* Code generator setup *}

subsubsection {* Generic code generator preprocessor setup *}

lemma conj_left_cong:
  "P \<longleftrightarrow> Q \<Longrightarrow> P \<and> R \<longleftrightarrow> Q \<and> R"
  by (fact arg_cong)

lemma disj_left_cong:
  "P \<longleftrightarrow> Q \<Longrightarrow> P \<or> R \<longleftrightarrow> Q \<or> R"
  by (fact arg_cong)

setup {*
  Code_Preproc.map_pre (put_simpset HOL_basic_ss) #>
  Code_Preproc.map_post (put_simpset HOL_basic_ss) #>
  Code_Simp.map_ss (put_simpset HOL_basic_ss #>
  Simplifier.add_cong @{thm conj_left_cong} #>
  Simplifier.add_cong @{thm disj_left_cong})
*}

subsubsection {* Equality *}

class equal =
  fixes equal :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes equal_eq: "equal x y \<longleftrightarrow> x = y"
begin

lemma equal: "equal = (op =)"
  by (rule ext equal_eq)+

lemma equal_refl: "equal x x \<longleftrightarrow> True"
  unfolding equal by rule+

lemma eq_equal: "(op =) \<equiv> equal"
  by (rule eq_reflection) (rule ext, rule ext, rule sym, rule equal_eq)

end

declare eq_equal [symmetric, code_post]
declare eq_equal [code]

setup {*
  Code_Preproc.map_pre (fn ctxt =>
    ctxt addsimprocs [Simplifier.simproc_global_i @{theory} "equal" [@{term HOL.eq}]
      (fn _ => fn Const (_, Type ("fun", [Type _, _])) => SOME @{thm eq_equal} | _ => NONE)])
*}

subsubsection {* Generic code generator foundation *}

text {* Datatype @{typ bool} *}

code_datatype True False

lemma [code]:
  shows "False \<or> P \<longleftrightarrow> P"
    and "True \<or> P \<longleftrightarrow> True"
    and "P \<or> False \<longleftrightarrow> P"
    and "P \<or> True \<longleftrightarrow> True" by simp_all

lemma [code]:
  shows "(False \<longrightarrow> P) \<longleftrightarrow> True"
    and "(True \<longrightarrow> P) \<longleftrightarrow> P"
    and "(P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
    and "(P \<longrightarrow> True) \<longleftrightarrow> True" by simp_all

text {* More about @{typ prop} *}

lemma [code nbe]:
  shows "(True \<Longrightarrow> PROP Q) \<equiv> PROP Q"
    and "(PROP Q \<Longrightarrow> True) \<equiv> Trueprop True"
    and "(P \<Longrightarrow> R) \<equiv> Trueprop (P \<longrightarrow> R)" by (auto intro!: equal_intr_rule)

lemma Trueprop_code [code]:
  "Trueprop True \<equiv> Code_Generator.holds"
  by (auto intro!: equal_intr_rule holds)

declare Trueprop_code [symmetric, code_post]

text {* Equality *}

declare simp_thms(6) [code nbe]

instantiation itself :: (type) equal
begin

definition equal_itself :: "'a itself \<Rightarrow> 'a itself \<Rightarrow> bool" where
  "equal_itself x y \<longleftrightarrow> x = y"

instance proof
qed (fact equal_itself_def)

end

lemma equal_itself_code [code]:
  "equal TYPE('a) TYPE('a) \<longleftrightarrow> True"
  by (simp add: equal)

setup {* Sign.add_const_constraint (@{const_name equal}, SOME @{typ "'a\<Colon>type \<Rightarrow> 'a \<Rightarrow> bool"}) *}

lemma equal_alias_cert: "OFCLASS('a, equal_class) \<equiv> ((op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool) \<equiv> equal)" (is "?ofclass \<equiv> ?equal")
proof
  assume "PROP ?ofclass"
  show "PROP ?equal"
    by (tactic {* ALLGOALS (resolve_tac [Thm.unconstrainT @{thm eq_equal}]) *})
      (fact `PROP ?ofclass`)
next
  assume "PROP ?equal"
  show "PROP ?ofclass" proof
  qed (simp add: `PROP ?equal`)
qed

setup {* Sign.add_const_constraint (@{const_name equal}, SOME @{typ "'a\<Colon>equal \<Rightarrow> 'a \<Rightarrow> bool"}) *}

setup {* Nbe.add_const_alias @{thm equal_alias_cert} *}

text {* Cases *}

lemma Let_case_cert:
  assumes "CASE \<equiv> (\<lambda>x. Let x f)"
  shows "CASE x \<equiv> f x"
  using assms by simp_all

setup {*
  Code.add_case @{thm Let_case_cert} #>
  Code.add_undefined @{const_name undefined}
*}

declare [[code abort: undefined]]

subsubsection {* Generic code generator target languages *}

text {* type @{typ bool} *}

code_printing
  type_constructor bool \<rightharpoonup>
    (SML) "bool" and (OCaml) "bool" and (Haskell) "Bool" and (Scala) "Boolean"
| constant True \<rightharpoonup>
    (SML) "true" and (OCaml) "true" and (Haskell) "True" and (Scala) "true"
| constant False \<rightharpoonup>
    (SML) "false" and (OCaml) "false" and (Haskell) "False" and (Scala) "false"

code_reserved SML
  bool true false

code_reserved OCaml
  bool

code_reserved Scala
  Boolean

code_printing
  constant Not \<rightharpoonup>
    (SML) "not" and (OCaml) "not" and (Haskell) "not" and (Scala) "'! _"
| constant HOL.conj \<rightharpoonup>
    (SML) infixl 1 "andalso" and (OCaml) infixl 3 "&&" and (Haskell) infixr 3 "&&" and (Scala) infixl 3 "&&"
| constant HOL.disj \<rightharpoonup>
    (SML) infixl 0 "orelse" and (OCaml) infixl 2 "||" and (Haskell) infixl 2 "||" and (Scala) infixl 1 "||"
| constant HOL.implies \<rightharpoonup>
    (SML) "!(if (_)/ then (_)/ else true)"
    and (OCaml) "!(if (_)/ then (_)/ else true)"
    and (Haskell) "!(if (_)/ then (_)/ else True)"
    and (Scala) "!(if ((_))/ (_)/ else true)"
| constant If \<rightharpoonup>
    (SML) "!(if (_)/ then (_)/ else (_))"
    and (OCaml) "!(if (_)/ then (_)/ else (_))"
    and (Haskell) "!(if (_)/ then (_)/ else (_))"
    and (Scala) "!(if ((_))/ (_)/ else (_))"

code_reserved SML
  not

code_reserved OCaml
  not

code_identifier
  code_module Pure \<rightharpoonup>
    (SML) HOL and (OCaml) HOL and (Haskell) HOL and (Scala) HOL

text {* using built-in Haskell equality *}

code_printing
  type_class equal \<rightharpoonup> (Haskell) "Eq"
| constant HOL.equal \<rightharpoonup> (Haskell) infix 4 "=="
| constant HOL.eq \<rightharpoonup> (Haskell) infix 4 "=="

text {* undefined *}

code_printing
  constant undefined \<rightharpoonup>
    (SML) "!(raise/ Fail/ \"undefined\")"
    and (OCaml) "failwith/ \"undefined\""
    and (Haskell) "error/ \"undefined\""
    and (Scala) "!sys.error(\"undefined\")"

subsubsection {* Evaluation and normalization by evaluation *}

method_setup eval = {*
  let
    fun eval_tac ctxt =
      let val conv = Code_Runtime.dynamic_holds_conv ctxt
      in
        CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN'
        resolve_tac [TrueI]
      end
  in
    Scan.succeed (SIMPLE_METHOD' o eval_tac)
  end
*} "solve goal by evaluation"

method_setup normalization = {*
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD'
      (CHANGED_PROP o
        (CONVERSION (Nbe.dynamic_conv ctxt)
          THEN_ALL_NEW (TRY o resolve_tac [TrueI]))))
*} "solve goal by normalization"

subsection {* Counterexample Search Units *}

subsubsection {* Quickcheck *}

quickcheck_params [size = 5, iterations = 50]

subsubsection {* Nitpick setup *}

named_theorems nitpick_unfold "alternative definitions of constants as needed by Nitpick"
  and nitpick_simp "equational specification of constants as needed by Nitpick"
  and nitpick_psimp "partial equational specification of constants as needed by Nitpick"
  and nitpick_choice_spec "choice specification of constants as needed by Nitpick"

declare if_bool_eq_conj [nitpick_unfold, no_atp]
        if_bool_eq_disj [no_atp]

subsection {* Preprocessing for the predicate compiler *}

named_theorems code_pred_def "alternative definitions of constants for the Predicate Compiler"
  and code_pred_inline "inlining definitions for the Predicate Compiler"
  and code_pred_simp "simplification rules for the optimisations in the Predicate Compiler"

subsection {* Legacy tactics and ML bindings *}

ML {*
  (* combination of (spec RS spec RS ...(j times) ... spec RS mp) *)
  local
    fun wrong_prem (Const (@{const_name All}, _) $ Abs (_, _, t)) = wrong_prem t
      | wrong_prem (Bound _) = true
      | wrong_prem _ = false;
    val filter_right = filter (not o wrong_prem o HOLogic.dest_Trueprop o hd o Thm.prems_of);
  in
    fun smp i = funpow i (fn m => filter_right ([spec] RL m)) ([mp]);
    fun smp_tac ctxt j = EVERY'[dresolve_tac (smp j), assume_tac ctxt];
  end;

  local
    val nnf_ss =
      simpset_of (put_simpset HOL_basic_ss @{context} addsimps @{thms simp_thms nnf_simps});
  in
    fun nnf_conv ctxt = Simplifier.rewrite (put_simpset nnf_ss ctxt);
  end
*}

hide_const (open) eq equal

end


theory TTreeImplCardinalitySafe
imports TTreeImplCardinality TTreeAnalysisSpec CardinalityAnalysisSpec
begin

hide_const Multiset.single

lemma pathsCard_paths_nxt:  "pathsCard (paths (nxt f x)) \<sqsubseteq> record_call x\<cdot>(pathsCard (paths f))"
  apply transfer
  apply (rule pathsCard_below)
  apply auto
  apply (erule below_trans[OF _ monofun_cfun_arg[OF paths_Card_above], rotated]) back
  apply (auto intro: fun_belowI simp add: record_call_simp two_pred_two_add_once)
  done

lemma pathsCards_none: "pathsCard (paths t) x = none \<Longrightarrow> x \<notin> carrier t"
  by transfer (auto dest: pathCards_noneD)

lemma const_on_edom_disj: "const_on f S empty \<longleftrightarrow> edom f \<inter> S = {}"
  by (auto simp add: empty_is_bottom edom_def)

context TTreeAnalysisCarrier
begin
  lemma carrier_Fstack: "carrier (Fstack as S) \<subseteq> fv S"
    by (induction S rule: Fstack.induct)
       (auto simp add: empty_is_bottom[symmetric] carrier_Fexp dest!: set_mp[OF Aexp_edom])

  lemma carrier_FBinds: "carrier ((FBinds \<Gamma>\<cdot>ae) x) \<subseteq> fv \<Gamma>"
  apply (simp add: Texp.AnalBinds_lookup)
  apply (auto split: option.split simp add: empty_is_bottom[symmetric] )
  apply (case_tac "ae x")
  apply (auto simp add: empty_is_bottom[symmetric] carrier_Fexp dest!: set_mp[OF Aexp_edom])
  by (metis (poly_guards_query) contra_subsetD domA_from_set map_of_fv_subset map_of_SomeD option.sel)
end

context TTreeAnalysisSafe
begin

  sublocale CardinalityPrognosisShape prognosis
  proof
    fix \<Gamma> :: heap and ae ae' :: AEnv and u e S as
    assume "ae f|` domA \<Gamma> = ae' f|` domA \<Gamma>"
    from Texp.AnalBinds_cong[OF this]
    show "prognosis ae as u (\<Gamma>, e, S) = prognosis ae' as u (\<Gamma>, e, S)" by simp
  next
    fix ae as a \<Gamma> e S
    show "const_on (prognosis ae as a (\<Gamma>, e, S)) (ap S) many"
    proof
      fix x
      assume "x \<in> ap S"
      hence "[x,x] \<in> paths (Fstack as S)"
        by (induction S rule: Fstack.induct)
           (auto 4 4 intro: set_mp[OF both_contains_arg1] set_mp[OF both_contains_arg2] paths_Cons_nxt)
      hence "[x,x] \<in> paths (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)"
        by (rule set_mp[OF both_contains_arg2])
      hence "[x,x] \<in> paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))"
        by (rule set_mp[OF substitute_contains_arg])
      hence "pathCard [x,x] x \<sqsubseteq> pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))) x"
        by (metis fun_belowD paths_Card_above)
      also have "pathCard [x,x] x = many"  by (auto simp add: pathCard_def)
      finally
      show "prognosis ae as a (\<Gamma>, e, S) x = many"
        by (auto intro: below_antisym)
    qed
  next
    fix \<Gamma> \<Delta> :: heap and e :: exp and ae :: AEnv and as u S
    assume "map_of \<Gamma> = map_of \<Delta>"
    hence "FBinds \<Gamma> = FBinds \<Delta>" and "thunks \<Gamma> = thunks \<Delta>" by (auto intro!: cfun_eqI  thunks_cong simp add: Texp.AnalBinds_lookup)
    thus "prognosis ae as u (\<Gamma>, e, S) = prognosis ae as u (\<Delta>, e, S)"  by simp
  next
    fix \<Gamma> :: heap and e :: exp and ae :: AEnv and as u S x
    show "prognosis ae as u (\<Gamma>, e, S) \<sqsubseteq> prognosis ae as u (\<Gamma>, e, Upd x # S)" by simp
  next
  fix \<Gamma> :: heap and e :: exp and ae :: AEnv and as a S x
  assume "ae x = \<bottom>"

  hence "FBinds (delete x \<Gamma>)\<cdot>ae = FBinds \<Gamma>\<cdot>ae" by (rule Texp.AnalBinds_delete_bot)
  moreover
  hence "((FBinds \<Gamma>\<cdot>ae) x) = \<bottom>" by (metis Texp.AnalBinds_delete_lookup)
  ultimately
  show "prognosis ae as a (\<Gamma>, e, S) \<sqsubseteq> prognosis ae as a (delete x \<Gamma>, e, S)"
    by (simp add: substitute_T_delete empty_is_bottom)
  next
    fix ae as a \<Gamma> x S
    have "once \<sqsubseteq> (pathCard [x]) x" by (simp add: two_add_simp)
    also have "pathCard [x] \<sqsubseteq> pathsCard ({[],[x]})"
      by (rule paths_Card_above) simp
    also have "\<dots> = pathsCard (paths (single x))" by simp
    also have "single x \<sqsubseteq> (Texp (Var x)\<cdot>a)" by (rule Texp_Var)
    also have "\<dots> \<sqsubseteq> Texp (Var x)\<cdot>a \<otimes>\<otimes> Fstack as S" by (rule both_above_arg1)
    also have "\<dots> \<sqsubseteq> substitute  (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (Var x)\<cdot>a \<otimes>\<otimes> Fstack as S)" by (rule substitute_above_arg)
    also have "pathsCard (paths \<dots>) x = prognosis ae as a (\<Gamma>, Var x, S) x" by simp
    finally
    show "once \<sqsubseteq> prognosis ae as a (\<Gamma>, Var x, S) x"
      by this (rule cont2cont_fun, intro cont2cont)+
  qed

  sublocale CardinalityPrognosisApp prognosis
  proof
    fix ae as a \<Gamma> e x S
    have "Texp e\<cdot>(inc\<cdot>a)  \<otimes>\<otimes> many_calls x \<otimes>\<otimes> Fstack as S = many_calls x  \<otimes>\<otimes> (Texp e)\<cdot>(inc\<cdot>a) \<otimes>\<otimes> Fstack as S"
      by (metis both_assoc both_comm)
    thus "prognosis ae as (inc\<cdot>a) (\<Gamma>, e, Arg x # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, App e x, S)"
      by simp (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_App)
  qed

  sublocale CardinalityPrognosisLam prognosis
  proof
    fix ae as a \<Gamma> e y x S
    have "Texp e[y::=x]\<cdot>(pred\<cdot>a) \<sqsubseteq> many_calls x  \<otimes>\<otimes> Texp (Lam [y]. e)\<cdot>a"
      by (rule below_trans[OF Texp_subst both_mono2'[OF Texp_Lam]])
    moreover have "Texp (Lam [y]. e)\<cdot>a \<otimes>\<otimes> many_calls x \<otimes>\<otimes> Fstack as S = many_calls x  \<otimes>\<otimes> Texp (Lam [y]. e)\<cdot>a \<otimes>\<otimes> Fstack as S"
      by (metis both_assoc both_comm)
    ultimately
    show "prognosis ae as (pred\<cdot>a) (\<Gamma>, e[y::=x], S) \<sqsubseteq> prognosis ae as a (\<Gamma>, Lam [y]. e, Arg x # S)"
      by simp (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1')
  qed

  sublocale CardinalityPrognosisVar prognosis
  proof
    fix \<Gamma> :: heap and e :: exp and x :: var and ae :: AEnv and as u a S
    assume "map_of \<Gamma> x = Some e"
    assume "ae x = up\<cdot>u"

    assume "isVal e"
    hence "x \<notin> thunks \<Gamma>" using `map_of \<Gamma> x = Some e` by (metis thunksE)
    hence [simp]: "f_nxt (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) x = FBinds \<Gamma>\<cdot>ae" by (auto simp add: f_nxt_def)

    have "prognosis ae as u (\<Gamma>, e, S) = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (nxt (single x) x \<otimes>\<otimes> Texp e\<cdot>u  \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((nxt (single x) x \<otimes>\<otimes> Fstack as S) \<otimes>\<otimes> Texp e\<cdot>u )))"
      by (metis both_assoc both_comm)
    also have "\<dots> \<sqsubseteq> pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (nxt (single x \<otimes>\<otimes> Fstack as S) x \<otimes>\<otimes> Texp e\<cdot>u)))"
      by (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1'  nxt_both_left) simp
    also have "\<dots> = pathsCard (paths (nxt (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S)) x))"
      using `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` by (simp add: Texp.AnalBinds_lookup)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S))))"
      by (rule pathsCard_paths_nxt)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((Texp (Var x)\<cdot>a) \<otimes>\<otimes> Fstack as S))))"
      by (intro monofun_cfun_arg pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_Var)
    also have "\<dots> = record_call x \<cdot>(prognosis ae as a (\<Gamma>, Var x, S))"
      by simp
    finally
    show "prognosis ae as u (\<Gamma>, e, S) \<sqsubseteq> record_call x\<cdot>(prognosis ae as a (\<Gamma>, Var x, S))" by this simp_all
  next
    fix \<Gamma> :: heap and e :: exp and x :: var and ae :: AEnv and as u a S
    assume "map_of \<Gamma> x = Some e"
    assume "ae x = up\<cdot>u"
    assume "\<not> isVal e"
    hence "x \<in> thunks \<Gamma>" using `map_of \<Gamma> x = Some e` by (metis thunksI)
    hence [simp]: "f_nxt (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) x = FBinds (delete x \<Gamma>)\<cdot>ae"
      by (auto simp add: f_nxt_def Texp.AnalBinds_delete_to_fun_upd empty_is_bottom)

    have "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks (delete x \<Gamma>)) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
       by (rule arg_cong[OF substitute_cong_T]) (auto simp add: empty_is_bottom)
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (nxt (single x) x \<otimes>\<otimes> Texp e\<cdot>u  \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) ((nxt (single x) x \<otimes>\<otimes> Fstack as S) \<otimes>\<otimes> Texp e\<cdot>u )))"
      by (metis both_assoc both_comm)
    also have "\<dots> \<sqsubseteq> pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (nxt (single x \<otimes>\<otimes> Fstack as S) x  \<otimes>\<otimes> Texp e\<cdot>u)))"
      by (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1'  nxt_both_left) simp
    also have "\<dots> = pathsCard (paths (nxt (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S)) x))"
      using `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` by (simp add: Texp.AnalBinds_lookup)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S))))"
      by (rule pathsCard_paths_nxt)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((Texp (Var x)\<cdot>a) \<otimes>\<otimes> Fstack as S))))"
      by (intro monofun_cfun_arg pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_Var)
    also have "\<dots> = record_call x \<cdot>(prognosis ae as a (\<Gamma>, Var x, S))"
      by simp
    finally
    show "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> record_call x\<cdot>(prognosis ae as a (\<Gamma>, Var x, S))" by this simp_all
  next
    fix \<Gamma> :: heap and e :: exp and ae :: AEnv and  x :: var and as S
    assume "isVal e"
    hence "repeatable (Texp e\<cdot>0)" by (rule Fun_repeatable)

    assume [simp]: "x \<notin> domA \<Gamma>"

    have [simp]: "thunks ((x, e) # \<Gamma>) = thunks \<Gamma>"
      using `isVal e`
      by (auto simp add: thunks_Cons dest: set_mp[OF thunks_domA])

    have "fup\<cdot>(Texp e)\<cdot>(ae x) \<sqsubseteq> Texp e\<cdot>0" by (metis fup2 monofun_cfun_arg up_zero_top)
    hence "substitute ((FBinds \<Gamma>\<cdot>ae)(x := fup\<cdot>(Texp e)\<cdot>(ae x))) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute ((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0)) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S)"
      by (intro substitute_mono1' fun_upd_mono below_refl monofun_cfun_arg)
    also have "\<dots> = substitute (((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0))(x := empty)) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S)"
      using `repeatable (Texp e\<cdot>0)` by (rule substitute_remove_anyways, simp)
    also have "((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0))(x := empty) = FBinds \<Gamma>\<cdot>ae"
      by (simp add: fun_upd_idem Texp.AnalBinds_not_there empty_is_bottom)
    finally
    show "prognosis ae as 0 ((x, e) # \<Gamma>, e, S) \<sqsubseteq> prognosis ae as 0 (\<Gamma>, e, Upd x # S)"
      by (simp, intro pathsCard_mono' paths_mono)
  qed

  sublocale CardinalityPrognosisIfThenElse prognosis
  proof
    fix ae as \<Gamma> scrut e1 e2 S a
    have "Texp scrut\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<sqsubseteq> Texp (scrut ? e1 : e2)\<cdot>a"
      by (rule Texp_IfThenElse)
    hence "substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp scrut\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (scrut ? e1 : e2)\<cdot>a \<otimes>\<otimes> Fstack as S)"
      by (rule substitute_mono2'[OF both_mono1'])
    thus "prognosis ae (a#as) 0 (\<Gamma>, scrut, Alts e1 e2 # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, scrut ? e1 : e2, S)"
      by (simp, intro pathsCard_mono' paths_mono)
  next
    fix ae as a \<Gamma> b e1 e2 S
    have "Texp (if b then e1 else e2)\<cdot>a \<sqsubseteq> Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a"
      by (auto simp add: either_above_arg1 either_above_arg2)
    hence "substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (if b then e1 else e2)\<cdot>a \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (Bool b)\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S)"
      by (rule substitute_mono2'[OF both_mono1'[OF below_trans[OF _ both_above_arg2]]])
    thus "prognosis ae as a (\<Gamma>, if b then e1 else e2, S) \<sqsubseteq> prognosis ae (a#as) 0 (\<Gamma>, Bool b, Alts e1 e2 # S)"
      by (auto intro!: pathsCard_mono' paths_mono)
  qed

end

context TTreeAnalysisCardinalityHeap
begin

  definition cHeap where
    "cHeap \<Gamma> e = (\<Lambda> a. pathsCard (paths (Theap \<Gamma> e\<cdot>a)))"

  lemma cHeap_simp: "(cHeap \<Gamma> e)\<cdot>a = pathsCard (paths (Theap \<Gamma> e\<cdot>a))"
    unfolding cHeap_def  by (rule beta_cfun) (intro cont2cont)

  sublocale CardinalityHeap cHeap.

  sublocale CardinalityHeapSafe cHeap Aheap
  proof
    fix x \<Gamma> e a
    assume "x \<in> thunks \<Gamma>"
    moreover
    assume "many \<sqsubseteq> (cHeap \<Gamma> e\<cdot>a) x"
    hence "many \<sqsubseteq> pathsCard (paths (Theap \<Gamma> e \<cdot>a)) x" unfolding cHeap_def by simp
    hence "\<exists>p\<in> (paths (Theap \<Gamma> e\<cdot>a)). \<not> (one_call_in_path x p)" unfolding pathsCard_def
      by (auto split: if_splits)
    ultimately
    show "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>0"
      by (metis Theap_thunk)
  next
    fix \<Gamma> e a
    show "edom (cHeap \<Gamma> e\<cdot>a) = edom (Aheap \<Gamma> e\<cdot>a)"
    by (simp add: cHeap_def Union_paths_carrier carrier_Fheap)
  qed

  sublocale CardinalityPrognosisEdom prognosis
  proof
    fix ae as a \<Gamma> e S
    show "edom (prognosis ae as a (\<Gamma>, e, S)) \<subseteq> fv \<Gamma> \<union> fv e \<union> fv S"
      apply (simp add: Union_paths_carrier)
      apply (rule carrier_substitute_below)
      apply (auto simp add: carrier_Fexp dest: set_mp[OF Aexp_edom] set_mp[OF carrier_Fstack] set_mp[OF ap_fv_subset] set_mp[OF carrier_FBinds])
      done
  qed

  sublocale CardinalityPrognosisLet prognosis cHeap
  proof
    fix \<Delta> \<Gamma> :: heap and e :: exp and S :: stack and  ae :: AEnv and a :: Arity and as
    assume "atom ` domA \<Delta> \<sharp>* \<Gamma>"
    assume "atom ` domA \<Delta> \<sharp>* S"
    assume "edom ae \<subseteq> domA \<Gamma> \<union> upds S"

    have "domA \<Delta> \<inter> edom ae = {}"
      using fresh_distinct[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`] fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* S`]
            `edom ae \<subseteq> domA \<Gamma> \<union> upds S` ups_fv_subset[of S]
      by auto

    have const_on1:  "\<And> x. const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (carrier ((FBinds \<Gamma>\<cdot>ae) x)) empty"
      unfolding const_on_edom_disj using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`]
      by (auto dest!: set_mp[OF carrier_FBinds] set_mp[OF Texp.edom_AnalBinds])
    have const_on2:  "const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (carrier (Fstack as S)) empty"
      unfolding const_on_edom_disj using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* S`]
      by (auto dest!: set_mp[OF carrier_FBinds] set_mp[OF carrier_Fstack] set_mp[OF Texp.edom_AnalBinds] set_mp[OF ap_fv_subset ])
    have  const_on3: "const_on (FBinds \<Gamma>\<cdot>ae) (- (- domA \<Delta>)) TTree.empty"
      and const_on4: "const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (domA \<Gamma>) TTree.empty"
      unfolding const_on_edom_disj using fresh_distinct[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`]
      by (auto dest!:  set_mp[OF Texp.edom_AnalBinds])

    have disj1: "\<And> x. carrier ((FBinds \<Gamma>\<cdot>ae) x) \<inter> domA \<Delta> = {}"
      using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`]
      by (auto dest: set_mp[OF carrier_FBinds])
    hence disj1': "\<And> x. carrier ((FBinds \<Gamma>\<cdot>ae) x) \<subseteq> - domA \<Delta>" by auto
    have disj2: "\<And> x. carrier (Fstack as S) \<inter> domA \<Delta> = {}"
      using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* S`] by (auto dest!: set_mp[OF carrier_Fstack])
    hence disj2': "carrier (Fstack as S) \<subseteq> - domA \<Delta>" by auto

    {
    fix x
    have "(FBinds (\<Delta> @ \<Gamma>)\<cdot>(ae \<squnion> Aheap \<Delta> e\<cdot>a)) x = (FBinds \<Gamma>\<cdot>ae) x \<otimes>\<otimes> (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x"
    proof (cases "x \<in> domA \<Delta>")
      case True
      have "map_of \<Gamma> x = None" using True fresh_distinct[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`] by (metis disjoint_iff_not_equal domA_def map_of_eq_None_iff)
      moreover
      have "ae x = \<bottom>" using True `domA \<Delta> \<inter> edom ae = {}` by auto
      ultimately
      show ?thesis using True
          by (auto simp add: Texp.AnalBinds_lookup empty_is_bottom[symmetric] cong: option.case_cong)
    next
      case False
      have "map_of \<Delta> x = None" using False by (metis domA_def map_of_eq_None_iff)
      moreover
      have "(Aheap \<Delta> e\<cdot>a) x = \<bottom>" using False using edom_Aheap by (metis contra_subsetD edomIff)
      ultimately
      show ?thesis using False
         by (auto simp add: Texp.AnalBinds_lookup empty_is_bottom[symmetric] cong: option.case_cong)
    qed
    }
    note FBinds = ext[OF this]

    {
    have "pathsCard (paths (substitute (FBinds (\<Delta> @ \<Gamma>)\<cdot>(Aheap \<Delta> e\<cdot>a \<squnion> ae)) (thunks (\<Delta> @ \<Gamma>)) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)))
      = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks (\<Delta> @ \<Gamma>)) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a))  (thunks (\<Delta> @ \<Gamma>))  (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))))"
       by (simp add: substitute_substitute[OF const_on1] FBinds)
    also have "substitute (FBinds \<Gamma>\<cdot>ae) (thunks (\<Delta> @ \<Gamma>)) = substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>)"
      apply (rule substitute_cong_T)
      using const_on3
      by (auto dest: set_mp[OF thunks_domA])
    also have "substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks (\<Delta> @ \<Gamma>)) = substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>)"
      apply (rule substitute_cong_T)
      using const_on4
      by (auto dest: set_mp[OF thunks_domA])
    also have "substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S) = substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S"
      by (rule substitute_only_empty_both[OF const_on2])
    also note calculation
    }
    note eq_imp_below[OF this]
    also
    note env_restr_split[where S = "domA \<Delta>"]
    also
    have "pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S))) f|` domA \<Delta>
        = pathsCard (paths (ttree_restr (domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a))))"
          by (simp add: filter_paths_conv_free_restr ttree_restr_both ttree_rest_substitute[OF disj1]  ttree_restr_is_empty[OF disj2])
    also
    have "ttree_restr (domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<sqsubseteq> Theap \<Delta> e\<cdot>a"  by (rule Theap_substitute)
    also
    have "pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S))) f|` (- domA \<Delta>) =
          pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (ttree_restr (- domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<otimes>\<otimes> Fstack as S)))"
          by (simp add: filter_paths_conv_free_restr2 ttree_rest_substitute2[OF disj1' const_on3] ttree_restr_both  ttree_restr_noop[OF disj2'])
    also have "ttree_restr (- domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a))  (thunks \<Delta>)  (Texp e\<cdot>a)) \<sqsubseteq> Texp (Terms.Let \<Delta> e)\<cdot>a" by (rule Texp_Let)
    finally
    show "prognosis (Aheap \<Delta> e\<cdot>a \<squnion> ae) as a (\<Delta> @ \<Gamma>, e, S) \<sqsubseteq> cHeap \<Delta> e\<cdot>a \<squnion> prognosis ae as a (\<Gamma>, Terms.Let \<Delta> e, S)"
      by (simp add: cHeap_def del: fun_meet_simp)
  qed

  sublocale CardinalityPrognosisSafe prognosis cHeap Aheap Aexp ..
end

end


(* Title:     Xml
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

header \<open>A Sum Type with Bottom Element\<close>

theory Strict_Sum
imports
  "~~/src/HOL/Library/Monad_Syntax"
  Error_Syntax
  "../Partial_Function_MR/Partial_Function_MR"
begin

datatype (dead 'e, 'a) sum_bot (infixr "+\<^sub>\<bottom>" 10) = Bottom | Left 'e | Right 'a for map: sum_bot_map

subsection \<open>Setup for Partial Functions\<close>

abbreviation sum_bot_ord :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a \<Rightarrow> bool"
where
  "sum_bot_ord \<equiv> flat_ord Bottom"

interpretation sum_bot!:
  partial_function_definitions sum_bot_ord "flat_lub Bottom"
  by (rule flat_interpretation)

declaration \<open>
Partial_Function.init
  "sum_bot"
  @{term sum_bot.fixp_fun}
  @{term sum_bot.mono_body}
  @{thm sum_bot.fixp_rule_uc}
  @{thm sum_bot.fixp_induct_uc}
  NONE
\<close>

subsection \<open>Monad Setup\<close>

fun bind :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'e +\<^sub>\<bottom> 'b"
where
  "bind Bottom f = Bottom" |
  "bind (Left e) f = Left e" |
  "bind (Right x) f = f x"

abbreviation mono_sum_bot :: "(('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'f +\<^sub>\<bottom> 'c) \<Rightarrow> bool"
where
  "mono_sum_bot \<equiv> monotone (fun_ord sum_bot_ord) sum_bot_ord"

(* TODO: perhaps use Partial_Function.bind_mono to proof this result immediately *)
lemma bind_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B" and mg: "\<And>y. mono_sum_bot (\<lambda>f. C y f)"
  shows "mono_sum_bot (\<lambda>f. bind (B f) (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then have "sum_bot_ord (bind (B f) (\<lambda>y. C y f)) (bind (B g) (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg have "\<And>y'. sum_bot_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "sum_bot_ord (bind (B g) (\<lambda>y'. C y' f)) (bind (B g) (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (sum_bot.leq_trans)
  show "sum_bot_ord (bind (B f) (\<lambda>y. C y f)) (bind (B g) (\<lambda>y'. C y' g))" .
qed

adhoc_overloading
  Monad_Syntax.bind bind

hide_const (open) bind

fun catch_error :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('e \<Rightarrow> ('f +\<^sub>\<bottom> 'a)) \<Rightarrow> 'f +\<^sub>\<bottom> 'a"
where
  "catch_error Bottom f = Bottom " |
  "catch_error (Left a) f = f a" |
  "catch_error (Right a) f = Right a"

adhoc_overloading
  Error_Syntax.catch catch_error

lemma catch_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B" and mg: "\<And>y. mono_sum_bot (\<lambda>f. C y f)"
  shows "mono_sum_bot (\<lambda>f. try (B f) catch (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then have "sum_bot_ord (try (B f) catch (\<lambda>y. C y f)) (try (B g) catch (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg
  have "\<And>y'. sum_bot_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "sum_bot_ord (try (B g) catch (\<lambda>y'. C y' f)) (try (B g) catch (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (sum_bot.leq_trans)
    show "sum_bot_ord (try (B f) catch (\<lambda>y. C y f)) (try (B g) catch (\<lambda>y'. C y' g))" .
qed

definition error :: "'e \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  [simp]: "error x = Left x"

definition return :: "'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  [simp]: "return x = Right x"

fun map_sum_bot :: "('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'a list \<Rightarrow> 'e +\<^sub>\<bottom> 'b list"
where
  "map_sum_bot f [] = return []" |
  "map_sum_bot f (x#xs) = do {
    y \<leftarrow> f x;
    ys \<leftarrow> map_sum_bot f xs;
    return (y # ys)
  }"

lemma map_sum_bot_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "map_sum_bot f xs = map_sum_bot g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemmas sum_bot_const_mono =
  sum_bot.const_mono [of "fun_ord sum_bot_ord"]

lemma map_sum_bot_mono [partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> ('e +\<^sub>\<bottom> 'c)) \<Rightarrow> 'e +\<^sub>\<bottom> 'd"
  assumes "\<And>y. y \<in> set B \<Longrightarrow> mono_sum_bot (C y)"
  shows "mono_sum_bot (\<lambda>f. map_sum_bot (\<lambda>y. C y f) B)"
  using assms by (induct B) (auto intro!: partial_function_mono)

abbreviation update_error :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 'f +\<^sub>\<bottom> 'a"
where
  "update_error r f \<equiv> try r catch (\<lambda> e. error (f e))"

adhoc_overloading
  Error_Syntax.update_error update_error

fun sumbot :: "'e + 'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  "sumbot (Inl x) = Left x" |
  "sumbot (Inr x) = Right x"

code_datatype sumbot

lemma [code]:
  "(try (sumbot a) catch f) = (case a of Inl b \<Rightarrow> f b | Inr a \<Rightarrow> sumbot (Inr a))"
  by (cases a) auto

lemma [code]: "Right x = sumbot (Inr x)" by simp

lemma [code]: "Left x = sumbot (Inl x)" by simp

lemma [code]: "return x = sumbot (Inr x)" by simp

lemma [code]: "error x = sumbot (Inl x)" by simp

lemma [code]:
  "case_sum_bot f g h (sumbot p) = case_sum g h p"
  by (cases p) auto

subsection \<open>Connection to @{theory Partial_Function_MR}\<close>

lemma sum_bot_map_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B"
  shows "mono_sum_bot (\<lambda>f. sum_bot_map h (B f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then show "sum_bot_ord (sum_bot_map h (B f)) (sum_bot_map h (B g))"
    unfolding flat_ord_def by auto
qed

declaration \<open>
Partial_Function_MR.init
  "sum_bot"
  (fn (mt, t_to_ss, mtT, msT, t_to_sTs) =>
      list_comb (Const (@{const_name sum_bot_map}, t_to_sTs ---> mtT --> msT), t_to_ss) $ mt)
  (fn (commonTs, argTs) => Type (@{type_name sum_bot}, commonTs @ argTs))
  (fn mT => Term.dest_Type mT |> #2 |> (fn [err, res] => ([err], [res])))
  @{thms sum_bot.map_comp}
  @{thms sum_bot.map_ident}
\<close>

end


(*  Title:      HOL/Auth/n_deadlock_lemma_inv__5_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

(*header{*The n_deadlock Protocol Case Study*}*)

theory n_deadlock_lemma_inv__5_on_rules imports n_deadlock_lemma_on_inv__5
begin
section{*All lemmas on causal relation between inv__5*}
lemma lemma_inv__5_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__5  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__5) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory Conntrack_State_Transform
imports Common_Primitive_Matcher
        "../Semantics_Ternary/Semantics_Ternary"
begin

text\<open>The following function assumes that the packet is in a certain state.\<close>

fun ctstate_assume_state :: "ctstate \<Rightarrow> 'i::len  common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
  "ctstate_assume_state s (Match (CT_State x)) = (if s \<in> x then MatchAny else MatchNot MatchAny)" |
  "ctstate_assume_state s (Match m) = Match m" |
  "ctstate_assume_state s (MatchNot m) = MatchNot (ctstate_assume_state s m)" |
  "ctstate_assume_state _ MatchAny = MatchAny" |
  "ctstate_assume_state s (MatchAnd m1 m2) = MatchAnd (ctstate_assume_state s m1) (ctstate_assume_state s m2)"

lemma ctstate_assume_state: "p_tag_ctstate p = s \<Longrightarrow>
    matches (common_matcher, \<alpha>) (ctstate_assume_state s m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
apply(rule matches_iff_apply_f)
by(induction m rule: ctstate_assume_state.induct) (simp_all)

definition ctstate_assume_new :: "'i::len  common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "ctstate_assume_new \<equiv> optimize_matches (ctstate_assume_state CT_New)"

lemma ctstate_assume_new_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (ctstate_assume_new rs)"
  by (simp add: ctstate_assume_new_def optimize_matches_simple_ruleset)

text\<open>Usually, the interesting part of a firewall is only about the rules for setting up connections.
      That means, we mostly only care about packets in state @{const CT_New}.
      Use the function @{const ctstate_assume_new} to remove all state matching and just care about
      the connection setup.
\<close>
corollary ctstate_assume_new: "p_tag_ctstate p = CT_New \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (ctstate_assume_new rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding ctstate_assume_new_def
apply(rule optimize_matches)
apply(simp add: ctstate_assume_state)
done

text\<open>If we assume the CT State is @{const CT_New}, we can also assume that the TCP SYN flag (@{const ipt_tcp_syn}) is set.\<close>

fun ipt_tcp_flags_assume_flag :: "ipt_tcp_flags \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
  "ipt_tcp_flags_assume_flag flg (Match (L4_Flags x)) = (if ipt_tcp_flags_equal x flg then MatchAny else (case match_tcp_flags_conjunct_option x flg of None \<Rightarrow> MatchNot MatchAny | Some f3 \<Rightarrow> Match (L4_Flags f3)))" |
  "ipt_tcp_flags_assume_flag flg (Match m) = Match m" |
  "ipt_tcp_flags_assume_flag flg (MatchNot m) = MatchNot (ipt_tcp_flags_assume_flag flg m)" |
  "ipt_tcp_flags_assume_flag _ MatchAny = MatchAny" |
  "ipt_tcp_flags_assume_flag flg (MatchAnd m1 m2) = MatchAnd (ipt_tcp_flags_assume_flag flg m1) (ipt_tcp_flags_assume_flag flg m2)"

lemma ipt_tcp_flags_assume_flag: assumes "match_tcp_flags flg (p_tcp_flags p)"
    shows "matches (common_matcher, \<alpha>) (ipt_tcp_flags_assume_flag flg m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
proof(rule matches_iff_apply_f)
show "ternary_ternary_eval (map_match_tac common_matcher p (ipt_tcp_flags_assume_flag flg m)) = ternary_ternary_eval (map_match_tac common_matcher p m)"
  using assms proof(induction m rule: ipt_tcp_flags_assume_flag.induct)
  case (1 flg x)
    thus ?case
    apply(simp add: ipt_tcp_flags_equal del: match_tcp_flags.simps)
    apply(cases "match_tcp_flags_conjunct_option x flg")
     apply(simp)
     using match_tcp_flags_conjunct_option_None bool_to_ternary_simps(2) apply metis
    apply(simp)
    apply(drule_tac pkt="(p_tcp_flags p)" in match_tcp_flags_conjunct_option_Some)
    by simp
  qed(simp_all del: match_tcp_flags.simps)
qed

definition ipt_tcp_flags_assume_syn :: "'i::len common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "ipt_tcp_flags_assume_syn \<equiv> optimize_matches (ipt_tcp_flags_assume_flag ipt_tcp_syn)"

lemma ipt_tcp_flags_assume_syn_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (ipt_tcp_flags_assume_syn rs)"
  by (simp add: ipt_tcp_flags_assume_syn_def optimize_matches_simple_ruleset)

corollary ipt_tcp_flags_assume_syn: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p) \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (ipt_tcp_flags_assume_syn rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding ipt_tcp_flags_assume_syn_def
apply(rule optimize_matches)
apply(simp add: ipt_tcp_flags_assume_flag)
done

definition packet_assume_new :: "'i::len common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "packet_assume_new \<equiv> ctstate_assume_new \<circ> ipt_tcp_flags_assume_syn"

lemma packet_assume_new_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (packet_assume_new rs)"
  by (simp add: packet_assume_new_def ipt_tcp_flags_assume_syn_simple_ruleset ctstate_assume_new_simple_ruleset)

corollary packet_assume_new: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p) \<Longrightarrow> p_tag_ctstate p = CT_New \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (packet_assume_new rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding packet_assume_new_def
by (simp add: ctstate_assume_new ipt_tcp_flags_assume_syn)

end


theory Affine_Arithmetic_Misc
  imports "HOL-ODE-Numerics.ODE_Numerics"
begin

section \<open>Branch-And-Bound Arithmetic\<close>

primrec prove_nonneg::"(nat * nat * string) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> slp \<Rightarrow> real aform list list \<Rightarrow> bool" where
  "prove_nonneg prnt 0 p slp X = (let _ = if prnt \<noteq> [] then print (STR ''# depth limit exceeded\<newline>'') else () in False)"
| "prove_nonneg prnt (Suc i) p slp XXS =
    (case XXS of [] \<Rightarrow> True | (X#XS) \<Rightarrow>
      let RS = approx_slp_outer p 1 slp X
      in if RS\<noteq>None \<and> Inf_aform' p (hd (the RS)) \<ge> 0
        then
          let _ = if prnt \<noteq> [] then print (STR ''# Success\<newline>'') else ();
             _ = if prnt \<noteq> [] then print (String.implode ((shows ''# '' o shows_box_of_aforms_hr X) ''\<newline>'')) else ();
             _ = fold (\<lambda>(a, b, c) _. print (String.implode (shows_segments_of_aform a b X c ''\<newline>''))) prnt ()
          in prove_nonneg prnt i p slp XS
        else let _ = if prnt \<noteq> [] then print (STR ''# Split\<newline>'') else () in case split_aforms_largest_uncond X of (a, b) \<Rightarrow>
          prove_nonneg prnt i p slp (a#b#XS))"

lemma prove_nonneg_simps[simp]:
  "prove_nonneg prnt 0 p slp X = False"
  "prove_nonneg prnt (Suc i) p slp XXS =
    (case XXS of [] \<Rightarrow> True | (X#XS) \<Rightarrow>
      let RS = approx_slp_outer p 1 slp X
      in if RS\<noteq>None \<and> Inf_aform' p (hd (the RS)) \<ge> 0
        then prove_nonneg prnt i p slp XS
        else case split_aforms_largest_uncond X of (a, b) \<Rightarrow> prove_nonneg prnt i p slp (a#b#XS))"
  by (auto simp: Let_def split: if_splits option.splits list.splits)

lemmas [simp del] = prove_nonneg.simps

lemma split_aforms_lemma:
  fixes xs::"real list"
  assumes "split_aforms XS i = (YS, ZS)"
  assumes "xs \<in> Joints XS"
  shows "xs \<in> Joints YS \<union> Joints ZS"
  using set_rev_mp[OF assms(2) Joints_map_split_aform[of XS i]] assms(1)
  by (auto simp: split_aforms_def o_def)

lemma prove_nonneg_empty[simp]: "prove_nonneg prnt (Suc i) p slp []"
  by simp

lemma prove_nonneg_fuel_mono:
  "prove_nonneg prnt (Suc i) p (slp_of_fas [fa]) YSS"
  if "prove_nonneg prnt i p (slp_of_fas [fa]) YSS"
  using that
proof (induction i arbitrary: YSS)
  case 0
  then show ?case by simp
next
  case (Suc i)
  from Suc.prems show ?case
    supply [simp del] = prove_nonneg_simps
    apply (subst prove_nonneg_simps)
    apply (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal apply (rule Suc.IH)
      apply (subst (asm) prove_nonneg_simps)
      by (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal apply (rule Suc.IH)
      apply (subst (asm) prove_nonneg.simps)
      by (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal apply (rule Suc.IH)
      apply (subst (asm) prove_nonneg.simps)
      by (auto simp: Let_def split: if_splits option.splits list.splits)
    done
qed

lemma prove_nonneg_mono:
  "prove_nonneg prnt i p (slp_of_fas [fa]) YSS" if "prove_nonneg prnt i p (slp_of_fas [fa]) (YS # YSS)"
  using that
proof (induction i arbitrary: YS YSS)
  case 0
  then show ?case by auto
next
  case (Suc i)
  from Suc.prems show ?case
    supply [simp del] = prove_nonneg_simps
    apply (subst (asm) prove_nonneg_simps)
    apply (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal by (rule prove_nonneg_fuel_mono)
    subgoal for x y apply (rule prove_nonneg_fuel_mono)
      apply (rule Suc.IH[of y])
      by (rule Suc.IH[of x])
    subgoal for x y apply (rule prove_nonneg_fuel_mono)
      apply (rule Suc.IH[of y])
      by (rule Suc.IH[of x])
    done
qed

lemma prove_nonneg:
  assumes "prove_nonneg prnt i p (slp_of_fas [fa]) XSS"
  shows "\<forall>XS \<in> set XSS. \<forall>xs \<in> Joints XS. interpret_floatarith fa xs \<ge> 0"
  using assms
proof (induction i arbitrary: XSS)
  case 0
  then show ?case
    by (auto )
next
  case (Suc i)
  show ?case
  proof (cases XSS)
    case Nil then show ?thesis by auto
  next
    case (Cons YS YSS)
    show ?thesis
      unfolding Cons
      apply auto
      subgoal for xs using Suc.prems
        apply (auto simp: Cons Let_def split: if_splits option.splits)
        subgoal for ys
          apply (drule approx_slp_outer_plain)
             apply (rule refl)
            apply force
           apply assumption
          apply simp
          apply (frule Joints_imp_length_eq[where XS=ys])
          apply (auto simp: Suc_length_conv)
          by (smt Inf_aform'_Affine_le)
        subgoal
          apply (simp add: split_aforms_largest_uncond_def split: prod.splits)
          apply (drule Suc.IH)
          apply (drule split_aforms_lemma, assumption)
          by auto
        subgoal
          apply (simp add: split_aforms_largest_uncond_def split: prod.splits)
          apply (drule Suc.IH)
          apply (drule split_aforms_lemma, assumption)
          by auto
        done
      subgoal for XS xs using Suc.prems
        apply (auto simp: Cons Let_def split: if_splits option.splits)
        subgoal for ys by (rule Suc.IH[rule_format], assumption, assumption, assumption)
        subgoal for ys
          apply (drule prove_nonneg_mono)
          apply (drule prove_nonneg_mono)
          by (rule Suc.IH[rule_format], assumption, assumption, assumption)
        subgoal for ys
          apply (drule prove_nonneg_mono)
          apply (drule prove_nonneg_mono)
          by (rule Suc.IH[rule_format], assumption, assumption, assumption)
        done
      done
  qed
qed

end