(*  Title       : HOL/NSA/HyperDef.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 1998  University of Cambridge
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section{*Construction of Hyperreals Using Ultrafilters*}

theory HyperDef
imports Complex_Main HyperNat
begin

type_synonym hypreal = "real star"

abbreviation
  hypreal_of_real :: "real => real star" where
  "hypreal_of_real == star_of"

abbreviation
  hypreal_of_hypnat :: "hypnat \<Rightarrow> hypreal" where
  "hypreal_of_hypnat \<equiv> of_hypnat"

definition
  omega :: hypreal where
   -- {*an infinite number @{text "= [<1,2,3,...>]"} *}
  "omega = star_n (\<lambda>n. real (Suc n))"

definition
  epsilon :: hypreal where
   -- {*an infinitesimal number @{text "= [<1,1/2,1/3,...>]"} *}
  "epsilon = star_n (\<lambda>n. inverse (real (Suc n)))"

notation (xsymbols)
  omega  ("\<omega>") and
  epsilon  ("\<epsilon>")

notation (HTML output)
  omega  ("\<omega>") and
  epsilon  ("\<epsilon>")

subsection {* Real vector class instances *}

instantiation star :: (scaleR) scaleR
begin

definition
  star_scaleR_def [transfer_unfold]: "scaleR r \<equiv> *f* (scaleR r)"

instance ..

end

lemma Standard_scaleR [simp]: "x \<in> Standard \<Longrightarrow> scaleR r x \<in> Standard"
by (simp add: star_scaleR_def)

lemma star_of_scaleR [simp]: "star_of (scaleR r x) = scaleR r (star_of x)"
by transfer (rule refl)

instance star :: (real_vector) real_vector
proof
  fix a b :: real
  show "\<And>x y::'a star. scaleR a (x + y) = scaleR a x + scaleR a y"
    by transfer (rule scaleR_right_distrib)
  show "\<And>x::'a star. scaleR (a + b) x = scaleR a x + scaleR b x"
    by transfer (rule scaleR_left_distrib)
  show "\<And>x::'a star. scaleR a (scaleR b x) = scaleR (a * b) x"
    by transfer (rule scaleR_scaleR)
  show "\<And>x::'a star. scaleR 1 x = x"
    by transfer (rule scaleR_one)
qed

instance star :: (real_algebra) real_algebra
proof
  fix a :: real
  show "\<And>x y::'a star. scaleR a x * y = scaleR a (x * y)"
    by transfer (rule mult_scaleR_left)
  show "\<And>x y::'a star. x * scaleR a y = scaleR a (x * y)"
    by transfer (rule mult_scaleR_right)
qed

instance star :: (real_algebra_1) real_algebra_1 ..

instance star :: (real_div_algebra) real_div_algebra ..

instance star :: (field_char_0) field_char_0 ..

instance star :: (real_field) real_field ..

lemma star_of_real_def [transfer_unfold]: "of_real r = star_of (of_real r)"
by (unfold of_real_def, transfer, rule refl)

lemma Standard_of_real [simp]: "of_real r \<in> Standard"
by (simp add: star_of_real_def)

lemma star_of_of_real [simp]: "star_of (of_real r) = of_real r"
by transfer (rule refl)

lemma of_real_eq_star_of [simp]: "of_real = star_of"
proof
  fix r :: real
  show "of_real r = star_of r"
    by transfer simp
qed

lemma Reals_eq_Standard: "(Reals :: hypreal set) = Standard"
by (simp add: Reals_def Standard_def)

subsection {* Injection from @{typ hypreal} *}

definition
  of_hypreal :: "hypreal \<Rightarrow> 'a::real_algebra_1 star" where
  [transfer_unfold]: "of_hypreal = *f* of_real"

lemma Standard_of_hypreal [simp]:
  "r \<in> Standard \<Longrightarrow> of_hypreal r \<in> Standard"
by (simp add: of_hypreal_def)

lemma of_hypreal_0 [simp]: "of_hypreal 0 = 0"
by transfer (rule of_real_0)

lemma of_hypreal_1 [simp]: "of_hypreal 1 = 1"
by transfer (rule of_real_1)

lemma of_hypreal_add [simp]:
  "\<And>x y. of_hypreal (x + y) = of_hypreal x + of_hypreal y"
by transfer (rule of_real_add)

lemma of_hypreal_minus [simp]: "\<And>x. of_hypreal (- x) = - of_hypreal x"
by transfer (rule of_real_minus)

lemma of_hypreal_diff [simp]:
  "\<And>x y. of_hypreal (x - y) = of_hypreal x - of_hypreal y"
by transfer (rule of_real_diff)

lemma of_hypreal_mult [simp]:
  "\<And>x y. of_hypreal (x * y) = of_hypreal x * of_hypreal y"
by transfer (rule of_real_mult)

lemma of_hypreal_inverse [simp]:
  "\<And>x. of_hypreal (inverse x) =
   inverse (of_hypreal x :: 'a::{real_div_algebra, division_ring_inverse_zero} star)"
by transfer (rule of_real_inverse)

lemma of_hypreal_divide [simp]:
  "\<And>x y. of_hypreal (x / y) =
   (of_hypreal x / of_hypreal y :: 'a::{real_field, field_inverse_zero} star)"
by transfer (rule of_real_divide)

lemma of_hypreal_eq_iff [simp]:
  "\<And>x y. (of_hypreal x = of_hypreal y) = (x = y)"
by transfer (rule of_real_eq_iff)

lemma of_hypreal_eq_0_iff [simp]:
  "\<And>x. (of_hypreal x = 0) = (x = 0)"
by transfer (rule of_real_eq_0_iff)

subsection{*Properties of @{term starrel}*}

lemma lemma_starrel_refl [simp]: "x \<in> starrel `` {x}"
by (simp add: starrel_def)

lemma starrel_in_hypreal [simp]: "starrel``{x}:star"
by (simp add: star_def starrel_def quotient_def, blast)

declare Abs_star_inject [simp] Abs_star_inverse [simp]
declare equiv_starrel [THEN eq_equiv_class_iff, simp]

subsection{*@{term hypreal_of_real}:
            the Injection from @{typ real} to @{typ hypreal}*}

lemma inj_star_of: "inj star_of"
by (rule inj_onI, simp)

lemma mem_Rep_star_iff: "(X \<in> Rep_star x) = (x = star_n X)"
by (cases x, simp add: star_n_def)

lemma Rep_star_star_n_iff [simp]:
  "(X \<in> Rep_star (star_n Y)) = ({n. Y n = X n} \<in> \<U>)"
by (simp add: star_n_def)

lemma Rep_star_star_n: "X \<in> Rep_star (star_n X)"
by simp

subsection{* Properties of @{term star_n} *}

lemma star_n_add:
  "star_n X + star_n Y = star_n (%n. X n + Y n)"
by (simp only: star_add_def starfun2_star_n)

lemma star_n_minus:
   "- star_n X = star_n (%n. -(X n))"
by (simp only: star_minus_def starfun_star_n)

lemma star_n_diff:
     "star_n X - star_n Y = star_n (%n. X n - Y n)"
by (simp only: star_diff_def starfun2_star_n)

lemma star_n_mult:
  "star_n X * star_n Y = star_n (%n. X n * Y n)"
by (simp only: star_mult_def starfun2_star_n)

lemma star_n_inverse:
      "inverse (star_n X) = star_n (%n. inverse(X n))"
by (simp only: star_inverse_def starfun_star_n)

lemma star_n_le:
      "star_n X \<le> star_n Y =
       ({n. X n \<le> Y n} \<in> FreeUltrafilterNat)"
by (simp only: star_le_def starP2_star_n)

lemma star_n_less:
      "star_n X < star_n Y = ({n. X n < Y n} \<in> FreeUltrafilterNat)"
by (simp only: star_less_def starP2_star_n)

lemma star_n_zero_num: "0 = star_n (%n. 0)"
by (simp only: star_zero_def star_of_def)

lemma star_n_one_num: "1 = star_n (%n. 1)"
by (simp only: star_one_def star_of_def)

lemma star_n_abs:
     "abs (star_n X) = star_n (%n. abs (X n))"
by (simp only: star_abs_def starfun_star_n)

lemma hypreal_omega_gt_zero [simp]: "0 < omega"
by (simp add: omega_def star_n_zero_num star_n_less)

subsection{*Existence of Infinite Hyperreal Number*}

text{*Existence of infinite number not corresponding to any real number.
Use assumption that member @{term FreeUltrafilterNat} is not finite.*}

text{*A few lemmas first*}

lemma lemma_omega_empty_singleton_disj: "{n::nat. x = real n} = {} |
      (\<exists>y. {n::nat. x = real n} = {y})"
by force

lemma lemma_finite_omega_set: "finite {n::nat. x = real n}"
by (cut_tac x = x in lemma_omega_empty_singleton_disj, auto)

lemma not_ex_hypreal_of_real_eq_omega:
      "~ (\<exists>x. hypreal_of_real x = omega)"
apply (simp add: omega_def)
apply (simp add: star_of_def star_n_eq_iff)
apply (auto simp add: real_of_nat_Suc diff_eq_eq [symmetric]
            lemma_finite_omega_set [THEN FreeUltrafilterNat.finite])
done

lemma hypreal_of_real_not_eq_omega: "hypreal_of_real x \<noteq> omega"
by (insert not_ex_hypreal_of_real_eq_omega, auto)

text{*Existence of infinitesimal number also not corresponding to any
 real number*}

lemma lemma_epsilon_empty_singleton_disj:
     "{n::nat. x = inverse(real(Suc n))} = {} |
      (\<exists>y. {n::nat. x = inverse(real(Suc n))} = {y})"
by auto

lemma lemma_finite_epsilon_set: "finite {n. x = inverse(real(Suc n))}"
by (cut_tac x = x in lemma_epsilon_empty_singleton_disj, auto)

lemma not_ex_hypreal_of_real_eq_epsilon: "~ (\<exists>x. hypreal_of_real x = epsilon)"
by (auto simp add: epsilon_def star_of_def star_n_eq_iff
                   lemma_finite_epsilon_set [THEN FreeUltrafilterNat.finite])

lemma hypreal_of_real_not_eq_epsilon: "hypreal_of_real x \<noteq> epsilon"
by (insert not_ex_hypreal_of_real_eq_epsilon, auto)

lemma hypreal_epsilon_not_zero: "epsilon \<noteq> 0"
by (simp add: epsilon_def star_zero_def star_of_def star_n_eq_iff
         del: star_of_zero)

lemma hypreal_epsilon_inverse_omega: "epsilon = inverse(omega)"
by (simp add: epsilon_def omega_def star_n_inverse)

lemma hypreal_epsilon_gt_zero: "0 < epsilon"
by (simp add: hypreal_epsilon_inverse_omega)

subsection{*Absolute Value Function for the Hyperreals*}

lemma hrabs_add_less:
     "[| abs x < r; abs y < s |] ==> abs(x+y) < r + (s::hypreal)"
by (simp add: abs_if split: split_if_asm)

lemma hrabs_less_gt_zero: "abs x < r ==> (0::hypreal) < r"
by (blast intro!: order_le_less_trans abs_ge_zero)

lemma hrabs_disj: "abs x = (x::'a::abs_if) | abs x = -x"
by (simp add: abs_if)

lemma hrabs_add_lemma_disj: "(y::hypreal) + - x + (y + - z) = abs (x + - z) ==> y = z | x = y"
by (simp add: abs_if split add: split_if_asm)

subsection{*Embedding the Naturals into the Hyperreals*}

abbreviation
  hypreal_of_nat :: "nat => hypreal" where
  "hypreal_of_nat == of_nat"

lemma SNat_eq: "Nats = {n. \<exists>N. n = hypreal_of_nat N}"
by (simp add: Nats_def image_def)

(*------------------------------------------------------------*)
(* naturals embedded in hyperreals                            *)
(* is a hyperreal c.f. NS extension                           *)
(*------------------------------------------------------------*)

lemma hypreal_of_nat_eq:
     "hypreal_of_nat (n::nat) = hypreal_of_real (real n)"
by (simp add: real_of_nat_def)

lemma hypreal_of_nat:
     "hypreal_of_nat m = star_n (%n. real m)"
apply (fold star_of_def)
apply (simp add: real_of_nat_def)
done

(*
FIXME: we should declare this, as for type int, but many proofs would break.
It replaces x+-y by x-y.
Addsimps [symmetric hypreal_diff_def]
*)

declaration {*
  K (Lin_Arith.add_inj_thms [@{thm star_of_le} RS iffD2,
    @{thm star_of_less} RS iffD2, @{thm star_of_eq} RS iffD2]
  #> Lin_Arith.add_simps [@{thm star_of_zero}, @{thm star_of_one},
      @{thm star_of_numeral}, @{thm star_of_add},
      @{thm star_of_minus}, @{thm star_of_diff}, @{thm star_of_mult}]
  #> Lin_Arith.add_inj_const (@{const_name "StarDef.star_of"}, @{typ "real \<Rightarrow> hypreal"}))
*}

simproc_setup fast_arith_hypreal ("(m::hypreal) < n" | "(m::hypreal) <= n" | "(m::hypreal) = n") =
  {* fn _ => fn ss => fn ct => Lin_Arith.simproc ss (term_of ct) *}

subsection {* Exponentials on the Hyperreals *}

lemma hpowr_0 [simp]:   "r ^ 0       = (1::hypreal)"
by (rule power_0)

lemma hpowr_Suc [simp]: "r ^ (Suc n) = (r::hypreal) * (r ^ n)"
by (rule power_Suc)

lemma hrealpow_two: "(r::hypreal) ^ Suc (Suc 0) = r * r"
by simp

lemma hrealpow_two_le [simp]: "(0::hypreal) \<le> r ^ Suc (Suc 0)"
by (auto simp add: zero_le_mult_iff)

lemma hrealpow_two_le_add_order [simp]:
     "(0::hypreal) \<le> u ^ Suc (Suc 0) + v ^ Suc (Suc 0)"
by (simp only: hrealpow_two_le add_nonneg_nonneg)

lemma hrealpow_two_le_add_order2 [simp]:
     "(0::hypreal) \<le> u ^ Suc (Suc 0) + v ^ Suc (Suc 0) + w ^ Suc (Suc 0)"
by (simp only: hrealpow_two_le add_nonneg_nonneg)

lemma hypreal_add_nonneg_eq_0_iff:
     "[| 0 \<le> x; 0 \<le> y |] ==> (x+y = 0) = (x = 0 & y = (0::hypreal))"
by arith

text{*FIXME: DELETE THESE*}
lemma hypreal_three_squares_add_zero_iff:
     "(x*x + y*y + z*z = 0) = (x = 0 & y = 0 & z = (0::hypreal))"
apply (simp only: zero_le_square add_nonneg_nonneg hypreal_add_nonneg_eq_0_iff, auto)
done

lemma hrealpow_three_squares_add_zero_iff [simp]:
     "(x ^ Suc (Suc 0) + y ^ Suc (Suc 0) + z ^ Suc (Suc 0) = (0::hypreal)) =
      (x = 0 & y = 0 & z = 0)"
by (simp only: hypreal_three_squares_add_zero_iff hrealpow_two)

(*FIXME: This and RealPow.abs_realpow_two should be replaced by an abstract
  result proved in Rings or Fields*)
lemma hrabs_hrealpow_two [simp]:
     "abs(x ^ Suc (Suc 0)) = (x::hypreal) ^ Suc (Suc 0)"
by (simp add: abs_mult)

lemma two_hrealpow_ge_one [simp]: "(1::hypreal) \<le> 2 ^ n"
by (insert power_increasing [of 0 n "2::hypreal"], simp)

lemma two_hrealpow_gt [simp]: "hypreal_of_nat n < 2 ^ n"
apply (induct n)
apply (auto simp add: distrib_right)
apply (cut_tac n = n in two_hrealpow_ge_one, arith)
done

lemma hrealpow:
    "star_n X ^ m = star_n (%n. (X n::real) ^ m)"
apply (induct_tac "m")
apply (auto simp add: star_n_one_num star_n_mult power_0)
done

lemma hrealpow_sum_square_expand:
     "(x + (y::hypreal)) ^ Suc (Suc 0) =
      x ^ Suc (Suc 0) + y ^ Suc (Suc 0) + (hypreal_of_nat (Suc (Suc 0)))*x*y"
by (simp add: distrib_left distrib_right)

lemma power_hypreal_of_real_numeral:
     "(numeral v :: hypreal) ^ n = hypreal_of_real ((numeral v) ^ n)"
by simp
declare power_hypreal_of_real_numeral [of _ "numeral w", simp] for w

lemma power_hypreal_of_real_neg_numeral:
     "(- numeral v :: hypreal) ^ n = hypreal_of_real ((- numeral v) ^ n)"
by simp
declare power_hypreal_of_real_neg_numeral [of _ "numeral w", simp] for w
(*
lemma hrealpow_HFinite:
  fixes x :: "'a::{real_normed_algebra,power} star"
  shows "x \<in> HFinite ==> x ^ n \<in> HFinite"
apply (induct_tac "n")
apply (auto simp add: power_Suc intro: HFinite_mult)
done
*)

subsection{*Powers with Hypernatural Exponents*}

definition pow :: "['a::power star, nat star] \<Rightarrow> 'a star" (infixr "pow" 80) where
  hyperpow_def [transfer_unfold]: "R pow N = ( *f2* op ^) R N"
  (* hypernatural powers of hyperreals *)

lemma Standard_hyperpow [simp]:
  "\<lbrakk>r \<in> Standard; n \<in> Standard\<rbrakk> \<Longrightarrow> r pow n \<in> Standard"
unfolding hyperpow_def by simp

lemma hyperpow: "star_n X pow star_n Y = star_n (%n. X n ^ Y n)"
by (simp add: hyperpow_def starfun2_star_n)

lemma hyperpow_zero [simp]:
  "\<And>n. (0::'a::{power,semiring_0} star) pow (n + (1::hypnat)) = 0"
by transfer simp

lemma hyperpow_not_zero:
  "\<And>r n. r \<noteq> (0::'a::{field} star) ==> r pow n \<noteq> 0"
by transfer (rule field_power_not_zero)

lemma hyperpow_inverse:
  "\<And>r n. r \<noteq> (0::'a::field_inverse_zero star)
   \<Longrightarrow> inverse (r pow n) = (inverse r) pow n"
by transfer (rule power_inverse)

lemma hyperpow_hrabs:
  "\<And>r n. abs (r::'a::{linordered_idom} star) pow n = abs (r pow n)"
by transfer (rule power_abs [symmetric])

lemma hyperpow_add:
  "\<And>r n m. (r::'a::monoid_mult star) pow (n + m) = (r pow n) * (r pow m)"
by transfer (rule power_add)

lemma hyperpow_one [simp]:
  "\<And>r. (r::'a::monoid_mult star) pow (1::hypnat) = r"
by transfer (rule power_one_right)

lemma hyperpow_two:
  "\<And>r. (r::'a::monoid_mult star) pow (2::hypnat) = r * r"
by transfer (rule power2_eq_square)

lemma hyperpow_gt_zero:
  "\<And>r n. (0::'a::{linordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
by transfer (rule zero_less_power)

lemma hyperpow_ge_zero:
  "\<And>r n. (0::'a::{linordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
by transfer (rule zero_le_power)

lemma hyperpow_le:
  "\<And>x y n. \<lbrakk>(0::'a::{linordered_semidom} star) < x; x \<le> y\<rbrakk>
   \<Longrightarrow> x pow n \<le> y pow n"
by transfer (rule power_mono [OF _ order_less_imp_le])

lemma hyperpow_eq_one [simp]:
  "\<And>n. 1 pow n = (1::'a::monoid_mult star)"
by transfer (rule power_one)

lemma hrabs_hyperpow_minus [simp]:
  "\<And>(a::'a::{linordered_idom} star) n. abs((-a) pow n) = abs (a pow n)"
by transfer (rule abs_power_minus)

lemma hyperpow_mult:
  "\<And>r s n. (r * s::'a::{comm_monoid_mult} star) pow n
   = (r pow n) * (s pow n)"
by transfer (rule power_mult_distrib)

lemma hyperpow_two_le [simp]:
  "\<And>r. (0::'a::{monoid_mult,linordered_ring_strict} star) \<le> r pow 2"
by (auto simp add: hyperpow_two zero_le_mult_iff)

lemma hrabs_hyperpow_two [simp]:
  "abs(x pow 2) =
   (x::'a::{monoid_mult,linordered_ring_strict} star) pow 2"
by (simp only: abs_of_nonneg hyperpow_two_le)

lemma hyperpow_two_hrabs [simp]:
  "abs(x::'a::{linordered_idom} star) pow 2 = x pow 2"
by (simp add: hyperpow_hrabs)

text{*The precondition could be weakened to @{term "0\<le>x"}*}
lemma hypreal_mult_less_mono:
     "[| u<v;  x<y;  (0::hypreal) < v;  0 < x |] ==> u*x < v* y"
 by (simp add: mult_strict_mono order_less_imp_le)

lemma hyperpow_two_gt_one:
  "\<And>r::'a::{linordered_semidom} star. 1 < r \<Longrightarrow> 1 < r pow 2"
by transfer simp

lemma hyperpow_two_ge_one:
  "\<And>r::'a::{linordered_semidom} star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow 2"
by transfer (rule one_le_power)

lemma two_hyperpow_ge_one [simp]: "(1::hypreal) \<le> 2 pow n"
apply (rule_tac y = "1 pow n" in order_trans)
apply (rule_tac [2] hyperpow_le, auto)
done

lemma hyperpow_minus_one2 [simp]:
     "\<And>n. (- 1) pow (2*n) = (1::hypreal)"
by transfer (rule power_minus1_even)

lemma hyperpow_less_le:
     "!!r n N. [|(0::hypreal) \<le> r; r \<le> 1; n < N|] ==> r pow N \<le> r pow n"
by transfer (rule power_decreasing [OF order_less_imp_le])

lemma hyperpow_SHNat_le:
     "[| 0 \<le> r;  r \<le> (1::hypreal);  N \<in> HNatInfinite |]
      ==> ALL n: Nats. r pow N \<le> r pow n"
by (auto intro!: hyperpow_less_le simp add: HNatInfinite_iff)

lemma hyperpow_realpow:
      "(hypreal_of_real r) pow (hypnat_of_nat n) = hypreal_of_real (r ^ n)"
by transfer (rule refl)

lemma hyperpow_SReal [simp]:
     "(hypreal_of_real r) pow (hypnat_of_nat n) \<in> Reals"
by (simp add: Reals_eq_Standard)

lemma hyperpow_zero_HNatInfinite [simp]:
     "N \<in> HNatInfinite ==> (0::hypreal) pow N = 0"
by (drule HNatInfinite_is_Suc, auto)

lemma hyperpow_le_le:
     "[| (0::hypreal) \<le> r; r \<le> 1; n \<le> N |] ==> r pow N \<le> r pow n"
apply (drule order_le_less [of n, THEN iffD1])
apply (auto intro: hyperpow_less_le)
done

lemma hyperpow_Suc_le_self2:
     "[| (0::hypreal) \<le> r; r < 1 |] ==> r pow (n + (1::hypnat)) \<le> r"
apply (drule_tac n = " (1::hypnat) " in hyperpow_le_le)
apply auto
done

lemma hyperpow_hypnat_of_nat: "\<And>x. x pow hypnat_of_nat n = x ^ n"
by transfer (rule refl)

lemma of_hypreal_hyperpow:
  "\<And>x n. of_hypreal (x pow n) =
   (of_hypreal x::'a::{real_algebra_1} star) pow n"
by transfer (rule of_real_power)

end


theory Check
  imports Submission
begin

theorem enc_dec: "rldec (rlenc a 0 l) = l"
  by (rule Submission.enc_dec)

theorem semantics_unchanged: "aval (normalize a) s = aval a s"
  by (rule Submission.semantics_unchanged)

theorem normalize_normalizes: "normal (normalize a)"
  by (rule Submission.normalize_normalizes)

end


theory list_weird_is_normal
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun weirdconcat :: "('a list) list => 'a list" where
"weirdconcat (Nil2) = Nil2"
| "weirdconcat (Cons2 (Nil2) xss) = weirdconcat xss"
| "weirdconcat (Cons2 (Cons2 z xs) xss) =
     Cons2 z (weirdconcat (Cons2 xs xss))"
by pat_completeness auto

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun concat2 :: "('a list) list => 'a list" where
"concat2 (Nil2) = Nil2"
| "concat2 (Cons2 xs xss) = append xs (concat2 xss)"

(*hipster weirdconcat append concat2 *)

theorem x0 :
  "!! (x :: ('a list) list) . (concat2 x) = (weirdconcat x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
    File:        dB.thy
    Time-stamp:  <2020-06-22T04:36:14Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory dB imports dAlpha LAlpha begin

definition dB :: "i=>i" where
"dB(M) == LTerm_rec(%x. dVar(x), %x M r. dLam(dAbst(r, x, 0)),
                    %M N rm rn. dApp(rm, rn), M)"

definition LAlpha3 :: "[i,i] => o" where
"LAlpha3(M, N) == M: LTerm & N: LTerm & dB(M) = dB(N)"

definition dsubst :: "[i, i, i]=>i" where
"dsubst(M, x, N) == dSubst(dAbst(M, x, 0), 0, N)"

definition isSubst1 :: "[i,i,i,i]=>o" where
"isSubst1(A, x, B, C) == EX A'. LAlpha(A, A') & LFreeForIn(B, x, A') &
    LAlpha(Lsubst(A', x, B), C)"

definition isSubst2 :: "[i,i,i,i]=>o" where
"isSubst2(A, x, B, C) == A: LTerm & B: LTerm & C: LTerm & x: LVariable &
    dsubst(dB(A), x, dB(B)) = dB(C)"

lemma dB_eqns:
  "dB(LVar(x)) = dVar(x)"
  "dB(LLam(x, M)) = dLam(dAbst(dB(M), x, 0))"
  "dB(LApp(A, B)) = dApp(dB(A), dB(B))"
apply (unfold dB_def)
apply simp_all
done

lemma dB_type:
  "M: LTerm ==> dB(M): dProp"
apply (erule LTerm.induct)
apply (simp_all only: dB_eqns)
apply (case_tac [2] "x : dFV(dB(M))")
apply (erule_tac [2] dPropE)
apply (rule_tac [2] dProp_dLamI2)
prefer 3 apply (simp add: dDeg_dAbst_lemma2)
apply (frule_tac [3] dPropD1)
prefer 3 apply (simp add: dDeg_dAbst_lemma1)
apply (erule dProp_dLamI1)
apply (assumption | rule dProp_dTermIs dAbst_type nat_0I)+
done

lemma LFreeIn_imp_dFreeIn:
  assumes prem: "LFreeIn(<l, TLVar(x)>, M)"
  shows "<l, TdVar(x)>: dOcc(dB(M))"
apply (rule prem [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LFreeInD1, THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LFreeIn_LTermEs LTag.free_elims
            intro!: dOcc_dTermIs)
apply (rule dOcc_dAbstI2)
apply (erule_tac [3] dB_type [THEN dPropD1])
apply (rule_tac [3] nat_0I)
prefer 2 apply (blast elim!: dTag.free_elims)
apply simp_all
done

lemma dFreeIn_imp_LFreeIn:
  assumes prem1: "<l, TdVar(x)>: dOcc(dB(M))"
  and prem2: "M: LTerm"
  shows "LFreeIn(<l, TLVar(x)>, M)"
apply (rule prem1 [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem2 [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dOcc_dTermEs dTag.free_elims)
apply (frule_tac [2] dOcc_dAbst_lemma1)
apply (erule_tac [4] dOcc_dAbstE)
apply (erule_tac [2] dB_type [THEN dPropD1]
       | rule_tac [2] nat_0I)+
apply (blast intro!: LFreeIn_LTermIs elim!: dTag.free_elims)+
done

lemma dBoundBy_imp_LBoundBy:
  assumes prem1: "dBoundBy(<l, T>, <m, U>, dB(M))"
  and prem2: "M: LTerm"
  shows "EX T U. LBoundBy(<l, T>, <m, U>, M)"
apply (rule prem1 [THEN rev_mp])
apply (rule_tac x="m" in spec)
apply (rule_tac x="l" in spec)
apply (rule prem2 [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dBoundBy_dTermEs dTag.free_elims)
apply (subgoal_tac "EX T. <m, T>: dOcc(dB(M))")
apply (erule_tac [2] dOcc_dAbstE)
apply (rule_tac [5] exI)
apply (rule_tac [4] exI)
apply (erule_tac [2] asm_rl
       | rule_tac [2] dB_type [THEN dPropD1] nat_0I)+
apply (erule exE)
apply (rule_tac n1="0" and x1="x" in dLamDeg_dAbst_lemma [THEN revcut_rl])
apply (erule dB_type [THEN dPropD1])
apply (assumption | rule nat_0I)+
apply (rotate_tac 6)
apply simp
apply (drule dOcc_dAbst_lemma3 [THEN dFreeIn_imp_LFreeIn])
apply (assumption | rule dB_type)+
apply (rule exI [THEN exI])
apply (erule LBoundBy_LLamI1)
apply (drule dBoundBy_dAbstD)
apply (assumption | rule dB_type [THEN dPropD1] nat_0I)+
apply (drule_tac [3] spec [THEN spec, THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN spec, THEN mp], erule_tac [2] asm_rl)
apply (drule_tac [1] spec [THEN spec, THEN mp], erule_tac [1] asm_rl)
apply safe
apply (assumption | rule exI [THEN exI]
       | erule LBoundBy_LTermIs)+
done

lemma LBoundBy_imp_dBoundBy:
  assumes prem1: "LBoundBy(<l, T>, <m, U>, M)"
  shows "EX T U. dBoundBy(<l, T>, <m, U>, dB(M))"
apply (rule prem1 [THEN rev_mp])
apply (rule_tac x="m" in spec)
apply (rule_tac x="l" in spec)
apply (rule prem1 [THEN LBoundByD1, THEN LBindingD1, THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LBoundBy_LTermEs LTag.free_elims)
apply (drule LFreeIn_imp_dFreeIn)
apply (rule exI [THEN exI])
apply (rule dBoundBy_dLamI1)
apply (erule_tac [3] dOcc_dAbstI1)
apply (rule_tac [2] add_0 [THEN ssubst])
apply (assumption | rule dAbst_type dB_type [THEN dPropD1]
         dLamDeg_dAbst_lemma nat_0I dLamDeg_type)+
apply (drule_tac [3] spec [THEN spec, THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN spec, THEN mp], erule_tac [2] asm_rl)
apply (drule_tac [1] spec [THEN spec, THEN mp], erule_tac [1] asm_rl)
apply safe
apply (assumption | rule dBoundBy_dTermIs dBoundBy_dAbstI
         nat_0I dB_type [THEN dPropD1] exI)+
done

lemma dOcc_TdLam_imp_LOcc_TLLam:
  assumes major: "<l, TdLam>: dOcc(dB(M))"
  and prem: "M: LTerm"
  shows "EX x. <l, TLLam(x)>: LOcc(M)"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dOcc_dTermEs dOcc_dAbstE dTag.free_elims)
apply (erule_tac [2] asm_rl
       | rule_tac [2] dB_type [THEN dPropD1] nat_0I)+
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN mp], erule_tac [2] asm_rl)
apply safe
apply (assumption | rule exI LOcc_LTermIs)+
done

lemma LOcc_TLLam_imp_dOcc_TdLam:
  assumes major: "<l, TLLam(x)>: LOcc(M)"
  and prem: "M: LTerm"
  shows "<l, TdLam>: dOcc(dB(M))"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LOcc_LTermEs LTag.free_elims)
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN mp], erule_tac [2] asm_rl)
apply (rule_tac [2] dOcc_dTermIs)
apply (erule_tac [2] dOcc_dAbstI2)
prefer 2 apply (blast elim!: dTag.free_elims)
apply (assumption | rule exI dB_type [THEN dPropD1] nat_0I
         dOcc_dTermIs)+
done

lemma dOcc_TdApp_imp_LOcc_TLApp:
  assumes major: "<l, TdApp>: dOcc(dB(M))"
  and prem: "M: LTerm"
  shows "<l, TLApp>: LOcc(M)"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dOcc_dTermEs dOcc_dAbstE dTag.free_elims)
apply (assumption | rule dB_type [THEN dPropD1] nat_0I)+
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [1] spec [THEN mp], erule_tac [1] asm_rl)
apply (assumption | rule exI LOcc_LTermIs)+
done

lemma LOcc_TLApp_imp_dOcc_TdApp:
  assumes major: "<l, TLApp>: LOcc(M)"
  and prem: "M: LTerm"
  shows "<l, TdApp>: dOcc(dB(M))"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LOcc_LTermEs LTag.free_elims)
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [1] spec [THEN mp], erule_tac [1] asm_rl)
apply (rule dOcc_dTermIs)
apply (erule dOcc_dAbstI2)
apply (blast elim!: dTag.free_elims)
apply (assumption | rule exI dB_type [THEN dPropD1] nat_0I
         dOcc_dTermIs)+
done

lemma LAlpha_imp_dAlpha:
  assumes major: "LAlpha(M, N)"
  shows "dAlpha(dB(M), dB(N))"
apply (insert major [THEN LAlphaD1, THEN LSkeltonEqD1]
              major [THEN LAlphaD1, THEN LSkeltonEqD2])
apply (rule dAlpha_dPropI)
apply (assumption | rule dB_type)+
apply safe
apply (drule_tac [8] dBoundBy_imp_LBoundBy)
apply (drule_tac [7] dBoundBy_imp_LBoundBy)
apply (drule_tac [6] dFreeIn_imp_LFreeIn)
apply (drule_tac [5] dFreeIn_imp_LFreeIn)
apply (drule_tac [4] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [3] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [2] dOcc_TdLam_imp_LOcc_TLLam)
apply (drule_tac [1] dOcc_TdLam_imp_LOcc_TLLam)
apply safe
apply (drule_tac [8] major [THEN LAlpha_sym, THEN LAlphaD3])
apply (drule_tac [7] major [THEN LAlphaD3])
apply (drule_tac [6] major [THEN LAlpha_sym, THEN LAlphaD2])
apply (drule_tac [5] major [THEN LAlphaD2])
apply (drule_tac [4] major [THEN LAlpha_sym, THEN LAlphaD1,
                            THEN LSkeltonEq_TLAppD])
apply (drule_tac [3] major [THEN LAlphaD1,
                            THEN LSkeltonEq_TLAppD])
apply (drule_tac [2] major [THEN LAlpha_sym, THEN LAlphaD1,
                            THEN LSkeltonEq_TLLamD])
apply (drule_tac [1] major [THEN LAlphaD1,
                            THEN LSkeltonEq_TLLamD])
apply safe
apply (drule_tac [8] LBoundBy_imp_dBoundBy)
apply (drule_tac [7] LBoundBy_imp_dBoundBy)
apply (drule_tac [6] LFreeIn_imp_dFreeIn)
apply (drule_tac [5] LFreeIn_imp_dFreeIn)
apply (drule_tac [4] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [3] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [2] LOcc_TLLam_imp_dOcc_TdLam)
apply (drule_tac [1] LOcc_TLLam_imp_dOcc_TdLam)
apply safe
apply (blast elim!: dBoundByE intro: dBoundByI)+
done

lemma dAlpha_imp_LAlpha:
  assumes major: "dAlpha(dB(M), dB(N))"
  and prem1: "M: LTerm"
  and prem2: "N: LTerm"
  shows "LAlpha(M, N)"
apply (insert prem1 prem2)
apply (rule LAlphaI2)
apply safe
apply (drule_tac [8] LBoundBy_imp_dBoundBy)
apply (drule_tac [7] LBoundBy_imp_dBoundBy)
apply (drule_tac [6] LFreeIn_imp_dFreeIn)
apply (drule_tac [5] LFreeIn_imp_dFreeIn)
apply (drule_tac [4] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [3] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [2] LOcc_TLLam_imp_dOcc_TdLam)
apply (drule_tac [1] LOcc_TLLam_imp_dOcc_TdLam)
apply safe
apply (drule_tac [8] major [THEN dAlpha_sym, THEN dAlpha_dBoundByD])
apply (drule_tac [7] major [THEN dAlpha_dBoundByD])
apply (drule_tac [6] major [THEN dAlpha_sym, THEN dAlphaD2])
apply (drule_tac [5] major [THEN dAlphaD2])
apply (drule_tac [4] major [THEN dAlpha_sym, THEN dAlphaD1,
                            THEN dSkeltonEq_TdAppD])
apply (drule_tac [3] major [THEN dAlphaD1,
                            THEN dSkeltonEq_TdAppD])
apply (drule_tac [2] major [THEN dAlpha_sym, THEN dAlphaD1,
                            THEN dSkeltonEq_TdLamD])
apply (drule_tac [1] major [THEN dAlphaD1,
                            THEN dSkeltonEq_TdLamD])
apply (drule_tac [8] dBoundBy_imp_LBoundBy)
apply (drule_tac [7] dBoundBy_imp_LBoundBy)
apply (drule_tac [6] dFreeIn_imp_LFreeIn)
apply (drule_tac [5] dFreeIn_imp_LFreeIn)
apply (drule_tac [4] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [3] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [2] dOcc_TdLam_imp_LOcc_TLLam)
apply (drule_tac [1] dOcc_TdLam_imp_LOcc_TLLam)
apply safe
apply (blast elim!: LBoundByE intro: LBoundByI)+
done

(** Now, we can prove correspondence between our alpha-equivarence, LAlpha,
    and equivarence under the de Bruijn notation, LAlpha3. **)

lemma LAlpha3_iff_LAlpha:
  "LAlpha3(M, N) <-> LAlpha(M, N)"
apply (unfold LAlpha3_def)
apply (rule iffI)
apply (erule conjE)+
apply (rule dAlpha_imp_LAlpha)
apply simp
apply (rule dAlpha_refl)
apply (assumption | rule dB_type [THEN dPropD1])+
apply (frule LAlphaD1 [THEN LSkeltonEqD1])
apply (frule LAlphaD1 [THEN LSkeltonEqD2])
apply (drule LAlpha_imp_dAlpha [THEN dAlpha_imp_dProp_eq])
apply (assumption | rule dB_type conjI)+
done

lemma LAlpha3D1:
  "LAlpha3(M, N) ==> M: LTerm"
apply (unfold LAlpha3_def)
apply (erule conjunct1)
done

lemma LAlpha3D2:
  "LAlpha3(M, N) ==> N: LTerm"
apply (unfold LAlpha3_def)
apply (erule conjunct2 [THEN conjunct1])
done

lemma LAlpha3D3:
  "LAlpha3(M, N) ==> dB(M) = dB(N)"
apply (unfold LAlpha3_def)
apply (erule conjunct2 [THEN conjunct2])
done

lemmas LAlpha_imp_dB_eq = LAlpha3_iff_LAlpha [THEN iffD2,
  THEN LAlpha3D3, rule_format]

lemmas dTerm_def_Terms_depth_induct = def_Terms_depth_induct [OF
  dTerm_Occ_cons_cond dTerm_Occ_ind_cond dOccinv_def]

lemma dProp_LTerm_lemma:
  assumes infv: "Infinite(LVariable)"
  and prem: "M: dProp"
  shows "EX M': LTerm. M = dB(M')"
apply (rule prem [THEN rev_mp])
apply (rule prem [THEN dPropD1, THEN dTerm_def_Terms_depth_induct])
apply (erule dTerm.cases)
prefer 4 apply hypsubst
prefer 4 apply hypsubst
defer 1
defer 1
apply (frule_tac [4] depth_ind_dApp1)
apply (frule_tac [6] depth_ind_dApp2)
apply (frule_tac [3] depth_ind_dLam)
apply (rule_tac [4] InfiniteE [OF infv dFV_Fin])
prefer 4 apply assumption
apply (safe elim!: dProp_dTermEs)
apply (drule_tac [3] M="Ma" and x="x" and n="0" in
         depth_ind_dSubst_dVar)
apply (frule_tac [6] M="Ma" and N="dVar(x)" in
         dDeg_dSubst_lemma3)
apply (erule_tac [3] asm_rl | rule_tac [3] nat_0I dProp_dVarI)+
apply (rule_tac x="LVar(x)" in bexI)
apply (simp only: dB_eqns)
apply (assumption | rule LTerm.intros)+
apply (frule_tac [3] x="Ma" in bspec)
apply (drule_tac [4] x="N" in bspec)
apply (drule_tac [2] x="dSubst(Ma, 0, dVar(x))" in bspec)
apply (drule_tac [1] x="Ma" in bspec)
prefer 3
prefer 5
prefer 6
apply (assumption | rule dSubst_type nat_0I dTerm.intros)+
apply (drule_tac [3] mp [THEN mp], erule_tac [3] asm_rl,
       erule_tac [3] asm_rl)+
apply (drule_tac [2] mp [THEN mp], erule_tac [2] asm_rl,
       erule_tac [2] asm_rl)+
apply (drule_tac [1] mp [THEN mp], erule_tac [1] asm_rl,
       erule_tac [1] asm_rl)+
apply safe
apply (rule_tac [3] x="LApp(M', M'a)" in bexI)
apply (rule_tac [2] x="LLam(x, M')" in bexI)
apply (rule_tac [1] x="LLam(x, M')" in bexI)
apply safe
apply (drule_tac [2] sym)
apply (drule_tac [2] sym)
apply (frule dDeg_dAbst_lemma1)
apply (assumption | rule nat_0I)+
apply (simp_all add: dB_eqns dAbst_dSubst_lemma)
done

(** LFV and dFV **)
lemma LFV_eq_dFV_dB:
  assumes major: "M: LTerm"
  shows "LFV(M) = dFV(dB(M))"
apply (rule major [THEN LTerm.induct])
apply (simp_all add: dB_eqns dB_type [THEN dPropD1]
         dFV_dAbst dAbst_type)
done

(** isSubst **)
lemma dsubst_lemma1:
  "[| x ~: dFV(M); dDeg(M) \<le> n;
     M: dTerm; n: nat; N: dTerm
   |] ==> dSubst(dAbst(M, x, n), n, N) = M"
apply (rule dDeg_dAbst_lemma1 [THEN ssubst])
apply (rule_tac [4] dDeg_dSubst_lemma1)
apply assumption+
done

lemma dsubst_lemma2:
  assumes major: "x ~: dFV(N)"
  and sub: "dDeg(M) \<le> n"
  and prem0: "x ~= y"
  and prem1: "M: dTerm"
  and prem2: "n: nat"
  and prem3: "N: dTerm"
  shows "dSubst(dAbst(dAbst(M, x, n), y, succ(n)), succ(n), N)
          = dAbst(dSubst(dAbst(M, y, n), n, N), x, n)"
apply (insert prem0)
apply (rule sub [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule prem2 [THEN [2] bspec])
apply (rule prem3 [THEN [2] bspec])
apply (rule prem1 [THEN dTerm.induct])
apply (rule_tac [4] ballI [THEN ballI])
apply (rule_tac [3] ballI [THEN ballI])
apply (rule_tac [2] ballI [THEN ballI])
apply (rule_tac [1] ballI [THEN ballI])
apply (case_tac [2] "xaa = n")
apply (case_tac "x = xa")
apply (case_tac [2] "y = xa")
apply (case_tac "y = xa")
apply (simp_all add: dDeg_dAbst_lemma1 succ_neq_self_simps
        split del: split_if del: ball_simps)
apply safe
apply (erule_tac [2] bspec [THEN bspec, THEN mp, THEN mp, THEN function_apply_eq])
prefer 4 apply (simp add: dFV_dLift_iff)
apply (subgoal_tac "succ(xaa) ~= n" "~ succ(xaa) < n")
apply (simp split del: split_if)
apply (safe intro!: dLift_type)
apply (drule_tac [2] leI [THEN succ_le_iff [THEN iffD1]])
apply (erule_tac [2] lt_irrefl)
apply (drule lt_trans, assumption)
apply (drule leI [THEN succ_le_iff [THEN iffD1]])
apply (erule lt_irrefl)
done

lemma Lsubst_eq_dsubst:
  assumes major: "LFreeForIn(B, x, A)"
  shows "dB(Lsubst(A, x, B)) = dsubst(dB(A), x, dB(B))"
apply (rule major [THEN rev_mp])
apply (rule major [THEN LFreeForInD3, THEN LTerm.induct])
apply (rule_tac [3] impI, erule_tac [3] LFreeForIn_LTermEs)
apply (rule_tac [2] impI, erule_tac [2] LFreeForIn_LTermEs)
apply (rule_tac [1] impI, erule_tac [1] LFreeForIn_LTermEs)
apply (subgoal_tac [4] "LFreeForIn(B, x, M)")
apply (rule_tac [5] LFreeForInI)
apply (erule_tac [8] notE, erule_tac [8] LFV_I)
apply (erule_tac [5] asm_rl)+
apply (drule_tac [5] mp, erule_tac [5] asm_rl)+
apply (drule_tac [4] mp, erule_tac [4] asm_rl)+
apply (drule_tac [3] mp, erule_tac [3] asm_rl)+
prefer 2 apply hypsubst
prefer 2
apply (drule_tac [5] LFreeForInD1)+
apply (drule_tac [4] LFreeForInD1)+
apply (drule_tac [3] LFreeForInD1)+
apply (case_tac "x = xa")
prefer 2
apply (simp_all add: dB_eqns)
apply (simp_all add: dsubst_def dB_type [THEN dPropD1]
        dB_type [THEN dPropD2] dDeg_dLift_lemma1)
apply (rule_tac [2] dsubst_lemma2 [THEN sym, THEN function_apply_eq])
apply (rule_tac [8] dsubst_lemma1 [THEN sym, THEN function_apply_eq])
apply (rule_tac [1] dsubst_lemma1 [THEN sym, THEN function_apply_eq])
prefer 3
prefer 4
prefer 5
prefer 9
prefer 10
prefer 11
prefer 14
prefer 15
prefer 16
apply (assumption | rule dAbst_type dB_type dPropD1 nat_succI
         nat_0I)+
prefer 5 apply blast
apply (erule_tac [4] dB_type [THEN dPropD2, THEN ssubst])
apply (rule_tac [4] Ord_0 [THEN le_refl])
apply (rule_tac [4] notI, erule_tac [4] dFV_E)
apply (rule_tac [3] notI, erule_tac [3] dFV_E)
apply (rule_tac [1] notI, erule_tac [1] dFV_E)
apply (drule_tac [3] dFreeIn_imp_LFreeIn)
apply (erule_tac [4] notE, erule_tac [4] LFV_I)
apply (erule_tac [4] dOcc_dAbstE)
apply (drule dOcc_dAbst_lemma1)
prefer 3 apply blast
prefer 7 apply (blast elim!: dTag.free_elims)
apply (drule_tac [7] dFreeIn_imp_LFreeIn)
apply (erule_tac [8] notE, erule_tac [8] LFV_I)
prefer 4
prefer 5
prefer 6
prefer 7
apply (assumption | rule dB_type dPropD1 nat_succI nat_0I)+
apply (erule_tac [2] dB_type [THEN dPropE])+
apply (erule_tac [1] dB_type [THEN dPropE])+
apply (case_tac [2] "xa: dFV(dB(M))")
apply (case_tac [1] "x: dFV(dB(M))")
apply (simp_all add: dDeg_dAbst_lemma1 dDeg_dAbst_lemma2)
done

lemma isSubst1_isSubst2_iff:
  assumes infv: "Infinite(LVariable)"
  shows "isSubst1(A, x, B, C) <-> isSubst2(A, x, B, C)"
apply (unfold isSubst1_def isSubst2_def)
apply safe
apply (erule LAlphaD1 [THEN LSkeltonEqD1])
apply (erule LFreeForInD1)
apply (erule LAlphaD1 [THEN LSkeltonEqD2])
apply (erule LFreeForInD2)
apply (frule_tac [2] M="A" and N="B" in
         infv [THEN Infinite_LVariable_LAlpha_lemma])
apply (erule_tac [2] asm_rl)+
apply safe
apply (rule_tac [2] exI)
apply (erule_tac [2] asm_rl | rule_tac [2] conjI)+
apply (simp_all only: LAlpha3_iff_LAlpha [THEN iff_sym])
apply (unfold LAlpha3_def)
apply safe
prefer 2
apply (assumption | rule Lsubst_type)+
apply (rotate_tac [2] 9)
apply (simp_all add: Lsubst_eq_dsubst)
done

end


theory Lambda
imports
  "../Nominal2"
  "~~/src/HOL/Library/Monad_Syntax"
begin

lemma perm_commute:
  "a \<sharp> p \<Longrightarrow> a' \<sharp> p \<Longrightarrow> (a \<rightleftharpoons> a') + p = p + (a \<rightleftharpoons> a')"
apply(rule plus_perm_eq)
apply(simp add: supp_swap fresh_def)
done

atom_decl name

thm obtain_atom

lemma
 "(\<forall>thesis. (finite X \<longrightarrow> (\<forall>a. ((a \<notin> X \<and> sort_of a = s) \<longrightarrow> thesis)) \<longrightarrow> thesis)) \<longleftrightarrow>
  (finite X \<longrightarrow> (\<exists> a. (a \<notin> X \<and> sort_of a = s)))"
apply(auto)
done

ML {* trace := true *}

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam"  binds x in l ("Lam [_]. _" [100, 100] 100)

nominal_datatype environment =
   Ni
 | En name closure environment
and closure =
   Clos "lam" "environment"

thm environment_closure.exhaust(1)

nominal_function
  env_lookup :: "environment => name => closure"
where
  "env_lookup Ni x = Clos (Var x) Ni"
| "env_lookup (En v clos rest) x = (if (v = x) then clos else env_lookup rest x)"
   apply (auto)
   apply (simp add: env_lookup_graph_aux_def eqvt_def)
   by (metis environment_closure.strong_exhaust(1))

lemma
  "Lam [x]. Var x = Lam [y]. Var y"
proof -
  obtain c::name where fresh: "atom c \<sharp> (Lam [x]. Var x, Lam [y]. Var y)"
    by (metis obtain_fresh)
  have "Lam [x]. Var x = (c \<leftrightarrow> x) \<bullet> Lam [x]. Var x"
    using fresh by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: fresh_Pair)
  also have "... = Lam [c].Var c" by simp
  also have "... = (c \<leftrightarrow> y) \<bullet> Lam [c]. Var c"
    using fresh by (rule_tac flip_fresh_fresh[symmetric]) (auto simp add: fresh_Pair)
  also have "... = Lam [y]. Var y" by simp
  finally show "Lam [x]. Var x = Lam [y]. Var y" .
qed

definition
  Name :: "nat \<Rightarrow> name"
where
  "Name n = Abs_name (Atom (Sort ''name'' []) n)"

definition
   "Ident2 = Lam [Name 1].(Var (Name 1))"

definition
   "Ident x = Lam [x].(Var x)"

lemma "Ident2 = Ident x"
unfolding Ident_def Ident2_def
by simp

lemma "Ident x = Ident y"
unfolding Ident_def
by simp

thm lam.strong_induct

lemma alpha_lam_raw_eqvt[eqvt]: "p \<bullet> (alpha_lam_raw x y) = alpha_lam_raw (p \<bullet> x) (p \<bullet> y)"
  unfolding alpha_lam_raw_def
  by perm_simp rule

lemma abs_lam_eqvt[eqvt]: "(p \<bullet> abs_lam t) = abs_lam (p \<bullet> t)"
proof -
  have "alpha_lam_raw (rep_lam (abs_lam t)) t"
    using rep_abs_rsp_left Quotient3_lam equivp_reflp lam_equivp by metis
  then have "alpha_lam_raw (p \<bullet> rep_lam (abs_lam t)) (p \<bullet> t)"
    unfolding alpha_lam_raw_eqvt[symmetric] permute_pure .
  then have "abs_lam (p \<bullet> rep_lam (abs_lam t)) = abs_lam (p \<bullet> t)"
    using Quotient3_rel Quotient3_lam by metis
  thus ?thesis using permute_lam_def id_apply map_fun_apply by metis
qed

section {* Simple examples from Norrish 2004 *}

nominal_function
  is_app :: "lam \<Rightarrow> bool"
where
  "is_app (Var x) = False"
| "is_app (App t1 t2) = True"
| "is_app (Lam [x]. t) = False"
thm is_app_graph_def is_app_graph_aux_def
apply(simp add: eqvt_def is_app_graph_aux_def)
apply(rule TrueI)
apply(rule_tac y="x" in lam.exhaust)
apply(auto)[3]
apply(all_trivials)
done

nominal_termination (eqvt) by lexicographic_order

thm is_app_def
thm is_app.eqvt

thm eqvts

nominal_function
  rator :: "lam \<Rightarrow> lam option"
where
  "rator (Var x) = None"
| "rator (App t1 t2) = Some t1"
| "rator (Lam [x]. t) = None"
apply(simp add: eqvt_def rator_graph_aux_def)
apply(rule TrueI)
apply(rule_tac y="x" in lam.exhaust)
apply(auto)[3]
apply(simp_all)
done

nominal_termination (eqvt) by lexicographic_order

nominal_function
  rand :: "lam \<Rightarrow> lam option"
where
  "rand (Var x) = None"
| "rand (App t1 t2) = Some t2"
| "rand (Lam [x]. t) = None"
apply(simp add: eqvt_def rand_graph_aux_def)
apply(rule TrueI)
apply(rule_tac y="x" in lam.exhaust)
apply(auto)[3]
apply(simp_all)
done

nominal_termination (eqvt) by lexicographic_order

nominal_function
  is_eta_nf :: "lam \<Rightarrow> bool"
where
  "is_eta_nf (Var x) = True"
| "is_eta_nf (App t1 t2) = (is_eta_nf t1 \<and> is_eta_nf t2)"
| "is_eta_nf (Lam [x]. t) = (is_eta_nf t \<and>
                             ((is_app t \<and> rand t = Some (Var x)) \<longrightarrow> atom x \<in> supp (rator t)))"
apply(simp add: eqvt_def is_eta_nf_graph_aux_def)
apply(rule TrueI)
apply(rule_tac y="x" in lam.exhaust)
apply(auto)[3]
using [[simproc del: alpha_lst]]
apply(simp_all)
apply(erule_tac c="()" in Abs_lst1_fcb2')
apply(simp_all add: pure_fresh fresh_star_def)[3]
apply(simp add: eqvt_at_def conj_eqvt)
apply(simp add: eqvt_at_def conj_eqvt)
done

nominal_termination (eqvt) by lexicographic_order

nominal_datatype path = Left | Right | In

section {* Paths to a free variables *}

instance path :: pure
apply(default)
apply(induct_tac "x::path" rule: path.induct)
apply(simp_all)
done

nominal_function
  var_pos :: "name \<Rightarrow> lam \<Rightarrow> (path list) set"
where
  "var_pos y (Var x) = (if y = x then {[]} else {})"
| "var_pos y (App t1 t2) = (Cons Left ` (var_pos y t1)) \<union> (Cons Right ` (var_pos y t2))"
| "atom x \<sharp> y \<Longrightarrow> var_pos y (Lam [x]. t) = (Cons In ` (var_pos y t))"
apply(simp add: eqvt_def var_pos_graph_aux_def)
apply(rule TrueI)
apply(case_tac x)
apply(rule_tac y="b" and c="a" in lam.strong_exhaust)
apply(auto simp add: fresh_star_def)[3]
using [[simproc del: alpha_lst]]
apply(simp_all)
apply(erule conjE)+
apply(erule_tac Abs_lst1_fcb2)
apply(simp add: pure_fresh)
apply(simp add: fresh_star_def)
apply(simp only: eqvt_at_def)
apply(perm_simp)
apply(simp)
apply(simp add: perm_supp_eq)
apply(simp only: eqvt_at_def)
apply(perm_simp)
apply(simp)
apply(simp add: perm_supp_eq)
done

nominal_termination (eqvt) by lexicographic_order

lemma var_pos1:
  assumes "atom y \<notin> supp t"
  shows "var_pos y t = {}"
using assms
apply(induct t rule: var_pos.induct)
apply(simp_all add: lam.supp supp_at_base fresh_at_base)
done

lemma var_pos2:
  shows "var_pos y (Lam [y].t) = {}"
apply(rule var_pos1)
apply(simp add: lam.supp)
done

text {* strange substitution operation *}

nominal_function
  subst' :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_ [_ ::== _]" [90, 90, 90] 90)
where
  "(Var x)[y ::== s] = (if x = y then s else (Var x))"
| "(App t1 t2)[y ::== s] = App (t1[y ::== s]) (t2[y ::== s])"
| "atom x \<sharp> (y, s) \<Longrightarrow> (Lam [x]. t)[y ::== s] = Lam [x].(t[y ::== (App (Var y) s)])"
  apply(simp add: eqvt_def subst'_graph_aux_def)
  apply(rule TrueI)
  apply(case_tac x)
  apply(rule_tac y="a" and c="(b, c)" in lam.strong_exhaust)
  apply(auto simp add: fresh_star_def)[3]
  using [[simproc del: alpha_lst]]
  apply(simp_all)
  apply(erule conjE)+
  apply (erule_tac c="(ya,sa)" in Abs_lst1_fcb2)
  apply(simp_all add: Abs_fresh_iff)
  apply(simp add: fresh_star_def fresh_Pair)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
done

nominal_termination (eqvt) by lexicographic_order

section {* free name function *}

lemma fresh_removeAll_name:
  fixes x::"name"
    and xs:: "name list"
  shows "atom x \<sharp> (removeAll y xs) \<longleftrightarrow> (atom x \<sharp> xs \<or> x = y)"
  apply (induct xs)
  apply(auto simp add: fresh_def supp_Nil supp_Cons supp_at_base)
  done

text {* first returns an atom list *}

nominal_function
  frees_lst :: "lam \<Rightarrow> atom list"
where
  "frees_lst (Var x) = [atom x]"
| "frees_lst (App t1 t2) = frees_lst t1 @ frees_lst t2"
| "frees_lst (Lam [x]. t) = removeAll (atom x) (frees_lst t)"
apply(simp add: eqvt_def frees_lst_graph_aux_def)
apply(rule TrueI)
apply(rule_tac y="x" in lam.exhaust)
using [[simproc del: alpha_lst]]
apply(auto)
apply (erule_tac c="()" in Abs_lst1_fcb2)
apply(simp add: supp_removeAll fresh_def)
apply(simp add: fresh_star_def fresh_Unit)
apply(simp add: eqvt_at_def removeAll_eqvt atom_eqvt)
apply(simp add: eqvt_at_def removeAll_eqvt atom_eqvt)
done

nominal_termination (eqvt) by lexicographic_order

text {* a small test lemma *}
lemma shows "supp t = set (frees_lst t)"
  by (induct t rule: frees_lst.induct) (simp_all add: lam.supp supp_at_base)

text {* second returns an atom set - therefore needs an invariant *}

nominal_function (invariant "\<lambda>x (y::atom set). finite y")
  frees_set :: "lam \<Rightarrow> atom set"
where
  "frees_set (Var x) = {atom x}"
| "frees_set (App t1 t2) = frees_set t1 \<union> frees_set t2"
| "frees_set (Lam [x]. t) = (frees_set t) - {atom x}"
  apply(simp add: eqvt_def frees_set_graph_aux_def)
  apply(erule frees_set_graph.induct)
  apply(auto)[9]
  apply(rule_tac y="x" in lam.exhaust)
  apply(auto)[3]
  using [[simproc del: alpha_lst]]
  apply(simp)
  apply(erule_tac c="()" in Abs_lst1_fcb2)
  apply(simp add: fresh_minus_atom_set)
  apply(simp add: fresh_star_def fresh_Unit)
  apply(simp add: Diff_eqvt eqvt_at_def)
  apply(simp add: Diff_eqvt eqvt_at_def)
  done

nominal_termination (eqvt)
  by lexicographic_order

lemma "frees_set t = supp t"
  by (induct rule: frees_set.induct) (simp_all add: lam.supp supp_at_base)

section {* height function *}

nominal_function
  height :: "lam \<Rightarrow> int"
where
  "height (Var x) = 1"
| "height (App t1 t2) = max (height t1) (height t2) + 1"
| "height (Lam [x].t) = height t + 1"
  apply(simp add: eqvt_def height_graph_aux_def)
  apply(rule TrueI)
  apply(rule_tac y="x" in lam.exhaust)
  using [[simproc del: alpha_lst]]
  apply(auto)
  apply (erule_tac c="()" in Abs_lst1_fcb2)
  apply(simp_all add: fresh_def pure_supp eqvt_at_def fresh_star_def)
  done

nominal_termination (eqvt)
  by lexicographic_order

thm height.simps

section {* capture-avoiding substitution *}

nominal_function
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_ [_ ::= _]" [90, 90, 90] 90)
where
  "(Var x)[y ::= s] = (if x = y then s else (Var x))"
| "(App t1 t2)[y ::= s] = App (t1[y ::= s]) (t2[y ::= s])"
| "atom x \<sharp> (y, s) \<Longrightarrow> (Lam [x]. t)[y ::= s] = Lam [x].(t[y ::= s])"
  apply(simp add: eqvt_def subst_graph_aux_def)
  apply(rule TrueI)
  using [[simproc del: alpha_lst]]
  apply(auto)
  apply(rule_tac y="a" and c="(aa, b)" in lam.strong_exhaust)
  apply(blast)+
  using [[simproc del: alpha_lst]]
  apply(simp_all add: fresh_star_def fresh_Pair_elim)
  apply (erule_tac c="(ya,sa)" in Abs_lst1_fcb2)
  apply(simp_all add: Abs_fresh_iff)
  apply(simp add: fresh_star_def fresh_Pair)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
done

nominal_termination (eqvt)
  by lexicographic_order

thm subst.eqvt

lemma forget:
  shows "atom x \<sharp> t \<Longrightarrow> t[x ::= s] = t"
  by (nominal_induct t avoiding: x s rule: lam.strong_induct)
     (auto simp add: fresh_at_base)

text {* same lemma but with subst.induction *}
lemma forget2:
  shows "atom x \<sharp> t \<Longrightarrow> t[x ::= s] = t"
  apply(induct t x s rule: subst.induct)
  using [[simproc del: alpha_lst]]
  apply(auto simp add:  flip_fresh_fresh fresh_Pair fresh_at_base)
  done

lemma fresh_fact:
  fixes z::"name"
  assumes a: "atom z \<sharp> s"
      and b: "z = y \<or> atom z \<sharp> t"
  shows "atom z \<sharp> t[y ::= s]"
  using a b
  by (nominal_induct t avoiding: z y s rule: lam.strong_induct)
      (auto simp add:  fresh_at_base)

lemma substitution_lemma:
  assumes a: "x \<noteq> y" "atom x \<sharp> u"
  shows "t[x ::= s][y ::= u] = t[y ::= u][x ::= s[y ::= u]]"
using a
by (nominal_induct t avoiding: x y s u rule: lam.strong_induct)
   (auto simp add: fresh_fact forget)

lemma subst_rename:
  assumes a: "atom y \<sharp> t"
  shows "t[x ::= s] = ((y \<leftrightarrow> x) \<bullet>t)[y ::= s]"
using a
apply (nominal_induct t avoiding: x y s rule: lam.strong_induct)
apply (auto simp add:  fresh_at_base)
done

lemma height_ge_one:
  shows "1 \<le> (height e)"
by (induct e rule: lam.induct) (simp_all)

theorem height_subst:
  shows "height (e[x::=e']) \<le> ((height e) - 1) + (height e')"
proof (nominal_induct e avoiding: x e' rule: lam.strong_induct)
  case (Var y)
  have "1 \<le> height e'" by (rule height_ge_one)
  then show "height (Var y[x::=e']) \<le> height (Var y) - 1 + height e'" by simp
next
  case (Lam y e1)
  hence ih: "height (e1[x::=e']) \<le> ((height e1) - 1) + (height e')" by simp
  moreover
  have vc: "atom y\<sharp>x" "atom y\<sharp>e'" by fact+ (* usual variable convention *)
  ultimately show "height ((Lam [y]. e1)[x::=e']) \<le> height (Lam [y]. e1) - 1 + height e'" by simp
next
  case (App e1 e2)
  hence ih1: "height (e1[x::=e']) \<le> ((height e1) - 1) + (height e')"
    and ih2: "height (e2[x::=e']) \<le> ((height e2) - 1) + (height e')" by simp_all
  then show "height ((App e1 e2)[x::=e']) \<le> height (App e1 e2) - 1 + height e'"  by simp
qed

subsection {* single-step beta-reduction *}

inductive
  beta :: "lam \<Rightarrow> lam \<Rightarrow> bool" (" _ \<longrightarrow>b _" [80,80] 80)
where
  b1[intro]: "t1 \<longrightarrow>b t2 \<Longrightarrow> App t1 s \<longrightarrow>b App t2 s"
| b2[intro]: "s1 \<longrightarrow>b s2 \<Longrightarrow> App t s1 \<longrightarrow>b App t s2"
| b3[intro]: "t1 \<longrightarrow>b t2 \<Longrightarrow> Lam [x]. t1 \<longrightarrow>b Lam [x]. t2"
| b4[intro]: "atom x \<sharp> s \<Longrightarrow> App (Lam [x]. t) s \<longrightarrow>b t[x ::= s]"

equivariance beta

nominal_inductive beta
  avoids b4: "x"
  by (simp_all add: fresh_star_def fresh_Pair  fresh_fact)

thm beta.strong_induct

text {* One-Reduction *}

inductive
  One :: "lam \<Rightarrow> lam \<Rightarrow> bool" (" _ \<longrightarrow>1 _" [80,80] 80)
where
  o1[intro]: "Var x \<longrightarrow>1 Var x"
| o2[intro]: "\<lbrakk>t1 \<longrightarrow>1 t2; s1 \<longrightarrow>1 s2\<rbrakk> \<Longrightarrow> App t1 s1 \<longrightarrow>1 App t2 s2"
| o3[intro]: "t1 \<longrightarrow>1 t2 \<Longrightarrow> Lam [x].t1 \<longrightarrow>1 Lam [x].t2"
| o4[intro]: "\<lbrakk>atom x \<sharp> (s1, s2); t1 \<longrightarrow>1 t2; s1 \<longrightarrow>1 s2\<rbrakk> \<Longrightarrow> App (Lam [x].t1) s1 \<longrightarrow>1 t2[x ::= s2]"

equivariance One

nominal_inductive One
  avoids o3: "x"
      |  o4: "x"
  by (simp_all add: fresh_star_def fresh_Pair  fresh_fact)

lemma One_refl:
  shows "t \<longrightarrow>1 t"
by (nominal_induct t rule: lam.strong_induct) (auto)

lemma One_subst:
  assumes a: "t1 \<longrightarrow>1 t2" "s1 \<longrightarrow>1 s2"
  shows "t1[x ::= s1] \<longrightarrow>1 t2[x ::= s2]"
using a
apply(nominal_induct t1 t2 avoiding: s1 s2 x rule: One.strong_induct)
apply(auto simp add: substitution_lemma fresh_at_base fresh_fact fresh_Pair)
done

lemma better_o4_intro:
  assumes a: "t1 \<longrightarrow>1 t2" "s1 \<longrightarrow>1 s2"
  shows "App (Lam [x]. t1) s1 \<longrightarrow>1 t2[ x ::= s2]"
proof -
  obtain y::"name" where fs: "atom y \<sharp> (x, t1, s1, t2, s2)" by (rule obtain_fresh)
  have "App (Lam [x]. t1) s1 = App (Lam [y]. ((y \<leftrightarrow> x) \<bullet> t1)) s1" using fs
    by (auto simp add: Abs1_eq_iff' flip_def fresh_Pair fresh_at_base)
  also have "\<dots> \<longrightarrow>1 ((y \<leftrightarrow> x) \<bullet> t2)[y ::= s2]" using fs a by (auto simp add: One.eqvt)
  also have "\<dots> = t2[x ::= s2]" using fs by (simp add: subst_rename[symmetric])
  finally show "App (Lam [x].t1) s1 \<longrightarrow>1 t2[x ::= s2]" by simp
qed

section {* Locally Nameless Terms *}

nominal_datatype ln =
  LNBnd nat
| LNVar name
| LNApp ln ln
| LNLam ln

fun
  lookup :: "name list \<Rightarrow> nat \<Rightarrow> name \<Rightarrow> ln"
where
  "lookup [] n x = LNVar x"
| "lookup (y # ys) n x = (if x = y then LNBnd n else (lookup ys (n + 1) x))"

lemma supp_lookup:
  shows "supp (lookup xs n x) \<subseteq> {atom x}"
  apply(induct arbitrary: n rule: lookup.induct)
  apply(simp add: ln.supp supp_at_base)
  apply(simp add: ln.supp pure_supp)
  done

lemma supp_lookup_in:
  shows "x \<in> set xs \<Longrightarrow> supp (lookup xs n x) = {}"
  by (induct arbitrary: n rule: lookup.induct)(auto simp add: ln.supp pure_supp)

lemma supp_lookup_notin:
  shows "x \<notin> set xs \<Longrightarrow> supp (lookup xs n x) = {atom x}"
  by (induct arbitrary: n rule: lookup.induct) (auto simp add: ln.supp pure_supp supp_at_base)

lemma supp_lookup_fresh:
  shows "atom ` set xs \<sharp>* lookup xs n x"
  by (case_tac "x \<in> set xs") (auto simp add: fresh_star_def fresh_def supp_lookup_in supp_lookup_notin)

lemma lookup_eqvt[eqvt]:
  shows "(p \<bullet> lookup xs n x) = lookup (p \<bullet> xs) (p \<bullet> n) (p \<bullet> x)"
  by (induct xs arbitrary: n) (simp_all add: permute_pure)

text {* Function that translates lambda-terms into locally nameless terms *}

nominal_function (invariant "\<lambda>(_, xs) y. atom ` set xs \<sharp>* y")
  trans :: "lam \<Rightarrow> name list \<Rightarrow> ln"
where
  "trans (Var x) xs = lookup xs 0 x"
| "trans (App t1 t2) xs = LNApp (trans t1 xs) (trans t2 xs)"
| "atom x \<sharp> xs \<Longrightarrow> trans (Lam [x]. t) xs = LNLam (trans t (x # xs))"
  apply (simp add: eqvt_def trans_graph_aux_def)
  apply (erule trans_graph.induct)
  apply (auto simp add: ln.fresh)[3]
  apply (simp add: supp_lookup_fresh)
  apply (simp add: fresh_star_def ln.fresh)
  apply (simp add: ln.fresh fresh_star_def)
  apply(auto)[1]
  apply (rule_tac y="a" and c="b" in lam.strong_exhaust)
  apply (auto simp add: fresh_star_def)[3]
  using [[simproc del: alpha_lst]]
  apply(simp_all)
  apply(erule conjE)+
  apply (erule_tac c="xsa" in Abs_lst1_fcb2')
  apply (simp add: fresh_star_def)
  apply (simp add: fresh_star_def)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  done

nominal_termination (eqvt)
  by lexicographic_order

text {* count the occurences of lambdas in a term *}

nominal_function
  cntlams :: "lam  \<Rightarrow> nat"
where
  "cntlams (Var x) = 0"
| "cntlams (App t1 t2) = (cntlams t1) + (cntlams t2)"
| "cntlams (Lam [x]. t) = Suc (cntlams t)"
  apply(simp add: eqvt_def cntlams_graph_aux_def)
  apply(rule TrueI)
  apply(rule_tac y="x" in lam.exhaust)
  apply(auto)[3]
  apply(all_trivials)
  apply(simp)
  using [[simproc del: alpha_lst]]
  apply(simp)
  apply(erule_tac c="()" in Abs_lst1_fcb2')
  apply(simp add: pure_fresh)
  apply(simp add: fresh_star_def pure_fresh)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
  done

nominal_termination (eqvt)
  by lexicographic_order

text {* count the bound-variable occurences in a lambda-term *}

nominal_function
  cntbvs :: "lam \<Rightarrow> name list \<Rightarrow> nat"
where
  "cntbvs (Var x) xs = (if x \<in> set xs then 1 else 0)"
| "cntbvs (App t1 t2) xs = (cntbvs t1 xs) + (cntbvs t2 xs)"
| "atom x \<sharp> xs \<Longrightarrow> cntbvs (Lam [x]. t) xs = cntbvs t (x # xs)"
  apply(simp add: eqvt_def cntbvs_graph_aux_def)
  apply(rule TrueI)
  apply(case_tac x)
  apply(rule_tac y="a" and c="b" in lam.strong_exhaust)
  apply(auto simp add: fresh_star_def)[3]
  apply(all_trivials)
  apply(simp)
  apply(simp)
  using [[simproc del: alpha_lst]]
  apply(simp)
  apply(erule conjE)
  apply(erule Abs_lst1_fcb2')
  apply(simp add: pure_fresh fresh_star_def)
  apply(simp add: fresh_star_def)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  done

nominal_termination (eqvt)
  by lexicographic_order

section {* De Bruijn Terms *}

nominal_datatype db =
  DBVar nat
| DBApp db db
| DBLam db

instance db :: pure
  apply default
  apply (induct_tac x rule: db.induct)
  apply (simp_all add: permute_pure)
  done

lemma fresh_at_list: "atom x \<sharp> xs \<longleftrightarrow> x \<notin> set xs"
  unfolding fresh_def supp_set[symmetric]
  by (induct xs) (auto simp add: supp_of_finite_insert supp_at_base supp_set_empty)

fun
  vindex :: "name list \<Rightarrow> name \<Rightarrow> nat \<Rightarrow> db option"
where
  "vindex [] v n = None"
| "vindex (h # t) v n = (if v = h then (Some (DBVar n)) else (vindex t v (Suc n)))"

lemma vindex_eqvt[eqvt]:
  "(p \<bullet> vindex l v n) = vindex (p \<bullet> l) (p \<bullet> v) (p \<bullet> n)"
  by (induct l arbitrary: n) (simp_all add: permute_pure)

nominal_function
  transdb :: "lam \<Rightarrow> name list \<Rightarrow> db option"
where
  "transdb (Var x) l = vindex l x 0"
| "transdb (App t1 t2) xs =
      Option.bind (transdb t1 xs) (\<lambda>d1. Option.bind (transdb t2 xs) (\<lambda>d2. Some (DBApp d1 d2)))"
| "x \<notin> set xs \<Longrightarrow> transdb (Lam [x].t) xs = Option.map_option DBLam (transdb t (x # xs))"
  apply(simp add: eqvt_def transdb_graph_aux_def)
  apply(rule TrueI)
  apply (case_tac x)
  apply (rule_tac y="a" and c="b" in lam.strong_exhaust)
  apply (auto simp add: fresh_star_def fresh_at_list)[3]
  using [[simproc del: alpha_lst]]
  apply(simp_all)
  apply(elim conjE)
  apply (erule_tac c="xsa" in Abs_lst1_fcb2')
  apply (simp add: pure_fresh)
  apply(simp add: fresh_star_def fresh_at_list)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  done

nominal_termination (eqvt)
  by lexicographic_order

lemma transdb_eqvt[eqvt]:
  "p \<bullet> transdb t l = transdb (p \<bullet>t) (p \<bullet>l)"
  apply (nominal_induct t avoiding: l rule: lam.strong_induct)
  apply (simp add: vindex_eqvt)
  apply (simp_all add: permute_pure)
  apply (simp add: fresh_at_list)
  apply (subst transdb.simps)
  apply (simp add: fresh_at_list[symmetric])
  apply (drule_tac x="name # l" in meta_spec)
  apply auto
  done

lemma db_trans_test:
  assumes a: "y \<noteq> x"
  shows "transdb (Lam [x]. Lam [y]. App (Var x) (Var y)) [] =
  Some (DBLam (DBLam (DBApp (DBVar 1) (DBVar 0))))"
  using a by simp

lemma supp_subst:
  shows "supp (t[x ::= s]) \<subseteq> (supp t - {atom x}) \<union> supp s"
  by (induct t x s rule: subst.induct) (auto simp add: lam.supp supp_at_base)

lemma var_fresh_subst:
  "atom x \<sharp> s \<Longrightarrow> atom x \<sharp> (t[x ::= s])"
  by (induct t x s rule: subst.induct) (auto simp add: lam.supp  fresh_at_base)

(* function that evaluates a lambda term *)
nominal_function
   eval :: "lam \<Rightarrow> lam" and
   apply_subst :: "lam \<Rightarrow> lam \<Rightarrow> lam"
where
  "eval (Var x) = Var x"
| "eval (Lam [x].t) = Lam [x].(eval t)"
| "eval (App t1 t2) = apply_subst (eval t1) (eval t2)"
| "apply_subst (Var x) t2 = App (Var x) t2"
| "apply_subst (App t0 t1) t2 = App (App t0 t1) t2"
| "atom x \<sharp> t2 \<Longrightarrow> apply_subst (Lam [x].t1) t2 = eval (t1[x::= t2])"
  apply(simp add: eval_apply_subst_graph_aux_def eqvt_def)
  apply(rule TrueI)
  apply (case_tac x)
  apply (case_tac a rule: lam.exhaust)
  using [[simproc del: alpha_lst]]
  apply simp_all[3]
  apply (case_tac b)
  apply (rule_tac y="a" and c="ba" in lam.strong_exhaust)
  apply simp_all[3]
  apply (simp add: Abs1_eq_iff fresh_star_def)
  using [[simproc del: alpha_lst]]
  apply(simp_all)
  apply(erule_tac c="()" in Abs_lst1_fcb2)
  apply (simp add: Abs_fresh_iff)
  apply(simp add: fresh_star_def fresh_Unit)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
  apply(erule conjE)
  apply(erule_tac c="t2a" in Abs_lst1_fcb2')
  apply (erule fresh_eqvt_at)
  apply (simp add: finite_supp)
  apply (simp add: fresh_Inl var_fresh_subst)
  apply(simp add: fresh_star_def)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
  apply(simp only: eqvt_at_def)
  apply(perm_simp)
  apply(simp add: fresh_star_Pair perm_supp_eq)
done

(* a small test
nominal_termination (eqvt) sorry

lemma
  assumes "x \<noteq> y"
  shows "eval (App (Lam [x].App (Var x) (Var x)) (Var y)) = App (Var y) (Var y)"
using assms
apply(simp add: lam.supp fresh_def supp_at_base)
done
*)

text {* TODO: eqvt_at for the other side *}
nominal_function q where
  "atom c \<sharp> (x, M) \<Longrightarrow> q (Lam [x]. M) (N :: lam) = Lam [x]. (Lam [c]. (App M (q (Var c) N)))"
| "q (Var x) N = Var x"
| "q (App l r) N = App l r"
apply(simp add: eqvt_def q_graph_aux_def)
apply (rule TrueI)
apply (case_tac x)
apply (rule_tac y="a" in lam.exhaust)
using [[simproc del: alpha_lst]]
apply simp_all
apply (rule_tac x="(name, lam)" and ?'a="name" in obtain_fresh)
apply blast
apply clarify
apply (rule_tac x="(x, xa, M, Ma, c, ca, Na)" and ?'a="name" in obtain_fresh)
apply (subgoal_tac "eqvt_at q_sumC (Var ca, Na)") --"Could come from nominal_function?"
apply (subgoal_tac "Lam [c]. App M (q_sumC (Var c, Na)) = Lam [a]. App M (q_sumC (Var a, Na))")
apply (subgoal_tac "Lam [ca]. App Ma (q_sumC (Var ca, Na)) = Lam [a]. App Ma (q_sumC (Var a, Na))")
apply (simp only:)
apply (erule Abs_lst1_fcb)
oops

text {* Working Examples *}

nominal_function
  map_term :: "(lam \<Rightarrow> lam) \<Rightarrow> lam \<Rightarrow> lam"
where
  "eqvt f \<Longrightarrow> map_term f (Var x) = f (Var x)"
| "eqvt f \<Longrightarrow> map_term f (App t1 t2) = App (f t1) (f t2)"
| "eqvt f \<Longrightarrow> map_term f (Lam [x].t) = Lam [x].(f t)"
| "\<not>eqvt f \<Longrightarrow> map_term f t = t"
  apply (simp add: eqvt_def map_term_graph_aux_def)
  apply(rule TrueI)
  apply (case_tac x, case_tac "eqvt a", case_tac b rule: lam.exhaust)
  using [[simproc del: alpha_lst]]
  apply auto
  apply (erule Abs_lst1_fcb)
  apply (simp_all add: Abs_fresh_iff fresh_fun_eqvt_app)
  apply (simp add: eqvt_def permute_fun_app_eq)
  done

nominal_termination (eqvt)
  by lexicographic_order

(*
abbreviation
  mbind :: "'a option => ('a => 'b option) => 'b option"  ("_ \<guillemotright>= _" [65,65] 65)
where
  "c \<guillemotright>= f \<equiv> case c of None => None | (Some v) => f v"

lemma mbind_eqvt:
  fixes c::"'a::pt option"
  shows "(p \<bullet> (c \<guillemotright>= f)) = ((p \<bullet> c) \<guillemotright>= (p \<bullet> f))"
apply(cases c)
apply(simp_all)
apply(perm_simp)
apply(rule refl)
done

lemma mbind_eqvt_raw[eqvt_raw]:
  shows "(p \<bullet> option_case) \<equiv> option_case"
apply(rule eq_reflection)
apply(rule ext)+
apply(case_tac xb)
apply(simp_all)
apply(rule_tac p="-p" in permute_boolE)
apply(perm_simp add: permute_minus_cancel)
apply(simp)
apply(rule_tac p="-p" in permute_boolE)
apply(perm_simp add: permute_minus_cancel)
apply(simp)
done

fun
  index :: "atom list \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> nat option"
where
  "index [] n x = None"
| "index (y # ys) n x = (if x = y then (Some n) else (index ys (n + 1) x))"

lemma [eqvt]:
  shows "(p \<bullet> index xs n x) = index (p \<bullet> xs) (p \<bullet> n) (p \<bullet> x)"
apply(induct xs arbitrary: n)
apply(simp_all add: permute_pure)
done
*)

(*
nominal_function
  trans2 :: "lam \<Rightarrow> atom list \<Rightarrow> db option"
where
  "trans2 (Var x) xs = (index xs 0 (atom x) \<guillemotright>= (\<lambda>n::nat. Some (DBVar n)))"
| "trans2 (App t1 t2) xs =
     ((trans2 t1 xs) \<guillemotright>= (\<lambda>db1::db. (trans2 t2 xs) \<guillemotright>= (\<lambda>db2::db. Some (DBApp db1 db2))))"
| "trans2 (Lam [x].t) xs = (trans2 t (atom x # xs) \<guillemotright>= (\<lambda>db::db. Some (DBLam db)))"
oops
*)

nominal_function
  CPS :: "lam \<Rightarrow> (lam \<Rightarrow> lam) \<Rightarrow> lam"
where
  "CPS (Var x) k = Var x"
| "CPS (App M N) k = CPS M (\<lambda>m. CPS N (\<lambda>n. n))"
oops

consts b :: name
nominal_function
  Z :: "lam \<Rightarrow> (lam \<Rightarrow> lam) \<Rightarrow> lam"
where
  "Z (App M N) k = Z M (%m. (Z N (%n.(App m n))))"
| "Z (App M N) k = Z M (%m. (Z N (%n.(App (App m n) (Abs b (k (Var b)))))))"
apply(simp add: eqvt_def Z_graph_aux_def)
apply (rule, perm_simp, rule)
oops

lemma test:
  assumes "t = s"
  and "supp p \<sharp>* t" "supp p \<sharp>* x"
  and "(p \<bullet> t) = s \<Longrightarrow> (p \<bullet> x) = y"
  shows "x = y"
using assms by (simp add: perm_supp_eq)

lemma test2:
  assumes "cs \<subseteq> as \<union> bs"
  and "as \<sharp>* x" "bs \<sharp>* x"
  shows "cs \<sharp>* x"
using assms
by (auto simp add: fresh_star_def)

lemma test3:
  assumes "cs \<subseteq> as"
  and "as \<sharp>* x"
  shows "cs \<sharp>* x"
using assms
by (auto simp add: fresh_star_def)

nominal_function  (invariant "\<lambda>(_, _, xs) y. atom ` fst ` set xs \<sharp>* y \<and> atom ` snd ` set xs \<sharp>* y")
  aux :: "lam \<Rightarrow> lam \<Rightarrow> (name \<times> name) list \<Rightarrow> bool"
where
  "aux (Var x) (Var y) xs = ((x, y) \<in> set xs)"
| "aux (App t1 t2) (App s1 s2) xs = (aux t1 s1 xs \<and> aux t2 s2 xs)"
| "aux (Var x) (App t1 t2) xs = False"
| "aux (Var x) (Lam [y].t) xs = False"
| "aux (App t1 t2) (Var x) xs = False"
| "aux (App t1 t2) (Lam [x].t) xs = False"
| "aux (Lam [x].t) (Var y) xs = False"
| "aux (Lam [x].t) (App t1 t2) xs = False"
| "\<lbrakk>{atom x} \<sharp>* (s, xs); {atom y} \<sharp>* (t, xs); x \<noteq> y\<rbrakk> \<Longrightarrow>
       aux (Lam [x].t) (Lam [y].s) xs = aux t s ((x, y) # xs)"
  apply (simp add: eqvt_def aux_graph_aux_def)
  apply(erule aux_graph.induct)
  apply(simp_all add: fresh_star_def pure_fresh)[9]
  apply(case_tac x)
  apply(simp)
  apply(rule_tac y="a" and c="(b, c)" in lam.strong_exhaust)
  apply(simp)
  apply(rule_tac y="b" and c="c" in lam.strong_exhaust)
  apply(metis)+
  apply(simp)
  apply(rule_tac y="b" and c="c" in lam.strong_exhaust)
  apply(metis)+
  apply(simp)
  apply(rule_tac y="b" and c="(lam, c, name)" in lam.strong_exhaust)
  apply(metis)+
  apply(simp)
  apply(drule_tac x="name" in meta_spec)
  apply(drule_tac x="lama" in meta_spec)
  apply(drule_tac x="c" in meta_spec)
  apply(drule_tac x="namea" in meta_spec)
  apply(drule_tac x="lam" in meta_spec)
  apply(simp add: fresh_star_Pair)
  apply(simp add: fresh_star_def fresh_at_base )
  apply(auto)[1]
  apply(simp_all)[44]
  apply(simp del: Product_Type.prod.inject)
  oops

lemma abs_same_binder:
  fixes t ta s sa :: "_ :: fs"
  and x y::"'a::at"
  shows "[[atom x]]lst. t = [[atom y]]lst. ta \<and> [[atom x]]lst. s = [[atom y]]lst. sa
     \<longleftrightarrow> [[atom x]]lst. (t, s) = [[atom y]]lst. (ta, sa)"
  by (cases "atom x = atom y") (auto simp add: Abs1_eq_iff assms fresh_Pair)

nominal_function
  aux2 :: "lam \<Rightarrow> lam \<Rightarrow> bool"
where
  "aux2 (Var x) (Var y) = (x = y)"
| "aux2 (App t1 t2) (App s1 s2) = (aux2 t1 s1 \<and> aux2 t2 s2)"
| "aux2 (Var x) (App t1 t2) = False"
| "aux2 (Var x) (Lam [y].t) = False"
| "aux2 (App t1 t2) (Var x) = False"
| "aux2 (App t1 t2) (Lam [x].t) = False"
| "aux2 (Lam [x].t) (Var y) = False"
| "aux2 (Lam [x].t) (App t1 t2) = False"
| "x = y \<Longrightarrow> aux2 (Lam [x].t) (Lam [y].s) = aux2 t s"
  apply(simp add: eqvt_def aux2_graph_aux_def)
  apply(rule TrueI)
  apply(case_tac x)
  apply(rule_tac y="a" and c="b" in lam.strong_exhaust)
  apply(rule_tac y="b" in lam.exhaust)
  apply(auto)[3]
  apply(rule_tac y="b" in lam.exhaust)
  apply(auto)[3]
  apply(rule_tac y="b" and c="(name, lam)" in lam.strong_exhaust)
  using [[simproc del: alpha_lst]]
  apply(auto)[3]
  apply(drule_tac x="name" in meta_spec)
  apply(drule_tac x="name" in meta_spec)
  apply(drule_tac x="lam" in meta_spec)
  apply(drule_tac x="(name \<leftrightarrow> namea) \<bullet> lama" in meta_spec)
  using [[simproc del: alpha_lst]]
  apply(simp add: Abs1_eq_iff fresh_star_def fresh_Pair_elim fresh_at_base flip_def)
  apply (metis Nominal2_Base.swap_commute fresh_permute_iff sort_of_atom_eq swap_atom_simps(2))
  using [[simproc del: alpha_lst]]
  apply simp_all
  apply (simp add: abs_same_binder)
  apply (erule_tac c="()" in Abs_lst1_fcb2)
  apply (simp_all add: pure_fresh fresh_star_def eqvt_at_def)
  done

text {* tests of functions containing if and case *}

consts P :: "lam \<Rightarrow> bool"

(*
nominal_function
  A :: "lam => lam"
where
  "A (App M N) = (if (True \<or> P M) then (A M) else (A N))"
| "A (Var x) = (Var x)"
| "A (App M N) = (if True then M else A N)"
oops

nominal_function
  C :: "lam => lam"
where
  "C (App M N) = (case (True \<or> P M) of True \<Rightarrow> (A M) | False \<Rightarrow> (A N))"
| "C (Var x) = (Var x)"
| "C (App M N) = (if True then M else C N)"
oops

nominal_function
  A :: "lam => lam"
where
  "A (Lam [x].M) = (Lam [x].M)"
| "A (Var x) = (Var x)"
| "A (App M N) = (if True then M else A N)"
oops

nominal_function
  B :: "lam => lam"
where
  "B (Lam [x].M) = (Lam [x].M)"
| "B (Var x) = (Var x)"
| "B (App M N) = (if True then M else (B N))"
unfolding eqvt_def
unfolding B_graph_def
apply(perm_simp)
apply(rule allI)
apply(rule refl)
oops
*)
end


theory "Value"
  imports HOLCF
begin

subsubsection \<open>The semantic domain for values and environments\<close>

domain Value = Fn (lazy "Value \<rightarrow> Value") | B (lazy "bool discr")

fixrec Fn_project :: "Value \<rightarrow> Value \<rightarrow> Value"
 where "Fn_project\<cdot>(Fn\<cdot>f) = f"

abbreviation Fn_project_abbr (infix "\<down>Fn" 55)
  where "f \<down>Fn v \<equiv> Fn_project\<cdot>f\<cdot>v"

fixrec B_project :: "Value \<rightarrow> Value \<rightarrow> Value \<rightarrow> Value" where
  "B_project\<cdot>(B\<cdot>db)\<cdot>v\<^sub>1\<cdot>v\<^sub>2 = (if undiscr db then v\<^sub>1 else v\<^sub>2)"

lemma [simp]:
  "B_project\<cdot>(B\<cdot>(Discr b))\<cdot>v\<^sub>1\<cdot>v\<^sub>2 = (if b then v\<^sub>1 else v\<^sub>2)"
  "B_project\<cdot>\<bottom>\<cdot>v\<^sub>1\<cdot>v\<^sub>2 = \<bottom>"
  "B_project\<cdot>(Fn\<cdot>f)\<cdot>v\<^sub>1\<cdot>v\<^sub>2 = \<bottom>"
by fixrec_simp+

text \<open>
A chain in the domain @{typ Value} is either always bottom, or eventually @{term "Fn"} of another
chain
\<close>

lemma Value_chainE[consumes 1, case_names bot B Fn]:
  assumes "chain Y"
  obtains "Y = (\<lambda> _ . \<bottom>)" |
          n b where "Y = (\<lambda> m. (if m < n then \<bottom> else B\<cdot>b))" |
          n Y' where "Y = (\<lambda> m. (if m < n then \<bottom> else Fn\<cdot>(Y' (m-n))))" "chain Y'"
proof(cases "Y = (\<lambda> _ . \<bottom>)")
  case True
  thus ?thesis by (rule that(1))
next
  case False
  hence "\<exists> i. Y i \<noteq> \<bottom>" by auto
  hence "\<exists> n. Y n \<noteq> \<bottom> \<and> (\<forall>m. Y m \<noteq> \<bottom> \<longrightarrow> m \<ge> n)"
    by (rule exE)(rule ex_has_least_nat)
  then obtain n where "Y n \<noteq> \<bottom>" and "\<forall>m. m < n \<longrightarrow> Y m = \<bottom>" by fastforce
  hence "(\<exists> f. Y n = Fn\<cdot>f) \<or> (\<exists> b. Y n = B\<cdot>b)" by (metis Value.exhaust)
  thus ?thesis
  proof
    assume "(\<exists> f. Y n = Fn\<cdot>f)"
    then obtain f where "Y n = Fn \<cdot> f" by blast
    {
      fix i
      from \<open>chain Y\<close> have "Y n \<sqsubseteq> Y (i+n)" by (metis chain_mono le_add2)
      with \<open>Y n = _\<close>
      have "\<exists> g. (Y (i+n) = Fn \<cdot> g)"
        by (metis Value.dist_les(1) Value.exhaust below_bottom_iff)
    }
    then obtain Y' where Y': "\<And> i. Y (i + n) = Fn \<cdot> (Y' i)" by metis

    have "Y = (\<lambda>m. if m < n then \<bottom> else Fn\<cdot>(Y' (m - n)))"
        using \<open>\<forall>m. _\<close> Y' by (metis add_diff_inverse add.commute)
    moreover
    have"chain Y'" using \<open>chain Y\<close>
      by (auto intro!:chainI elim: chainE  simp add: Value.inverts[symmetric] Y'[symmetric] simp del: Value.inverts)
    ultimately
    show ?thesis by (rule that(3))
  next
    assume "(\<exists> b. Y n = B\<cdot>b)"
    then obtain b where "Y n = B\<cdot>b" by blast
    {
      fix i
      from \<open>chain Y\<close> have "Y n \<sqsubseteq> Y (i+n)" by (metis chain_mono le_add2)
      with \<open>Y n = _\<close>
      have "Y (i+n) = B\<cdot>b"
        by (metis Value.dist_les(2) Value.exhaust Value.inverts(2) below_bottom_iff discrete_cpo)
    }
    hence  Y': "\<And> i. Y (i + n) = B\<cdot>b" by metis

    have "Y = (\<lambda>m. if m < n then \<bottom> else B\<cdot>b)"
        using \<open>\<forall>m. _\<close> Y' by (metis add_diff_inverse add.commute)
    thus ?thesis by (rule that(2))
  qed
qed

end


(*
 * Copyright 2018, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory FastMap_Test
imports
  Lib.FastMap
  Lib.LexordList
  Lib.NICTATools
  Lib.Qualify
begin

section \<open>Basic usage example\<close>

experiment begin
  local_setup \<open>
    FastMap.define_map
      (* The name of the map constant and names of associated theorems.
       * This function constructs a set of sensible default names, but
       * you can also choose different names manually. *)
      (FastMap.name_opts_default "simple_test_map")

      (* List of the actual mappings. These must be sorted by key
       * and the key type must admit a linear order. *)
      [(@{term "0 :: nat"}, @{term "0 :: nat"}),
       (@{term "1 :: nat"}, @{term "1 :: nat"}),
       (@{term "2 :: nat"}, @{term "1 :: nat"}),
       (@{term "3 :: nat"}, @{term "2 :: nat"}),
       (@{term "4 :: nat"}, @{term "3 :: nat"}),
       (@{term "5 :: nat"}, @{term "5 :: nat"})]

      (* Key transformer. Must be an injective function that maps the
       * key type to a linorder type. This will usually be id, unless
       * the key type isn't naturally linorder. See string_map below
       * for an example of a non-trivial key transform. *)
      @{term "id :: nat \<Rightarrow> nat"}

      (* Extra simp rules to use when verifying the key ordering. *)
      @{thms}

      (* Use the default background simpset for solving goals.
       * Set to true if you want precise control over the simpset. *)
      false
  \<close>
  thm simple_test_map_def

  text \<open>Default theorem names are generated based on the map name\<close>
  thm simple_test_map_to_lookup_list
  thm simple_test_map_lookups
  thm simple_test_map_domain simple_test_map_range simple_test_map_keys_distinct

  subsection \<open>Check the generated theorems\<close>
  lemma "simple_test_map = map_of [(0, 0), (1, 1), (2, 1), (3, 2), (4, 3), (5, 5)]"
    by (rule simple_test_map_to_lookup_list)

  lemma
    "simple_test_map 0 = Some 0"
    "simple_test_map 1 = Some 1"
    "simple_test_map 2 = Some 1"
    "simple_test_map 3 = Some 2"
    "simple_test_map 4 = Some 3"
    "simple_test_map 5 = Some 5"
    by (rule simple_test_map_lookups)+

  lemma
    "dom simple_test_map = set [0, 1, 2, 3, 4, 5]"
    by (rule simple_test_map_domain)

  text \<open>Note that the range is not simplified\<close>
  lemma
    "ran simple_test_map = set [0, 1, 1, 2, 3, 5]"
    by (rule simple_test_map_range)

  lemma
    "distinct ([0, 1, 2, 3, 4, 5] :: nat list)"
    by (rule simple_test_map_keys_distinct[simplified list.map prod.sel])

end

section \<open>Basic tests for the generated theorems\<close>

ML \<open>
fun create_int_map name n typ ctxt =
  FastMap.define_map (FastMap.name_opts_default name)
    (List.tabulate (n, fn i => (HOLogic.mk_number typ i,
                                HOLogic.mk_string (string_of_int i))))
    (Const (@{const_name id}, typ --> typ))
    @{thms}
    false
    ctxt
\<close>

experiment begin
  local_setup \<open>
    create_int_map "simple_test_map_100" 100 @{typ int}
  \<close>
  print_theorems

  text \<open>Direct lookup theorems\<close>
  lemma "simple_test_map_100 42 = Some ''42''"
    by (rule simple_test_map_100_lookups)

  text \<open>We try to configure the default simpset for fast lookups\<close>
  lemma "simple_test_map_100 100 = None"
    by (time_methods
            default:
                \<open>simp add: simple_test_map_100_def\<close>
            minimal:
                \<open>simp only: simple_test_map_100_def FastMap.lookup_tree_simps'
                            id_apply rel_simps if_False
                      cong: if_weak_cong\<close>
            slow_simps:
                \<open>simp add: simple_test_map_100_def FastMap.lookup_tree.simps
                      del: FastMap.lookup_tree_simps'
                      cong: if_weak_cong cong del: if_cong\<close>
            slow_simps_l4v:
                \<open>simp add: simple_test_map_100_def FastMap.lookup_tree.simps
                      del: FastMap.lookup_tree_simps'
                      cong: if_cong cong del: if_weak_cong\<close>
            (* This simulates using a functional map instead of FastMap *)
            fun_map:
                \<open>simp add: simple_test_map_100_to_lookup_list\<close>
            (* Strangely, this is much faster, even though it uses the same rules
               (and even has the same simp trace) *)
            fun_map_minimal:
                \<open>simp only: simple_test_map_100_to_lookup_list
                            map_of.simps fun_upd_apply prod.sel
                            rel_simps simp_thms if_True if_False
                      cong: if_weak_cong\<close>)

  text \<open>Domain and range theorems\<close>
  lemma "dom simple_test_map_100 = {0 .. 99}"
    apply (simp add: atLeastAtMost_upto upto_rec1)
    by (simp only: simple_test_map_100_domain set_simps)

  lemma
    "ran simple_test_map_100 =
     set ([[x] | x \<leftarrow> ''0123456789''] @ [[x, y] | x \<leftarrow> ''123456789'', y \<leftarrow> ''0123456789''])"
    apply simp
    by (simp only: simple_test_map_100_range set_simps)
end

section \<open>Test with larger mapping\<close>

experiment begin
  local_setup \<open>
    create_int_map "simple_test_map_1000" 1000 @{typ int}
  \<close>

  lemma "simple_test_map_1000 42 = Some ''42''"
    by (rule simple_test_map_1000_lookups)

  lemma "simple_test_map_1000 1000 = None"
    by (simp add: simple_test_map_1000_def)

  lemma "dom simple_test_map_1000 = {0 .. 999}"
    apply (simp add: atLeastAtMost_upto upto_rec1)
    by (simp only: simple_test_map_1000_domain set_simps)

  lemma
    "ran simple_test_map_1000 =
     set ([[x] | x \<leftarrow> ''0123456789''] @
          [[x, y] | x \<leftarrow> ''123456789'', y \<leftarrow> ''0123456789''] @
          [[x, y, z] | x \<leftarrow> ''123456789'', y \<leftarrow> ''0123456789'', z \<leftarrow> ''0123456789''])"
    apply simp
    by (simp only: simple_test_map_1000_range set_simps)
end

section \<open>Optimising an existing mapping\<close>

experiment begin
  local_setup \<open>
    let
      val map_def =
          fold (fn i => fn m =>
                @{term "fun_upd :: (int \<Rightarrow> string option) \<Rightarrow> int \<Rightarrow> string option \<Rightarrow> (int \<Rightarrow> string option)"} $
                  m $ HOLogic.mk_number @{typ int} i $
                  (@{term "Some :: string \<Rightarrow> string option"} $ HOLogic.mk_string (string_of_int i)))
               (0 upto 100 - 1) @{term "Map.empty :: int \<Rightarrow> string option"};
      val name = Binding.name "slow_map";
    in
      Local_Theory.define
        ((name, NoSyn), ((Thm.def_binding name, []), map_def))
      #> snd
    end
  \<close>
  thm slow_map_def

  local_setup \<open>
    create_int_map "fast_map" 100 @{typ int}
  \<close>

  lemma slow_map_alt_def:
    "slow_map = fast_map"
    unfolding slow_map_def
    unfolding fast_map_to_lookup_list
    apply (simp only: FastMap.map_of_rev[symmetric] fast_map_keys_distinct)
    apply (simp only: rev.simps append.simps map_of.simps prod.sel)
    done

  lemma "slow_map 42 = Some ''42''"
    by (time_methods
          fast_map:      \<open>simp add: slow_map_alt_def fast_map_def\<close>
          direct_lookup: \<open>simp add: slow_map_alt_def fast_map_lookups\<close>
          slow_map:      \<open>simp add: slow_map_def\<close>)

  lemma "slow_map 100 = None"
    by (time_methods
          fast_map: \<open>simp add: slow_map_alt_def fast_map_def\<close>
          slow_map: \<open>simp add: slow_map_def\<close>)

  lemma "dom slow_map = {0 .. 99}"
    supply upto_rec1[simp]
    apply (simp add: atLeastAtMost_upto)
    (* Domain for slow_map gets generated in reverse order *)
    using set_rev[where xs="[0 .. 99] :: int list", simplified]

    by (time_methods
          fast_map: \<open>simp add: slow_map_alt_def fast_map_domain\<close>
          slow_map: \<open>simp add: slow_map_def\<close>)
end

section \<open>Simpset tests\<close>

definition my_id
  where
  "my_id x \<equiv> x"

lemma my_id_loop:
  "my_id x = my_id (Suc x) - 1"
  by (simp add: my_id_def)

declare my_id_loop[simp]
declare my_id_def[simp]

text \<open>With our faulty simpset, the key ordering solver gets into a loop.\<close>
local_setup \<open> fn ctxt =>
  (Timeout.apply (Time.fromSeconds 5) (
      FastMap.define_map (FastMap.name_opts_default "minimal_test_map")
        (List.tabulate (100, fn i => (HOLogic.mk_number @{typ nat} i,
                                      HOLogic.mk_string (string_of_int i))))
        @{term "my_id :: nat => nat"}
        @{thms}
        false
      ) ctxt;
   error "FastMap timeout test: shouldn't get here"
  )
  handle Timeout.TIMEOUT _ => ctxt
\<close>
declare my_id_loop[simp del]
declare my_id_def[simp del]

text \<open>The solver for injectivity of the key transformer can also loop.\<close>
lemma inj_my_id_loop[simp]:
  fixes x y :: nat
  shows "(my_id x = my_id y) = (my_id (x + x) = my_id (y + y))"
  by (auto simp: my_id_def)

lemma my_id_lessI:
  "(my_id x < my_id y) = (x < y)"
  by (simp add: my_id_def)

local_setup \<open> fn ctxt =>
  (Timeout.apply (Time.fromSeconds 5) (
      FastMap.define_map (FastMap.name_opts_default "minimal_test_map")
        (List.tabulate (100, fn i => (HOLogic.mk_number @{typ nat} i,
                                      HOLogic.mk_string (string_of_int i))))
        @{term "my_id :: nat => nat"}
        @{thms my_id_lessI}
        false
      ) ctxt;
   error "FastMap timeout test: shouldn't get here"
  )
  handle Timeout.TIMEOUT _ => ctxt
\<close>

text \<open>Manual simpset control.\<close>
lemma my_id_inj:
  "inj my_id"
  by (simp add: inj_def my_id_def)

local_setup \<open>
  FastMap.define_map (FastMap.name_opts_default "minimal_test_map")
    (List.tabulate (100, fn i => (HOLogic.mk_number @{typ nat} i,
                                  HOLogic.mk_string (string_of_int i))))
    @{term "my_id :: nat => nat"}
    @{thms my_id_lessI rel_simps my_id_inj[THEN inj_eq]}
    true
\<close>

section \<open>Test preserving user input\<close>

text \<open>
  Even when using the background simpset, FastMap should never simplify
  inside of the supplied keys and values.
\<close>

local_setup \<open>
  FastMap.define_map (FastMap.name_opts_default "preserve_input_test_map")
    (List.tabulate (100, fn i => (@{term "(+) :: nat \<Rightarrow> nat \<Rightarrow> nat"} $
                                    HOLogic.mk_number @{typ nat} i $
                                    @{term "0 :: nat"},
                                  @{term "rev :: string \<Rightarrow> string"} $
                                    HOLogic.mk_string (string_of_int i))))
    @{term "id :: nat => nat"}
    @{thms}
    false
\<close>

lemma "preserve_input_test_map (42 + 0) = Some (rev ''42'')"
  apply (fails \<open>simp; rule preserve_input_test_map_lookups\<close>)
  by (rule preserve_input_test_map_lookups)

lemma "42 + 0 \<in> dom preserve_input_test_map"
  apply (fails \<open>solves \<open>simp; unfold preserve_input_test_map_domain; intro list.set_intros\<close>\<close>)
  by (unfold preserve_input_test_map_domain; intro list.set_intros)

lemma "rev ''42'' \<in> ran preserve_input_test_map"
  apply (fails \<open>solves \<open>simp; unfold preserve_input_test_map_range; intro list.set_intros\<close>\<close>)
  by (unfold preserve_input_test_map_range; intro list.set_intros)

section \<open>Test @{command qualify}\<close>

locale qualified_map_test
qualify qualified_map_test

local_setup \<open>
  create_int_map "qualified_map" 100 @{typ nat}
\<close>

end_qualify

text \<open>Check that unqualified name doesn't exist\<close>
ML \<open>
  @{assert} (not (can dest_Const @{term qualified_map}));
  @{assert} (can dest_Const @{term qualified_map_test.qualified_map});
\<close>

section \<open>Test locales\<close>

context qualified_map_test begin

local_setup \<open>
  create_int_map "locale_map" 100 @{typ nat}
\<close>
thm locale_map_def

end

text \<open>Check that unqualified name doesn't exist\<close>
ML \<open>
  @{assert} (not (can dest_Const @{term locale_map}));
  @{assert} (can dest_Const @{term qualified_map_test.locale_map});
\<close>

section \<open>Test other key types\<close>

subsection \<open>Finite words\<close>

experiment begin
  local_setup \<open>
    create_int_map "word_map" 256 @{typ word32}
  \<close>

  lemma "word_map 42 = Some ''42''"
    by (rule word_map_lookups)

  lemma "word_map 999 = None"
    by (simp add: word_map_def)
end

subsection \<open>Strings\<close>

instantiation char :: ord begin
  definition[simp]: "(c::char) < d \<equiv> (of_char c :: nat) < of_char d"
  definition[simp]: "(c::char) \<le> d \<equiv> (of_char c :: nat) \<le> of_char d"
  instance ..
end

instantiation char :: linorder begin
  instance
    by intro_classes
       (auto simp: preorder_class.less_le_not_le linorder_class.linear)
end

experiment begin
  text \<open>
    Strings are not naturally in the @{class linorder} class.
    However, we can use a key transformer (@{const lexord_list})
    to use strings as @{class linorder} keys.
  \<close>
  local_setup \<open>
    FastMap.define_map (FastMap.name_opts_default "string_map")
      (List.tabulate (100, fn i => (HOLogic.mk_string (StringCvt.padLeft #"0" 3 (string_of_int i)),
                                    HOLogic.mk_number @{typ nat} i)))
      @{term "lexord_list :: string \<Rightarrow> char lexord_list"}
      @{thms}
      false
  \<close>

  lemma "string_map ''042'' = Some 42"
    by (rule string_map_lookups)

  lemma "string_map ''0123'' = None"
    by (simp add: string_map_def)

  text \<open>
    Notice that the domain and map theorems don't include the key
    transformer; it is merely an implementation detail.
  \<close>
  schematic_goal "(dom string_map = (?x :: string set))"
    by (rule string_map_domain)
  schematic_goal "string_map = map_of (?binds :: (string \<times> nat) list)"
    by (rule string_map_to_lookup_list)
end

section \<open>Small inputs\<close>
experiment begin
  text \<open>
    Note that the current interface doesn't support empty mappings,
    because it would have no input values to derive the correct map
    type. This tests 1-to-4-element mappings.
  \<close>

  local_setup \<open>
    create_int_map "small_test_map_1" 1 @{typ nat}
  \<close>
  lemma
    "small_test_map_1 \<equiv> FastMap.lookup_tree id (FastMap.Node 0 ''0'' FastMap.Leaf FastMap.Leaf)"
    by (rule small_test_map_1_def)
  lemma
    "small_test_map_1 = map_of [(0, ''0'')]"
    by (rule small_test_map_1_to_lookup_list)
  lemma
    "small_test_map_1 0 = Some ''0''"
    by (rule small_test_map_1_lookups)

  local_setup \<open>
      create_int_map "small_test_map_2" 2 @{typ nat}
      #>
      create_int_map "small_test_map_3" 3 @{typ nat}
      #>
      create_int_map "small_test_map_4" 4 @{typ nat}
  \<close>
end

end


section{* Example Verifications with KAD *}

theory VC_KAD_dual_Examples
imports VC_KAD_dual GCD Binomial (*"$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"*)

begin

lemma euclid:
  "FPRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  by (rule rel_modal_kleene_algebra.bdia_whilei, simp_all, auto simp: p2r_def rel_ad_def gcd_non_0_nat)

lemma euclid_diff:
   "FPRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y \<and> x > 0 \<and> y > 0)
    (WHILE (\<lambda>s. s ''x''\<noteq> s ''y'') INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
     DO
        (IF (\<lambda>s. s ''x'' >  s ''y'')
         THEN (''x'' ::= (\<lambda>s. s ''x'' - s ''y''))
         ELSE (''y'' ::= (\<lambda>s. s ''y'' - s ''x''))
         FI)
    OD)
    POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_modal_kleene_algebra.bdia_whilei, simp_all)
  apply (simp_all add: p2r_def rel_ar_def)
  apply auto[2]
  apply (safe, simp add: gcd_diff1_nat)
  using gcd_commute_nat gcd_diff1_nat by auto

lemma varible_swap:
  "FPRE (\<lambda>s. s ''x'' = a \<and> s ''y'' = b)
    (''z'' ::= (\<lambda>s. s ''x''));
    (''x'' ::= (\<lambda>s. s ''y''));
    (''y'' ::= (\<lambda>s. s ''z''))
   POST (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by (simp, clarsimp simp: p2r_def)

lemma maximum:
  "FPRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by (simp, simp add: p2r_def rel_ad_def, fastforce)

lemma integer_division:
  "FPRE (\<lambda>s::nat store. x \<ge> 0)
    (''q'' ::= (\<lambda>s. 0));
    (''r'' ::= (\<lambda>s. x));
    (WHILE (\<lambda>s. y \<le> s ''r'') INV (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0)
     DO
      (''q'' ::= (\<lambda>s. s ''q'' + 1));
      (''r'' ::= (\<lambda>s. s ''r'' - y))
      OD)
   POST (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0 \<and> s ''r'' < y)"
  by (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all, auto simp: p2r_def)

lemma factorial:
  "FPRE (\<lambda>s::nat store. True)
   (''x'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''x'' \<noteq> x0) INV (\<lambda>s. s ''y'' = fact (s ''x''))
   DO
     (''x'' ::= (\<lambda>s. s ''x'' + 1));
     (''y'' ::= (\<lambda>s. s ''y'' \<cdot> s ''x''))
   OD)
   POST (\<lambda>s. s ''y'' = fact x0)"
  by (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all, auto simp: p2r_def)

lemma my_power:
  "FPRE (\<lambda>s::nat store. True)
   (''i'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''i'' < n) INV (\<lambda>s. s ''y'' = x ^ (s ''i'') \<and> s ''i'' \<le> n)
     DO
       (''y'' ::= (\<lambda>s. (s ''y'') * x));
       (''i'' ::= (\<lambda>s. s ''i'' + 1))
     OD)
   POST (\<lambda>s. s ''y'' = x ^ n)"
  by (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all, auto simp add: p2r_def)

lemma imp_reverse:
  "FPRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  apply (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all, simp_all add: p2r_def)
  apply auto[2]
  by (safe, metis append.simps append_assoc hd_Cons_tl rev.simps(2))

end