(*  Author: Tobias Nipkow, Dmitriy Traytel *)

section "Connection Between Derivatives and Partial Derivatives"

(*<*)
theory Deriv_PDeriv
imports Derivatives_Finite
begin
(*>*)

lemma pderiv_not_is_Zero_is_Plus[simp]: "\<forall>x \<in> pderiv a r. \<not> is_Zero x \<and> \<not> is_Plus x"
  by (induct r) auto

lemma finite_pderiv[simp]: "finite (pderiv a r)"
  by (induct r) auto

lemma PLUS_inject: "\<lbrakk>\<forall>x \<in> set xs \<union> set ys. \<not> is_Zero x \<and> \<not> is_Plus x; sorted xs; sorted ys\<rbrakk> \<Longrightarrow>
  (PLUS xs = PLUS ys) \<longleftrightarrow> xs = ys"
proof (induct xs arbitrary: ys rule: list_singleton_induct)
  case nil then show ?case by (induct ys rule: list_singleton_induct) auto
next
  case single then show ?case by (induct ys rule: list_singleton_induct) auto
next
  case cons then show ?case by (induct ys rule: list_singleton_induct) auto
qed

lemma sorted_list_of_set_inject: "\<lbrakk>finite R; finite S\<rbrakk> \<Longrightarrow>
  (sorted_list_of_set R = sorted_list_of_set S) \<longleftrightarrow> R = S"
proof (induct R arbitrary: S rule: finite_linorder_min_induct)
  case empty then show ?case
  proof (induct S rule: finite_linorder_min_induct)
    case (insert b S) then show ?case by simp (metis insort_not_Nil)
  qed simp
next
  case (insert a R) from this(4,1-3) show ?case
  proof (induct S rule: finite_linorder_min_induct)
    case (insert b S)
    show ?case
    proof
      assume "sorted_list_of_set (insert a R) = sorted_list_of_set (insert b S)"
      with insert(1,2,4,5) have "insort a (sorted_list_of_set R) = insort b (sorted_list_of_set S)"
        by fastforce
      with insert(2,5) have "a # sorted_list_of_set R = b # sorted_list_of_set S"
        apply (cases "sorted_list_of_set R" "sorted_list_of_set S" rule: list.exhaust[case_product list.exhaust])
        apply (auto split: if_splits simp add: not_le)
        using insort_not_Nil apply metis
        using insert.prems(1) set_sorted_list_of_set apply fastforce
        using insert.prems(1) set_sorted_list_of_set apply fastforce
        using insert.prems(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        done
      with insert show "insert a R = insert b S" by auto
    next
      assume "insert a R = insert b S"
      then show "sorted_list_of_set (insert a R) = sorted_list_of_set (insert b S)" by simp
    qed
  qed simp
qed

lemma flatten_PLUS_inject: "\<lbrakk>\<forall>x \<in> R \<union> S. \<not> is_Zero x \<and> \<not> is_Plus x; finite R; finite S\<rbrakk> \<Longrightarrow>
  (flatten PLUS R = flatten PLUS S) = (R = S)"
  by (rule trans[OF PLUS_inject sorted_list_of_set_inject]) auto

primrec pset where
  "pset Zero = {}"
| "pset One = {One}"
| "pset (Atom a) = {Atom a}"
| "pset (Plus r s) = pset r \<union> pset s"
| "pset (Times r s) = Timess (pset r) s"
| "pset (Star r) = {Star r}"

lemma pset_not_is_Zero_is_Plus[simp]: "\<forall>x \<in> pset r. \<not> is_Zero x \<and> \<not> is_Plus x"
  by (induct r) auto

lemma finite_pset[simp]: "finite (pset r)"
  by (induct r) auto

lemma pset_deriv: "pset (deriv a r) = pderiv a r"
  by (induct r) auto

definition pnorm where
  "pnorm = flatten PLUS o pset"

fun pnPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnPlus Zero r = r"
| "pnPlus r Zero = r"
| "pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
| "pnPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if le_rexp r s then Plus r (Plus s t)
     else Plus s (pnPlus r t))"
| "pnPlus r s =
     (if r = s then r
      else if le_rexp r s then Plus r s
      else Plus s r)"

fun pnTimes :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnTimes Zero r = Zero"
| "pnTimes (Plus r s) t = pnPlus (pnTimes r t) (pnTimes s t)"
| "pnTimes r s = Times r s"

primrec pnorm_alt :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnorm_alt Zero = Zero"
| "pnorm_alt One = One"
| "pnorm_alt (Atom a) = Atom a"
| "pnorm_alt (Plus r s) = pnPlus (pnorm_alt r) (pnorm_alt s)"
| "pnorm_alt (Times r s) = pnTimes (pnorm_alt r) s"
| "pnorm_alt (Star r) = Star r"

lemma pset_pnPlus:
  "pset (pnPlus r s) = pset (Plus r s)"
  by (induct r s rule: pnPlus.induct) auto

lemma pset_pnTimes:
  "pset (pnTimes r s) = pset (Times r s)"
  by (induct r s rule: pnTimes.induct) (auto simp: pset_pnPlus)

lemma pset_pnorm_alt_Times: "s \<in> pset r \<Longrightarrow> pnTimes (pnorm_alt s) t = Times (pnorm_alt s) t"
  by (induct r arbitrary: s t) auto

lemma pset_pnorm_alt:
  "pset (pnorm_alt r) = pnorm_alt ` pset r"
  by (induct r) (auto simp: pset_pnPlus pset_pnTimes pset_pnorm_alt_Times image_iff)

lemma pset_pnTimes_Times: "s \<in> pset r \<Longrightarrow> pnTimes s t = Times s t"
  by (induct r arbitrary: s t) auto

lemma pset_pnorm_alt_id: "s \<in> pset r \<Longrightarrow> pnorm_alt s = s"
  by (induct r arbitrary: s) (auto simp: pset_pnTimes_Times)

lemma pnorm_alt_image_pset: "pnorm_alt ` pset r = pset r"
  by (induction r) (auto, auto simp add: pset_pnorm_alt_id pset_pnTimes_Times image_iff)

lemma pnorm_pnorm_alt: "pnorm (pnorm_alt r) = pnorm r"
  by (induct r) (auto simp: pnorm_def pset_pnPlus pset_pnTimes pset_pnorm_alt pnorm_alt_image_pset)

lemma pnPlus_singleton_PLUS:
  "\<lbrakk>xs \<noteq> []; sorted xs; distinct xs; \<forall>x \<in> {x} \<union> set xs. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk> \<Longrightarrow>
  pnPlus x (PLUS xs) = (if x \<in> set xs then PLUS xs else PLUS (insort x xs))"
proof (induct xs rule: list_singleton_induct)
  case (single y)
  thus ?case unfolding is_Zero_def is_Plus_def
    apply (cases x y rule: linorder_cases)
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    apply (cases y)
    apply auto
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    done
next
  case (cons y1 y2 ys) thus ?case unfolding is_Zero_def is_Plus_def
    apply (cases x)
    apply (metis UnCI insertI1)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply (metis UnCI insertI1)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply simp apply (metis antisym less_eq_rexp_def)
    done
qed simp

lemma pnPlus_PlusL[simp]: "t \<noteq> Zero \<Longrightarrow> pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
  by (induct t) auto

lemma pnPlus_ZeroR[simp]: "pnPlus r Zero = r"
  by (induct r) auto

lemma PLUS_eq_Zero: "PLUS xs = Zero \<longleftrightarrow> xs = [] \<or> xs = [Zero]"
  by (induct xs rule: list_singleton_induct) auto

lemma pnPlus_PLUS:
  "\<lbrakk>xs1 \<noteq> []; xs2 \<noteq> []; \<forall>x \<in> set (xs1 @ xs2). \<not>is_Zero x \<and> \<not>is_Plus x; sorted xs2; distinct xs2\<rbrakk>\<Longrightarrow>
  pnPlus (PLUS xs1) (PLUS xs2) = flatten PLUS (set (xs1 @ xs2))"
proof (induct xs1 arbitrary: xs2 rule: list_singleton_induct)
  case (single x1)
  thus ?case
    apply (auto intro!: trans[OF pnPlus_singleton_PLUS]
      simp: insert_absorb simp del: sorted_list_of_set_insert_remove)
    apply (metis List.finite_set finite_sorted_distinct_unique sorted_list_of_set)
    apply (rule arg_cong[of _ _ PLUS])
    apply (metis remdups_id_iff_distinct sorted_list_of_set_sort_remdups sorted_sort_id)
    done
next
  case (cons x11 x12 xs1)
  then show ?case unfolding rexp_of_list.simps
  apply (subst pnPlus_PlusL)
  apply (unfold PLUS_eq_Zero) []
  apply (metis in_set_conv_decomp rexp.disc(1))
  apply (subst cons(1))
  apply (simp_all del: sorted_list_of_set_insert_remove)
  apply (rule trans[OF pnPlus_singleton_PLUS])
  apply (simp_all add: sorted_insort set_insort_key del: sorted_list_of_set_insert_remove)
  apply safe
  unfolding insert_commute[of x11]
  apply (auto simp only: Un_insert_left[of x11, symmetric] insert_absorb) []
  apply (auto simp only: Un_insert_right[of _ x11, symmetric] insert_absorb) []
  done
qed simp

lemma pnPlus_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; X2 \<noteq> {}; finite X1; finite X2; \<forall>x \<in> X1 \<union> X2.  \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnPlus (flatten PLUS X1) (flatten PLUS X2) = flatten PLUS (X1 \<union> X2)"
  by (rule trans[OF pnPlus_PLUS]) auto

lemma pnPlus_pnorm: "pnPlus (pnorm r) (pnorm s) = pnorm (Plus r s)"
  by (cases "pset r = {} \<or> pset s = {}")
    (auto simp: pnorm_def pset_pnPlus pset_pnorm_alt intro: pnPlus_flatten_PLUS)

lemma pnTimes_not_Zero_or_Plus[simp]: "\<lbrakk>\<not> is_Zero x; \<not> is_Plus x\<rbrakk> \<Longrightarrow> pnTimes x r = Times x r"
  by (cases x) auto

lemma pnTimes_PLUS:
  "\<lbrakk>xs \<noteq> []; \<forall>x \<in> set xs. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnTimes (PLUS xs) r = flatten PLUS (Timess (set xs) r)"
proof (induct xs arbitrary: r rule: list_singleton_induct)
  case (cons x y xs) then show ?case unfolding rexp_of_list.simps pnTimes.simps
  apply (subst pnTimes_not_Zero_or_Plus)
  apply (simp_all add: sorted_insort set_insort_key del: sorted_list_of_set_insert_remove)
  apply (subst pnPlus_singleton_PLUS)
  apply (simp_all add: sorted_insort set_insort_key del: sorted_list_of_set_insert_remove)
  unfolding insert_commute[of "Times y r"]
  apply (simp del: sorted_list_of_set_insert_remove)
  apply safe
  apply (subst insert_absorb[of "Times x r"])
  apply simp_all
  done
qed auto

lemma pnTimes_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; finite X1; \<forall>x \<in> X1. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnTimes (flatten PLUS X1) r = flatten PLUS (Timess X1 r)"
  by (rule trans[OF pnTimes_PLUS]) auto

lemma pnTimes_pnorm: "pnTimes (pnorm r1) r2 = pnorm (Times r1 r2)"
  by (cases "pset r1 = {}")
    (auto simp: pnorm_def pset_pnTimes pset_pnorm_alt intro: pnTimes_flatten_PLUS)

lemma pnorm_alt[symmetric]: "pnorm_alt r = pnorm r"
  by (induct r) (simp_all only: pnorm_alt.simps pnPlus_pnorm pnTimes_pnorm, auto simp: pnorm_def)

lemma insort_eq_Cons: "\<lbrakk>\<forall>a \<in> set xs. b < a; sorted xs\<rbrakk> \<Longrightarrow> insort b xs = b # xs"
  by (cases xs) auto

lemma pderiv_PLUS: "pderiv a (PLUS (x # xs)) = pderiv a x \<union> pderiv a (PLUS xs)"
  by (cases xs) auto

lemma pderiv_set_flatten_PLUS:
   "finite X \<Longrightarrow> pderiv (a :: 'a :: linorder) (flatten PLUS X) = pderiv_set a X"
proof (induction X rule: finite_linorder_min_induct)
  case (insert b X)
  then have "b \<notin> X" by auto
  then have "pderiv a (flatten PLUS (insert b X)) = pderiv a b \<union> pderiv a (flatten PLUS X)"
    by (simp add: pderiv_PLUS insort_eq_Cons insert.hyps)
  also from insert.IH have "\<dots> = pderiv a b \<union> pderiv_set a X" by simp
  finally show ?case by simp
qed simp

lemma fold_pderiv_set_flatten_PLUS:
  "\<lbrakk>w \<noteq> []; finite X\<rbrakk> \<Longrightarrow> fold pderiv_set w {flatten PLUS X} = fold pderiv_set w X"
  by (induct w arbitrary: X) (simp_all add: pderiv_set_flatten_PLUS)

lemma fold_pnorm_deriv:
  "fold (\<lambda>a r. pnorm (deriv a r)) w s = flatten PLUS (fold pderiv_set w {s})"
proof (induction w arbitrary: s)
  case (Cons x w) then show ?case
  proof (cases "w = []")
    case False
    show ?thesis using fold_pderiv_set_flatten_PLUS[OF False] Cons.IH
      by (auto simp: pnorm_def pset_deriv)
  qed (simp add: pnorm_def pset_deriv)
qed simp

primrec
  pnderiv :: "'a :: linorder \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "pnderiv c (Zero) = Zero"
| "pnderiv c (One) = Zero"
| "pnderiv c (Atom c') = (if c = c' then One else Zero)"
| "pnderiv c (Plus r1 r2) = pnPlus (pnderiv c r1) (pnderiv c r2)"
| "pnderiv c (Times r1 r2) =
    (if nullable r1 then pnPlus (pnTimes (pnderiv c r1) r2) (pnderiv c r2) else pnTimes (pnderiv c r1) r2)"
| "pnderiv c (Star r) = pnTimes (pnderiv c r) (Star r)"

lemma pnderiv_alt[code]: "pnderiv a r = pnorm (deriv a r)"
  by (induct r) (auto simp: pnorm_alt)

lemma pnderiv_pderiv: "pnderiv a r = flatten PLUS (pderiv a r)"
  unfolding pnderiv_alt pnorm_def o_apply pset_deriv ..

(*<*)
end
(*>*)


section \<open>Conditional Elimination Phase\<close>

theory ConditionalElimination
  imports
    Semantics.IRTreeEvalThms
    Proofs.Rewrites
    Proofs.Bisimulation
begin

subsection \<open>Individual Elimination Rules\<close>

text \<open>The set of rules used for determining whether a condition @{term q1} implies
    another condition @{term q2} or its negation.
    These rules are used for conditional elimination.\<close>

inductive impliesx :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> bool" ("_ \<Rrightarrow> _") and
      impliesnot :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> bool" ("_ \<Rrightarrow>\<not> _") where
  q_imp_q:
  "q \<Rrightarrow> q" |
  eq_impliesnot_less:
  "(BinaryExpr BinIntegerEquals x y) \<Rrightarrow>\<not> (BinaryExpr BinIntegerLessThan x y)" |
  eq_impliesnot_less_rev:
  "(BinaryExpr BinIntegerEquals x y) \<Rrightarrow>\<not> (BinaryExpr BinIntegerLessThan y x)" |
  less_impliesnot_rev_less:
  "(BinaryExpr BinIntegerLessThan x y) \<Rrightarrow>\<not> (BinaryExpr BinIntegerLessThan y x)" |
  less_impliesnot_eq:
  "(BinaryExpr BinIntegerLessThan x y) \<Rrightarrow>\<not> (BinaryExpr BinIntegerEquals x y)" |
  less_impliesnot_eq_rev:
  "(BinaryExpr BinIntegerLessThan x y) \<Rrightarrow>\<not> (BinaryExpr BinIntegerEquals y x)" |
  negate_true:
  "\<lbrakk>x \<Rrightarrow>\<not> y\<rbrakk> \<Longrightarrow> x \<Rrightarrow> (UnaryExpr UnaryLogicNegation y)" |
  negate_false:
  "\<lbrakk>x \<Rrightarrow> y\<rbrakk> \<Longrightarrow> x \<Rrightarrow>\<not> (UnaryExpr UnaryLogicNegation y)"

text \<open>The relation @{term "q1 \<Rrightarrow> q2"} indicates that the implication @{term "q1 \<longrightarrow> q2"}
    is known true (i.e. universally valid),
    and the relation @{term "q1 \<Rrightarrow>\<not> q2"} indicates that the implication @{term "q1 \<longrightarrow> q2"}
    is known false (i.e. @{term "q1 \<longrightarrow>\<not> q2"} is universally valid.
    If neither @{term "q1 \<Rrightarrow> q2"} nor @{term "q1 \<Rrightarrow>\<not> q2"} then the status is unknown.
    Only the known true and known false cases can be used for conditional elimination.\<close>

fun implies_valid :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> bool" (infix "\<Zinj>" 50) where
  "implies_valid q1 q2 =
    (\<forall>m p v1 v2. ([m, p] \<turnstile> q1 \<mapsto> v1) \<and> ([m,p] \<turnstile> q2 \<mapsto> v2) \<longrightarrow>
            (val_to_bool v1 \<longrightarrow> val_to_bool v2))"

fun impliesnot_valid :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> bool" (infix "\<Zpinj>" 50) where
  "impliesnot_valid q1 q2 =
    (\<forall>m p v1 v2. ([m, p] \<turnstile> q1 \<mapsto> v1) \<and> ([m,p] \<turnstile> q2 \<mapsto> v2) \<longrightarrow>
            (val_to_bool v1 \<longrightarrow> \<not>val_to_bool v2))"

text \<open>The relation @{term "q1 \<Zinj> q2"} means @{term "q1 \<longrightarrow> q2"} is universally valid,
      and the relation @{term "q1 \<Zpinj> q2"} means @{term "q1 \<longrightarrow> \<not>q2"} is universally valid.\<close>

lemma eq_impliesnot_less_helper:
  "v1 = v2 \<longrightarrow> \<not>(int_signed_value b v1 < int_signed_value b v2)"
  by force

lemma eq_impliesnot_less_val:
  "val_to_bool(intval_equals v1 v2) \<longrightarrow> \<not>val_to_bool(intval_less_than v1 v2)"
  using eq_impliesnot_less_helper bool_to_val.simps bool_to_val_bin.simps intval_equals.simps
    intval_less_than.elims val_to_bool.elims val_to_bool.simps
  by (smt (verit))

lemma eq_impliesnot_less_rev_val:
  "val_to_bool(intval_equals v1 v2) \<longrightarrow> \<not>val_to_bool(intval_less_than v2 v1)"
proof -
  have a: "intval_equals v1 v2 = intval_equals v2 v1"
    using bool_to_val_bin.simps intval_equals.simps intval_equals.elims
    by (smt (verit))
  show ?thesis using a eq_impliesnot_less_val by presburger
qed

lemma less_impliesnot_rev_less_val:
  "val_to_bool(intval_less_than v1 v2) \<longrightarrow> \<not>val_to_bool(intval_less_than v2 v1)"
  by (smt (verit, del_insts) Value.exhaust Value.inject(1) bool_to_val.simps(2)
      bool_to_val_bin.simps intval_less_than.simps(1) intval_less_than.simps(5)
      intval_less_than.simps(6) intval_less_than.simps(7) val_to_bool.elims(2))

lemma less_impliesnot_eq_val:
  "val_to_bool(intval_less_than v1 v2) \<longrightarrow> \<not>val_to_bool(intval_equals v1 v2)"
  using eq_impliesnot_less_val by blast

lemma logic_negate_type:
  assumes "[m, p] \<turnstile> UnaryExpr UnaryLogicNegation x \<mapsto> v"
  shows "\<exists>b v2. [m, p] \<turnstile> x \<mapsto> IntVal b v2"
  using assms
  by (metis UnaryExprE intval_logic_negation.elims unary_eval.simps(4))

lemma intval_logic_negation_inverse:
  assumes "b > 0"
  assumes "x = IntVal b v"
  shows "val_to_bool (intval_logic_negation x) \<longleftrightarrow> \<not>(val_to_bool x)"
  using assms by (cases x; auto simp: logic_negate_def)

lemma logic_negation_relation_tree:
  assumes "[m, p] \<turnstile> y \<mapsto> val"
  assumes "[m, p] \<turnstile> UnaryExpr UnaryLogicNegation y \<mapsto> invval"
  shows "val_to_bool val \<longleftrightarrow> \<not>(val_to_bool invval)"
  using assms using intval_logic_negation_inverse
  by (metis UnaryExprE evalDet eval_bits_1_64 logic_negate_type unary_eval.simps(4))

text \<open>The following theorem shows that the known true/false rules are valid.\<close>

theorem implies_impliesnot_valid:
  shows "((q1 \<Rrightarrow> q2) \<longrightarrow> (q1 \<Zinj> q2)) \<and>
         ((q1 \<Rrightarrow>\<not> q2) \<longrightarrow> (q1 \<Zpinj> q2))"
          (is "(?imp \<longrightarrow> ?val) \<and> (?notimp \<longrightarrow> ?notval)")
proof (induct q1 q2  rule: impliesx_impliesnot.induct)
  case (q_imp_q q)
  then show ?case
    using evalDet by fastforce
next
  case (eq_impliesnot_less x y)
  then show ?case apply auto using eq_impliesnot_less_val evalDet by blast
next
  case (eq_impliesnot_less_rev x y)
  then show ?case apply auto using eq_impliesnot_less_rev_val evalDet by blast
next
  case (less_impliesnot_rev_less x y)
  then show ?case apply auto using less_impliesnot_rev_less_val evalDet by blast
next
  case (less_impliesnot_eq x y)
  then show ?case apply auto using less_impliesnot_eq_val evalDet by blast
next
  case (less_impliesnot_eq_rev x y)
  then show ?case apply auto using eq_impliesnot_less_rev_val evalDet by metis
next
  case (negate_true x y)
  then show ?case apply auto
    by (metis logic_negation_relation_tree unary_eval.simps(4) unfold_unary)
next
  case (negate_false x y)
  then show ?case apply auto
    by (metis UnaryExpr logic_negation_relation_tree unary_eval.simps(4))
qed

text \<open>
We introduce a type @{term "TriState"} (as in the GraalVM compiler) to represent when static
analysis can tell us information about the value of a Boolean expression.
If @{term "Unknown"} then no information can be inferred and if
@{term "KnownTrue"}/@{term "KnownFalse"} one can infer the expression is always true/false.
\<close>
datatype TriState = Unknown | KnownTrue | KnownFalse

text \<open>
The implies relation corresponds to the LogicNode.implies
method from the compiler which attempts to infer when one
logic nodes value can be inferred from a known logic node.
\<close>
inductive implies :: "IRGraph \<Rightarrow> IRNode \<Rightarrow> IRNode \<Rightarrow> TriState \<Rightarrow> bool"
  ("_ \<turnstile> _ & _ \<hookrightarrow> _") for g where
  eq_imp_less:
  "g \<turnstile> (IntegerEqualsNode x y) & (IntegerLessThanNode x y) \<hookrightarrow> KnownFalse" |
  eq_imp_less_rev:
  "g \<turnstile> (IntegerEqualsNode x y) & (IntegerLessThanNode y x) \<hookrightarrow> KnownFalse" |
  less_imp_rev_less:
  "g \<turnstile> (IntegerLessThanNode x y) & (IntegerLessThanNode y x) \<hookrightarrow> KnownFalse" |
  less_imp_not_eq:
  "g \<turnstile> (IntegerLessThanNode x y) & (IntegerEqualsNode x y) \<hookrightarrow> KnownFalse" |
  less_imp_not_eq_rev:
  "g \<turnstile> (IntegerLessThanNode x y) & (IntegerEqualsNode y x) \<hookrightarrow> KnownFalse" |

  x_imp_x:
  "g \<turnstile> x & x \<hookrightarrow> KnownTrue" |

  negate_false:
  "\<lbrakk>g \<turnstile> x & (kind g y) \<hookrightarrow> KnownTrue\<rbrakk> \<Longrightarrow> g \<turnstile> x & (LogicNegationNode y) \<hookrightarrow> KnownFalse" |
  negate_true:
  "\<lbrakk>g \<turnstile> x & (kind g y) \<hookrightarrow> KnownFalse\<rbrakk> \<Longrightarrow> g \<turnstile> x & (LogicNegationNode y) \<hookrightarrow> KnownTrue"

text \<open>Total relation over partial implies relation\<close>
inductive condition_implies :: "IRGraph \<Rightarrow> IRNode \<Rightarrow> IRNode \<Rightarrow> TriState \<Rightarrow> bool"
  ("_ \<turnstile> _ & _ \<rightharpoonup> _") for g where
  "\<lbrakk>\<not>(g \<turnstile> a & b \<hookrightarrow> imp)\<rbrakk> \<Longrightarrow> (g \<turnstile> a & b \<rightharpoonup> Unknown)" |
  "\<lbrakk>(g \<turnstile> a & b \<hookrightarrow> imp)\<rbrakk> \<Longrightarrow> (g \<turnstile> a & b \<rightharpoonup> imp)"

inductive implies_tree :: "IRExpr \<Rightarrow> IRExpr \<Rightarrow> bool \<Rightarrow> bool"
  ("_ & _ \<hookrightarrow> _") where
  eq_imp_less:
  "(BinaryExpr BinIntegerEquals x y) & (BinaryExpr BinIntegerLessThan x y) \<hookrightarrow> False" |
  eq_imp_less_rev:
  "(BinaryExpr BinIntegerEquals x y) & (BinaryExpr BinIntegerLessThan y x) \<hookrightarrow> False" |
  less_imp_rev_less:
  "(BinaryExpr BinIntegerLessThan x y) & (BinaryExpr BinIntegerLessThan y x) \<hookrightarrow> False" |
  less_imp_not_eq:
  "(BinaryExpr BinIntegerLessThan x y) & (BinaryExpr BinIntegerEquals x y) \<hookrightarrow> False" |
  less_imp_not_eq_rev:
  "(BinaryExpr BinIntegerLessThan x y) & (BinaryExpr BinIntegerEquals y x) \<hookrightarrow> False" |
  x_imp_x:
  "x & x \<hookrightarrow> True" |
  negate_false:
  "\<lbrakk>x & y \<hookrightarrow> True\<rbrakk> \<Longrightarrow> x & (UnaryExpr UnaryLogicNegation y) \<hookrightarrow> False" |
  negate_true:
  "\<lbrakk>x & y \<hookrightarrow> False\<rbrakk> \<Longrightarrow> x & (UnaryExpr UnaryLogicNegation y) \<hookrightarrow> True"

text \<open>
Proofs that the implies relation is correct with respect to the
existing evaluation semantics.
\<close>

lemma logic_negation_relation:
  assumes "[g, m, p] \<turnstile> y \<mapsto> val"
  assumes "kind g neg = LogicNegationNode y"
  assumes "[g, m, p] \<turnstile> neg \<mapsto> invval"
  assumes "invval \<noteq> UndefVal"
  shows "val_to_bool val \<longleftrightarrow> \<not>(val_to_bool invval)"
  using assms
  by (metis LogicNegationNode encodeeval_def logic_negation_relation_tree repDet)

lemma implies_valid:
  assumes "x & y \<hookrightarrow> imp"
  assumes "[m, p] \<turnstile> x \<mapsto> v1"
  assumes "[m, p] \<turnstile> y \<mapsto> v2"
  shows "(imp \<longrightarrow> (val_to_bool v1 \<longrightarrow> val_to_bool v2)) \<and>
         (\<not>imp \<longrightarrow> (val_to_bool v1 \<longrightarrow> \<not>(val_to_bool v2)))"
    (is "(?TP \<longrightarrow> ?TC) \<and> (?FP \<longrightarrow> ?FC)")
  apply (intro conjI; rule impI)
proof -
  assume KnownTrue: ?TP
  show ?TC
  using assms(1) KnownTrue assms(2-) proof (induct x y imp rule: implies_tree.induct)
    case (eq_imp_less x y)
    then show ?case by simp
  next
    case (eq_imp_less_rev x y)
    then show ?case by simp
  next
    case (less_imp_rev_less x y)
    then show ?case by simp
  next
    case (less_imp_not_eq x y)
    then show ?case by simp
  next
    case (less_imp_not_eq_rev x y)
    then show ?case by simp
  next
    case (x_imp_x)
    then show ?case
      by (metis evalDet)
  next
    case (negate_false x1)
    then show ?case using evalDet
      using assms(2,3) by blast
  next
    case (negate_true x y)
    then show ?case
      using logic_negation_relation_tree sorry
  qed
next
  assume KnownFalse: ?FP
  show ?FC using assms KnownFalse proof (induct x y imp rule: implies_tree.induct)
    case (eq_imp_less x y)
    obtain xval where xval: "[m, p] \<turnstile> x \<mapsto> xval"
      using eq_imp_less(1) eq_imp_less.prems(3)
      by blast
    then obtain yval where yval: "[m, p] \<turnstile> y \<mapsto> yval"
      using eq_imp_less.prems(3)
      using eq_imp_less.prems(2) by blast
    have eqeval: "[m, p] \<turnstile> (BinaryExpr BinIntegerEquals x y) \<mapsto> intval_equals xval yval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(11) eq_imp_less.prems(1) evalDet)
    have lesseval: "[m, p] \<turnstile> (BinaryExpr BinIntegerLessThan x y) \<mapsto> intval_less_than xval yval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(12) eq_imp_less.prems(2) evalDet)
    have "val_to_bool (intval_equals xval yval) \<longrightarrow> \<not>(val_to_bool (intval_less_than xval yval))"
      apply (cases xval; cases yval; auto)
      by (smt (verit, best) bool_to_val.simps(2) val_to_bool.simps(1))
    then show ?case
      using eqeval lesseval
      by (metis eq_imp_less.prems(1) eq_imp_less.prems(2) evalDet)
  next
    case (eq_imp_less_rev x y)
    obtain xval where xval: "[m, p] \<turnstile> x \<mapsto> xval"
      using eq_imp_less_rev.prems(3)
      using eq_imp_less_rev.prems(2) by blast
    obtain yval where yval: "[m, p] \<turnstile> y \<mapsto> yval"
      using eq_imp_less_rev.prems(3)
      using eq_imp_less_rev.prems(2) by blast
    have eqeval: "[m, p] \<turnstile> (BinaryExpr BinIntegerEquals x y) \<mapsto> intval_equals xval yval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(11) eq_imp_less_rev.prems(1) evalDet)
    have lesseval: "[m, p] \<turnstile> (BinaryExpr BinIntegerLessThan y x) \<mapsto> intval_less_than yval xval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(12) eq_imp_less_rev.prems(2) evalDet)
    have "val_to_bool (intval_equals xval yval) \<longrightarrow> \<not>(val_to_bool (intval_less_than yval xval))"
      apply (cases xval; cases yval; auto)
      by (metis (full_types) bool_to_val.simps(2) less_irrefl val_to_bool.simps(1))
    then show ?case
      using eqeval lesseval
      by (metis eq_imp_less_rev.prems(1) eq_imp_less_rev.prems(2) evalDet)
  next
    case (less_imp_rev_less x y)
    obtain xval where xval: "[m, p] \<turnstile> x \<mapsto> xval"
      using less_imp_rev_less.prems(3)
      using less_imp_rev_less.prems(2) by blast
    obtain yval where yval: "[m, p] \<turnstile> y \<mapsto> yval"
      using less_imp_rev_less.prems(3)
      using less_imp_rev_less.prems(2) by blast
    have lesseval: "[m, p] \<turnstile> (BinaryExpr BinIntegerLessThan x y) \<mapsto> intval_less_than xval yval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(12) evalDet less_imp_rev_less.prems(1))
    have revlesseval: "[m, p] \<turnstile> (BinaryExpr BinIntegerLessThan y x) \<mapsto> intval_less_than yval xval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(12) evalDet less_imp_rev_less.prems(2))
    have "val_to_bool (intval_less_than xval yval) \<longrightarrow> \<not>(val_to_bool (intval_less_than yval xval))"
      apply (cases xval; cases yval; auto)
      by (smt (verit) bool_to_val.simps(2) val_to_bool.simps(1))
    then show ?case
      by (metis evalDet less_imp_rev_less.prems(1) less_imp_rev_less.prems(2) lesseval revlesseval)
  next
    case (less_imp_not_eq x y)
    obtain xval where xval: "[m, p] \<turnstile> x \<mapsto> xval"
      using less_imp_not_eq.prems(3)
      using less_imp_not_eq.prems(1) by blast
    obtain yval where yval: "[m, p] \<turnstile> y \<mapsto> yval"
      using less_imp_not_eq.prems(3)
      using less_imp_not_eq.prems(1) by blast
    have eqeval: "[m, p] \<turnstile> (BinaryExpr BinIntegerEquals x y) \<mapsto> intval_equals xval yval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(11) evalDet less_imp_not_eq.prems(2))
    have lesseval: "[m, p] \<turnstile> (BinaryExpr BinIntegerLessThan x y) \<mapsto> intval_less_than xval yval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(12) evalDet less_imp_not_eq.prems(1))
    have "val_to_bool (intval_less_than xval yval) \<longrightarrow> \<not>(val_to_bool (intval_equals xval yval))"
      apply (cases xval; cases yval; auto)
      by (smt (verit, best) bool_to_val.simps(2) val_to_bool.simps(1))
    then show ?case
      by (metis eqeval evalDet less_imp_not_eq.prems(1) less_imp_not_eq.prems(2) lesseval)
  next
    case (less_imp_not_eq_rev x y)
    obtain xval where xval: "[m, p] \<turnstile> x \<mapsto> xval"
      using less_imp_not_eq_rev.prems(3)
      using less_imp_not_eq_rev.prems(1) by blast
    obtain yval where yval: "[m, p] \<turnstile> y \<mapsto> yval"
      using less_imp_not_eq_rev.prems(3)
      using less_imp_not_eq_rev.prems(1) by blast
    have eqeval: "[m, p] \<turnstile> (BinaryExpr BinIntegerEquals y x) \<mapsto> intval_equals yval xval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(11) evalDet less_imp_not_eq_rev.prems(2))
    have lesseval: "[m, p] \<turnstile> (BinaryExpr BinIntegerLessThan x y) \<mapsto> intval_less_than xval yval"
      using xval yval evaltree.BinaryExpr
      by (metis BinaryExprE bin_eval.simps(12) evalDet less_imp_not_eq_rev.prems(1))
    have "val_to_bool (intval_less_than xval yval) \<longrightarrow> \<not>(val_to_bool (intval_equals yval xval))"
      apply (cases xval; cases yval; auto)
      by (smt (verit, best) bool_to_val.simps(2) val_to_bool.simps(1))
    then show ?case
      by (metis eqeval evalDet less_imp_not_eq_rev.prems(1) less_imp_not_eq_rev.prems(2) lesseval)
  next
    case (x_imp_x x1)
    then show ?case by simp
  next
    case (negate_false x y)
    then show ?case sorry
  next
    case (negate_true x1)
    then show ?case by simp
  qed
qed

lemma implies_true_valid:
  assumes "x & y \<hookrightarrow> imp"
  assumes "imp"
  assumes "[m, p] \<turnstile> x \<mapsto> v1"
  assumes "[m, p] \<turnstile> y \<mapsto> v2"
  shows "val_to_bool v1 \<longrightarrow> val_to_bool v2"
  using assms implies_valid
  by blast

lemma implies_false_valid:
  assumes "x & y \<hookrightarrow> imp"
  assumes "\<not>imp"
  assumes "[m, p] \<turnstile> x \<mapsto> v1"
  assumes "[m, p] \<turnstile> y \<mapsto> v2"
  shows "val_to_bool v1 \<longrightarrow> \<not>(val_to_bool v2)"
  using assms implies_valid by blast

text \<open>
The following relation corresponds to the UnaryOpLogicNode.tryFold
and BinaryOpLogicNode.tryFold methods and their associated concrete implementations.

The relation determines if a logic operation can be shown true or false
through the stamp typing information.
\<close>
inductive tryFold :: "IRNode \<Rightarrow> (ID \<Rightarrow> Stamp) \<Rightarrow> bool \<Rightarrow> bool"
  where
  "\<lbrakk>alwaysDistinct (stamps x) (stamps y)\<rbrakk>
    \<Longrightarrow> tryFold (IntegerEqualsNode x y) stamps False" |
  "\<lbrakk>neverDistinct (stamps x) (stamps y)\<rbrakk>
    \<Longrightarrow> tryFold (IntegerEqualsNode x y) stamps True" |
  "\<lbrakk>is_IntegerStamp (stamps x);
    is_IntegerStamp (stamps y);
    stpi_upper (stamps x) < stpi_lower (stamps y)\<rbrakk>
    \<Longrightarrow> tryFold (IntegerLessThanNode x y) stamps True" |
  "\<lbrakk>is_IntegerStamp (stamps x);
    is_IntegerStamp (stamps y);
    stpi_lower (stamps x) \<ge> stpi_upper (stamps y)\<rbrakk>
    \<Longrightarrow> tryFold (IntegerLessThanNode x y) stamps False"

text \<open>
Proofs that show that when the stamp lookup function is well-formed,
the tryFold relation correctly predicts the output value with respect to
our evaluation semantics.
\<close>
lemma
  assumes "kind g nid = IntegerEqualsNode x y"
  assumes "[g, m, p] \<turnstile> nid \<mapsto> v"
  assumes "([g, m, p] \<turnstile> x \<mapsto> xval) \<and> ([g, m, p] \<turnstile> y \<mapsto> yval)"
  shows "val_to_bool (intval_equals xval yval) \<longleftrightarrow> v = IntVal 32 1"
proof -
  have "v = intval_equals xval yval"
    using assms(1, 2, 3) BinaryExprE IntegerEqualsNode bin_eval.simps(7)
    by (smt (verit) bin_eval.simps(11) encodeeval_def evalDet repDet)
  then show ?thesis using intval_equals.simps val_to_bool.simps
    by (smt (verit) bool_to_val.simps(1) bool_to_val.simps(2) bool_to_val_bin.simps
        intval_equals.elims one_neq_zero)
qed

lemma tryFoldIntegerEqualsAlwaysDistinct:
  assumes "wf_stamp g stamps"
  assumes "kind g nid = (IntegerEqualsNode x y)"
  assumes "[g, m, p] \<turnstile> nid \<mapsto> v"
  assumes "alwaysDistinct (stamps x) (stamps y)"
  shows "v = IntVal 32 0"
proof -
  have "\<forall> val. \<not>(valid_value val (join (stamps x) (stamps y)))"
    using assms(1,4) unfolding alwaysDistinct.simps
    by (smt (verit, best) is_stamp_empty.elims(2) valid_int valid_value.simps(1))
  obtain xv where "[g, m, p] \<turnstile> x \<mapsto> xv"
    using assms using assms(2,3) unfolding encodeeval_def sorry
  have "\<not>(\<exists> val . ([g, m, p] \<turnstile> x \<mapsto> val) \<and> ([g, m, p] \<turnstile> y \<mapsto> val))"
    using assms(1,4) unfolding alwaysDistinct.simps wf_stamp.simps encodeeval_def sorry
  then show ?thesis sorry
qed

lemma tryFoldIntegerEqualsNeverDistinct:
  assumes "wf_stamp g stamps"
  assumes "kind g nid = (IntegerEqualsNode x y)"
  assumes "[g, m, p] \<turnstile> nid \<mapsto> v"
  assumes "neverDistinct (stamps x) (stamps y)"
  shows "v = IntVal 32 1"
  using assms IntegerEqualsNodeE sorry

lemma tryFoldIntegerLessThanTrue:
  assumes "wf_stamp g stamps"
  assumes "kind g nid = (IntegerLessThanNode x y)"
  assumes "[g, m, p] \<turnstile> nid \<mapsto> v"
  assumes "stpi_upper (stamps x) < stpi_lower (stamps y)"
  shows "v = IntVal 32 1"
proof -
  have stamp_type: "is_IntegerStamp (stamps x)"
    using assms
    sorry
  obtain xval where xval: "[g, m, p] \<turnstile> x \<mapsto> xval"
    using assms(2,3) sorry
  obtain yval where yval: "[g, m, p] \<turnstile> y \<mapsto> yval"
    using assms(2,3) sorry
  have "is_IntegerStamp (stamps x) \<and> is_IntegerStamp (stamps y)"
    using assms(4)
    sorry
  then have "val_to_bool (intval_less_than xval yval)"
    sorry
  then show ?thesis
    sorry
qed

lemma tryFoldIntegerLessThanFalse:
  assumes "wf_stamp g stamps"
  assumes "kind g nid = (IntegerLessThanNode x y)"
  assumes "[g, m, p] \<turnstile> nid \<mapsto> v"
  assumes "stpi_lower (stamps x) \<ge> stpi_upper (stamps y)"
  shows "v = IntVal 32 0"
  proof -
  have stamp_type: "is_IntegerStamp (stamps x)"
    using assms
    sorry
  obtain xval where xval: "[g, m, p] \<turnstile> x \<mapsto> xval"
    using assms(2,3) sorry
  obtain yval where yval: "[g, m, p] \<turnstile> y \<mapsto> yval"
    using assms(2,3) sorry
  have "is_IntegerStamp (stamps x) \<and> is_IntegerStamp (stamps y)"
    using assms(4)
    sorry
  then have "\<not>(val_to_bool (intval_less_than xval yval))"
    sorry
  then show ?thesis
    sorry
qed

theorem tryFoldProofTrue:
  assumes "wf_stamp g stamps"
  assumes "tryFold (kind g nid) stamps True"
  assumes "[g, m, p] \<turnstile> nid \<mapsto> v"
  shows "val_to_bool v"
  using assms(2) proof (induction "kind g nid" stamps True rule: tryFold.induct)
case (1 stamps x y)
  then show ?case using tryFoldIntegerEqualsAlwaysDistinct assms
    by force
next
  case (2 stamps x y)
  then show ?case using tryFoldIntegerEqualsAlwaysDistinct assms
    by (smt (verit, best) one_neq_zero tryFold.cases tryFoldIntegerEqualsNeverDistinct tryFoldIntegerLessThanTrue val_to_bool.simps(1))
next
  case (3 stamps x y)
  then show ?case using tryFoldIntegerLessThanTrue assms
    by (smt (verit, best) one_neq_zero tryFold.cases tryFoldIntegerEqualsNeverDistinct val_to_bool.simps(1))
next
case (4 stamps x y)
  then show ?case using tryFoldIntegerLessThanFalse assms sorry
qed

theorem tryFoldProofFalse:
  assumes "wf_stamp g stamps"
  assumes "tryFold (kind g nid) stamps False"
  assumes "[g, m, p] \<turnstile> nid \<mapsto> v"
  shows "\<not>(val_to_bool v)"
using assms(2) proof (induction "kind g nid" stamps False rule: tryFold.induct)
case (1 stamps x y)
  then show ?case using tryFoldIntegerEqualsAlwaysDistinct assms sorry
next
case (2 stamps x y)
  then show ?case using tryFoldIntegerEqualsNeverDistinct assms sorry
next
  case (3 stamps x y)
  then show ?case using tryFoldIntegerLessThanTrue assms sorry
next
  case (4 stamps x y)
  then show ?case using tryFoldIntegerLessThanFalse assms sorry

qed

inductive_cases StepE:
  "g, p \<turnstile> (nid,m,h) \<rightarrow> (nid',m',h)"

text \<open>
Perform conditional elimination rewrites on the graph for a particular node.

In order to determine conditional eliminations appropriately the rule needs two
data structures produced by static analysis.
The first parameter is the set of IRNodes that we know result in a true value
when evaluated.
The second parameter is a mapping from node identifiers to the flow-sensitive stamp.

The relation transforms the third parameter to the fifth parameter for a node identifier
which represents the fourth parameter.
\<close>
inductive ConditionalEliminationStep ::
  "IRExpr set \<Rightarrow> (ID \<Rightarrow> Stamp) \<Rightarrow> IRGraph \<Rightarrow> ID \<Rightarrow> IRGraph \<Rightarrow> bool" where
  impliesTrue:
  "\<lbrakk>kind g ifcond = (IfNode cid t f);
    g \<turnstile> cid \<simeq> cond;
    \<exists> ce \<in> conds . (ce \<Rrightarrow> cond);
    g' = constantCondition True ifcond (kind g ifcond) g
    \<rbrakk> \<Longrightarrow> ConditionalEliminationStep conds stamps g ifcond g'" |

  impliesFalse:
  "\<lbrakk>kind g ifcond = (IfNode cid t f);
    g \<turnstile> cid \<simeq> cond;
    \<exists> ce \<in> conds . (ce \<Rrightarrow>\<not> cond);
    g' = constantCondition False ifcond (kind g ifcond) g
    \<rbrakk> \<Longrightarrow> ConditionalEliminationStep conds stamps g ifcond g'" |

  tryFoldTrue:
  "\<lbrakk>kind g ifcond = (IfNode cid t f);
    cond = kind g cid;
    tryFold (kind g cid) stamps True;
    g' = constantCondition True ifcond (kind g ifcond) g
    \<rbrakk> \<Longrightarrow> ConditionalEliminationStep conds stamps g ifcond g'" |

  tryFoldFalse:
  "\<lbrakk>kind g ifcond = (IfNode cid t f);
    cond = kind g cid;
    tryFold (kind g cid) stamps False;
    g' = constantCondition False ifcond (kind g ifcond) g
    \<rbrakk> \<Longrightarrow> ConditionalEliminationStep conds stamps g ifcond g'"

code_pred (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) ConditionalEliminationStep .

thm ConditionalEliminationStep.equation

subsection \<open>Control-flow Graph Traversal\<close>

type_synonym Seen = "ID set"
type_synonym Condition = "IRExpr"
type_synonym Conditions = "Condition list"
type_synonym StampFlow = "(ID \<Rightarrow> Stamp) list"

text \<open>
nextEdge helps determine which node to traverse next by returning the first successor
edge that isn't in the set of already visited nodes.
If there is not an appropriate successor, None is returned instead.
\<close>
fun nextEdge :: "Seen \<Rightarrow> ID \<Rightarrow> IRGraph \<Rightarrow> ID option" where
  "nextEdge seen nid g =
    (let nids = (filter (\<lambda>nid'. nid' \<notin> seen) (successors_of (kind g nid))) in
     (if length nids > 0 then Some (hd nids) else None))"

text \<open>
pred determines which node, if any, acts as the predecessor of another.

Merge nodes represent a special case where-in the predecessor exists as
an input edge of the merge node, to simplify the traversal we treat only
the first input end node as the predecessor, ignoring that multiple nodes
may act as a successor.

For all other nodes, the predecessor is the first element of the predecessors set.
Note that in a well-formed graph there should only be one element in the predecessor set.\<close>
fun pred :: "IRGraph \<Rightarrow> ID \<Rightarrow> ID option" where
  "pred g nid = (case kind g nid of
    (MergeNode ends _ _) \<Rightarrow> Some (hd ends) |
    _ \<Rightarrow>
      (if IRGraph.predecessors g nid = {}
        then None else
        Some (hd (sorted_list_of_set (IRGraph.predecessors g nid)))
      )
  )"

text \<open>
When the basic block of an if statement is entered, we know that the condition of the
preceding if statement must be true.
As in the GraalVM compiler, we introduce the registerNewCondition funciton which roughly
corresponds to the ConditionalEliminationPhase.registerNewCondition.
This method updates the flow-sensitive stamp information based on the condition which
we know must be true.
\<close>
fun clip_upper :: "Stamp \<Rightarrow> int \<Rightarrow> Stamp" where
  "clip_upper (IntegerStamp b l h) c = (IntegerStamp b l c)" |
  "clip_upper s c = s"
fun clip_lower :: "Stamp \<Rightarrow> int \<Rightarrow> Stamp" where
  "clip_lower (IntegerStamp b l h) c = (IntegerStamp b c h)" |
  "clip_lower s c = s"

fun registerNewCondition :: "IRGraph \<Rightarrow> IRNode \<Rightarrow> (ID \<Rightarrow> Stamp) \<Rightarrow> (ID \<Rightarrow> Stamp)" where
  (* constrain equality by joining the stamps *)
  "registerNewCondition g (IntegerEqualsNode x y) stamps =
    (stamps
      (x := join (stamps x) (stamps y)))
      (y := join (stamps x) (stamps y))" |
  (* constrain less than by removing overlapping stamps *)
  "registerNewCondition g (IntegerLessThanNode x y) stamps =
    (stamps
      (x := clip_upper (stamps x) (stpi_lower (stamps y))))
      (y := clip_lower (stamps y) (stpi_upper (stamps x)))" |
  "registerNewCondition g _ stamps = stamps"

fun hdOr :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "hdOr (x # xs) de = x" |
  "hdOr [] de = de"

text \<open>
The Step relation is a small-step traversal of the graph which handles transitions between
individual nodes of the graph.

It relates a pairs of tuple of the current node, the set of seen nodes,
the always true stack of IfNode conditions, and the flow-sensitive stamp information.
\<close>
inductive Step
  :: "IRGraph \<Rightarrow> (ID \<times> Seen \<times> Conditions \<times> StampFlow) \<Rightarrow> (ID \<times> Seen \<times> Conditions \<times> StampFlow) option \<Rightarrow> bool"
  for g where
  \<comment> \<open>
  Hit a BeginNode with an IfNode predecessor which represents
  the start of a basic block for the IfNode.
     1. nid' will be the successor of the begin node.
     2. Find the first and only predecessor.
     3. Extract condition from the preceding IfNode.
     4. Negate condition if the begin node is second branch
        (we've taken the else branch of the condition)
     5. Add the condition or the negated condition to stack
     6. Perform any stamp updates based on the condition using
        the registerNewCondition function and place them on the
        top of the stack of stamp information
  \<close>
  "\<lbrakk>kind g nid = BeginNode nid';

    nid \<notin> seen;
    seen' = {nid} \<union> seen;

    Some ifcond = pred g nid;
    kind g ifcond = IfNode cond t f;

    i = find_index nid (successors_of (kind g ifcond));
    c = (if i = 0 then kind g cond else LogicNegationNode cond);
    rep g cond ce;
    ce' = (if i = 0 then ce else UnaryExpr UnaryLogicNegation ce);
    conds' = ce' # conds;

    flow' = registerNewCondition g c (hdOr flow (stamp g))\<rbrakk>
   \<Longrightarrow> Step g (nid, seen, conds, flow) (Some (nid', seen', conds', flow' # flow))" |

  \<comment> \<open>
  Hit an EndNode
     1. nid' will be the usage of EndNode
     2. pop the conditions and stamp stack
  \<close>
  "\<lbrakk>kind g nid = EndNode;

    nid \<notin> seen;
    seen' = {nid} \<union> seen;

    nid' = any_usage g nid;

    conds' = tl conds;
    flow' = tl flow\<rbrakk>
   \<Longrightarrow> Step g (nid, seen, conds, flow) (Some (nid', seen', conds', flow'))" |

  \<comment> \<open>We can find a successor edge that is not in seen, go there\<close>
  "\<lbrakk>\<not>(is_EndNode (kind g nid));
    \<not>(is_BeginNode (kind g nid));

    nid \<notin> seen;
    seen' = {nid} \<union> seen;

    Some nid' = nextEdge seen' nid g\<rbrakk>
   \<Longrightarrow> Step g (nid, seen, conds, flow) (Some (nid', seen', conds, flow))" |

  \<comment> \<open>We can cannot find a successor edge that is not in seen, give back None\<close>
  "\<lbrakk>\<not>(is_EndNode (kind g nid));
    \<not>(is_BeginNode (kind g nid));

    nid \<notin> seen;
    seen' = {nid} \<union> seen;

    None = nextEdge seen' nid g\<rbrakk>
    \<Longrightarrow> Step g (nid, seen, conds, flow) None" |

  \<comment> \<open>We've already seen this node, give back None\<close>
  "\<lbrakk>nid \<in> seen\<rbrakk> \<Longrightarrow> Step g (nid, seen, conds, flow) None"

code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) Step .

text \<open>
The ConditionalEliminationPhase relation is responsible for combining
the individual traversal steps from the Step relation and the optimizations
from the ConditionalEliminationStep relation to perform a transformation of the
whole graph.
\<close>

inductive ConditionalEliminationPhase
  :: "IRGraph \<Rightarrow> (ID \<times> Seen \<times> Conditions \<times> StampFlow) \<Rightarrow> IRGraph \<Rightarrow> bool" where

  \<comment> \<open>Can do a step and optimise for the current node\<close>
  "\<lbrakk>Step g (nid, seen, conds, flow) (Some (nid', seen', conds', flow'));
    ConditionalEliminationStep (set conds) (hdOr flow (stamp g)) g nid g';

    ConditionalEliminationPhase g' (nid', seen', conds', flow') g''\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhase g (nid, seen, conds, flow) g''" |

  \<comment> \<open>Can do a step, matches whether optimised or not causing non-determinism
      We need to find a way to negate ConditionalEliminationStep\<close>
  "\<lbrakk>Step g (nid, seen, conds, flow) (Some (nid', seen', conds', flow'));

    ConditionalEliminationPhase g (nid', seen', conds', flow') g'\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhase g (nid, seen, conds, flow) g'" |

  \<comment> \<open>Can't do a step but there is a predecessor we can backtrace to\<close>
  "\<lbrakk>Step g (nid, seen, conds, flow) None;
    Some nid' = pred g nid;
    seen' = {nid} \<union> seen;
    ConditionalEliminationPhase g (nid', seen', conds, flow) g'\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhase g (nid, seen, conds, flow) g'" |

  \<comment> \<open>Can't do a step and have no predecessors so terminate\<close>
  "\<lbrakk>Step g (nid, seen, conds, flow) None;
    None = pred g nid\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhase g (nid, seen, conds, flow) g"

code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) ConditionalEliminationPhase .

definition runConditionalElimination :: "IRGraph \<Rightarrow> IRGraph" where
  "runConditionalElimination g =
    (Predicate.the (ConditionalEliminationPhase_i_i_o g (0, {}, ([], []))))"

(*

inductive ConditionalEliminationPhaseWithTrace\<^marker>\<open>tag invisible\<close>
  :: "IRGraph \<Rightarrow> (ID \<times> Seen \<times> Conditions \<times> StampFlow) \<Rightarrow> ID list \<Rightarrow> IRGraph \<Rightarrow> ID list \<Rightarrow> Conditions \<Rightarrow> bool" where\<^marker>\<open>tag invisible\<close>

  (* Can do a step and optimise for the current nid *)
  "\<lbrakk>Step g (nid, seen, conds, flow) (Some (nid', seen', conds', flow'));
    ConditionalEliminationStep (set conds) (hdOr flow (stamp g)) g nid g';

    ConditionalEliminationPhaseWithTrace g' (nid', seen', conds', flow') (nid # t) g'' t' conds''\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhaseWithTrace g (nid, seen, conds, flow) t g'' t' conds''" |

  (* Can do a step, matches whether optimised or not causing non-determinism
     Need to find a way to negate ConditionalEliminationStep *)
  "\<lbrakk>Step g (nid, seen, conds, flow) (Some (nid', seen', conds', flow'));

    ConditionalEliminationPhaseWithTrace g (nid', seen', conds', flow') (nid # t) g' t' conds''\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhaseWithTrace g (nid, seen, conds, flow) t g' t' conds''" |

  (* Can't do a step but there is a predecessor we can backtrace to *)
  "\<lbrakk>Step g (nid, seen, conds, flow) None;
    Some nid' = pred g nid;
    seen' = {nid} \<union> seen;
    ConditionalEliminationPhaseWithTrace g (nid', seen', conds, flow) (nid # t) g' t' conds'\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhaseWithTrace g (nid, seen, conds, flow) t g' t' conds'" |

  (* Can't do a step and have no predecessors do terminate *)
  "\<lbrakk>Step g (nid, seen, conds, flow) None;
    None = pred g nid\<rbrakk>
    \<Longrightarrow> ConditionalEliminationPhaseWithTrace g (nid, seen, conds, flow) t g (nid # t) conds"

code_pred (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool) ConditionalEliminationPhaseWithTrace .

lemma IfNodeStepE: "g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m', h) \<Longrightarrow>
  (\<And>cond tb fb val.
        kind g nid = IfNode cond tb fb \<Longrightarrow>
        nid' = (if val_to_bool val then tb else fb) \<Longrightarrow>
        [g, m, p] \<turnstile> kind g cond \<mapsto> val \<Longrightarrow> m' = m)"
  using StepE
  by (smt (verit, best) IfNode Pair_inject stepDet)

lemma ifNodeHasCondEvalStutter:
  assumes "(g m p h \<turnstile> nid \<leadsto> nid')"
  assumes "kind g nid = IfNode cond t f"
  shows "\<exists> v. ([g, m, p] \<turnstile> kind g cond \<mapsto> v)"
  using IfNodeStepE assms(1) assms(2)  stutter.cases
  by (meson IfNodeCond)

lemma ifNodeHasCondEval:
  assumes "(g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m', h'))"
  assumes "kind g nid = IfNode cond t f"
  shows "\<exists> v. ([g, m, p] \<turnstile> kind g cond \<mapsto> v)"
  using IfNodeStepE assms(1) assms(2)
  by (smt (z3) IRNode.disc(932) IRNode.simps(938) IRNode.simps(958) IRNode.simps(972) IRNode.simps(974) IRNode.simps(978) Pair_inject StutterStep ifNodeHasCondEvalStutter is_AbstractEndNode.simps is_EndNode.simps(12) step.cases)

lemma replace_if_t:
  assumes "kind g nid = IfNode cond tb fb"
  assumes "[g, m, p] \<turnstile> kind g cond \<mapsto> bool"
  assumes "val_to_bool bool"
  assumes g': "g' = replace_usages nid tb g"
  shows "\<exists>nid' .(g m p h \<turnstile> nid \<leadsto> nid') \<longleftrightarrow> (g' m p h \<turnstile> nid \<leadsto> nid')"
proof -
  have g1step: "g, p \<turnstile> (nid, m, h) \<rightarrow> (tb, m, h)"
    by (meson IfNode assms(1) assms(2) assms(3))
  have g2step: "g', p \<turnstile> (nid, m, h) \<rightarrow> (tb, m, h)"
    using g' unfolding replace_usages.simps
    by (simp add: stepRefNode)
  from g1step g2step show ?thesis
    using StutterStep by blast
qed

lemma replace_if_t_imp:
  assumes "kind g nid = IfNode cond tb fb"
  assumes "[g, m, p] \<turnstile> kind g cond \<mapsto> bool"
  assumes "val_to_bool bool"
  assumes g': "g' = replace_usages nid tb g"
  shows "\<exists>nid' .(g m p h \<turnstile> nid \<leadsto> nid') \<longrightarrow> (g' m p h \<turnstile> nid \<leadsto> nid')"
  using replace_if_t assms by blast

lemma replace_if_f:
  assumes "kind g nid = IfNode cond tb fb"
  assumes "[g, m, p] \<turnstile> kind g cond \<mapsto> bool"
  assumes "\<not>(val_to_bool bool)"
  assumes g': "g' = replace_usages nid fb g"
  shows "\<exists>nid' .(g m p h \<turnstile> nid \<leadsto> nid') \<longleftrightarrow> (g' m p h \<turnstile> nid \<leadsto> nid')"
proof -
  have g1step: "g, p \<turnstile> (nid, m, h) \<rightarrow> (fb, m, h)"
    by (meson IfNode assms(1) assms(2) assms(3))
  have g2step: "g', p \<turnstile> (nid, m, h) \<rightarrow> (fb, m, h)"
    using g' unfolding replace_usages.simps
    by (simp add: stepRefNode)
  from g1step g2step show ?thesis
    using StutterStep by blast
qed

text \<open>
Prove that the individual conditional elimination rules are correct
with respect to preservation of stuttering steps.
\<close>
lemma ConditionalEliminationStepProof:
  assumes wg: "wf_graph g"
  assumes ws: "wf_stamps g"
  assumes wv: "wf_values g"
  assumes nid: "nid \<in> ids g"
  assumes conds_valid: "\<forall> c \<in> conds . \<exists> v. ([g, m, p] \<turnstile> c \<mapsto> v) \<and> val_to_bool v"
  assumes ce: "ConditionalEliminationStep conds stamps g nid g'"

  shows "\<exists>nid' .(g m p h \<turnstile> nid \<leadsto> nid') \<longrightarrow> (g' m p h \<turnstile> nid \<leadsto> nid')"
  using ce using assms
proof (induct g nid g' rule: ConditionalEliminationStep.induct)
  case (impliesTrue g ifcond cid t f cond conds g')
  show ?case proof (cases "(g m p h \<turnstile> ifcond \<leadsto> nid')")
    case True
    obtain condv where condv: "[g, m, p] \<turnstile> kind g cid \<mapsto> condv"
      using implies.simps impliesTrue.hyps(3) impliesTrue.prems(4)
      using impliesTrue.hyps(2) True
      by (metis ifNodeHasCondEvalStutter impliesTrue.hyps(1))
    have condvTrue: "val_to_bool condv"
      by (metis condition_implies.intros(2) condv impliesTrue.hyps(2) impliesTrue.hyps(3) impliesTrue.prems(1) impliesTrue.prems(3) impliesTrue.prems(5) implies_true_valid)
    then show ?thesis
      using constantConditionValid
      using impliesTrue.hyps(1) condv impliesTrue.hyps(4)
      by blast
  next
    case False
    then show ?thesis by auto
  qed
next
  case (impliesFalse g ifcond cid t f cond conds g')
  then show ?case
  proof (cases "(g m p h \<turnstile> ifcond \<leadsto> nid')")
    case True
    obtain condv where condv: "[g, m, p] \<turnstile> kind g cid \<mapsto> condv"
      using ifNodeHasCondEvalStutter impliesFalse.hyps(1)
      using True by blast
    have condvFalse: "False = val_to_bool condv"
      by (metis condition_implies.intros(2) condv impliesFalse.hyps(2) impliesFalse.hyps(3) impliesFalse.prems(1) impliesFalse.prems(3) impliesFalse.prems(5) implies_false_valid)
    then show ?thesis
      using constantConditionValid
      using impliesFalse.hyps(1) condv impliesFalse.hyps(4)
      by blast
  next
    case False
    then show ?thesis
      by auto
  qed
next
  case (tryFoldTrue g ifcond cid t f cond g' conds)
  then show ?case using constantConditionValid tryFoldProofTrue
    using StutterStep constantConditionTrue by metis
next
  case (tryFoldFalse g ifcond cid t f cond g' conds)
  then show ?case using constantConditionValid tryFoldProofFalse
    using StutterStep constantConditionFalse by metis
qed

text \<open>
Prove that the individual conditional elimination rules are correct
with respect to finding a bisimulation between the unoptimized and optimized graphs.
\<close>
lemma ConditionalEliminationStepProofBisimulation:
  assumes wf: "wf_graph g \<and> wf_stamp g stamps \<and> wf_values g"
  assumes nid: "nid \<in> ids g"
  assumes conds_valid: "\<forall> c \<in> conds . \<exists> v. ([g, m, p] \<turnstile> c \<mapsto> v) \<and> val_to_bool v"
  assumes ce: "ConditionalEliminationStep conds stamps g nid g'"
  assumes gstep: "\<exists> h nid'. (g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h))" (* we don't yet consider optimizations which produce a step that didn't already exist *)

  shows "nid | g \<sim> g'"
  using ce gstep using assms
proof (induct g nid g' rule: ConditionalEliminationStep.induct)
  case (impliesTrue g ifcond cid t f cond conds g' stamps)
  from impliesTrue(5) obtain h where gstep: "g, p \<turnstile> (ifcond, m, h) \<rightarrow> (t, m, h)"
    by (metis IfNode StutterStep condition_implies.intros(2) ifNodeHasCondEvalStutter impliesTrue.hyps(1) impliesTrue.hyps(2) impliesTrue.hyps(3) impliesTrue.prems(2) impliesTrue.prems(4) implies_true_valid)
  have "g', p \<turnstile> (ifcond, m, h) \<rightarrow> (t, m, h)"
    using constantConditionTrue impliesTrue.hyps(1) impliesTrue.hyps(4) by blast
  then show ?case using gstep
    by (metis stepDet strong_noop_bisimilar.intros)
next
  case (impliesFalse g ifcond cid t f cond conds g' stamps)
  from impliesFalse(5) obtain h where gstep: "g, p \<turnstile> (ifcond, m, h) \<rightarrow> (f, m, h)"
    by (metis IfNode condition_implies.intros(2) ifNodeHasCondEval impliesFalse.hyps(1) impliesFalse.hyps(2) impliesFalse.hyps(3) impliesFalse.prems(2) impliesFalse.prems(4) implies_false_valid)
  have "g', p \<turnstile> (ifcond, m, h) \<rightarrow> (f, m, h)"
    using constantConditionFalse impliesFalse.hyps(1) impliesFalse.hyps(4) by blast
  then show ?case using gstep
    by (metis stepDet strong_noop_bisimilar.intros)
next
  case (tryFoldTrue g ifcond cid t f cond stamps g' conds)
  from tryFoldTrue(5) obtain val where "[g, m, p] \<turnstile> kind g cid \<mapsto> val"
    using ifNodeHasCondEval tryFoldTrue.hyps(1) by blast
  then have "val_to_bool val"
    using tryFoldProofTrue tryFoldTrue.prems(2) tryFoldTrue(3)
    by blast
  then obtain h where gstep: "g, p \<turnstile> (ifcond, m, h) \<rightarrow> (t, m, h)"
    using tryFoldTrue(5)
    by (meson IfNode \<open>[g, m, p] \<turnstile> kind g cid \<mapsto> val\<close> tryFoldTrue.hyps(1))
  have "g', p \<turnstile> (ifcond, m, h) \<rightarrow> (t, m, h)"
    using constantConditionTrue tryFoldTrue.hyps(1) tryFoldTrue.hyps(4) by presburger
  then show ?case using gstep
    by (metis stepDet strong_noop_bisimilar.intros)
next
  case (tryFoldFalse g ifcond cid t f cond stamps g' conds)
  from tryFoldFalse(5) obtain h where gstep: "g, p \<turnstile> (ifcond, m, h) \<rightarrow> (f, m, h)"
    by (meson IfNode ifNodeHasCondEval tryFoldFalse.hyps(1) tryFoldFalse.hyps(3) tryFoldFalse.prems(2) tryFoldProofFalse)
  have "g', p \<turnstile> (ifcond, m, h) \<rightarrow> (f, m, h)"
    using constantConditionFalse tryFoldFalse.hyps(1) tryFoldFalse.hyps(4) by blast
  then show ?case using gstep
    by (metis stepDet strong_noop_bisimilar.intros)
qed

text \<open>Mostly experimental proofs from here on out.\<close>

experiment begin
lemma if_step:
  assumes "nid \<in> ids g"
  assumes "(kind g nid) \<in> control_nodes"
  shows "(g m p h \<turnstile> nid \<leadsto> nid')"
  using assms apply (cases "kind g nid") sorry

lemma StepConditionsValid:
  assumes "\<forall> cond \<in> set conds. ([g, m, p] \<turnstile> cond \<mapsto> v) \<and> val_to_bool v"
  assumes "Step g (nid, seen, conds, flow) (Some (nid', seen', conds', flow'))"
  shows "\<forall> cond \<in> set conds'. ([g, m, p] \<turnstile> cond \<mapsto> v) \<and> val_to_bool v"
  using assms(2)
proof (induction "(nid, seen, conds, flow)" "Some (nid', seen', conds', flow')" rule: Step.induct)
  case (1 ifcond cond t f i c)
  obtain cv where cv: "[g, m, p] \<turnstile> c \<mapsto> cv"
    sorry
  have cvt: "val_to_bool cv"
    sorry
  have "set conds' = {c} \<union> set conds"
    using "1.hyps"(8) by auto
  then show ?case using cv cvt assms(1) sorry
next
  case (2)
  from 2(5) have "set conds' \<subseteq> set conds"
    by (metis list.sel(2) list.set_sel(2) subsetI)
  then show ?case using assms(1)
    by blast
next
case (3)
  then show ?case
    using assms(1) by force
qed

lemma ConditionalEliminationPhaseProof:
  assumes "wf_graph g"
  assumes "wf_stamps g"
  assumes "ConditionalEliminationPhase g (0, {}, [], []) g'"

  shows "\<exists>nid' .(g m p h \<turnstile> 0 \<leadsto> nid') \<longrightarrow> (g' m p h \<turnstile> 0 \<leadsto> nid')"
proof -
  have "0 \<in> ids g"
    using assms(1) wf_folds by blast
  show ?thesis
using assms(3) assms proof (induct rule: ConditionalEliminationPhase.induct)
case (1 g nid g' succs nid' g'')
  then show ?case sorry
next
  case (2 succs g nid nid' g'')
  then show ?case sorry
next
  case (3 succs g nid)
  then show ?case
    by simp
next
  case (4)
  then show ?case sorry
qed
qed
end
*)

end


(*
    File:        Lambda.thy
    Time-stamp:  <2016-01-03T14:03:42Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory Lambda imports LBeta begin

axiomatization where
  Infinite_LVariable: "Infinite(LVariable)"

definition LAQ :: "i=>i" where
"LAQ(M) == {N: LTerm. LAlpha(M, N)}"

definition Term :: "i" where
"Term == {LAQ(M). M: LTerm}"

definition Var :: "i=>i" where
"Var(x) == {LVar(x)}"

definition Lam :: "[i,i]=>i" where
"Lam(x, M) == {m': LTerm. M: Term & (EX m: M. LAlpha(m', LLam(x, m)))}"

definition App :: "[i,i]=>i" where
"App(M, N) == {m: LTerm. M: Term & N: Term &
                       (EX a b. a: M & b: N & m = LApp(a, b))}"

definition FV :: "i=>i" where
"FV(M) == INT m: M. LFV(m)"

definition subst :: "[i,i,i]=>i" where
"subst(M, x, N) == {m': LTerm. EX m n. m: M & n: N &
                     LFreeForIn(n, x, m) &
                     LAlpha(Lsubst(m, x, n), m')}"

definition Beta1 :: "[i,i]=>o" where
"Beta1(M, N) == M: Term & N: Term & (EX m: M. EX n: N. LBeta1(m, n))"

lemmas LAlpha_LLamE2 = Infinite_LVariable [THEN LAlpha_LLamE]
lemmas LAlpha_LTermEs2 = LAlpha_LVarE LAlpha_LLamE2
                         LAlpha_LAppE

 (** LAQ: LAlpha-quotient **)
lemma LAQ_I:
  "LAlpha(M, N) ==> N: LAQ(M)"
apply (unfold LAQ_def)
apply (blast dest: LAlphaD1 [THEN LSkeltonEqD2])
done

lemma LAQ_D:
  "N: LAQ(M) ==> LAlpha(M, N)"
apply (unfold LAQ_def)
apply blast
done

lemma LAQ_self:
  "M: LTerm ==> M: LAQ(M)"
apply (rule LAQ_I)
apply (erule LAlpha_refl)
done

lemma LAQ_eqI:
  "LAlpha(M, N) ==> LAQ(M) = LAQ(N)"
apply (rule equalityI)
apply (safe dest!: LAQ_D intro!: LAQ_I)
apply (erule LAlpha_sym [THEN LAlpha_trans])
apply assumption
apply (erule LAlpha_trans)
apply assumption
done

lemma LAQ_eqD:
  "[| LAQ(M) = LAQ(N); M: LTerm |] ==> LAlpha(M, N)"
apply (erule equalityE)
apply (drule subsetD, erule LAQ_self)
apply (erule LAQ_D [THEN LAlpha_sym])
done

(** Term **)
lemma TermI:
  "[| m: LTerm; M = LAQ(m) |] ==> M: Term"
apply (unfold Term_def)
apply blast
done

lemma LAQ_type:
  "m: LTerm ==> LAQ(m): Term"
apply (assumption | rule TermI refl)+
done

lemma TermE:
  "[| M: Term;
      !! m. [| M = LAQ(m); m: LTerm |] ==> R
   |] ==> R"
apply (unfold Term_def)
apply blast
done

lemma Term_LFreeForInE:
  assumes major: "M: Term"
  and prem1: "x: LVariable"
  and prem2: "n: LTerm"
  and prem3: "!!m. [| M = LAQ(m); m: LTerm; LFreeForIn(n, x, m) |] ==> R"
  shows "R"
apply (rule major [THEN TermE])
apply (rule Infinite_LVariable [THEN Infinite_LVariable_LAlpha_lemma,
         THEN bexE])
apply (rule_tac [2] prem1)
apply (rule_tac [2] prem2)
apply assumption
apply (rule prem3)
apply (safe dest!: LAQ_eqI)
apply assumption+
done

lemma Term_LFreeForInE2:
  assumes major: "M: Term"
  and prem1: "x: LVariable"
  and prem2: "X: Fin(LTerm)"
  and prem3:
     "!!m. [| M = LAQ(m); m: LTerm; ALL n: X. LFreeForIn(n, x, m) |]
            ==> R"
  shows "R"
apply (rule major [THEN TermE])
apply (rule Infinite_LVariable [THEN Infinite_LVariable_LAlpha_lemma2,
         THEN bexE])
apply (rule_tac [2] prem1)
apply (rule_tac [2] prem2)
apply assumption
apply (rule prem3)
apply (safe dest!: LAQ_eqI)
apply (erule_tac [3] bspec)
apply assumption+
done

lemma LAQ_LVar:
  "x: LVariable ==> LAQ(LVar(x)) = Var(x)"
apply (unfold Var_def)
apply (blast intro: LAlpha_LVarI dest!: LAQ_D intro!: LAQ_I
         elim!: LAlpha_LTermEs2)
done

lemma LAQ_LLam:
  "[| x: LVariable; m: LTerm |] ==> LAQ(LLam(x, m)) = Lam(x, LAQ(m))"
apply (unfold Lam_def)
apply (rule equalityI)
apply (safe dest!: LAQ_D intro!: LAQ_type LAQ_I
         elim!: TermE LAlpha_LTermEs2)
apply (erule LAlphaD1 [THEN LSkeltonEqD2])
apply (erule_tac [3] LAlphaD1 [THEN LSkeltonEqD1])
apply (drule_tac [2] LFreeForInD1)
apply (erule_tac [2] LTerm_typeEs)
prefer 2 apply assumption
apply (rule bexI)
apply (assumption | rule LAQ_self LAlpha_sym [THEN LAlpha_LLamI1])+
apply (drule LAlpha_LLamI2)
apply (rule_tac [3] bexI)
apply (assumption | rule LAQ_I)+
apply (rule LAlpha_trans)
apply (erule_tac [2] LAlpha_sym)
apply (erule LAlpha_LLamI1)
apply assumption
done

lemma LAQ_LApp:
  "[| m: LTerm; n: LTerm |] ==> LAQ(LApp(m, n)) = App(LAQ(m), LAQ(n))"
apply (unfold App_def)
apply (blast dest!: LAQ_D intro: LAlpha_LTermIs elim!: TermE
         intro: LAlphaD1 [THEN LSkeltonEqD1]
                LAlphaD1 [THEN LSkeltonEqD2]
         intro!: LAQ_I LAQ_type elim!: LAlpha_LTermEs2)
done

lemmas Term_LAQ_sym = LAQ_LVar LAQ_LLam LAQ_LApp
lemmas Term_LAQ = Term_LAQ_sym [THEN sym]

lemma Term_VarI:
  assumes major: "x: LVariable"
  shows "Var(x): Term"
apply (rule major [THEN LAQ_LVar, THEN subst])
apply (rule TermI)
apply (rule_tac [2] refl)
apply (assumption | rule LTerm.intros major)+
done

lemma Term_LamI:
  assumes prem1: "x: LVariable"
  and prem2: "M: Term"
  shows "Lam(x, M): Term"
apply (rule prem2 [THEN TermE])
apply hypsubst
apply (rule prem1 [THEN LAQ_LLam, THEN subst])
apply assumption
apply (rule TermI)
apply (rule_tac [2] refl)
apply (assumption | rule prem1 LTerm.intros)+
done

lemma Term_AppI:
  assumes prem1: "M: Term"
  and prem2: "N: Term"
  shows "App(M, N): Term"
apply (rule prem1 [THEN TermE])
apply (rule prem2 [THEN TermE])
apply hypsubst
apply (rule LAQ_LApp [THEN subst])
apply (rule_tac [3] TermI)
apply (rule_tac [4] refl)
apply (assumption | rule LTerm.intros)+
done

lemmas Term_intros = Term_VarI Term_LamI Term_AppI

lemma Term_VarD:
  "Var(x): Term ==> x: LVariable"
apply (unfold Var_def)
apply (erule TermE)
apply (drule equalityD1)
apply (drule singletonI [THEN [2] subsetD])
apply (drule LAQ_D)
apply (erule LAlpha_sym [THEN LAlpha_LVarE])
apply assumption
done

lemma Term_LamE:
  assumes major: "Lam(x, M): Term"
  and prem: "[| x: LVariable; M: Term |] ==> R"
  shows "R"
apply (rule major [unfolded Lam_def, THEN TermE])
apply (rule prem)
apply (drule_tac [2] equalityD2)
apply (drule_tac [2] LAQ_self [THEN [2] subsetD])
apply (drule equalityD2)
apply (drule_tac LAQ_self [THEN [2] subsetD])
apply safe
apply (drule LAlphaD1 [THEN LSkeltonEqD2])
apply (erule LTerm_typeEs)
apply assumption
done

lemma Term_AppE:
  assumes major: "App(M, N): Term"
  and prem: "[| M: Term; N: Term |] ==> R"
  shows "R"
apply (rule major [unfolded App_def, THEN TermE])
apply (drule equalityD2)
apply (drule LAQ_self [THEN [2] subsetD])
apply (rule_tac [2] prem)
apply safe
done

lemmas Term_typeEs = Term_VarD [elim_format] Term_LamE Term_AppE

lemma Term_cases:
  assumes major: "M: Term"
  and prem1:
      "!! x. [| x: LVariable; M = Var(x) |] ==> R"
  and prem2:
      "!! x N. [| x: LVariable; N: Term; M = Lam(x, N) |] ==> R"
  and prem3:
      "!! A B. [| A: Term; B: Term; M = App(A, B) |] ==> R"
  shows "R"
apply (rule major [THEN TermE])
apply (erule LTerm.cases)
apply (rule_tac [3] prem3)
apply (rule_tac [2] prem2)
apply (rule_tac [1] prem1)
prefer 8
apply hypsubst
apply (rule Term_LAQ_sym)
prefer 7
apply hypsubst
apply (rule Term_LAQ_sym)
prefer 6
apply hypsubst
apply (rule Term_LAQ_sym)
apply (assumption | rule LAQ_type)+
done

lemma Term_induct:
  assumes major: "M: Term"
  and "!! x. x: LVariable ==> P(Var(x))"
  and "!! x N. [| x: LVariable; N: Term; P(N) |] ==> P(Lam(x, N))"
  and "!! A B. [| A: Term; P(A); B: Term; P(B) |] ==> P(App(A, B))"
  shows "P(M)"
apply (rule major [THEN TermE])
apply (erule rev_mp)
apply (rule_tac x="M" in spec)
apply (erule LTerm.induct)
apply safe
apply (simp_all add: Term_LAQ_sym)
apply (assumption | rule LAQ_type assms)+
done

(** FV **)
lemma FV_LAQ:
  assumes major: "m: LTerm"
  shows "FV(LAQ(m)) = LFV(m)"
apply (unfold FV_def)
apply (rule equalityI)
apply (safe elim!: LFV_E LAQ_D [elim_format] intro!: LAQ_I)
apply (drule_tac [3] equals0D)
apply (erule_tac [3] notE)
apply (rule_tac [3] RepFunI)
apply (rule_tac [3] major [THEN LAQ_self])
apply (rule_tac [2] LFV_I)
apply (erule_tac [2] LAlphaD2)
apply (erule_tac [2] asm_rl)
apply (erule INT_E)
apply (rule major [THEN LAQ_self])
done

lemma FV_Var:
  "x: LVariable ==> FV(Var(x)) = {x}"
apply (simp add: Term_LAQ FV_LAQ)
done

lemma FV_Lam:
  assumes prem1: "x: LVariable"
  and prem2: "M: Term"
  shows "FV(Lam(x, M)) = FV(M) - {x}"
apply (rule prem2 [THEN TermE])
apply (insert prem1)
apply (simp add: Term_LAQ FV_LAQ)
done

lemma FV_App:
  assumes prem1: "M: Term"
  and prem2: "N: Term"
  shows "FV(App(M, N)) = FV(M) Un FV(N)"
apply (rule prem1 [THEN TermE])
apply (rule prem2 [THEN TermE])
apply (simp add: Term_LAQ FV_LAQ)
done

lemmas FV_eqns = FV_Var FV_App FV_Lam

(** subst **)
lemma subst_LAQ:
  assumes major: "LFreeForIn(n, x, m)"
  shows "subst(LAQ(m), x, LAQ(n)) = LAQ(Lsubst(m, x, n))"
apply (unfold subst_def)
apply (insert major [THEN LFreeForInD1] major [THEN LFreeForInD2]
              major [THEN LFreeForInD3])
apply (insert major)
apply (rule equalityI)
apply (safe elim!: LAlpha_LTermEs2 LTerm.free_elims
         dest!: LAQ_D intro!: LAQ_I)
apply (rule LAlpha_trans)
prefer 2 apply assumption
apply (assumption | rule LAlpha_LsubstI)+
apply (erule LAlphaD1 [THEN LSkeltonEqD2])
apply (assumption | rule exI LAQ_self conjI)+
done

lemma subst_type:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "N: Term"
  shows "subst(M, x, N): Term"
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem2])
apply assumption
apply (simp add: subst_LAQ)
apply (assumption | rule LAQ_type Lsubst_type prem2)+
done

lemma subst_Var1:
  assumes prem1: "x: LVariable"
  and prem2: "N: Term"
  shows "subst(Var(x), x, N) = N"
apply (insert prem1)
apply (rule prem2 [THEN TermE])
apply (simp add: Term_LAQ)
apply (rule subst_LAQ [THEN trans])
apply (assumption | rule LFreeForIn_LTermIs)+
apply simp
done

lemma subst_Var2:
  assumes prem1: "x ~= y"
  and prem2: "y: LVariable"
  and prem3: "x: LVariable"
  and prem4: "N: Term"
  shows "subst(Var(y), x, N) = Var(y)"
apply (insert prem1 prem2 prem3)
apply (rule prem4 [THEN TermE])
apply (simp add: Term_LAQ)
apply (rule subst_LAQ [THEN trans])
apply (assumption | rule LFreeForIn_LTermIs)+
apply simp
done

lemma subst_Lam1:
  assumes prem1: "x: LVariable"
  and prem2: "M: Term"
  and prem3: "N: Term"
  shows "subst(Lam(x, M), x, N) = Lam(x, M)"
apply (rule prem3 [THEN TermE])
apply (rule prem2 [THEN TermE])
apply (insert prem1)
apply (simp add: Term_LAQ)
apply (rule subst_LAQ [THEN trans])
apply (rule LFreeForIn_LLamI1)
prefer 4 apply simp
apply assumption+
done

lemma subst_Lam2:
  assumes prem0: "x: LVariable"
  and prem1: "y: LVariable"
  and prem2: "M: Term"
  and prem3: "N: Term"
  and prem4: "y ~= x"
  and prem5: "x ~: FV(N)"
  shows "subst(Lam(x, M), y, N) = Lam(x, subst(M, y, N))"
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem2 prem1])
apply assumption
apply (insert prem0 prem1 prem4 prem5)
apply (simp add: Term_LAQ subst_LAQ FV_LAQ)
apply (rule subst_LAQ [THEN trans])
prefer 2 apply simp
apply (rule LFreeForIn_LLamI2)
prefer 3 apply blast
apply assumption+
done

lemma subst_App:
  assumes prem1: "A: Term"
  and prem2: "B: Term"
  and prem3: "x: LVariable"
  and prem4: "N: Term"
  shows "subst(App(A, B), x, N) = App(subst(A, x, N), subst(B, x, N))"
apply (rule prem4 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem3])
apply assumption
apply (rule Term_LFreeForInE [OF prem2 prem3])
apply assumption
apply (simp add: Term_LAQ LFreeForIn_LAppI subst_LAQ)
done

lemma subst_self:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  shows "subst(M, x, Var(x)) = M"
apply (rule_tac n="LVar(x)" in Term_LFreeForInE [OF prem1 prem2])
apply (rule LTerm.intros prem2)+
apply (insert prem2)
apply (simp add: Term_LAQ subst_LAQ Lsubst_self)
done

lemma subst_lemma2:
  assumes prem1: "M: Term"
  and prem2: "N: Term"
  and prem3: "x: LVariable"
  and prem4: "y: LVariable"
  and prem5: "y ~: FV(M)"
  shows "subst(subst(M, x, Var(y)), y, N) = subst(M, x, N)"
apply (rule prem2 [THEN TermE])
apply (rule_tac X="{LVar(y), m}" in Term_LFreeForInE2 [OF prem1 prem3])
apply (assumption | rule prem4 LTerm.intros Fin.intros)+
apply (insert prem3 prem4 prem5)
apply (simp add: Term_LAQ subst_LAQ FV_LAQ)
apply (erule conjE)
apply (rule subst_LAQ [THEN trans])
apply (assumption | rule LFreeForIn_name_change)+
apply (simp add: Lsubst_lemma2)
done

lemmas subst_eqns = subst_Var1 subst_Var2 subst_App subst_Lam1
                  subst_Lam2 subst_self subst_lemma2

(** Term.free_iffs **)
lemma Var_iff:
  "Var(x) = Var(y) <-> x = y"
apply (unfold Var_def)
apply (simp only: singleton_iff2)
apply (blast elim!: LTerm.free_elims)
done

lemma App_eqD:
  assumes major: "App(A, B) = App(A', B')"
  and prem1: "A: Term"
  and prem2: "B: Term"
  shows "A = A' & B = B'"
apply (insert prem1 prem2)
apply (subgoal_tac "App(A', B'): Term")
apply (rule_tac [2] major [THEN subst])
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_AppE)
apply (erule TermE)+
apply (insert major)
apply hypsubst
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LAlpha_LTermEs2 LTerm.free_elims)
apply (erule LAQ_eqI)+
done

lemma App_iff:
  "[| A: Term; B: Term |] ==>
       App(A, B) = App(A', B') <-> A = A' & B = B'"
apply (rule iffI)
apply (erule App_eqD)
apply assumption+
apply blast
done

lemma Lam_eqD:
  assumes major: "Lam(x, M) = Lam(y, M')"
  and prem1: "x: LVariable"
  and prem2: "M: Term"
  and prem3: "y: LVariable"
  and prem4: "M': Term"
  shows "M = subst(M', y, Var(x)) & x ~: FV(M') - {y}"
apply (rule prem2 [THEN TermE])
apply (rule_tac n="LVar(x)" in Term_LFreeForInE [OF prem4 prem3])
apply (rule prem1 LTerm.intros)+
apply (insert prem1 prem3 major)
apply (simp only: Term_LAQ subst_LAQ FV_LAQ)
apply (drule LAQ_eqD [THEN LAlpha_sym])
apply (safe elim!: LAlpha_LTermEs2 LTerm.free_elims)
apply (erule_tac [3] LFV_E)
apply (erule_tac [3] swap)
apply (drule_tac [3] LAlphaD2, erule_tac [3] asm_rl)
apply (erule_tac [3] LFV_I)
apply (rule_tac [2] LAQ_eqI)
apply (rule LAQ_eqI)
apply (simp add: Lsubst_self)
apply (erule LAlpha_sym)
apply (erule LAlpha_trans)
apply (rule LAlpha_LsubstI)
apply (erule LAlpha_sym)
apply (assumption | rule LAlpha_LVarI)+
done

lemma Alpha:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "y: LVariable"
  and prem4: "x ~: FV(M) - {y}"
  shows "Lam(y, M) = Lam(x, subst(M, y, Var(x)))"
apply (rule_tac n="LVar(x)" in Term_LFreeForInE [OF prem1 prem3])
apply (rule prem2 LTerm.intros)+
apply (insert prem2 prem3 prem4)
apply (simp add: Term_LAQ subst_LAQ FV_LAQ)
apply (rule LAQ_eqI)
apply (erule disjE)
prefer 2
apply hypsubst
apply (simp add: Lsubst_self)
apply (rule_tac [2] LAlpha_LLamI3)
apply (assumption | rule LAlpha_refl LTerm.intros)+
done

lemma Lam_iff:
  "[| M: Term; N: Term; x: LVariable; y: LVariable |] ==>
     Lam(x, M) = Lam(y, N) <-> M = subst(N, y, Var(x)) & x ~: FV(N) - {y}"
apply (rule iffI)
apply (erule Lam_eqD)
apply assumption+
apply (erule conjE)
apply hypsubst
apply (rule Alpha [THEN sym])
apply assumption+
done

lemma Var_Lam_free_iff:
  "x: LVariable ==> Var(x) = Lam(y, M) <-> False"
apply safe
apply (subgoal_tac "Lam(y, M): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma Var_App_free_iff:
  "x: LVariable ==> Var(x) = App(M, N) <-> False"
apply safe
apply (subgoal_tac "App(M, N): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma Lam_Var_free_iff:
  "[| x: LVariable; M: Term |] ==> Lam(x, M) = Var(y) <-> False"
apply safe
apply (subgoal_tac "Var(y): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma Lam_App_free_iff:
  "[| x: LVariable; M: Term |] ==> Lam(x, M) = App(A, B) <-> False"
apply safe
apply (subgoal_tac "App(A, B): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma App_Var_free_iff:
  "[| M: Term; N: Term |] ==> App(M, N) = Var(y) <-> False"
apply safe
apply (subgoal_tac "Var(y): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemma App_Lam_free_iff:
  "[| A: Term; B: Term |] ==> App(A, B) = Lam(x, M) <-> False"
apply safe
apply (subgoal_tac "Lam(x, M): Term")
apply (erule_tac [2] subst)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (erule Term_typeEs)
apply (erule TermE)+
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (drule LAQ_eqD)
apply (safe elim!: LTerm.free_elims LAlpha_LTermEs2)
done

lemmas Term_free_iffs = Var_iff App_iff Lam_iff
  Var_Lam_free_iff Var_App_free_iff
  Lam_Var_free_iff Lam_App_free_iff
  App_Var_free_iff App_Lam_free_iff

(** Beta1 **)
lemma Beta1D1:
  "Beta1(M, N) ==> M: Term"
apply (unfold Beta1_def)
apply (erule conjunct1)
done

lemma Beta1D2:
  "Beta1(M, N) ==> N: Term"
apply (unfold Beta1_def)
apply (erule conjunct2 [THEN conjunct1])
done

lemma Beta1_baseI:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "N: Term"
  shows "Beta1(App(Lam(x, M), N), subst(M, x, N))"
apply (unfold Beta1_def)
apply (assumption | rule Term_intros prem1 prem2 prem3 conjI subst_type)+
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem2])
apply assumption
apply (insert prem2)
apply (simp add: Term_LAQ subst_LAQ)
apply (assumption | rule LTerm.intros bexI LBeta1_baseI
        LAQ_self Lsubst_type)+
done

lemma Beta1_LamI:
  "[| Beta1(M, M'); x: LVariable |]  ==>
        Beta1(Lam(x, M), Lam(x, M'))"
apply (unfold Beta1_def)
apply (safe intro!: Term_intros)
apply (erule TermE)+
apply hypsubst
apply (simp add: Term_LAQ)
apply (drule LAQ_D)+
apply (rule bexI)
apply (rule bexI)
apply (rule LBeta1_LLamI)
apply (assumption | rule LAQ_I LAlpha_LLamI1)+
done

lemma Beta1_AppI1:
  "[| Beta1(M, M'); N: Term |]  ==>
        Beta1(App(M, N), App(M', N))"
apply (unfold Beta1_def)
apply (safe intro!: Term_intros)
apply (erule TermE)+
apply hypsubst
apply (simp add: Term_LAQ)
apply (drule LAQ_D)+
apply (rule bexI)
apply (rule bexI)
apply (rule LBeta1_LAppI1)
apply (assumption | rule LAQ_I LAlpha_LAppI LAlpha_refl)+
done

lemma Beta1_AppI2:
  "[| Beta1(N, N'); M: Term |]  ==>
        Beta1(App(M, N), App(M, N'))"
apply (unfold Beta1_def)
apply (safe intro!: Term_intros)
apply (erule TermE)+
apply hypsubst
apply (simp add: Term_LAQ)
apply (drule LAQ_D)+
apply (rule bexI)
apply (rule bexI)
apply (rule LBeta1_LAppI2)
apply (assumption | rule LAQ_I LAlpha_LAppI LAlpha_refl)+
done

lemma Beta1_VarE:
  "Beta1(Var(x), N) ==> R"
apply (unfold Beta1_def)
apply (safe elim!: Term_typeEs)
apply (rotate_tac 2)
apply (simp only: Term_LAQ)
apply (safe dest!: LAQ_D elim!: LAlpha_LTermEs2 LBeta1_LTermEs)
done

lemma Beta1_LamE1:
  assumes major: "Beta1(Lam(x, M), N)"
  and prem1:
     "!!N'. [| x: LVariable; N = Lam(x, N'); Beta1(M, N')|]
         ==> R"
  and prem2:
     "!!y N'. [| x: LVariable; y: LVariable; M: Term; N': Term; y ~: FV(M);
          N = Lam(y, N'); Beta1(subst(M, x, Var(y)), N')|]
         ==> R"
  shows "R"
apply (insert major)
apply (unfold Beta1_def)
apply (erule Term_typeEs conjE bexE TermE)+
apply (rotate_tac 3)
apply (simp only: Term_LAQ)
apply (drule LAQ_D)+
apply (erule LAlpha_LTermEs2)
apply hypsubst
apply (erule_tac LBeta1_LTermEs)
apply hypsubst
prefer 2
apply hypsubst
apply (erule_tac LBeta1_LTermEs)
apply hypsubst
prefer 2
apply (rule_tac [2] y="y" and N'="LAQ(N'a)" in prem2)
apply (rule_tac N'="LAQ(N'a)" in prem1)
apply (unfold Beta1_def)
apply (safe intro!: subst_type LAQ_type Term_intros)
prefer 2
prefer 4
prefer 7
apply (erule LBeta1_type2)+
apply (drule_tac [5] M="ma" in LAQ_eqI)
apply (simp_all add: Term_LAQ FV_LAQ LBeta1_type2 subst_LAQ)
apply (erule LAQ_eqI)
apply (erule_tac [3] LAQ_eqI)
apply (erule_tac [2] LFV_E)
apply (drule_tac [2] LAlphaD2, erule_tac [2] asm_rl)
apply (erule_tac [2] notE, erule_tac [2] LFV_I)
apply (assumption | rule bexI LAQ_self LAQ_I
       | erule LBeta1_type2 | erule LAlpha_sym)+
done

lemma Beta1_AppE1:
  assumes major: "Beta1(App(A, B), N)"
  and prem1:
     "!!x N'. [| x: LVariable; N': Term; B: Term;
         A = Lam(x, N'); N = subst(N', x, B) |] ==> R"
  and prem2:
     "!!A'. [| N = App(A',B); Beta1(A, A'); B: Term |] ==> R"
  and prem3:
     "!!B'. [| N = App(A, B'); Beta1(B, B'); A: Term |] ==> R"
  shows "R"
apply (insert major)
apply (unfold Beta1_def)
apply (erule Term_typeEs conjE bexE TermE)+
apply (rotate_tac 3)
apply (simp only: Term_LAQ)
apply (drule LAQ_D)+
apply (erule_tac LAlpha_LTermEs2)
apply hypsubst
apply (erule_tac LBeta1_LTermEs)
prefer 3
apply hypsubst
apply (drule LAQ_eqI)+
prefer 3
apply hypsubst
apply (drule LAQ_eqI)+
prefer 3
apply hypsubst
apply (drule LAQ_eqI)+
apply (rule_tac [3] B'="LAQ(B')" in prem3)
apply (rule_tac [2] A'="LAQ(A')" in prem2)
apply (rule_tac x="x" and N'="LAQ(N')" in prem1)
apply (unfold Beta1_def)
apply (safe intro!: subst_type LAQ_type Term_intros)
prefer 6
prefer 9
apply (erule LBeta1_type2)+
apply (erule LFreeForInD2)
apply (erule LFreeForInD3)
apply (simp_all add: Term_LAQ FV_LAQ LBeta1_type2
         LFreeForInD2 LFreeForInD3 subst_LAQ)
apply (assumption | rule bexI LAQ_self LAQ_I
       | erule LBeta1_type2 LBeta1_type1 LAlpha_sym)+
done

lemma Beta1_substI:
  assumes major: "Beta1(M, M')"
  and prem1: "x: LVariable"
  and prem2: "N: Term"
  shows "Beta1(subst(M, x, N), subst(M', x, N))"
apply (unfold Beta1_def)
apply (rule prem2 [THEN TermE])
apply (rule Term_LFreeForInE [OF
        major [unfolded Beta1_def, THEN conjunct1] prem1])
apply assumption
apply (rule_tac n="m" in Term_LFreeForInE [OF
        major [unfolded Beta1_def, THEN conjunct2, THEN conjunct1] prem1])
apply assumption
apply (insert major [unfolded Beta1_def, THEN conjunct2, THEN conjunct2])
apply (erule bexE)+
apply (simp only: subst_LAQ)
apply (assumption | rule LAQ_type Lsubst_type conjI)+
apply (drule_tac X="m" in
        Infinite_LVariable [THEN LBeta1_LAlpha_parallel])
apply (erule LFreeForInD2)
apply assumption
apply (safe dest!: LAQ_D)
apply (rule bexI [THEN bexI])
apply (erule LBeta1_LsubstI)
apply assumption+
apply (assumption | rule LAQ_I LAlpha_LsubstI LAlpha_refl
       | erule LAlpha_trans)+
done

lemma Beta1_FV_lemma:
  assumes major: "Beta1(M, N)"
  shows "FV(N) <= FV(M)"
apply (rule major [unfolded Beta1_def, THEN conjunct1, THEN TermE])
apply (rule major [unfolded Beta1_def, THEN conjunct2,
                   THEN conjunct1, THEN TermE])
apply (insert major)
apply (unfold Beta1_def)
apply (erule bexE conjE)+
apply hypsubst
apply (drule LAQ_D [THEN LAQ_eqI])+
apply (simp only: FV_LAQ LBeta1_type1 LBeta1_type2)
apply (erule LBeta1_LFV_lemma)
done

lemma FV_subst_not_in_lemma:
  assumes prem1: "M: Term"
  and prem2: "x: LVariable"
  and prem3: "N: Term"
  shows "x ~: FV(subst(M, x, N)) - FV(N)"
apply (insert prem2)
apply (rule prem3 [THEN TermE])
apply (rule Term_LFreeForInE [OF prem1 prem2])
apply assumption
apply (simp add: FV_LAQ subst_LAQ)
apply (safe intro!: Lsubst_type elim!: LFV_E LFreeIn_LsubstE)
apply (erule notE, erule LFV_I)
done

lemma Beta1_LamE:
  assumes major: "Beta1(Lam(x, M), N)"
  and prem:
     "!!N'. [| x: LVariable; N = Lam(x, N'); Beta1(M, N')|]
         ==> R"
  shows "R"
apply (rule major [THEN Beta1_LamE1])
apply (frule_tac [2] Beta1_FV_lemma)
apply (rule_tac [2] M1="M" and x1="x" and N1="Var(y)" in
         FV_subst_not_in_lemma [THEN revcut_rl])
prefer 5
apply (simp add: FV_eqns)
defer 1
apply (erule_tac [5] disjE)
apply (drule_tac [5] x="y" and N="Var(x)" in Beta1_substI)
apply (erule_tac [2] asm_rl | rule_tac [2] Term_intros)+
apply (frule_tac [2] Term_VarI)
apply (rotate_tac [2] 9)
prefer 2
apply (simp add: subst_lemma2 subst_self)
prefer 2
apply (rotate_tac [3] 7)
prefer 3
apply (simp add: subst_self)
defer 1
apply (rule_tac [3] prem)
apply (rule_tac [2] prem)
apply (rule_tac [1] prem)
prefer 6
prefer 9
apply assumption+
apply safe
apply (rule Alpha)
prefer 4 apply blast
apply assumption+
done

lemma Fin_FV_I:
  "M: Term ==> FV(M): Fin(LVariable)"
apply (erule TermE)
apply hypsubst
apply (simp only: FV_LAQ)
apply (erule LFV_Fin)
done

lemma Infinite_LVariable_Alpha_lemma2:
  assumes major: "M: Term"
  and prem1: "x: LVariable"
  and prem2: "X: Fin(LVariable)"
  shows "EX y: LVariable. EX M': Term. Lam(x, M) = Lam(y, M') & y ~: X"
apply (rule_tac F="X Un FV(M)" in Infinite_LVariable [THEN InfiniteE])
apply (assumption | rule Fin_UnI Fin_FV_I prem2 major bexI conjI)+
apply (rule Alpha)
prefer 2 apply assumption
prefer 3 apply blast
prefer 3 apply blast
apply (assumption | rule major prem1 subst_type Term_intros)+
done

lemma Beta1_AppE:
  assumes major: "Beta1(App(A, B), N)"
  and prem1:
     "!!x N'. [| x: LVariable; N': Term; B: Term; x ~: FV(B);
         A = Lam(x, N'); N = subst(N', x, B) |] ==> R"
  and prem2:
     "!!A'. [| B: Term; Beta1(A, A'); N = App(A', B) |] ==> R"
  and prem3:
     "!!B'. [| A: Term; Beta1(B, B'); N = App(A, B') |] ==> R"
  shows "R"
apply (rule major [THEN Beta1_AppE1])
apply (rule_tac M1="N'" and X1="cons(x, FV(B))" in
         Infinite_LVariable_Alpha_lemma2 [THEN revcut_rl])
apply (assumption | rule Fin_FV_I Fin.intros)+
apply (erule Term_typeEs conjE bexE)+
apply (subgoal_tac "y ~= x")
prefer 2 apply blast
apply (erule swap, rule consI2)
apply (erule swap)
apply (erule swap)
apply (rotate_tac 7)
apply simp
apply (rule prem1)
prefer 5 apply assumption
apply assumption+
apply (rotate_tac 1)
apply (simp add: Term_free_iffs)
apply (elim conjE disjE)
apply (simp add: subst_lemma2)
apply (simp add: subst_lemma2)
apply (rule prem2)
apply (rule_tac [4] prem3)
apply assumption+
done

lemmas Beta1_TermEs = Beta1_VarE Beta1_LamE Beta1_AppE

end


(*  Title:      ZF/Coind/Map.thy
    Author:     Jacob Frost, Cambridge University Computer Laboratory
    Copyright   1995  University of Cambridge

Some sample proofs of inclusions for the final coalgebra "U" (by lcp).
*)

theory Map imports ZF begin

definition
  TMap :: "[i,i] => i"  where
   "TMap(A,B) == {m \<in> Pow(A*\<Union>(B)).\<forall>a \<in> A. m``{a} \<in> B}"

definition
  PMap :: "[i,i] => i"  where
   "PMap(A,B) == TMap(A,cons(0,B))"

(* Note: 0 \<in> B ==> TMap(A,B) = PMap(A,B) *)

definition
  map_emp :: i  where
   "map_emp == 0"

definition
  map_owr :: "[i,i,i]=>i"  where
   "map_owr(m,a,b) == \<Sum>x \<in> {a} \<union> domain(m). if x=a then b else m``{x}"

definition
  map_app :: "[i,i]=>i"  where
   "map_app(m,a) == m``{a}"

lemma "{0,1} \<subseteq> {1} \<union> TMap(I, {0,1})"
by (unfold TMap_def, blast)

lemma "{0} \<union> TMap(I,1) \<subseteq> {1} \<union> TMap(I, {0} \<union> TMap(I,1))"
by (unfold TMap_def, blast)

lemma "{0,1} \<union> TMap(I,2) \<subseteq> {1} \<union> TMap(I, {0,1} \<union> TMap(I,2))"
by (unfold TMap_def, blast)

(*A bit too slow.
lemma "{0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2) \<subseteq>
       {1} \<union> TMap(I, {0,1} \<union> TMap(I,TMap(I,2)) \<union> TMap(I,2))"
by (unfold TMap_def, blast)
*)

(* ############################################################ *)
(* Lemmas                                                       *)
(* ############################################################ *)

lemma qbeta_if: "Sigma(A,B)``{a} = (if a \<in> A then B(a) else 0)"
by auto

lemma qbeta: "a \<in> A ==> Sigma(A,B)``{a} = B(a)"
by fast

lemma qbeta_emp: "a\<notin>A ==> Sigma(A,B)``{a} = 0"
by fast

lemma image_Sigma1: "a \<notin> A ==> Sigma(A,B)``{a}=0"
by fast

(* ############################################################ *)
(* Inclusion in Quine Universes                                 *)
(* ############################################################ *)

(* Lemmas *)

lemma MapQU_lemma:
    "A \<subseteq> univ(X) ==> Pow(A * \<Union>(quniv(X))) \<subseteq> quniv(X)"
apply (unfold quniv_def)
apply (rule Pow_mono)
apply (rule subset_trans [OF Sigma_mono product_univ])
apply (erule subset_trans)
apply (rule arg_subset_eclose [THEN univ_mono])
apply (simp add: Union_Pow_eq)
done

(* Theorems *)

lemma mapQU:
  "[| m \<in> PMap(A,quniv(B)); !!x. x \<in> A ==> x \<in> univ(B) |] ==> m \<in> quniv(B)"
apply (unfold PMap_def TMap_def)
apply (blast intro!: MapQU_lemma [THEN subsetD])
done

(* ############################################################ *)
(* Monotonicity                                                 *)
(* ############################################################ *)

lemma PMap_mono: "B \<subseteq> C ==> PMap(A,B)<=PMap(A,C)"
by (unfold PMap_def TMap_def, blast)

(* ############################################################ *)
(* Introduction Rules                                           *)
(* ############################################################ *)

(** map_emp **)

lemma pmap_empI: "map_emp \<in> PMap(A,B)"
by (unfold map_emp_def PMap_def TMap_def, auto)

(** map_owr **)

lemma pmap_owrI:
  "[| m \<in> PMap(A,B); a \<in> A; b \<in> B |]  ==> map_owr(m,a,b):PMap(A,B)"
apply (unfold map_owr_def PMap_def TMap_def, safe)
apply (simp_all add: if_iff, auto)
(*Remaining subgoal*)
apply (rule excluded_middle [THEN disjE])
apply (erule image_Sigma1)
apply (drule_tac psi = "uu \<notin> B" for uu in asm_rl)
apply (auto simp add: qbeta)
done

(** map_app **)

lemma tmap_app_notempty:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> map_app(m,a) \<noteq>0"
by (unfold TMap_def map_app_def, blast)

lemma tmap_appI:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> map_app(m,a):B"
by (unfold TMap_def map_app_def domain_def, blast)

lemma pmap_appI:
  "[| m \<in> PMap(A,B); a \<in> domain(m) |] ==> map_app(m,a):B"
apply (unfold PMap_def)
apply (frule tmap_app_notempty, assumption)
apply (drule tmap_appI, auto)
done

(** domain **)

lemma tmap_domainD:
  "[| m \<in> TMap(A,B); a \<in> domain(m) |] ==> a \<in> A"
by (unfold TMap_def, blast)

lemma pmap_domainD:
  "[| m \<in> PMap(A,B); a \<in> domain(m) |] ==> a \<in> A"
by (unfold PMap_def TMap_def, blast)

(* ############################################################ *)
(* Equalities                                                   *)
(* ############################################################ *)

(** Domain **)

(* Lemmas *)

lemma domain_UN: "domain(\<Union>x \<in> A. B(x)) = (\<Union>x \<in> A. domain(B(x)))"
by fast

lemma domain_Sigma: "domain(Sigma(A,B)) = {x \<in> A. \<exists>y. y \<in> B(x)}"
by blast

(* Theorems *)

lemma map_domain_emp: "domain(map_emp) = 0"
by (unfold map_emp_def, blast)

lemma map_domain_owr:
  "b \<noteq> 0 ==> domain(map_owr(f,a,b)) = {a} \<union> domain(f)"
apply (unfold map_owr_def)
apply (auto simp add: domain_Sigma)
done

(** Application **)

lemma map_app_owr:
  "map_app(map_owr(f,a,b),c) = (if c=a then b else map_app(f,c))"
by (simp add: qbeta_if  map_app_def map_owr_def, blast)

lemma map_app_owr1: "map_app(map_owr(f,a,b),a) = b"
by (simp add: map_app_owr)

lemma map_app_owr2: "c \<noteq> a ==> map_app(map_owr(f,a,b),c)= map_app(f,c)"
by (simp add: map_app_owr)

end