(*                                                        *)
(* Formalisation of some typical SOS-proofs.              *)
(*                                                        *)
(* This work was inspired by challenge suggested by Adam  *)
(* Chlipala on the POPLmark mailing list.                 *)
(*                                                        *)
(* We thank Nick Benton for helping us with the           *)
(* termination-proof for evaluation.                      *)
(*                                                        *)
(* The formalisation was done by Julien Narboux and       *)
(* Christian Urban.                                       *)

theory SOS
  imports "HOL-Nominal.Nominal"
begin

atom_decl name

text \<open>types and terms\<close>
nominal_datatype ty =
    TVar "nat"
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
    Var "name"
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm"

lemma fresh_ty:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (auto simp add: fresh_nat)

text \<open>Parallel and single substitution.\<close>
fun
  lookup :: "(name\<times>trm) list \<Rightarrow> name \<Rightarrow> trm"
where
  "lookup [] x        = Var x"
| "lookup ((y,e)#\<theta>) x = (if x=y then e else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
by (induct \<theta>) (auto simp add: eqvts)

lemma lookup_fresh:
  fixes z::"name"
  assumes a: "z\<sharp>\<theta>" and b: "z\<sharp>x"
  shows "z \<sharp>lookup \<theta> x"
using a b
by (induct rule: lookup.induct) (auto simp add: fresh_list_cons)

lemma lookup_fresh':
  assumes "z\<sharp>\<theta>"
  shows "lookup \<theta> z = Var z"
using assms
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

(* parallel substitution *)

nominal_primrec
  psubst :: "(name\<times>trm) list \<Rightarrow> trm \<Rightarrow> trm"  ("_<_>" [95,95] 105)
where
  "\<theta><(Var x)> = (lookup \<theta> x)"
| "\<theta><(App e\<^sub>1 e\<^sub>2)> = App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>)"
| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

lemma psubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t::"trm"
  shows "pi\<bullet>(\<theta><t>) = (pi\<bullet>\<theta>)<(pi\<bullet>t)>"
by (nominal_induct t avoiding: \<theta> rule: trm.strong_induct)
   (perm_simp add: fresh_bij lookup_eqvt)+

lemma fresh_psubst:
  fixes z::"name"
  and   t::"trm"
  assumes "z\<sharp>t" and "z\<sharp>\<theta>"
  shows "z\<sharp>(\<theta><t>)"
using assms
by (nominal_induct t avoiding: z \<theta> t rule: trm.strong_induct)
   (auto simp add: abs_fresh lookup_fresh)

lemma psubst_empty[simp]:
  shows "[]<t> = t"
  by (nominal_induct t rule: trm.strong_induct)
     (auto simp add: fresh_list_nil)

text \<open>Single substitution\<close>
abbreviation
  subst :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_[_::=_]" [100,100,100] 100)
where
  "t[x::=t']  \<equiv> ([(x,t')])<t>"

lemma subst[simp]:
  shows "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
  and   "(App t\<^sub>1 t\<^sub>2)[y::=t'] = App (t\<^sub>1[y::=t']) (t\<^sub>2[y::=t'])"
  and   "x\<sharp>(y,t') \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
by (simp_all add: fresh_list_cons fresh_list_nil)

lemma fresh_subst:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: trm.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm)

lemma forget:
  assumes a: "x\<sharp>e"
  shows "e[x::=e'] = e"
using a
by (nominal_induct e avoiding: x e' rule: trm.strong_induct)
   (auto simp add: fresh_atm abs_fresh)

lemma psubst_subst_psubst:
  assumes h: "x\<sharp>\<theta>"
  shows "\<theta><e>[x::=e'] = ((x,e')#\<theta>)<e>"
  using h
by (nominal_induct e avoiding: \<theta> x e' rule: trm.strong_induct)
   (auto simp add: fresh_list_cons fresh_atm forget lookup_fresh lookup_fresh')

text \<open>Typing Judgements\<close>

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
  v_nil[intro]:  "valid []"
| v_cons[intro]: "\<lbrakk>valid \<Gamma>;x\<sharp>\<Gamma>\<rbrakk> \<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

inductive_cases
  valid_elim[elim]: "valid ((x,T)#\<Gamma>)"

lemma valid_insert:
  assumes a: "valid (\<Delta>@[(x,T)]@\<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)"
using a
by (induct \<Delta>)
   (auto simp add:  fresh_list_append fresh_list_cons elim!: valid_elim)

lemma fresh_set:
  shows "y\<sharp>xs = (\<forall>x\<in>set xs. y\<sharp>x)"
by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes a1: "valid \<Gamma>"
  and     a2: "(x,T) \<in> set \<Gamma>"
  and     a3: "(x,U) \<in> set \<Gamma>"
  shows "T = U"
using a1 a2 a3
by (induct) (auto simp add: fresh_set fresh_prod fresh_atm)

text \<open>Typing Relation\<close>

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
  t_Var[intro]:   "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
| t_App[intro]:   "\<lbrakk>\<Gamma> \<turnstile> e\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> e\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T\<^sub>2"
| t_Lam[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> e : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].e : T\<^sub>1\<rightarrow>T\<^sub>2"

equivariance typing

nominal_inductive typing
  by (simp_all add: abs_fresh fresh_ty)

lemma typing_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>"
using a by (induct) (auto)

lemma t_App_elim:
  assumes a: "\<Gamma> \<turnstile> App t1 t2 : T"
  obtains T' where "\<Gamma> \<turnstile> t1 : T' \<rightarrow> T" and "\<Gamma> \<turnstile> t2 : T'"
using a
by (cases) (auto simp add: trm.inject)

lemma t_Lam_elim:
  assumes a: "\<Gamma> \<turnstile> Lam [x].t : T" "x\<sharp>\<Gamma>"
  obtains T\<^sub>1 and T\<^sub>2 where "(x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2" and "T=T\<^sub>1\<rightarrow>T\<^sub>2"
using a
by (cases rule: typing.strong_cases [where x="x"])
   (auto simp add: abs_fresh fresh_ty alpha trm.inject)

abbreviation
  "sub_context" :: "(name\<times>ty) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ \<subseteq> _" [55,55] 55)
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x T. (x,T)\<in>set \<Gamma>\<^sub>1 \<longrightarrow> (x,T)\<in>set \<Gamma>\<^sub>2"

lemma weakening:
  fixes \<Gamma>\<^sub>1 \<Gamma>\<^sub>2::"(name\<times>ty) list"
  assumes "\<Gamma>\<^sub>1 \<turnstile> e: T" and "valid \<Gamma>\<^sub>2" and "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2"
  shows "\<Gamma>\<^sub>2 \<turnstile> e: T"
  using assms
proof(nominal_induct \<Gamma>\<^sub>1 e T avoiding: \<Gamma>\<^sub>2 rule: typing.strong_induct)
  case (t_Lam x \<Gamma>\<^sub>1 T\<^sub>1 t T\<^sub>2 \<Gamma>\<^sub>2)
  have vc: "x\<sharp>\<Gamma>\<^sub>2" by fact
  have ih: "\<lbrakk>valid ((x,T\<^sub>1)#\<Gamma>\<^sub>2); (x,T\<^sub>1)#\<Gamma>\<^sub>1 \<subseteq> (x,T\<^sub>1)#\<Gamma>\<^sub>2\<rbrakk> \<Longrightarrow> (x,T\<^sub>1)#\<Gamma>\<^sub>2 \<turnstile> t : T\<^sub>2" by fact
  have "valid \<Gamma>\<^sub>2" by fact
  then have "valid ((x,T\<^sub>1)#\<Gamma>\<^sub>2)" using vc by auto
  moreover
  have "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2" by fact
  then have "(x,T\<^sub>1)#\<Gamma>\<^sub>1 \<subseteq> (x,T\<^sub>1)#\<Gamma>\<^sub>2" by simp
  ultimately have "(x,T\<^sub>1)#\<Gamma>\<^sub>2 \<turnstile> t : T\<^sub>2" using ih by simp
  with vc show "\<Gamma>\<^sub>2 \<turnstile> Lam [x].t : T\<^sub>1\<rightarrow>T\<^sub>2" by auto
qed (auto)

lemma type_substitutivity_aux:
  assumes a: "(\<Delta>@[(x,T')]@\<Gamma>) \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "(\<Delta>@\<Gamma>) \<turnstile> e[x::=e'] : T"
using a b
proof (nominal_induct \<Gamma>\<equiv>"\<Delta>@[(x,T')]@\<Gamma>" e T avoiding: e' \<Delta> rule: typing.strong_induct)
  case (t_Var y T e' \<Delta>)
  then have a1: "valid (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a2: "(y,T) \<in> set (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a3: "\<Gamma> \<turnstile> e' : T'" .
  from a1 have a4: "valid (\<Delta>@\<Gamma>)" by (rule valid_insert)
  { assume eq: "x=y"
    from a1 a2 have "T=T'" using eq by (auto intro: context_unique)
    with a3 have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using eq a4 by (auto intro: weakening)
  }
  moreover
  { assume ineq: "x\<noteq>y"
    from a2 have "(y,T) \<in> set (\<Delta>@\<Gamma>)" using ineq by simp
    then have "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" using ineq a4 by auto
  }
  ultimately show "\<Delta>@\<Gamma> \<turnstile> Var y[x::=e'] : T" by blast
qed (force simp add: fresh_list_append fresh_list_cons)+

corollary type_substitutivity:
  assumes a: "(x,T')#\<Gamma> \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "\<Gamma> \<turnstile> e[x::=e'] : T"
using a b type_substitutivity_aux[where \<Delta>="[]"]
by (auto)

text \<open>Values\<close>
inductive
  val :: "trm\<Rightarrow>bool"
where
  v_Lam[intro]:   "val (Lam [x].e)"

equivariance val

lemma not_val_App[simp]:
  shows
  "\<not> val (App e\<^sub>1 e\<^sub>2)"
  "\<not> val (Var x)"
  by (auto elim: val.cases)

text \<open>Big-Step Evaluation\<close>

inductive
  big :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  b_Lam[intro]:   "Lam [x].e \<Down> Lam [x].e"
| b_App[intro]:   "\<lbrakk>x\<sharp>(e\<^sub>1,e\<^sub>2,e'); e\<^sub>1\<Down>Lam [x].e; e\<^sub>2\<Down>e\<^sub>2'; e[x::=e\<^sub>2']\<Down>e'\<rbrakk> \<Longrightarrow> App e\<^sub>1 e\<^sub>2 \<Down> e'"

equivariance big

nominal_inductive big
  by (simp_all add: abs_fresh)

lemma big_preserves_fresh:
  fixes x::"name"
  assumes a: "e \<Down> e'" "x\<sharp>e"
  shows "x\<sharp>e'"
  using a by (induct) (auto simp add: abs_fresh fresh_subst)

lemma b_App_elim:
  assumes a: "App e\<^sub>1 e\<^sub>2 \<Down> e'" "x\<sharp>(e\<^sub>1,e\<^sub>2,e')"
  obtains f\<^sub>1 and f\<^sub>2 where "e\<^sub>1 \<Down> Lam [x]. f\<^sub>1" "e\<^sub>2 \<Down> f\<^sub>2" "f\<^sub>1[x::=f\<^sub>2] \<Down> e'"
  using a
by (cases rule: big.strong_cases[where x="x" and xa="x"])
   (auto simp add: trm.inject)

lemma subject_reduction:
  assumes a: "e \<Down> e'" and b: "\<Gamma> \<turnstile> e : T"
  shows "\<Gamma> \<turnstile> e' : T"
  using a b
proof (nominal_induct avoiding: \<Gamma> arbitrary: T rule: big.strong_induct)
  case (b_App x e\<^sub>1 e\<^sub>2 e' e e\<^sub>2' \<Gamma> T)
  have vc: "x\<sharp>\<Gamma>" by fact
  have "\<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T" by fact
  then obtain T' where a1: "\<Gamma> \<turnstile> e\<^sub>1 : T'\<rightarrow>T" and a2: "\<Gamma> \<turnstile> e\<^sub>2 : T'"
    by (cases) (auto simp add: trm.inject)
  have ih1: "\<Gamma> \<turnstile> e\<^sub>1 : T' \<rightarrow> T \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].e : T' \<rightarrow> T" by fact
  have ih2: "\<Gamma> \<turnstile> e\<^sub>2 : T' \<Longrightarrow> \<Gamma> \<turnstile> e\<^sub>2' : T'" by fact
  have ih3: "\<Gamma> \<turnstile> e[x::=e\<^sub>2'] : T \<Longrightarrow> \<Gamma> \<turnstile> e' : T" by fact
  have "\<Gamma> \<turnstile> Lam [x].e : T'\<rightarrow>T" using ih1 a1 by simp
  then have "((x,T')#\<Gamma>) \<turnstile> e : T" using vc
    by (auto elim: t_Lam_elim simp add: ty.inject)
  moreover
  have "\<Gamma> \<turnstile> e\<^sub>2': T'" using ih2 a2 by simp
  ultimately have "\<Gamma> \<turnstile> e[x::=e\<^sub>2'] : T" by (simp add: type_substitutivity)
  thus "\<Gamma> \<turnstile> e' : T" using ih3 by simp
qed (blast)

lemma subject_reduction2:
  assumes a: "e \<Down> e'" and b: "\<Gamma> \<turnstile> e : T"
  shows "\<Gamma> \<turnstile> e' : T"
  using a b
by (nominal_induct avoiding: \<Gamma> T rule: big.strong_induct)
   (force elim: t_App_elim t_Lam_elim simp add: ty.inject type_substitutivity)+

lemma unicity_of_evaluation:
  assumes a: "e \<Down> e\<^sub>1"
  and     b: "e \<Down> e\<^sub>2"
  shows "e\<^sub>1 = e\<^sub>2"
  using a b
proof (nominal_induct e e\<^sub>1 avoiding: e\<^sub>2 rule: big.strong_induct)
  case (b_Lam x e t\<^sub>2)
  have "Lam [x].e \<Down> t\<^sub>2" by fact
  thus "Lam [x].e = t\<^sub>2" by cases (simp_all add: trm.inject)
next
  case (b_App x e\<^sub>1 e\<^sub>2 e' e\<^sub>1' e\<^sub>2' t\<^sub>2)
  have ih1: "\<And>t. e\<^sub>1 \<Down> t \<Longrightarrow> Lam [x].e\<^sub>1' = t" by fact
  have ih2:"\<And>t. e\<^sub>2 \<Down> t \<Longrightarrow> e\<^sub>2' = t" by fact
  have ih3: "\<And>t. e\<^sub>1'[x::=e\<^sub>2'] \<Down> t \<Longrightarrow> e' = t" by fact
  have app: "App e\<^sub>1 e\<^sub>2 \<Down> t\<^sub>2" by fact
  have vc: "x\<sharp>e\<^sub>1" "x\<sharp>e\<^sub>2" "x\<sharp>t\<^sub>2" by fact+
  then have "x\<sharp>App e\<^sub>1 e\<^sub>2" by auto
  from app vc obtain f\<^sub>1 f\<^sub>2 where x1: "e\<^sub>1 \<Down> Lam [x]. f\<^sub>1" and x2: "e\<^sub>2 \<Down> f\<^sub>2" and x3: "f\<^sub>1[x::=f\<^sub>2] \<Down> t\<^sub>2"
    by (auto elim!: b_App_elim)
  then have "Lam [x]. f\<^sub>1 = Lam [x]. e\<^sub>1'" using ih1 by simp
  then
  have "f\<^sub>1 = e\<^sub>1'" by (auto simp add: trm.inject alpha)
  moreover
  have "f\<^sub>2 = e\<^sub>2'" using x2 ih2 by simp
  ultimately have "e\<^sub>1'[x::=e\<^sub>2'] \<Down> t\<^sub>2" using x3 by simp
  thus "e' = t\<^sub>2" using ih3 by simp
qed

lemma reduces_evaluates_to_values:
  assumes h: "t \<Down> t'"
  shows "val t'"
using h by (induct) (auto)

(* Valuation *)

nominal_primrec
  V :: "ty \<Rightarrow> trm set"
where
  "V (TVar x) = {e. val e}"
| "V (T\<^sub>1 \<rightarrow> T\<^sub>2) = {Lam [x].e | x e. \<forall> v \<in> (V T\<^sub>1). \<exists> v'. e[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2}"
  by (rule TrueI)+

lemma V_eqvt:
  fixes pi::"name prm"
  assumes a: "x\<in>V T"
  shows "(pi\<bullet>x)\<in>V T"
using a
apply(nominal_induct T arbitrary: pi x rule: ty.strong_induct)
apply(auto simp add: trm.inject)
apply(simp add: eqvts)
apply(rule_tac x="pi\<bullet>xa" in exI)
apply(rule_tac x="pi\<bullet>e" in exI)
apply(simp)
apply(auto)
apply(drule_tac x="(rev pi)\<bullet>v" in bspec)
apply(force)
apply(auto)
apply(rule_tac x="pi\<bullet>v'" in exI)
apply(auto)
apply(drule_tac pi="pi" in big.eqvt)
apply(perm_simp add: eqvts)
done

lemma V_arrow_elim_weak:
  assumes h:"u \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)"
  obtains a t where "u = Lam [a].t" and "\<forall> v \<in> (V T\<^sub>1). \<exists> v'. t[a::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
using h by (auto)

lemma V_arrow_elim_strong:
  fixes c::"'a::fs_name"
  assumes h: "u \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)"
  obtains a t where "a\<sharp>c" "u = Lam [a].t" "\<forall>v \<in> (V T\<^sub>1). \<exists> v'. t[a::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
using h
apply -
apply(erule V_arrow_elim_weak)
apply(subgoal_tac "\<exists>a'::name. a'\<sharp>(a,t,c)") (*A*)
apply(erule exE)
apply(drule_tac x="a'" in meta_spec)
apply(drule_tac x="[(a,a')]\<bullet>t" in meta_spec)
apply(drule meta_mp)
apply(simp)
apply(drule meta_mp)
apply(simp add: trm.inject alpha fresh_left fresh_prod calc_atm fresh_atm)
apply(perm_simp)
apply(force)
apply(drule meta_mp)
apply(rule ballI)
apply(drule_tac x="[(a,a')]\<bullet>v" in bspec)
apply(simp add: V_eqvt)
apply(auto)
apply(rule_tac x="[(a,a')]\<bullet>v'" in exI)
apply(auto)
apply(drule_tac pi="[(a,a')]" in big.eqvt)
apply(perm_simp add: eqvts calc_atm)
apply(simp add: V_eqvt)
(*A*)
apply(rule exists_fresh')
apply(simp add: fin_supp)
done

lemma Vs_are_values:
  assumes a: "e \<in> V T"
  shows "val e"
using a by (nominal_induct T arbitrary: e rule: ty.strong_induct) (auto)

lemma values_reduce_to_themselves:
  assumes a: "val v"
  shows "v \<Down> v"
using a by (induct) (auto)

lemma Vs_reduce_to_themselves:
  assumes a: "v \<in> V T"
  shows "v \<Down> v"
using a by (simp add: values_reduce_to_themselves Vs_are_values)

text \<open>'\<theta> maps x to e' asserts that \<theta> substitutes x with e\<close>
abbreviation
  mapsto :: "(name\<times>trm) list \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> bool" ("_ maps _ to _" [55,55,55] 55)
where
 "\<theta> maps x to e \<equiv> (lookup \<theta> x) = e"

abbreviation
  v_closes :: "(name\<times>trm) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ Vcloses _" [55,55] 55)
where
  "\<theta> Vcloses \<Gamma> \<equiv> \<forall>x T. (x,T) \<in> set \<Gamma> \<longrightarrow> (\<exists>v. \<theta> maps x to v \<and> v \<in> V T)"

lemma case_distinction_on_context:
  fixes \<Gamma>::"(name\<times>ty) list"
  assumes asm1: "valid ((m,t)#\<Gamma>)"
  and     asm2: "(n,U) \<in> set ((m,T)#\<Gamma>)"
  shows "(n,U) = (m,T) \<or> ((n,U) \<in> set \<Gamma> \<and> n \<noteq> m)"
proof -
  from asm2 have "(n,U) \<in> set [(m,T)] \<or> (n,U) \<in> set \<Gamma>" by auto
  moreover
  { assume eq: "m=n"
    assume "(n,U) \<in> set \<Gamma>"
    then have "\<not> n\<sharp>\<Gamma>"
      by (induct \<Gamma>) (auto simp add: fresh_list_cons fresh_prod fresh_atm)
    moreover have "m\<sharp>\<Gamma>" using asm1 by auto
    ultimately have False using eq by auto
  }
  ultimately show ?thesis by auto
qed

lemma monotonicity:
  fixes m::"name"
  fixes \<theta>::"(name \<times> trm) list"
  assumes h1: "\<theta> Vcloses \<Gamma>"
  and     h2: "e \<in> V T"
  and     h3: "valid ((x,T)#\<Gamma>)"
  shows "(x,e)#\<theta> Vcloses (x,T)#\<Gamma>"
proof(intro strip)
  fix x' T'
  assume "(x',T') \<in> set ((x,T)#\<Gamma>)"
  then have "((x',T')=(x,T)) \<or> ((x',T')\<in>set \<Gamma> \<and> x'\<noteq>x)" using h3
    by (rule_tac case_distinction_on_context)
  moreover
  { (* first case *)
    assume "(x',T') = (x,T)"
    then have "\<exists>e'. ((x,e)#\<theta>) maps x to e' \<and> e' \<in> V T'" using h2 by auto
  }
  moreover
  { (* second case *)
    assume "(x',T') \<in> set \<Gamma>" and neq:"x' \<noteq> x"
      then have "\<exists>e'. \<theta> maps x' to e' \<and> e' \<in> V T'" using h1 by auto
      then have "\<exists>e'. ((x,e)#\<theta>) maps x' to e' \<and> e' \<in> V T'" using neq by auto
  }
  ultimately show "\<exists>e'.  ((x,e)#\<theta>) maps x' to e'  \<and> e' \<in> V T'" by blast
qed

lemma termination_aux:
  assumes h1: "\<Gamma> \<turnstile> e : T"
  and     h2: "\<theta> Vcloses \<Gamma>"
  shows "\<exists>v. \<theta><e> \<Down> v \<and> v \<in> V T"
using h2 h1
proof(nominal_induct e avoiding: \<Gamma> \<theta> arbitrary: T rule: trm.strong_induct)
  case (App e\<^sub>1 e\<^sub>2 \<Gamma> \<theta> T)
  have ih\<^sub>1: "\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e\<^sub>1 : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e\<^sub>1> \<Down> v \<and> v \<in> V T" by fact
  have ih\<^sub>2: "\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e\<^sub>2 : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e\<^sub>2> \<Down> v \<and> v \<in> V T" by fact
  have as\<^sub>1: "\<theta> Vcloses \<Gamma>" by fact
  have as\<^sub>2: "\<Gamma> \<turnstile> App e\<^sub>1 e\<^sub>2 : T" by fact
  then obtain T' where "\<Gamma> \<turnstile> e\<^sub>1 : T' \<rightarrow> T" and "\<Gamma> \<turnstile> e\<^sub>2 : T'" by (auto elim: t_App_elim)
  then obtain v\<^sub>1 v\<^sub>2 where "(i)": "\<theta><e\<^sub>1> \<Down> v\<^sub>1" "v\<^sub>1 \<in> V (T' \<rightarrow> T)"
                      and "(ii)": "\<theta><e\<^sub>2> \<Down> v\<^sub>2" "v\<^sub>2 \<in> V T'" using ih\<^sub>1 ih\<^sub>2 as\<^sub>1 by blast
  from "(i)" obtain x e'
            where "v\<^sub>1 = Lam [x].e'"
            and "(iii)": "(\<forall>v \<in> (V T').\<exists> v'. e'[x::=v] \<Down> v' \<and> v' \<in> V T)"
            and "(iv)":  "\<theta><e\<^sub>1> \<Down> Lam [x].e'"
            and fr: "x\<sharp>(\<theta>,e\<^sub>1,e\<^sub>2)" by (blast elim: V_arrow_elim_strong)
  from fr have fr\<^sub>1: "x\<sharp>\<theta><e\<^sub>1>" and fr\<^sub>2: "x\<sharp>\<theta><e\<^sub>2>" by (simp_all add: fresh_psubst)
  from "(ii)" "(iii)" obtain v\<^sub>3 where "(v)": "e'[x::=v\<^sub>2] \<Down> v\<^sub>3" "v\<^sub>3 \<in> V T" by auto
  from fr\<^sub>2 "(ii)" have "x\<sharp>v\<^sub>2" by (simp add: big_preserves_fresh)
  then have "x\<sharp>e'[x::=v\<^sub>2]" by (simp add: fresh_subst)
  then have fr\<^sub>3: "x\<sharp>v\<^sub>3" using "(v)" by (simp add: big_preserves_fresh)
  from fr\<^sub>1 fr\<^sub>2 fr\<^sub>3 have "x\<sharp>(\<theta><e\<^sub>1>,\<theta><e\<^sub>2>,v\<^sub>3)" by simp
  with "(iv)" "(ii)" "(v)" have "App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>) \<Down> v\<^sub>3" by auto
  then show "\<exists>v. \<theta><App e\<^sub>1 e\<^sub>2> \<Down> v \<and> v \<in> V T" using "(v)" by auto
next
  case (Lam x e \<Gamma> \<theta> T)
  have ih:"\<And>\<theta> \<Gamma> T. \<lbrakk>\<theta> Vcloses \<Gamma>; \<Gamma> \<turnstile> e : T\<rbrakk> \<Longrightarrow> \<exists>v. \<theta><e> \<Down> v \<and> v \<in> V T" by fact
  have as\<^sub>1: "\<theta> Vcloses \<Gamma>" by fact
  have as\<^sub>2: "\<Gamma> \<turnstile> Lam [x].e : T" by fact
  have fs: "x\<sharp>\<Gamma>" "x\<sharp>\<theta>" by fact+
  from as\<^sub>2 fs obtain T\<^sub>1 T\<^sub>2
    where "(i)": "(x,T\<^sub>1)#\<Gamma> \<turnstile> e:T\<^sub>2" and "(ii)": "T = T\<^sub>1 \<rightarrow> T\<^sub>2" using fs
    by (auto elim: t_Lam_elim)
  from "(i)" have "(iii)": "valid ((x,T\<^sub>1)#\<Gamma>)" by (simp add: typing_implies_valid)
  have "\<forall>v \<in> (V T\<^sub>1). \<exists>v'. (\<theta><e>)[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2"
  proof
    fix v
    assume "v \<in> (V T\<^sub>1)"
    with "(iii)" as\<^sub>1 have "(x,v)#\<theta> Vcloses (x,T\<^sub>1)#\<Gamma>" using monotonicity by auto
    with ih "(i)" obtain v' where "((x,v)#\<theta>)<e> \<Down> v' \<and> v' \<in> V T\<^sub>2" by blast
    then have "\<theta><e>[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2" using fs by (simp add: psubst_subst_psubst)
    then show "\<exists>v'. \<theta><e>[x::=v] \<Down> v' \<and> v' \<in> V T\<^sub>2" by auto
  qed
  then have "Lam[x].\<theta><e> \<in> V (T\<^sub>1 \<rightarrow> T\<^sub>2)" by auto
  then have "\<theta><Lam [x].e> \<Down> Lam [x].\<theta><e> \<and> Lam [x].\<theta><e> \<in> V (T\<^sub>1\<rightarrow>T\<^sub>2)" using fs by auto
  thus "\<exists>v. \<theta><Lam [x].e> \<Down> v \<and> v \<in> V T" using "(ii)" by auto
next
  case (Var x \<Gamma> \<theta> T)
  have "\<Gamma> \<turnstile> (Var x) : T" by fact
  then have "(x,T)\<in>set \<Gamma>" by (cases) (auto simp add: trm.inject)
  with Var have "\<theta><Var x> \<Down> \<theta><Var x> \<and> \<theta><Var x>\<in> V T"
    by (auto intro!: Vs_reduce_to_themselves)
  then show "\<exists>v. \<theta><Var x> \<Down> v \<and> v \<in> V T" by auto
qed

theorem termination_of_evaluation:
  assumes a: "[] \<turnstile> e : T"
  shows "\<exists>v. e \<Down> v \<and> val v"
proof -
  from a have "\<exists>v. []<e> \<Down> v \<and> v \<in> V T" by (rule termination_aux) (auto)
  thus "\<exists>v. e \<Down> v \<and> val v" using Vs_are_values by auto
qed

end


(*  Title:      Containers/List_Fusion.thy
    Author:     Andreas Lochbihler, KIT *)

theory List_Fusion
imports
  Main
  "~~/src/HOL/Coinduction"
begin

section {* Shortcut fusion for lists *}

lemma Option_map_mono [partial_function_mono]:
  "mono_option f \<Longrightarrow> mono_option (\<lambda>x. map_option g (f x))"
apply(rule monotoneI)
apply(drule (1) monotoneD)
apply(auto simp add: map_option_case flat_ord_def split: option.split)
done

lemma list_all2_coinduct [consumes 1, case_names Nil Cons, case_conclusion Cons hd tl, coinduct pred: list_all2]:
  assumes X: "X xs ys"
  and Nil': "\<And>xs ys. X xs ys \<Longrightarrow> xs = [] \<longleftrightarrow> ys = []"
  and Cons': "\<And>xs ys. \<lbrakk> X xs ys; xs \<noteq> []; ys \<noteq> [] \<rbrakk> \<Longrightarrow> A (hd xs) (hd ys) \<and> (X (tl xs) (tl ys) \<or> list_all2 A (tl xs) (tl ys))"
  shows "list_all2 A xs ys"
using X
proof(induction xs arbitrary: ys)
  case Nil
  from Nil'[OF this] show ?case by simp
next
  case (Cons x xs)
  from Nil'[OF Cons.prems] Cons'[OF Cons.prems] Cons.IH
  show ?case by(auto simp add: neq_Nil_conv)
qed

subsection {* The type of generators for finite lists *}

type_synonym ('a, 's) raw_generator = "('s \<Rightarrow> bool) \<times> ('s \<Rightarrow> 'a \<times> 's)"

inductive_set terminates_on :: "('a, 's) raw_generator \<Rightarrow> 's set"
  for g :: "('a, 's) raw_generator"
where
  stop: "\<not> fst g s \<Longrightarrow> s \<in> terminates_on g"
| unfold: "\<lbrakk> fst g s; snd (snd g s) \<in> terminates_on g \<rbrakk> \<Longrightarrow> s \<in> terminates_on g"

definition terminates :: "('a, 's) raw_generator \<Rightarrow> bool"
where "terminates g \<longleftrightarrow> (terminates_on g = UNIV)"

lemma terminatesI [intro?]:
  "(\<And>s. s \<in> terminates_on g) \<Longrightarrow> terminates g"
by(auto simp add: terminates_def)

lemma terminatesD:
  "terminates g \<Longrightarrow> s \<in> terminates_on g"
by(auto simp add: terminates_def)

lemma terminates_on_stop:
  "terminates_on (\<lambda>_. False, next) = UNIV"
by(auto intro: terminates_on.stop)

lemma wf_terminates:
  assumes "wf R"
  and step: "\<And>s. fst g s \<Longrightarrow> (snd (snd g s), s) \<in> R"
  shows "terminates g"
proof(rule terminatesI)
  fix s
  from `wf R` show "s \<in> terminates_on g"
  proof(induction rule: wf_induct[rule_format, consumes 1, case_names wf])
    case (wf s)
    show ?case
    proof(cases "fst g s")
      case True
      hence "(snd (snd g s), s) \<in> R" by(rule step)
      hence "snd (snd g s) \<in> terminates_on g" by(rule wf.IH)
      with True show ?thesis by(rule terminates_on.unfold)
    qed(rule terminates_on.stop)
  qed
qed

lemma terminates_wfD:
  assumes "terminates g"
  shows "wf {(snd (snd g s), s) | s . fst g s}"
proof(rule wfUNIVI)
  fix thesis s
  assume wf [rule_format]: "\<forall>s. (\<forall>s'. (s', s) \<in> {(snd (snd g s), s) |s. fst g s} \<longrightarrow> thesis s') \<longrightarrow> thesis s"
  from assms have "s \<in> terminates_on g" by(auto simp add: terminates_def)
  thus "thesis s" by induct (auto intro: wf)
qed

lemma terminates_wfE:
  assumes "terminates g"
  obtains R where "wf R" "\<And>s. fst g s \<Longrightarrow> (snd (snd g s), s) \<in> R"
by(rule that)(rule terminates_wfD[OF assms], simp)

context fixes g :: "('a, 's) raw_generator" begin

partial_function (option) terminates_within :: "'s \<Rightarrow> nat option"
where
  "terminates_within s =
   (let (has_next, next) = g
    in if has_next s then
          map_option (\<lambda>n. n + 1) (terminates_within (snd (next s)))
       else Some 0)"

lemma terminates_on_conv_dom_terminates_within:
  "terminates_on g = dom terminates_within"
proof(safe)
  fix s
  assume "s \<in> terminates_on g"
  then show "\<exists>n. terminates_within s = Some n"
    by(induct)(subst terminates_within.simps, simp add: split_beta)+
next
  fix s n
  assume "terminates_within s = Some n"
  then show "s \<in> terminates_on g"
    by(induct rule: terminates_within.raw_induct[rotated 1, consumes 1])(auto simp add: split_beta split: split_if_asm intro: terminates_on.intros)
qed

end

lemma terminates_within_unfold:
  "has_next s \<Longrightarrow>
  terminates_within (has_next, next) s = map_option (\<lambda>n. n + 1) (terminates_within (has_next, next) (snd (next s)))"
by(simp add: terminates_within.simps)

typedef ('a, 's) generator = "{g :: ('a, 's) raw_generator. terminates g}"
  morphisms generator Generator
proof
  show "(\<lambda>_. False, undefined) \<in> ?generator"
    by(simp add: terminates_on_stop terminates_def)
qed

setup_lifting type_definition_generator

lemma terminates_on_generator_eq_UNIV:
  "terminates_on (generator g) = UNIV"
by transfer(simp add: terminates_def)

lemma terminates_within_stop:
  "terminates_within (\<lambda>_. False, next) s = Some 0"
by(simp add: terminates_within.simps)

lemma terminates_within_generator_neq_None:
  "terminates_within (generator g) s \<noteq> None"
by(transfer)(auto simp add: terminates_def terminates_on_conv_dom_terminates_within)

locale list =
  fixes g :: "('a, 's) generator" begin

definition has_next :: "'s \<Rightarrow> bool"
where "has_next = fst (generator g)"

definition "next" :: "'s \<Rightarrow> 'a \<times> 's"
where "next = snd (generator g)"

function unfoldr :: "'s \<Rightarrow> 'a list"
where "unfoldr s = (if has_next s then let (a, s') = next s in a # unfoldr s' else [])"
by pat_completeness auto
termination
proof -
  have "terminates (generator g)" using generator[of g] by simp
  thus ?thesis
    by(rule terminates_wfE)(erule "termination", metis has_next_def next_def snd_conv)
qed

declare unfoldr.simps [simp del]

lemma unfoldr_simps:
  "has_next s \<Longrightarrow> unfoldr s = fst (next s) # unfoldr (snd (next s))"
  "\<not> has_next s \<Longrightarrow> unfoldr s = []"
by(simp_all add: unfoldr.simps split_beta)

end

declare
  list.has_next_def[code]
  list.next_def[code]
  list.unfoldr.simps[code]

context
begin
interpretation lifting_syntax .

lemma generator_has_next_transfer [transfer_rule]:
  "(pcr_generator op = op = ===> op =) fst list.has_next"
by(auto simp add: generator.pcr_cr_eq cr_generator_def list.has_next_def dest: sym)

lemma generator_next_transfer [transfer_rule]:
  "(pcr_generator op = op = ===> op =) snd list.next"
by(auto simp add: generator.pcr_cr_eq cr_generator_def list.next_def)

end

lemma unfoldr_eq_Nil_iff [iff]:
  "list.unfoldr g s = [] \<longleftrightarrow> \<not> list.has_next g s"
by(subst list.unfoldr.simps)(simp add: split_beta)

lemma Nil_eq_unfoldr_iff [simp]:
  "[] = list.unfoldr g s \<longleftrightarrow> \<not> list.has_next g s"
by(auto intro: sym dest: sym)

subsection {* Generators for @{typ "'a list"} *}

primrec list_has_next :: "'a list \<Rightarrow> bool"
where
  "list_has_next [] \<longleftrightarrow> False"
| "list_has_next (x # xs) \<longleftrightarrow> True"

primrec list_next :: "'a list \<Rightarrow> 'a \<times> 'a list"
where
  "list_next (x # xs) = (x, xs)"

lemma terminates_list_generator: "terminates (list_has_next, list_next)"
proof
  fix xs
  show "xs \<in> terminates_on (list_has_next, list_next)"
    by(induct xs)(auto intro: terminates_on.intros)
qed

lift_definition list_generator :: "('a, 'a list) generator"
  is "(list_has_next, list_next)"
by(rule terminates_list_generator)

lemma has_next_list_generator [simp]:
  "list.has_next list_generator = list_has_next"
by transfer simp

lemma next_list_generator [simp]:
  "list.next list_generator = list_next"
by transfer simp

lemma unfoldr_list_generator:
  "list.unfoldr list_generator xs = xs"
by(induct xs)(simp_all add: list.unfoldr_simps)

lemma terminates_replicate_generator:
  "terminates (\<lambda>n :: nat. 0 < n, \<lambda>n. (a, n - 1))"
by(rule wf_terminates)(lexicographic_order)

lift_definition replicate_generator :: "'a \<Rightarrow> ('a, nat) generator"
  is "\<lambda>a. (\<lambda>n. 0 < n, \<lambda>n. (a, n - 1))"
by(rule terminates_replicate_generator)

lemma has_next_replicate_generator [simp]:
  "list.has_next (replicate_generator a) n \<longleftrightarrow> 0 < n"
by transfer simp

lemma next_replicate_generator [simp]:
  "list.next (replicate_generator a) n = (a, n - 1)"
by transfer simp

lemma unfoldr_replicate_generator:
  "list.unfoldr (replicate_generator a) n = replicate n a"
by(induct n)(simp_all add: list.unfoldr_simps)

context fixes f :: "'a \<Rightarrow> 'b" begin

lift_definition map_generator :: "('a, 's) generator \<Rightarrow> ('b, 's) generator"
  is "\<lambda>(has_next, next). (has_next, \<lambda>s. let (a, s') = next s in (f a, s'))"
by(erule terminates_wfE)(erule wf_terminates, auto simp add: split_beta)

lemma has_next_map_generator [simp]:
  "list.has_next (map_generator g) = list.has_next g"
by transfer clarsimp

lemma next_map_generator [simp]:
  "list.next (map_generator g) = apfst f \<circ> list.next g"
by transfer(simp add: fun_eq_iff split_beta apfst_def map_prod_def)

lemma unfoldr_map_generator:
  "list.unfoldr (map_generator g) = map f \<circ> list.unfoldr g"
  (is "?lhs = ?rhs")
proof(rule ext)
  fix s
  show "?lhs s = ?rhs s"
    by(induct s taking: "map_generator g" rule: list.unfoldr.induct)
      (subst (1 2) list.unfoldr.simps, auto simp add: split_beta apfst_def map_prod_def)
qed

end

context fixes g1 :: "('a, 's1) raw_generator"
  and g2 :: "('a, 's2) raw_generator"
begin

fun append_has_next :: "'s1 \<times> 's2 + 's2 \<Rightarrow> bool"
where
  "append_has_next (Inl (s1, s2)) \<longleftrightarrow> fst g1 s1 \<or> fst g2 s2"
| "append_has_next (Inr s2) \<longleftrightarrow> fst g2 s2"

fun append_next :: "'s1 \<times> 's2 + 's2 \<Rightarrow> 'a \<times> ('s1 \<times> 's2 + 's2)"
where
  "append_next (Inl (s1, s2)) =
  (if fst g1 s1 then
     let (x, s1') = snd g1 s1 in (x, Inl (s1', s2))
   else append_next (Inr s2))"
| "append_next (Inr s2) = (let (x, s2') = snd g2 s2 in (x, Inr s2'))"

end

lift_definition append_generator :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> ('a, 's1 \<times> 's2 + 's2) generator"
  is "\<lambda>g1 g2. (append_has_next g1 g2, append_next g1 g2)"
proof(rule terminatesI, safe)
  fix has_next1 and next1 :: "'s1 \<Rightarrow> 'a \<times> 's1"
    and has_next2 and next2 :: "'s2 \<Rightarrow> 'a \<times> 's2"
    and s
  assume t1: "terminates (has_next1, next1)"
    and t2: "terminates (has_next2, next2)"
  let ?has_next = "append_has_next (has_next1, next1) (has_next2, next2)"
  let ?next = "append_next (has_next1, next1) (has_next2, next2)"
  note [simp] = split_beta
    and [intro] = terminates_on.intros
  { fix s2 :: 's2
    from t2 have "s2 \<in> terminates_on (has_next2, next2)" by(rule terminatesD)
    hence "Inr s2 \<in> terminates_on (?has_next, ?next)" by induct auto }
  note Inr' = this

  show "s \<in> terminates_on (?has_next, ?next)"
  proof(cases s)
    case Inr thus ?thesis by(simp add: Inr')
  next
    case (Inl s1s2)
    moreover obtain s1 s2 where "s1s2 = (s1, s2)" by(cases s1s2)
    ultimately have s: "s = Inl (s1, s2)" by simp
    from t1 have "s1 \<in> terminates_on (has_next1, next1)" by(rule terminatesD)
    thus ?thesis unfolding s
    proof induct
      case stop thus ?case
        by(cases "has_next2 s2")(auto simp add: Inr')
    qed auto
  qed
qed

definition append_init :: "'s1 \<Rightarrow> 's2 \<Rightarrow> 's1 \<times> 's2 + 's2"
where "append_init s1 s2 = Inl (s1, s2)"

lemma has_next_append_generator [simp]:
  "list.has_next (append_generator g1 g2) (Inl (s1, s2)) \<longleftrightarrow>
   list.has_next g1 s1 \<or> list.has_next g2 s2"
  "list.has_next (append_generator g1 g2) (Inr s2) \<longleftrightarrow> list.has_next g2 s2"
by(transfer, simp)+

lemma next_append_generator [simp]:
  "list.next (append_generator g1 g2) (Inl (s1, s2)) =
  (if list.has_next g1 s1 then
     let (x, s1') = list.next g1 s1 in (x, Inl (s1', s2))
   else list.next (append_generator g1 g2) (Inr s2))"
  "list.next (append_generator g1 g2) (Inr s2) = apsnd Inr (list.next g2 s2)"
by(transfer, simp add: apsnd_def map_prod_def)+

lemma unfoldr_append_generator_Inr:
  "list.unfoldr (append_generator g1 g2) (Inr s2) = list.unfoldr g2 s2"
by(induct s2 taking: g2 rule: list.unfoldr.induct)(subst (1 2) list.unfoldr.simps, auto split: prod.splits)

lemma unfoldr_append_generator_Inl:
  "list.unfoldr (append_generator g1 g2) (Inl (s1, s2)) =
   list.unfoldr g1 s1 @ list.unfoldr g2 s2"
apply(induct s1 taking: g1 rule: list.unfoldr.induct)
apply(subst (1 2 3) list.unfoldr.simps)
apply(auto split: prod.splits simp add: apsnd_def map_prod_def unfoldr_append_generator_Inr)
apply(simp add: list.unfoldr_simps)
done

lemma unfoldr_append_generator:
  "list.unfoldr (append_generator g1 g2) (append_init s1 s2) =
   list.unfoldr g1 s1 @ list.unfoldr g2 s2"
by(simp add: unfoldr_append_generator_Inl append_init_def)

lift_definition zip_generator :: "('a, 's1) generator \<Rightarrow> ('b, 's2) generator \<Rightarrow> ('a \<times> 'b, 's1 \<times> 's2) generator"
  is "\<lambda>(has_next1, next1) (has_next2, next2).
      (\<lambda>(s1, s2). has_next1 s1 \<and> has_next2 s2,
       \<lambda>(s1, s2). let (x, s1') = next1 s1; (y, s2') = next2 s2
                  in ((x, y), (s1', s2')))"
proof(rule terminatesI, safe)
  fix has_next1 next1 has_next2 next2 s1 s2
  assume t1: "terminates (has_next1, next1)"
    and t2: "terminates (has_next2, next2)"
  have "s1 \<in> terminates_on (has_next1, next1)" "s2 \<in> terminates_on (has_next2, next2)"
    using t1 t2 by(simp_all add: terminatesD)
  thus "(s1, s2) \<in> terminates_on (\<lambda>(s1, s2). has_next1 s1 \<and> has_next2 s2, \<lambda>(s1, s2). let (x, s1') = next1 s1; (y, s2') = next2 s2 in ((x, y), (s1', s2')))"
    by(induct arbitrary: s2)(auto 4 3 elim: terminates_on.cases intro: terminates_on.intros simp add: split_beta Let_def)
qed

abbreviation (input) zip_init :: "'s1 \<Rightarrow> 's2 \<Rightarrow> 's1 \<times> 's2"
where "zip_init \<equiv> Pair"

lemma has_next_zip_generator [simp]:
  "list.has_next (zip_generator g1 g2) (s1, s2) \<longleftrightarrow>
   list.has_next g1 s1 \<and> list.has_next g2 s2"
by transfer clarsimp

lemma next_zip_generator [simp]:
  "list.next (zip_generator g1 g2) (s1, s2) =
  ((fst (list.next g1 s1), fst (list.next g2 s2)),
   (snd (list.next g1 s1), snd (list.next g2 s2)))"
by transfer(simp add: split_beta)

lemma unfoldr_zip_generator:
  "list.unfoldr (zip_generator g1 g2) (zip_init s1 s2) =
   zip (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
by(induct "(s1, s2)" arbitrary: s1 s2 taking: "zip_generator g1 g2" rule: list.unfoldr.induct)
  (subst (1 2 3) list.unfoldr.simps, auto 9 2 simp add: split_beta)

context fixes bound :: nat begin

lift_definition upt_generator :: "(nat, nat) generator"
  is "(\<lambda>n. n < bound, \<lambda>n. (n, Suc n))"
by(rule wf_terminates)(relation "measure (\<lambda>n. bound - n)", auto)

lemma has_next_upt_generator [simp]:
  "list.has_next upt_generator n \<longleftrightarrow> n < bound"
by transfer simp

lemma next_upt_generator [simp]:
  "list.next upt_generator n = (n, Suc n)"
by transfer simp

lemma unfoldr_upt_generator:
  "list.unfoldr upt_generator n = [n..<bound]"
by(induct "bound - n" arbitrary: n)(simp_all add: list.unfoldr_simps upt_conv_Cons)

end

context fixes bound :: int begin

lift_definition upto_generator :: "(int, int) generator"
  is "(\<lambda>n. n \<le> bound, \<lambda>n. (n, n + 1))"
by(rule wf_terminates)(relation "measure (\<lambda>n. nat (bound + 1 - n))", auto)

lemma has_next_upto_generator [simp]:
  "list.has_next upto_generator n \<longleftrightarrow> n \<le> bound"
by transfer simp

lemma next_upto_generator [simp]:
  "list.next upto_generator n = (n, n + 1)"
by transfer simp

lemma unfoldr_upto_generator:
  "list.unfoldr upto_generator n = [n..bound]"
by(induct n taking: upto_generator rule: list.unfoldr.induct)(subst list.unfoldr.simps, subst upto.simps, auto)

end

context
  fixes P :: "'a \<Rightarrow> bool"
begin

context
  fixes g :: "('a, 's) raw_generator"
begin

inductive filter_has_next :: "'s \<Rightarrow> bool"
where
  "\<lbrakk> fst g s; P (fst (snd g s)) \<rbrakk> \<Longrightarrow> filter_has_next s"
| "\<lbrakk> fst g s; \<not> P (fst (snd g s)); filter_has_next (snd (snd g s)) \<rbrakk> \<Longrightarrow> filter_has_next s"

partial_function (tailrec) filter_next :: "'s \<Rightarrow> 'a \<times> 's"
where
  "filter_next s = (let (x, s') = snd g s in if P x then (x, s') else filter_next s')"

end

lift_definition filter_generator :: "('a, 's) generator \<Rightarrow> ('a, 's) generator"
  is "\<lambda>g. (filter_has_next g, filter_next g)"
proof(rule wf_terminates)
  fix g :: "('a, 's) raw_generator" and s
  let ?R = "{(snd (snd g s), s) | s. fst g s}"
  let ?g = "(filter_has_next g, filter_next g)"
  assume "terminates g"
  thus "wf (?R\<^sup>+)" by(rule terminates_wfD[THEN wf_trancl])
  assume "fst ?g s"
  hence "filter_has_next g s" by simp
  thus "(snd (snd ?g s), s) \<in> ?R\<^sup>+"
    by induct(subst filter_next.simps, auto simp add: split_beta filter_next.simps split del: split_if intro: trancl_into_trancl)
qed

lemma next_filter_generator:
   "list.next (filter_generator g) s =
   (let (x, s') = list.next g s
    in if P x then (x, s') else list.next (filter_generator g) s')"
apply transfer
apply simp
apply(subst filter_next.simps)
apply(simp cong: if_cong)
done

lemma has_next_filter_generator_induct [consumes 1, case_names find step]:
  assumes "list.has_next (filter_generator g) s"
  and find: "\<And>s. \<lbrakk> list.has_next g s; P (fst (list.next g s)) \<rbrakk> \<Longrightarrow> Q s"
  and step: "\<And>s. \<lbrakk> list.has_next g s; \<not> P (fst (list.next g s)); Q (snd (list.next g s)) \<rbrakk> \<Longrightarrow> Q s"
  shows "Q s"
using assms by transfer(auto elim: filter_has_next.induct)

lemma filter_generator_empty_conv:
  "list.has_next (filter_generator g) s \<longleftrightarrow> (\<exists>x\<in>set (list.unfoldr g s). P x)" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume "?lhs"
  thus ?rhs
  proof(induct rule: has_next_filter_generator_induct)
    case (find s)
    thus ?case
      by(cases "list.next g s")(subst list.unfoldr.simps, auto)
  next
    case (step s)
    thus ?case
      by(cases "list.next g s")(subst list.unfoldr.simps, auto)
  qed
next
  assume ?rhs
  then obtain x where "x \<in> set (list.unfoldr g s)" "P x" by blast
  thus ?lhs
  proof(induct xs\<equiv>"list.unfoldr g s" arbitrary: s)
    case Nil thus ?case by(simp del: Nil_eq_unfoldr_iff)
  next
    case (Cons x' xs)
    from `x' # xs = list.unfoldr g s`[symmetric, simp]
    have [simp]: "fst (list.next g s) = x' \<and> list.has_next g s \<and> list.unfoldr g (snd (list.next g s)) = xs"
      by(subst (asm) list.unfoldr.simps)(simp add: split_beta split: split_if_asm)
    from Cons.hyps(1)[of "snd (list.next g s)"] `x \<in> set (list.unfoldr g s)` `P x` show ?case
      by(subst has_next_filter_generator)(auto simp add: split_beta)
  qed
qed

lemma unfoldr_filter_generator:
  "list.unfoldr (filter_generator g) s = filter P (list.unfoldr g s)"
unfolding list_all2_eq
proof(coinduction arbitrary: s)
  case Nil
  thus ?case by(simp add: filter_empty_conv filter_generator_empty_conv)
next
  case (Cons s)
  hence "list.has_next (filter_generator g) s" by simp
  thus ?case
  proof(induction rule: has_next_filter_generator_induct)
    case (find s)
    thus ?case
      apply(subst (1 2 3 5) list.unfoldr.simps)
      apply(subst (1 2) has_next_filter_generator)
      apply(subst next_filter_generator)
      apply(simp add: split_beta)
      apply(rule disjI1 exI conjI refl)+
      apply(subst next_filter_generator)
      apply(simp add: split_beta)
      done
  next
    case (step s)
    from step.hyps
    have "list.unfoldr (filter_generator g) s = list.unfoldr (filter_generator g) (snd (list.next g s))"
      apply(subst (1 2) list.unfoldr.simps)
      apply(subst has_next_filter_generator)
      apply(subst next_filter_generator)
      apply(auto simp add: split_beta)
      done
    moreover from step.hyps
    have "filter P (list.unfoldr g (snd (list.next g s))) = filter P (list.unfoldr g s)"
      by(subst (2) list.unfoldr.simps)(auto simp add: split_beta)
    ultimately show ?case using step.IH by simp
  qed
qed

end

subsection {* Destroying lists *}

definition hd_fusion :: "('a, 's) generator \<Rightarrow> 's \<Rightarrow> 'a"
where "hd_fusion g s = hd (list.unfoldr g s)"

lemma hd_fusion_code [code]:
  "hd_fusion g s = (if list.has_next g s then fst (list.next g s) else undefined)"
unfolding hd_fusion_def
by(subst list.unfoldr.simps)(simp add: hd_def split_beta)

declare hd_fusion_def [symmetric, code_unfold]

definition fold_fusion :: "('a, 's) generator \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 's \<Rightarrow> 'b \<Rightarrow> 'b"
where "fold_fusion g f s = fold f (list.unfoldr g s)"

lemma fold_fusion_code [code]:
  "fold_fusion g f s b =
  (if list.has_next g s then
     let (x, s') = list.next g s
     in fold_fusion g f s' (f x b)
   else b)"
unfolding fold_fusion_def
by(subst list.unfoldr.simps)(simp add: split_beta)

declare fold_fusion_def[symmetric, code_unfold]

definition gen_length_fusion :: "('a, 's) generator \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> nat"
where "gen_length_fusion g n s = n + length (list.unfoldr g s)"

lemma gen_length_fusion_code [code]:
  "gen_length_fusion g n s =
  (if list.has_next g s then gen_length_fusion g (Suc n) (snd (list.next g s)) else n)"
unfolding gen_length_fusion_def
by(subst list.unfoldr.simps)(simp add: split_beta)

definition length_fusion :: "('a, 's) generator \<Rightarrow> 's \<Rightarrow> nat"
where "length_fusion g s = length (list.unfoldr g s)"

lemma length_fusion_code [code]:
  "length_fusion g = gen_length_fusion g 0"
by(simp add: fun_eq_iff length_fusion_def gen_length_fusion_def)

declare length_fusion_def[symmetric, code_unfold]

definition map_fusion :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) generator \<Rightarrow> 's \<Rightarrow> 'b list"
where "map_fusion f g s = map f (list.unfoldr g s)"

lemma map_fusion_code [code]:
  "map_fusion f g s =
  (if list.has_next g s then
     let (x, s') = list.next g s
     in f x # map_fusion f g s'
   else [])"
unfolding map_fusion_def
by(subst list.unfoldr.simps)(simp add: split_beta)

declare map_fusion_def[symmetric, code_unfold]

definition append_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> 'a list"
where "append_fusion g1 g2 s1 s2 = list.unfoldr g1 s1 @ list.unfoldr g2 s2"

lemma append_fusion [code]:
  "append_fusion g1 g2 s1 s2 =
  (if list.has_next g1 s1 then
     let (x, s1') = list.next g1 s1
     in x # append_fusion g1 g2 s1' s2
   else list.unfoldr g2 s2)"
unfolding append_fusion_def
by(subst list.unfoldr.simps)(simp add: split_beta)

declare append_fusion_def[symmetric, code_unfold]

definition zip_fusion :: "('a, 's1) generator \<Rightarrow> ('b, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> ('a \<times> 'b) list"
where "zip_fusion g1 g2 s1 s2 = zip (list.unfoldr g1 s1) (list.unfoldr g2 s2)"

lemma zip_fusion_code [code]:
  "zip_fusion g1 g2 s1 s2 =
  (if list.has_next g1 s1 \<and> list.has_next g2 s2 then
     let (x, s1') = list.next g1 s1;
         (y, s2') = list.next g2 s2
     in (x, y) # zip_fusion g1 g2 s1' s2'
   else [])"
unfolding zip_fusion_def
by(subst (1 2) list.unfoldr.simps)(simp add: split_beta)

declare zip_fusion_def[symmetric, code_unfold]

definition list_all_fusion :: "('a, 's) generator \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
where "list_all_fusion g P s = List.list_all P (list.unfoldr g s)"

lemma list_all_fusion_code [code]:
  "list_all_fusion g P s \<longleftrightarrow>
  (list.has_next g s \<longrightarrow>
   (let (x, s') = list.next g s
    in P x \<and> list_all_fusion g P s'))"
unfolding list_all_fusion_def
by(subst list.unfoldr.simps)(simp add: split_beta)

declare list_all_fusion_def[symmetric, code_unfold]

definition list_all2_fusion :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 's1) generator \<Rightarrow> ('b, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
where
  "list_all2_fusion P g1 g2 s1 s2 =
   list_all2 P (list.unfoldr g1 s1) (list.unfoldr g2 s2)"

lemma list_all2_fusion_code [code]:
  "list_all2_fusion P g1 g2 s1 s2 =
  (if list.has_next g1 s1 then
     list.has_next g2 s2 \<and>
     (let (x, s1') = list.next g1 s1;
          (y, s2') = list.next g2 s2
      in P x y \<and> list_all2_fusion P g1 g2 s1' s2')
   else \<not> list.has_next g2 s2)"
unfolding list_all2_fusion_def
by(subst (1 2) list.unfoldr.simps)(simp add: split_beta)

declare list_all2_fusion_def[symmetric, code_unfold]

definition singleton_list_fusion :: "('a, 'state) generator \<Rightarrow> 'state \<Rightarrow> bool"
where "singleton_list_fusion gen state = (case list.unfoldr gen state of [_] \<Rightarrow> True | _ \<Rightarrow> False)"

lemma singleton_list_fusion_code [code]:
  "singleton_list_fusion g s \<longleftrightarrow>
  list.has_next g s \<and> \<not> list.has_next g (snd (list.next g s))"
by(auto 4 5 simp add: singleton_list_fusion_def split: list.split split_if_asm prod.splits elim: list.unfoldr.elims dest: sym)

end


theory take
imports Main
        "../data/Natu"
        "../data/list"
        "$HIPSTER_HOME/IsaHipster"

begin

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

(*hipster take*)

lemma lemma_ai [thy_expl]: "take x3 Nil2 = Nil2"
by (hipster_induct_simp_metis take.simps)

lemma lemma_aj [thy_expl]: "take x3 (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

lemma lemma_ak [thy_expl]: "take (S x3) (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

lemma unknown [thy_expl]: "take x (take y z) = take y (take x z)"
oops

lemma unknown [thy_expl]: "take (S Z) (take x y) = take (S z) (take x y)"
oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_le_antisym
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

theorem property0 :
  "((le x y) ==> ((le y x) ==> (x = y)))"
  oops

end


theory week04A_demo_intro
imports Main
begin

lemma div_0:
  "0 div (x::nat) = 0"
  apply(rule semidom_divide_class.div_0)
  done

thm mult_0

(* All goals up to now have been solvable using intro/elim rules only. Rules
   that are equalities (like those above) can be used as intro rules for
   goals that match their shape. *)
lemma "\<exists> x::nat. x div 2 = 0"
  apply(rule_tac x=0 in exI)
  apply(rule div_0)
  done

(* However, using these rules as intro rules cannot solve the following goal.
   Instead, we need to use these rules to rewrite the left- and right-hand
   sides of the equality to match each other. *)
lemma "\<exists> x::nat. (x div 2) * 2 = 0 * x"
  apply(rule_tac x=0 in exI)
thm ssubst
thm ssubst[OF div_0]
  apply(rule ssubst[OF div_0])
  apply(rule ssubst[OF mult_0[where n=2]])
  apply(rule ssubst[OF mult_0[where n=0]])
  apply(rule refl)
  done

(* this rewriting is automated by Isabelle's rewrite-engine, called the
   simplifier. This is what we will be learning about today. *)
lemma "\<exists> x::nat. (x div 2) * 2 = 0 * x"
  apply(rule_tac x=0 in exI)
  apply(simp only: div_0 mult_0)
  done

(* REMINDER: automated tactics (like the simp and blast etc.) work best when
   they don't have to instantiate schematic variables, since automation often
   fails when the automated tactics cannot find the right instantiations.
   You should instantiate schematic variables in the rules that introduce
   them before applying those rules. *)
lemma "\<exists> x::nat. (x div 2) * 2 = 0 * x"
  apply(rule exI)
  apply(simp only: div_0 mult_0)
  oops

end


section \<open>Noninterference for models with finitely many users, commands and outputs\<close>

(*<*)
theory Finite_Noninterference
imports Noninterference Deep
begin
(*>*)

text\<open>In the Noninterference section, we showed how to express Goguen-Meseguer
noninterference as a shallow HyperCTL* formula.  Here we show that, if one assumes
finiteness of the sets of users, commands and outputs,
then one can express the property as (the denotation of) a syntactic formula.
Note that we do {\em not} need to assume the state space finite -- this is
important for a potential application to infinite-state systems.\<close>

text\<open>The Goguen-Meseguer security model with finiteness assumptions\<close>

locale GM_sec_model_finite = GM_sec_model st0 do out
  for st0 :: 'St
  and do :: "'St \<Rightarrow> 'U \<Rightarrow> 'C \<Rightarrow> 'St"
  and out :: "'St \<Rightarrow> 'U \<Rightarrow> 'Out"
  +
  assumes finite_U: "finite (UNIV :: 'U set)"
  and finite_C: "finite (UNIV :: 'C set)"
  and finite_Out: "finite (UNIV :: 'Out set)"
begin

lemma finite_UminusGH: "finite (UNIV - GH)"
by (metis finite_Diff finite_U)

lemma finite_GL: "finite GL"
by (metis Diff_UNIV finite_Diff2 finite_U)

definition EqOnUC ::
"pvar \<Rightarrow> pvar \<Rightarrow> 'U \<Rightarrow> 'C \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqOnUC p p' u c \<equiv> Eq (Atom (Last u c) p) (Atom (Last u c) p')"

lemma EqOnUC_eqOnUC[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqOnUC p p' u c) env = eqOnUC i i' u c"
using assms unfolding EqOnUC_def eqOnUC_def by simp

definition EqButGH ::
"pvar \<Rightarrow> pvar \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqButGH p p' \<equiv> Scon {EqOnUC p p' u c | u c. (u,c) \<in> (UNIV - GH) \<times> UNIV}"

lemma finite_EqButGH:
"finite {EqOnUC p p' u c | u c. (u,c) \<in> (UNIV - GH) \<times> UNIV}" (is "finite ?K")
proof-
  have 1: "?K = (\<lambda> (u,c). EqOnUC p p' u c) ` ((UNIV - GH) \<times> UNIV)" by auto
  show ?thesis unfolding 1 apply(rule finite_imageI)
  by (metis finite_C finite_SigmaI finite_UminusGH)
qed

lemma EqButGH_eqButGH[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqButGH p p') env = eqButGH i i'"
using assms finite_EqButGH
unfolding EqButGH_def eqButGH_def sem_Scon[OF finite_EqButGH] image_def
by simp (metis (hide_lams, no_types) EqOnUC_eqOnUC)

lemma FV_EqButGH: "FV (EqButGH p p') \<subseteq> {p,p'}" (is "?L \<subseteq> ?R")
proof-
  have "?L = \<Union> {FV (EqOnUC p p' u c) | u c. (u,c) \<in> (UNIV - GH) \<times> UNIV}"
  unfolding EqButGH_def FV_Scon[OF finite_EqButGH] by auto
  also have "... \<subseteq> ?R" unfolding EqOnUC_def der_Op_defs by auto
  finally show ?thesis .
qed

definition EqOnUOut ::
"pvar \<Rightarrow> pvar \<Rightarrow> 'U \<Rightarrow> 'Out \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqOnUOut p p' u ou \<equiv> Eq (Atom (Obs u ou) p) (Atom (Obs u ou) p')"

lemma EqOnUOut_eqOnUOut[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqOnUOut p p' u ou) env = eqOnUOut i i' u ou"
using assms unfolding EqOnUOut_def eqOnUOut_def by simp

definition EqOnGL ::
"pvar \<Rightarrow> pvar \<Rightarrow> ('U,'C,'Out) aprop dfmla"
where
"EqOnGL p p' \<equiv> Scon {EqOnUOut p p' u ou | u ou. (u,ou) \<in> GL \<times> UNIV}"

lemma finite_EqOnGL:
"finite {EqOnUOut p p' u ou | u ou. (u,ou) \<in> GL \<times> UNIV}" (is "finite ?K")
proof-
  have 1: "?K = (\<lambda> (u,ou). EqOnUOut p p' u ou) ` (GL \<times> UNIV)" by auto
  show ?thesis unfolding 1 apply(rule finite_imageI)
  by (metis finite_Out finite_SigmaI finite_GL)
qed

lemma EqOnGL_eqOnGL[simp]:
assumes "env p = i" and "env p' = i'"
shows "sem (EqOnGL p p') env = eqOnGL i i'"
using assms finite_EqOnGL
unfolding EqOnGL_def eqOnGL_def sem_Scon[OF finite_EqOnGL] image_def
by simp (metis (hide_lams, no_types) EqOnUOut_eqOnUOut)

lemma FV_EqOnGL: "FV (EqOnGL p p') \<subseteq> {p,p'}" (is "?L \<subseteq> ?R")
proof-
  have "?L = \<Union> {FV (EqOnUOut p p' u ou) | u ou. (u,ou) \<in> GL \<times> UNIV}"
  unfolding EqOnGL_def FV_Scon[OF finite_EqOnGL] by auto
  also have "... \<subseteq> ?R" unfolding EqOnUOut_def der_Op_defs by auto
  finally show ?thesis .
qed

definition "p0 = getFresh {}"
definition "p1 = getFresh {p0}"

lemma p0p1[simp]: "p0 \<noteq> p1" unfolding p1_def
by (metis Diff_cancel getFresh infinite_imp_nonempty infinite_remove insertI1)

definition nonintDfmla :: "('U,'C,'Out) aprop dfmla" where
"nonintDfmla \<equiv>
 Fall2 p0 p1 (Imp (Alw (EqButGH p0 p1)) (Alw (EqOnGL p0 p1)))"

lemma sem_nonintDfmla: "sem nonintDfmla env = nonintSfmla"
unfolding nonintDfmla_def nonintSfmla_def by simp

lemma wff_nonintDfmla[simp]: "wff nonintDfmla"
unfolding nonintDfmla_def Fall2_def Fall_def by simp

lemma closed_nonintDfmla[simp]: "FV nonintDfmla = {}"
unfolding nonintDfmla_def Fall2_def Fall_def der_Op_defs
using FV_EqButGH FV_EqOnGL by fastforce

text\<open>In the end, we obtain that the semantics of the closed (syntactic) formula
nonintDfmla expresses noninterference faithfully:\<close>

theorem semClosed_nonintDfmla: "semClosed nonintDfmla = nonint"
unfolding nonintSfmla_iff_nonint[symmetric]
apply(subst sem_nonintDfmla[symmetric]) apply(rule semClosed_Nil) by auto

(*<*)
end (* context GM_sec_model_finite  *)
(*>*)

text\<open>end-of-context GM-sec-model-finite\<close>

(*<*)
end
(*>*)


(*  Title:      Native_Word_Test.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Test cases\<close>

theory Native_Word_Test imports
  Uint64 Uint32 Uint16 Uint8 Uint Native_Cast_Uint
  "HOL-Library.Code_Test" "Word_Lib.Bit_Shifts_Infix_Syntax"
begin

section \<open>Tests for @{typ uint32}\<close>

notation sshiftr_uint32 (infixl ">>>" 55)

definition test_uint32 where
  "test_uint32 \<longleftrightarrow>
  (([ 0x100000001, -1, -4294967291, 0xFFFFFFFF, 0x12345678
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + (- 6), 0xFFFFFFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x12345678 * 0x87654321
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 32 True, set_bit 5 32 False, set_bit (- 5) 32 True, set_bit (- 5) 32 False
    , 1 << 2, -1 << 3, 1 << 32, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 32, -100 >> 32
    , 100 >>> 3, -100 >>> 3, 100 >>> 32, -100 >>> 32] :: uint32 list)
   =
    [ 1, 4294967295, 5, 4294967295, 305419896
    , 18
    , 126
    , 108
    , 4294967205
    , 11, 1, 4294967295, 4294967285, 0
    , 2, 4294967294
    , 15, 4294967281, 20, 1891143032
    , 1, 1431655763, 0, 0
    , 2, 2, 4294967291, 5
    , 21, 4294967295, 4, 4294967289
    , 5, 5, 4294967291, 4294967291
    , 4, 4294967288, 0, 1
    , 12, 536870899, 0, 0
    , 12, 4294967283, 0, 4294967295]) \<and>
  ([ (0x5 :: uint32) = 0x5, (0x5 :: uint32) = 0x6
   , (0x5 :: uint32) < 0x5, (0x5 :: uint32) < 0x6, (-5 :: uint32) < 6, (6 :: uint32) < -5
   , (0x5 :: uint32) \<le> 0x5, (0x5 :: uint32) \<le> 0x4, (-5 :: uint32) \<le> 6, (6 :: uint32) \<le> -5
   , (0x7FFFFFFF :: uint32) < 0x80000000, (0xFFFFFFFF :: uint32) < 0, (0x80000000 :: uint32) < 0x7FFFFFFF
   , bit (0x7FFFFFFF :: uint32) 0, bit (0x7FFFFFFF :: uint32) 31, bit (0x80000000 :: uint32) 31, bit (0x80000000 :: uint32) 32
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint32 0, integer_of_uint32 0x7FFFFFFF, integer_of_uint32 0x80000000, integer_of_uint32 0xAAAAAAAA]
  =
   [0, 0x7FFFFFFF, 0x80000000, 0xAAAAAAAA])"

no_notation sshiftr_uint32 (infixl ">>>" 55)

export_code test_uint32 checking SML Haskell? OCaml? Scala

notepad begin
have test_uint32 by eval
have test_uint32 by code_simp
have test_uint32 by normalization
end

definition test_uint32' :: uint32
where "test_uint32' = 0 + 10 - 14 * 3 div 6 mod 3 << 3 >> 2"
ML \<open>val 0wx12 = @{code test_uint32'}\<close>

lemma "x AND y = x OR (y :: uint32)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: uint32) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint32 \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section \<open>Tests for @{typ uint16}\<close>

notation sshiftr_uint16 (infixl ">>>" 55)

definition test_uint16 where
  "test_uint16 \<longleftrightarrow>
  (([ 0x10001, -1, -65535, 0xFFFF, 0x1234
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + -6, 0xFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x1234 * 0x8765
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 32 True, set_bit 5 32 False, set_bit (- 5) 32 True, set_bit (- 5) 32 False
    , 1 << 2, -1 << 3, 1 << 16, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 16, -100 >> 16
    , 100 >>> 3, -100 >>> 3, 100 >>> 16, -100 >>> 16] :: uint16 list)
   =
    [ 1, 65535, 1, 65535, 4660
    , 18
    , 126
    , 108
    , 65445
    , 11, 1, 65535, 65525, 0
    , 2, 65534
    , 15, 65521, 20, 39556
    , 1, 21843, 0, 0
    , 2, 2, 65531, 5
    , 21, 65535, 4, 65529
    , 5, 5, 65531, 65531
    , 4, 65528, 0, 1
    , 12, 8179, 0, 0
    , 12, 65523, 0, 65535]) \<and>
  ([ (0x5 :: uint16) = 0x5, (0x5 :: uint16) = 0x6
   , (0x5 :: uint16) < 0x5, (0x5 :: uint16) < 0x6, (-5 :: uint16) < 6, (6 :: uint16) < -5
   , (0x5 :: uint16) \<le> 0x5, (0x5 :: uint16) \<le> 0x4, (-5 :: uint16) \<le> 6, (6 :: uint16) \<le> -5
   , (0x7FFF :: uint16) < 0x8000, (0xFFFF :: uint16) < 0, (0x8000 :: uint16) < 0x7FFF
   , bit (0x7FFF :: uint16) 0, bit (0x7FFF :: uint16) 15, bit (0x8000 :: uint16) 15, bit (0x8000 :: uint16) 16
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint16 0, integer_of_uint16 0x7FFF, integer_of_uint16 0x8000, integer_of_uint16 0xAAAA]
  =
   [0, 0x7FFF, 0x8000, 0xAAAA])"

no_notation sshiftr_uint16 (infixl ">>>" 55)

export_code test_uint16 checking Haskell? Scala
export_code test_uint16 in SML_word

notepad begin
have test_uint16 by code_simp
have test_uint16 by normalization
end

lemma "(x :: uint16) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint16 \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section \<open>Tests for @{typ uint8}\<close>

notation sshiftr_uint8 (infixl ">>>" 55)

definition test_uint8 where
  "test_uint8 \<longleftrightarrow>
  (([ 0x101, -1, -255, 0xFF, 0x12
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + -6, 0xFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x12 * 0x87
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 32 True, set_bit 5 32 False, set_bit (- 5) 32 True, set_bit (- 5) 32 False
    , 1 << 2, -1 << 3, 1 << 8, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 8, -100 >> 8
    , 100 >>> 3, -100 >>> 3, 100 >>> 8, -100 >>> 8] :: uint8 list)
   =
    [ 1, 255, 1, 255, 18
    , 18
    , 126
    , 108
    , 165
    , 11, 1, 255, 245, 0
    , 2, 254
    , 15, 241, 20, 126
    , 1, 83, 0, 0
    , 2, 2, 251, 5
    , 21, 255, 4, 249
    , 5, 5, 251, 251
    , 4, 248, 0, 1
    , 12, 19, 0, 0
    , 12, 243, 0, 255]) \<and>
  ([ (0x5 :: uint8) = 0x5, (0x5 :: uint8) = 0x6
   , (0x5 :: uint8) < 0x5, (0x5 :: uint8) < 0x6, (-5 :: uint8) < 6, (6 :: uint8) < -5
   , (0x5 :: uint8) \<le> 0x5, (0x5 :: uint8) \<le> 0x4, (-5 :: uint8) \<le> 6, (6 :: uint8) \<le> -5
   , (0x7F :: uint8) < 0x80, (0xFF :: uint8) < 0, (0x80 :: uint8) < 0x7F
   , bit (0x7F :: uint8) 0, bit (0x7F :: uint8) 7, bit (0x80 :: uint8) 7, bit (0x80 :: uint8) 8
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint8 0, integer_of_uint8 0x7F, integer_of_uint8 0x80, integer_of_uint8 0xAA]
  =
   [0, 0x7F, 0x80, 0xAA])"

no_notation sshiftr_uint8 (infixl ">>>" 55)

export_code test_uint8 checking SML Haskell? Scala

export_code test_uint8 in SML

notepad begin
have test_uint8 by eval
have test_uint8 by code_simp
have test_uint8 by normalization
end
ML_val \<open>val true = @{code test_uint8}\<close>

definition test_uint8' :: uint8
where "test_uint8' = 0 + 10 - 14 * 3 div 6 mod 3 << 3 >> 2"
ML \<open>val 0wx12 = @{code test_uint8'}\<close>

lemma "x AND y = x OR (y :: uint8)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: uint8) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint8 \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section \<open>Tests for @{typ "uint"}\<close>

notation sshiftr_uint (infixl ">>>" 55)

definition "test_uint \<equiv> let
  test_list1 = (let
      HS = uint_of_int (2 ^ (dflt_size - 1))
    in
      ([ HS + HS + 1, -1, -HS - HS + 5, HS + (HS - 1), 0x12
      , 0x5A AND 0x36
      , 0x5A OR 0x36
      , 0x5A XOR 0x36
      , NOT 0x5A
      , 5 + 6, -5 + 6, -6 + 5, -5 + -6, HS + (HS - 1) + 1
      , 5 - 3, 3 - 5
      , 5 * 3, -5 * 3, -5 * -4, 0x12345678 * 0x87654321]
    @ (if dflt_size > 4 then
      [ 5 div 3, -5 div 3, -5 div -3, 5 div -3
      , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
      , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
      , set_bit 5 dflt_size True, set_bit 5 dflt_size False, set_bit (- 5) dflt_size True, set_bit (- 5) dflt_size False
      , 1 << 2, -1 << 3, push_bit dflt_size 1, 1 << 0
      , 31 >> 3, -1 >> 3, 31 >> dflt_size, -1 >> dflt_size
      , 15 >>> 2, -1 >>> 3, 15 >>> dflt_size, -1 >>> dflt_size]
    else []) :: uint list));

  test_list2 = (let
      S = wivs_shift
    in
      ([ 1, -1, -S + 5, S - 1, 0x12
      , 0x5A AND 0x36
      , 0x5A OR 0x36
      , 0x5A XOR 0x36
      , NOT 0x5A
      , 5 + 6, -5 + 6, -6 + 5, -5 + -6, 0
      , 5 - 3, 3 - 5
      , 5 * 3, -5 * 3, -5 * -4, 0x12345678 * 0x87654321]
    @ (if dflt_size > 4 then
      [ 5 div 3, (S - 5) div 3, (S - 5) div (S - 3), 5 div (S - 3)
      , 5 mod 3, (S - 5) mod 3, (S - 5) mod (S - 3), 5 mod (S - 3)
      , set_bit 5 4 True, -1, set_bit 5 0 False, -7
      , 5, 5, -5, -5
      , 4, -8, 0, 1
      , 3, (S >> 3) - 1, 0, 0
      , 3, (S >> 1) + (S >> 1) - 1, 0, -1]
    else []) :: int list));

  test_list_c1 = (let
      HS = uint_of_int ((2^(dflt_size - 1)))
    in
  [  (0x5 :: uint) = 0x5, (0x5 :: uint) = 0x6
   , (0x5 :: uint) < 0x5, (0x5 :: uint) < 0x6, (-5 :: uint) < 6, (6 :: uint) < -5
   , (0x5 :: uint) \<le> 0x5, (0x5 :: uint) \<le> 0x4, (-5 :: uint) \<le> 6, (6 :: uint) \<le> -5
   , (HS - 1) < HS, (HS + HS - 1) < 0, HS < HS - 1
   , bit (HS - 1) 0, bit (HS - 1 :: uint) (dflt_size - 1), bit (HS :: uint) (dflt_size - 1), bit (HS :: uint) dflt_size
   ]);

  test_list_c2 =
   [ True, False
   , False, dflt_size\<ge>2, dflt_size=3, dflt_size\<noteq>3
   , True, False, dflt_size=3, dflt_size\<noteq>3
   , True, False, False
   , dflt_size\<noteq>1, False, True, False
   ]
in
  test_list1 = map uint_of_int test_list2
\<and> test_list_c1 = test_list_c2"

no_notation sshiftr_uint (infixl ">>>" 55)

export_code test_uint checking SML Haskell? OCaml? Scala

lemma "test_uint"
quickcheck[exhaustive, expect=no_counterexample]
oops \<comment> \<open>FIXME: prove correctness of test by reflective means (not yet supported)\<close>

lemma "x AND y = x OR (y :: uint)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: uint) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section \<open> Tests for @{typ uint64} \<close>

notation sshiftr_uint64 (infixl ">>>" 55)

definition test_uint64 where
  "test_uint64 \<longleftrightarrow>
  (([ 0x10000000000000001, -1, -9223372036854775808, 0xFFFFFFFFFFFFFFFF, 0x1234567890ABCDEF
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + (- 6), 0xFFFFFFFFFFFFFFFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x1234567890ABCDEF * 0xFEDCBA0987654321
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 64 True, set_bit 5 64 False, set_bit (- 5) 64 True, set_bit (- 5) 64 False
    , 1 << 2, -1 << 3, 1 << 64, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 64, -100 >> 64
    , 100 >>> 3, -100 >>> 3, 100 >>> 64, -100 >>> 64] :: uint64 list)
   =
    [ 1, 18446744073709551615, 9223372036854775808, 18446744073709551615, 1311768467294899695
    , 18
    , 126
    , 108
    , 18446744073709551525
    , 11, 1, 18446744073709551615, 18446744073709551605, 0
    , 2, 18446744073709551614
    , 15, 18446744073709551601, 20, 14000077364136384719
    , 1, 6148914691236517203, 0, 0
    , 2, 2, 18446744073709551611, 5
    , 21, 18446744073709551615, 4, 18446744073709551609
    , 5, 5, 18446744073709551611, 18446744073709551611
    , 4, 18446744073709551608, 0, 1
    , 12, 2305843009213693939, 0, 0
    , 12, 18446744073709551603, 0, 18446744073709551615]) \<and>
  ([ (0x5 :: uint64) = 0x5, (0x5 :: uint64) = 0x6
   , (0x5 :: uint64) < 0x5, (0x5 :: uint64) < 0x6, (-5 :: uint64) < 6, (6 :: uint64) < -5
   , (0x5 :: uint64) \<le> 0x5, (0x5 :: uint64) \<le> 0x4, (-5 :: uint64) \<le> 6, (6 :: uint64) \<le> -5
   , (0x7FFFFFFFFFFFFFFF :: uint64) < 0x8000000000000000, (0xFFFFFFFFFFFFFFFF :: uint64) < 0, (0x8000000000000000 :: uint64) < 0x7FFFFFFFFFFFFFFF
   , bit (0x7FFFFFFFFFFFFFFF :: uint64) 0, bit (0x7FFFFFFFFFFFFFFF :: uint64) 63, bit (0x8000000000000000 :: uint64) 63, bit (0x8000000000000000 :: uint64) 64
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint64 0, integer_of_uint64 0x7FFFFFFFFFFFFFFF, integer_of_uint64 0x8000000000000000, integer_of_uint64 0xAAAAAAAAAAAAAAAA]
  =
   [0, 0x7FFFFFFFFFFFFFFF, 0x8000000000000000, 0xAAAAAAAAAAAAAAAA])"

value [nbe] "[0x10000000000000001, -1, -9223372036854775808, 0xFFFFFFFFFFFFFFFF, 0x1234567890ABCDEF
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + (- 6), 0xFFFFFFFFFFFFFFFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x1234567890ABCDEF * 0xFEDCBA0987654321
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 64 True, set_bit 5 64 False, set_bit (- 5) 64 True, set_bit (- 5) 64 False
    , 1 << 2, -1 << 3, 1 << 64, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 64, -100 >> 64
    , 100 >>> 3, -100 >>> 3, 100 >>> 64, -100 >>> 64] :: uint64 list"

no_notation sshiftr_uint64 (infixl ">>>" 55)

export_code test_uint64 checking SML Haskell? OCaml? Scala

notepad begin
have test_uint64 by eval
have test_uint64 by code_simp
have test_uint64 by normalization
end
ML_val \<open>val true = @{code test_uint64}\<close>

definition test_uint64' :: uint64
where "test_uint64' = 0 + 10 - 14 * 3 div 6 mod 3 << 3 >> 2"

section \<open>Tests for casts\<close>

definition test_casts :: bool
where "test_casts \<longleftrightarrow>
  map uint8_of_uint32 [10, 0, 0xFE, 0xFFFFFFFF] = [10, 0, 0xFE, 0xFF] \<and>
  map uint8_of_uint64 [10, 0, 0xFE, 0xFFFFFFFFFFFFFFFF] = [10, 0, 0xFE, 0xFF] \<and>
  map uint32_of_uint8 [10, 0, 0xFF] = [10, 0, 0xFF] \<and>
  map uint64_of_uint8 [10, 0, 0xFF] = [10, 0, 0xFF]"

definition test_casts' :: bool
where "test_casts' \<longleftrightarrow>
  map uint8_of_uint16 [10, 0, 0xFE, 0xFFFF] = [10, 0, 0xFE, 0xFF] \<and>
  map uint16_of_uint8 [10, 0, 0xFF] = [10, 0, 0xFF] \<and>
  map uint16_of_uint32 [10, 0, 0xFFFE, 0xFFFFFFFF] = [10, 0, 0xFFFE, 0xFFFF] \<and>
  map uint16_of_uint64 [10, 0, 0xFFFE, 0xFFFFFFFFFFFFFFFF] = [10, 0, 0xFFFE, 0xFFFF] \<and>
  map uint32_of_uint16 [10, 0, 0xFFFF] = [10, 0, 0xFFFF] \<and>
  map uint64_of_uint16 [10, 0, 0xFFFF] = [10, 0, 0xFFFF]"

definition test_casts'' :: bool
where "test_casts'' \<longleftrightarrow>
  map uint32_of_uint64 [10, 0, 0xFFFFFFFE, 0xFFFFFFFFFFFFFFFF] = [10, 0, 0xFFFFFFFE, 0xFFFFFFFF] \<and>
  map uint64_of_uint32 [10, 0, 0xFFFFFFFF] = [10, 0, 0xFFFFFFFF]"

export_code test_casts test_casts'' checking SML Haskell? Scala
export_code test_casts'' checking OCaml?
export_code test_casts' checking Haskell? Scala

notepad begin
  have test_casts by eval
  have test_casts by normalization
  have test_casts by code_simp
  have test_casts' by normalization
  have test_casts' by code_simp
  have test_casts'' by eval
  have test_casts'' by normalization
  have test_casts'' by code_simp
end
ML \<open>
  val true = @{code test_casts}
  val true = @{code test_casts''}
\<close>

definition test_casts_uint :: bool where
  "test_casts_uint \<longleftrightarrow>
  map uint_of_uint32 ([0, 10] @ (if dflt_size < 32 then [push_bit (dflt_size - 1) 1, 0xFFFFFFFF] else [0xFFFFFFFF])) =
  [0, 10] @ (if dflt_size < 32 then [push_bit (dflt_size - 1) 1, (push_bit dflt_size 1) - 1] else [0xFFFFFFFF]) \<and>
  map uint32_of_uint [0, 10, if dflt_size < 32 then push_bit (dflt_size - 1) 1 else 0xFFFFFFFF] =
  [0, 10, if dflt_size < 32 then push_bit (dflt_size - 1) 1 else 0xFFFFFFFF] \<and>
  map uint_of_uint64 [0, 10, push_bit (dflt_size - 1) 1, 0xFFFFFFFFFFFFFFFF] =
  [0, 10, push_bit (dflt_size - 1) 1, (push_bit dflt_size 1) - 1] \<and>
  map uint64_of_uint [0, 10, push_bit (dflt_size - 1) 1] =
  [0, 10, push_bit (dflt_size - 1) 1]"

definition test_casts_uint' :: bool where
  "test_casts_uint' \<longleftrightarrow>
  map uint_of_uint16 [0, 10, 0xFFFF] = [0, 10, 0xFFFF] \<and>
  map uint16_of_uint [0, 10, 0xFFFF] = [0, 10, 0xFFFF]"

definition test_casts_uint'' :: bool where
  "test_casts_uint'' \<longleftrightarrow>
  map uint_of_uint8 [0, 10, 0xFF] = [0, 10, 0xFF] \<and>
  map uint8_of_uint [0, 10, 0xFF] = [0, 10, 0xFF]"

end


theory Slides_demo imports
  "../Tests"
  "~~/src/HOL/Library/LaTeXsugar"
begin

text {*
@{thm [display] test_gr4_def}
@{lemma "norms_of_grammar test_gr4 =
   [(1, 1, 0, []), (2, 2, 0, [1]), (4, 4, 0, [1, 1, 1]), (3, 3, 0, [2]), (5, 4, 23, [3])]" by eval}
*}

end