(*  Title:      HOL/UNITY/Comp/AllocBase.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section\<open>Common Declarations for Chandy and Charpentier's Allocator\<close>

theory AllocBase imports "../UNITY_Main" "~~/src/HOL/Library/Multiset_Order" begin

consts Nclients :: nat  (*Number of clients*)

axiomatization NbT :: nat  (*Number of tokens in system*)
  where NbT_pos: "0 < NbT"

abbreviation (input) tokens :: "nat list \<Rightarrow> nat"
where
  "tokens \<equiv> sum_list"

abbreviation (input)
  "bag_of \<equiv> mset"

lemma sum_fun_mono:
  fixes f :: "nat \<Rightarrow> nat"
  shows "(\<And>i. i < n \<Longrightarrow> f i \<le> g i) \<Longrightarrow> sum f {..<n} \<le> sum g {..<n}"
  by (induct n) (auto simp add: lessThan_Suc add_le_mono)

lemma tokens_mono_prefix: "xs \<le> ys \<Longrightarrow> tokens xs \<le> tokens ys"
  by (induct ys arbitrary: xs) (auto simp add: prefix_Cons)

lemma mono_tokens: "mono tokens"
  using tokens_mono_prefix by (rule monoI)

(** bag_of **)

lemma bag_of_append [simp]: "bag_of (l@l') = bag_of l + bag_of l'"
  by (fact mset_append)

lemma mono_bag_of: "mono (bag_of :: 'a list => ('a::order) multiset)"
apply (rule monoI)
apply (unfold prefix_def)
apply (erule genPrefix.induct, simp_all add: add_right_mono)
apply (erule order_trans)
apply simp
done

(** sum **)

declare sum.cong [cong]

lemma bag_of_sublist_lemma:
     "(\<Sum>i\<in> A Int lessThan k. {#if i<k then f i else g i#}) =
      (\<Sum>i\<in> A Int lessThan k. {#f i#})"
by (rule sum.cong, auto)

lemma bag_of_sublist:
     "bag_of (sublist l A) =
      (\<Sum>i\<in> A Int lessThan (length l). {# l!i #})"
apply (rule_tac xs = l in rev_induct, simp)
apply (simp add: sublist_append Int_insert_right lessThan_Suc nth_append
                 bag_of_sublist_lemma ac_simps)
done

lemma bag_of_sublist_Un_Int:
     "bag_of (sublist l (A Un B)) + bag_of (sublist l (A Int B)) =
      bag_of (sublist l A) + bag_of (sublist l B)"
apply (subgoal_tac "A Int B Int {..<length l} =
                    (A Int {..<length l}) Int (B Int {..<length l}) ")
apply (simp add: bag_of_sublist Int_Un_distrib2 sum.union_inter, blast)
done

lemma bag_of_sublist_Un_disjoint:
     "A Int B = {}
      ==> bag_of (sublist l (A Un B)) =
          bag_of (sublist l A) + bag_of (sublist l B)"
by (simp add: bag_of_sublist_Un_Int [symmetric])

lemma bag_of_sublist_UN_disjoint [rule_format]:
     "[| finite I; ALL i:I. ALL j:I. i~=j --> A i Int A j = {} |]
      ==> bag_of (sublist l (UNION I A)) =
          (\<Sum>i\<in>I. bag_of (sublist l (A i)))"
apply (auto simp add: bag_of_sublist)
unfolding UN_simps [symmetric]
apply (subst sum.UNION_disjoint)
apply auto
done

end


theory Termination
  imports Multisubst
begin

abbreviation terminatesd :: "dexpr \<Rightarrow> bool" where
  "terminatesd e \<equiv> (\<exists>e'. vald e' \<and> iter (\<leadsto>\<^sub>d) e e')"

primrec stable :: "ty \<Rightarrow> dexpr \<Rightarrow> bool" where
  "stable (TyVar x) e = False"
| "stable Base e = (terminatesd e \<and> [] \<turnstile>\<^sub>d e : Base)"
| "stable (Arrow t\<^sub>1 t\<^sub>2) e = (terminatesd e \<and> ([] \<turnstile>\<^sub>d e : Arrow t\<^sub>1 t\<^sub>2) \<and>
    (\<forall>e'. stable t\<^sub>1 e' \<longrightarrow> vald e' \<longrightarrow> stable t\<^sub>2 (DApp e e')))"

lemma [simp]: "stable t e \<Longrightarrow> terminatesd e"
  by (induction t) simp_all

lemma [simp]: "terminatesd (DConst k)"
proof
  show "vald (DConst k) \<and> iter (\<leadsto>\<^sub>d) (DConst k) (DConst k)" by simp
qed

lemma [simp]: "terminatesd (DLam t e)"
proof
  show "vald (DLam t e) \<and> iter (\<leadsto>\<^sub>d) (DLam t e) (DLam t e)" by simp
qed

lemma [simp]: "stable t e \<Longrightarrow> stable t (multisubst es e)"
proof (induction es)
  case (Cons e' es)
  hence "[] \<turnstile>\<^sub>d e : t" by simp
  hence "substd 0 e' e = e" by simp
  with Cons show ?case by simp
qed simp_all

lemma [simp]: "subst_pairs \<Gamma> es \<Longrightarrow> list_all2 stable \<Gamma> es \<Longrightarrow> lookup \<Gamma> x = Some t \<Longrightarrow>
  stable t (multisubst es (DVar x))"
proof (induction \<Gamma> es arbitrary: x rule: subst_pairs.induct)
  case (subp_cons t' e \<Gamma> ves)
  thus ?case by (induction x) simp_all
qed simp_all

lemma [simp]: "e \<leadsto>\<^sub>d e' \<Longrightarrow> terminatesd e = terminatesd e'"
proof
  assume "terminatesd e"
  then obtain v where V: "vald v \<and> iter (\<leadsto>\<^sub>d) e v" by fastforce
  moreover assume "e \<leadsto>\<^sub>d e'"
  ultimately have "vald v \<and> iter (\<leadsto>\<^sub>d) e' v" by (metis evald_backwards)
  thus "terminatesd e'" by fastforce
next
  assume "terminatesd e'"
  then obtain v where V: "vald v \<and> iter (\<leadsto>\<^sub>d) e' v" by fastforce
  moreover assume "e \<leadsto>\<^sub>d e'"
  ultimately have "vald v \<and> iter (\<leadsto>\<^sub>d) e v" by (metis iter_step)
  thus "terminatesd e" by fastforce
qed

lemma stable_evald: "e \<leadsto>\<^sub>d e' \<Longrightarrow> stable t e \<Longrightarrow> stable t e'"
proof (induction t arbitrary: e e')
  case (Arrow t\<^sub>1 t\<^sub>2)
  moreover have "\<And>e\<^sub>2. stable t\<^sub>1 e\<^sub>2 \<Longrightarrow> vald e\<^sub>2 \<Longrightarrow> stable t\<^sub>2 (DApp e' e\<^sub>2)"
  proof -
    fix e\<^sub>2
    assume "stable t\<^sub>1 e\<^sub>2" and "vald e\<^sub>2"
    with Arrow have X: "stable t\<^sub>2 (DApp e e\<^sub>2)" by simp
    from Arrow have "DApp e e\<^sub>2 \<leadsto>\<^sub>d DApp e' e\<^sub>2" by simp
    with Arrow(2) X show "stable t\<^sub>2 (DApp e' e\<^sub>2)" by simp
  qed
  ultimately show ?case by simp
qed simp_all

lemma stable_persists: "iter (\<leadsto>\<^sub>d) e e' \<Longrightarrow> stable t e \<Longrightarrow> stable t e'"
  by (induction e e' rule: iter.induct) (simp_all add: stable_evald)

lemma stable_evald_back: "[] \<turnstile>\<^sub>d e : t \<Longrightarrow> e \<leadsto>\<^sub>d e' \<Longrightarrow> stable t e' \<Longrightarrow> stable t e"
proof (induction t arbitrary: e e')
  case Base
  from Base(3) have "terminatesd e'" by simp
  with Base(2) have "terminatesd e" by simp
  with Base(1) show ?case by simp
next
  case (Arrow t\<^sub>1 t\<^sub>2)
  from Arrow(5) have "terminatesd e'" by simp
  with Arrow(4) have X: "terminatesd e" by fastforce
  have "\<And>e\<^sub>2. stable t\<^sub>1 e\<^sub>2 \<Longrightarrow> vald e\<^sub>2 \<Longrightarrow> stable t\<^sub>2 (DApp e e\<^sub>2)"
  proof -
    fix e\<^sub>2
    assume S: "stable t\<^sub>1 e\<^sub>2" and "vald e\<^sub>2"
    with Arrow(5) have Y: "stable t\<^sub>2 (DApp e' e\<^sub>2)" by simp
    from Arrow(3) S have Z: "[] \<turnstile>\<^sub>d DApp e e\<^sub>2 : t\<^sub>2" by simp
    from Arrow(4) have "DApp e e\<^sub>2 \<leadsto>\<^sub>d DApp e' e\<^sub>2" by simp
    with Arrow(2) Y Z show "stable t\<^sub>2 (DApp e e\<^sub>2)" by blast
  qed
  with Arrow(3) X show ?case by simp
qed simp_all

lemma stable_persists_back: "iter (\<leadsto>\<^sub>d) e e' \<Longrightarrow> [] \<turnstile>\<^sub>d e : t \<Longrightarrow> stable t e' \<Longrightarrow> stable t e"
proof (induction e e' rule: iter.induct)
  case (iter_step e e' e'')
  thus ?case using stable_evald_back by fastforce
qed simp_all

lemma tc_stable [simp]: "\<Gamma> \<turnstile>\<^sub>d e : t \<Longrightarrow> subst_pairs \<Gamma> es \<Longrightarrow> list_all2 stable \<Gamma> es \<Longrightarrow>
  stable t (multisubst es e)"
proof (induction \<Gamma> e t arbitrary: es rule: typecheckd.induct)
  case (tcd_lam t\<^sub>1 \<Gamma> e t\<^sub>2)
  then obtain e' where E: "multisubst es (DLam t\<^sub>1 e) = DLam t\<^sub>1 e' \<and> ([t\<^sub>1] \<turnstile>\<^sub>d e' : t\<^sub>2) \<and>
    (\<forall>e\<^sub>2. ([] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1) \<longrightarrow> multisubst (insert_at 0 e\<^sub>2 es) e = substd 0 e\<^sub>2 e')" by fastforce
  moreover have "\<And>e\<^sub>2. stable t\<^sub>1 e\<^sub>2 \<Longrightarrow> vald e\<^sub>2 \<Longrightarrow> stable t\<^sub>2 (DApp (DLam t\<^sub>1 e') e\<^sub>2)"
  proof -
    fix e\<^sub>2
    assume S: "stable t\<^sub>1 e\<^sub>2" and V: "vald e\<^sub>2"
    hence E2: "[] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1" by simp
    hence T: "\<exists>t. [] \<turnstile>\<^sub>d e\<^sub>2 : t" by fastforce
    from tcd_lam S have "list_all2 stable (insert_at 0 t\<^sub>1 \<Gamma>) (insert_at 0 e\<^sub>2 es)" by simp
    with tcd_lam have "subst_pairs (insert_at 0 t\<^sub>1 \<Gamma>) (insert_at 0 e\<^sub>2 es) \<Longrightarrow>
      stable t\<^sub>2 (multisubst (insert_at 0 e\<^sub>2 es) e)" by blast
    with tcd_lam S V T E have "stable t\<^sub>2 (substd 0 e\<^sub>2 e')" by simp
    moreover with V have "DApp (DLam t\<^sub>1 e') e\<^sub>2 \<leadsto>\<^sub>d substd 0 e\<^sub>2 e'" by simp
    moreover from E have "[] \<turnstile>\<^sub>d DLam t\<^sub>1 e' : Arrow t\<^sub>1 t\<^sub>2" by simp
    moreover with E2 have "[] \<turnstile>\<^sub>d DApp (DLam t\<^sub>1 e') e\<^sub>2 : t\<^sub>2" by simp
    ultimately show "stable t\<^sub>2 (DApp (DLam t\<^sub>1 e') e\<^sub>2)" by (metis stable_evald_back)
  qed
  ultimately show ?case by simp
next
  case (tcd_app \<Gamma> e\<^sub>1 t\<^sub>1 t\<^sub>2 e\<^sub>2)
  hence "terminatesd (multisubst es e\<^sub>2)" by fastforce
  then obtain v\<^sub>2 where V2: "vald v\<^sub>2 \<and> iter (\<leadsto>\<^sub>d) (multisubst es e\<^sub>2) v\<^sub>2" by fastforce
  with tcd_app have V2S: "stable t\<^sub>1 v\<^sub>2" by (metis stable_persists)
  from tcd_app have "terminatesd (multisubst es e\<^sub>1)" by fastforce
  then obtain v\<^sub>1 where V1: "vald v\<^sub>1 \<and> iter (\<leadsto>\<^sub>d) (multisubst es e\<^sub>1) v\<^sub>1" by fastforce
  with tcd_app have SV: "stable (Arrow t\<^sub>1 t\<^sub>2) v\<^sub>1" by (metis stable_persists)
  with V2S V2 have "stable t\<^sub>2 (DApp v\<^sub>1 v\<^sub>2)" by simp
  moreover from V1 V2 have "iter (\<leadsto>\<^sub>d) (DApp v\<^sub>1 (multisubst es e\<^sub>2)) (DApp v\<^sub>1 v\<^sub>2)" by simp
  moreover from SV have "[] \<turnstile>\<^sub>d v\<^sub>1 : Arrow t\<^sub>1 t\<^sub>2" by simp
  moreover with tcd_app have "[] \<turnstile>\<^sub>d DApp v\<^sub>1 (multisubst es e\<^sub>2) : t\<^sub>2" by simp
  ultimately have X: "stable t\<^sub>2 (DApp v\<^sub>1 (multisubst es e\<^sub>2))" by (metis stable_persists_back)
  from V1 have Y: "iter (\<leadsto>\<^sub>d) (DApp (multisubst es e\<^sub>1) (multisubst es e\<^sub>2))
    (DApp v\<^sub>1 (multisubst es e\<^sub>2))" by simp
  from tcd_app have "[] \<turnstile>\<^sub>d multisubst es e\<^sub>1 : Arrow t\<^sub>1 t\<^sub>2" by simp
  moreover from tcd_app have "[] \<turnstile>\<^sub>d multisubst es e\<^sub>2 : t\<^sub>1" by simp
  ultimately have "[] \<turnstile>\<^sub>d DApp (multisubst es e\<^sub>1) (multisubst es e\<^sub>2) : t\<^sub>2" by simp
  with X Y have "stable t\<^sub>2 (DApp (multisubst es e\<^sub>1) (multisubst es e\<^sub>2))"
    by (metis stable_persists_back)
  thus ?case by simp
qed simp_all

theorem tc_terminationd [simp]: "[] \<turnstile>\<^sub>d e : t \<Longrightarrow> terminatesd e"
proof -
  assume "[] \<turnstile>\<^sub>d e : t"
  moreover have "list_all2 stable [] []" by simp
  ultimately have "stable t (multisubst [] e)" by (metis subp_nil tc_stable)
  thus ?thesis by simp
qed

end


(*  Title:      HOL/Auth/Guard/List_Msg.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>Lists of Messages and Lists of Agents\<close>

theory List_Msg imports Extensions begin

subsection\<open>Implementation of Lists by Messages\<close>

subsubsection\<open>nil is represented by any message which is not a pair\<close>

abbreviation (input)
  cons :: "msg => msg => msg" where
  "cons x l == \<lbrace>x,l\<rbrace>"

subsubsection\<open>induction principle\<close>

lemma lmsg_induct: "[| !!x. not_MPair x ==> P x; !!x l. P l ==> P (cons x l) |]
==> P l"
by (induct l) auto

subsubsection\<open>head\<close>

primrec head :: "msg => msg" where
"head (cons x l) = x"

subsubsection\<open>tail\<close>

primrec tail :: "msg => msg" where
"tail (cons x l) = l"

subsubsection\<open>length\<close>

fun len :: "msg => nat" where
"len (cons x l) = Suc (len l)" |
"len other = 0"

lemma len_not_empty: "n < len l \<Longrightarrow> \<exists>x l'. l = cons x l'"
by (cases l) auto

subsubsection\<open>membership\<close>

fun isin :: "msg * msg => bool" where
"isin (x, cons y l) = (x=y | isin (x,l))" |
"isin (x, other) = False"

subsubsection\<open>delete an element\<close>

fun del :: "msg * msg => msg" where
"del (x, cons y l) = (if x=y then l else cons y (del (x,l)))" |
"del (x, other) = other"

lemma notin_del [simp]: "~ isin (x,l) ==> del (x,l) = l"
by (induct l) auto

lemma isin_del [rule_format]: "isin (y, del (x,l)) --> isin (y,l)"
by (induct l) auto

subsubsection\<open>concatenation\<close>

fun app :: "msg * msg => msg" where
"app (cons x l, l') = cons x (app (l,l'))" |
"app (other, l') = l'"

lemma isin_app [iff]: "isin (x, app(l,l')) = (isin (x,l) | isin (x,l'))"
by (induct l) auto

subsubsection\<open>replacement\<close>

fun repl :: "msg * nat * msg => msg" where
"repl (cons x l, Suc i, x') = cons x (repl (l,i,x'))" |
"repl (cons x l, 0, x') = cons x' l" |
"repl (other, i, M') = other"

subsubsection\<open>ith element\<close>

fun ith :: "msg * nat => msg" where
"ith (cons x l, Suc i) = ith (l,i)" |
"ith (cons x l, 0) = x" |
"ith (other, i) = other"

lemma ith_head: "0 < len l ==> ith (l,0) = head l"
by (cases l) auto

subsubsection\<open>insertion\<close>

fun ins :: "msg * nat * msg => msg" where
"ins (cons x l, Suc i, y) = cons x (ins (l,i,y))" |
"ins (l, 0, y) = cons y l"

lemma ins_head [simp]: "ins (l,0,y) = cons y l"
by (cases l) auto

subsubsection\<open>truncation\<close>

fun trunc :: "msg * nat => msg" where
"trunc (l,0) = l" |
"trunc (cons x l, Suc i) = trunc (l,i)"

lemma trunc_zero [simp]: "trunc (l,0) = l"
by (cases l) auto

subsection\<open>Agent Lists\<close>

subsubsection\<open>set of well-formed agent-list messages\<close>

abbreviation
  nil :: msg where
  "nil == Number 0"

inductive_set agl :: "msg set"
where
  Nil[intro]: "nil \<in> agl"
| Cons[intro]: "[| A \<in> agent; I \<in> agl |] ==> cons (Agent A) I \<in> agl"

subsubsection\<open>basic facts about agent lists\<close>

lemma del_in_agl [intro]: "I \<in> agl \<Longrightarrow> del (a,I) \<in> agl"
by (erule agl.induct, auto)

lemma app_in_agl [intro]: "[| I \<in> agl; J \<in> agl |] ==> app (I,J) \<in> agl"
by (erule agl.induct, auto)

lemma no_Key_in_agl: "I \<in> agl \<Longrightarrow> Key K \<notin> parts {I}"
by (erule agl.induct, auto)

lemma no_Nonce_in_agl: "I \<in> agl \<Longrightarrow> Nonce n \<notin> parts {I}"
by (erule agl.induct, auto)

lemma no_Key_in_appdel: "[| I \<in> agl; J \<in> agl |] ==>
Key K \<notin> parts {app (J, del (Agent B, I))}"
by (rule no_Key_in_agl, auto)

lemma no_Nonce_in_appdel: "[| I \<in> agl; J \<in> agl |] ==>
Nonce n \<notin> parts {app (J, del (Agent B, I))}"
by (rule no_Nonce_in_agl, auto)

lemma no_Crypt_in_agl: "I \<in> agl \<Longrightarrow> Crypt K X \<notin> parts {I}"
by (erule agl.induct, auto)

lemma no_Crypt_in_appdel: "[| I \<in> agl; J \<in> agl |] ==>
Crypt K X \<notin> parts {app (J, del (Agent B,I))}"
by (rule no_Crypt_in_agl, auto)

end


theory Float_Tests_Fixed_Reduced
imports Main
        IEEE_Floating_Point.IEEE
        IEEE_Floating_Point.IEEE_Properties
begin

(*half precision*)
type_synonym floatT = "(5,10) float"

(*single precision*)
(*type_synonym floatT = "(8,23) float"*)

(*double precision*)
(*type_synonym floatT = "(11,52) float"*)

(*quadruple precision*)
(*type_synonym floatT = "(15,112) float"*)

(* SPECIAL INPUTS *)
(*from the IEEE 754-2019 standard*)

lemma rem_fin_inf: "is_finite x \<Longrightarrow> float_rem x \<infinity> = x"
  for x :: floatT
  oops

lemma sqrt_mzero: "float_sqrt (minus_zero::floatT) = minus_zero"
  oops

lemma compare_cases:
  "flt x y \<or> feq x y \<or> fgt x y \<longleftrightarrow>
    \<not>(is_nan x \<or> is_nan y)"
  for x y :: floatT
  oops

lemma compare_unique1: "\<not> (flt x y \<and> feq x y)"
  for x y :: floatT
  oops

lemma compare_unique2: "\<not> (flt x y \<and> fgt x y)"
  for x y :: floatT
  oops

lemma compare_unique3: "\<not> (flt x y \<and> (is_nan x \<or> is_nan y))"
  for x y :: floatT
  oops

lemma compare_unique4: "\<not> (feq x y \<and> fgt x y)"
  for x y :: floatT
  oops

lemma compare_unique5: "\<not> (feq x y \<and> (is_nan x \<or> is_nan y))"
  for x y :: floatT
  oops

lemma compare_unique6: "\<not> (fgt x y \<and> (is_nan x \<or> is_nan y))"
  for x y :: floatT
  oops

lemma zero_eq_mzero: "(0::floatT) \<doteq> minus_zero"
  oops

lemma float_id: "\<not> is_nan x \<Longrightarrow> x \<doteq> x"
  for x :: floatT
  oops

lemma fadd_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fadd rm x y)"
  for x y ::floatT
  oops

lemma fadd_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fadd rm y x)"
  for x y ::floatT
  oops

lemma fsub_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fsub rm x y)"
  for x y :: floatT
  oops

lemma fsub_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fsub rm y x)"
  for x y :: floatT
  oops

lemma fmul_inf1:
  "\<not> is_nan x \<Longrightarrow> \<not> is_zero x \<Longrightarrow>
    is_infinity y \<Longrightarrow> is_infinity (fmul rm x y)"
  for x y :: floatT
  oops

lemma fmul_inf2:
  "\<not> is_nan x \<Longrightarrow> \<not> is_zero x \<Longrightarrow>
    is_infinity y \<Longrightarrow> is_infinity (fmul rm y x)"
  for x y :: floatT
  oops

lemma fdiv_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_zero (fdiv rm x y)"
  for x y :: floatT
  oops

lemma fdiv_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fdiv rm y x)"
  for x y :: floatT
  oops

lemma fsqrt_inf: "fsqrt rm (plus_infinity::floatT) = plus_infinity"
  oops

lemma abs_nan: "is_nan x \<Longrightarrow> is_nan \<bar>x\<bar>"
  for x :: floatT
  oops

lemma neg_nan: "is_nan x \<Longrightarrow> is_nan (uminus x)"
  for x :: floatT
  oops

lemma fadd_nan1: "is_nan x \<Longrightarrow> is_nan (fadd rm x y)"
  for x y :: floatT
  oops

lemma fadd_nan2: "is_nan y \<Longrightarrow> is_nan (fadd rm x y)"
  for x y :: floatT
  oops

lemma fsub_nan1: "is_nan x \<Longrightarrow> is_nan (fsub rm x y)"
  for x y :: floatT
  oops

lemma fsub_nan2: "is_nan y \<Longrightarrow> is_nan (fsub rm x y)"
  for x y :: floatT
  oops

lemma fmul_nan1: "is_nan x \<Longrightarrow> is_nan (fmul rm x y)"
  for x y :: floatT
  oops

lemma fmul_nan2: "is_nan y \<Longrightarrow> is_nan (fmul rm x y)"
  for x y :: floatT
  oops

lemma fdiv_nan1: "is_nan x \<Longrightarrow> is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma fdiv_nan2: "is_nan y \<Longrightarrow> is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma fma_nan1: "is_nan x \<Longrightarrow> is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma fma_nan2: "is_nan y \<Longrightarrow> is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma fma_nan3: "is_nan z \<Longrightarrow> is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma frem_nan1: "is_nan x \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma frem_nan2: "is_nan y \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma fsqrt_nan: "is_nan x \<Longrightarrow> is_nan (fsqrt rm x)"
  for x :: floatT
  oops

lemma fintrnd_nan: "is_nan x \<Longrightarrow> is_nan (fintrnd rm x)"
  for x :: floatT
 oops

lemma zero_plus_zero: "fadd rm (0::floatT) 0 = 0"
  oops

lemma mzero_plus_mzero: "fadd rm (minus_zero::floatT) minus_zero = minus_zero"
  oops

lemma fmul_inf_zero1:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul rm x y)"
  for x y :: floatT
  oops

lemma fmul_inf_zero2:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul rm y x)"
  for x y :: floatT
  oops

lemma fma_inf_zero1:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma fma_inf_zero2:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul_add rm y x z)"
  for x y z :: floatT
  oops

lemma inf_plus_minf1: "is_nan (fadd rm (plus_infinity::floatT) minus_infinity)"
  oops

lemma inf_plus_minf2: "is_nan (fadd rm (minus_infinity::floatT) plus_infinity)"
  oops

lemma inf_minus_inf1: "is_nan (fsub rm (plus_infinity::floatT) plus_infinity)"
  oops

lemma inf_minus_inf2: "is_nan (fsub rm (minus_infinity::floatT) minus_infinity)"
  oops

lemma zero_div_zero:
  "is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma inf_div_inf:
  "is_infinity x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma frem_inf: "is_infinity x \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma frem_zero: "is_zero y \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma fsqrt_neg: "x < 0 \<Longrightarrow> is_nan (fsqrt rm x)"
  for x :: floatT
  oops

lemma div_zero:
  "\<not> is_nan x \<Longrightarrow> is_zero y \<Longrightarrow>
    \<not> is_zero x \<Longrightarrow> is_infinity (x div y)"
  for x y :: floatT
  oops

(* ROUNDING *)
(*from "Handbook of Floating-Point Arithmetic" by J-M Muller*)

lemma leq_round:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    x \<le> y \<Longrightarrow>
      (round rm (valof x) :: floatT) \<le> round rm (valof y)"
  for x y :: floatT
  oops

lemma round_id: "is_finite x \<Longrightarrow> feq (round rm (valof x)) x"
  for x :: floatT
  oops

lemma round_sym_nearest_even:
  "(round To_nearest (-x) :: floatT) = - (round To_nearest x)"
  oops

lemma round_sym_nearest_away:
  "(round To_nearest_away (-x) :: floatT) = - (round To_nearest_away x)"
  oops

lemma round_sym_zero:
  "(round float_To_zero (-x) :: floatT) = - (round float_To_zero x)"
  oops

lemma round_sym_updown:
  "(round To_pinfinity (-x) :: floatT) = - (round To_ninfinity x)"
  oops

lemma round_add_eq_sub:
  "\<not> is_nan x \<Longrightarrow> \<not> is_nan y \<Longrightarrow>
    feq (fadd To_pinfinity x y) (- (fsub To_ninfinity (-x) y))"
  for x y :: floatT
  oops

lemma round_mul_eq:
  "\<not> is_nan x \<Longrightarrow> \<not> is_nan y \<Longrightarrow>
    feq (fmul To_ninfinity x y) (- (fmul To_pinfinity (-x) y))"
  for x y :: floatT
  oops

lemma round_zero: "ROUNDFLOAT 0 = (0::floatT)"
  oops

lemma sterbenz:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    (valof y)/2 \<le> valof x \<and> valof x \<le> 2*(valof y) \<Longrightarrow>
      valof x - valof y = valof (fsub rm x y)"
  for x y :: floatT
  oops

lemma hauser:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_denormal (x+y) \<Longrightarrow> valof (x+y) = valof x + valof y"
  for x y :: floatT
  oops

(* VARIOUS *)

lemma triple_zero: "is_zero (Abs_float (s, 0 , 0) :: floatT)"
  oops

lemma some_nan_neq: "\<not> some_nan \<doteq> x"
  for x :: floatT
  oops

lemma float_mul_comm_eq:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow> x * y = y * x"
  for x y :: floatT
  oops

lemma less_greater_equal:
  "fle x y \<Longrightarrow> fge x y \<Longrightarrow> feq x y"
  for x y :: floatT
  oops

end


theory ContextEvaluate
imports "../Typecheck"
begin

(*

inductive evaluate :: "expr \<Rightarrow> expr \<Rightarrow> bool" (infix "\<leadsto>" 60) where
  ev_app1 [simp]: "e\<^sub>1 \<leadsto> e\<^sub>1' \<Longrightarrow> App e\<^sub>1 e\<^sub>2 \<leadsto> App e\<^sub>1' e\<^sub>2"
| ev_app2 [simp]: "App (Abs t e\<^sub>1) e\<^sub>2 \<leadsto> Let e\<^sub>2 e\<^sub>1"
| ev_app_let [simp]: "is_value e\<^sub>1\<^sub>2 \<Longrightarrow> App (Let e\<^sub>1\<^sub>1 e\<^sub>1\<^sub>2) e\<^sub>2 \<leadsto> Let e\<^sub>1\<^sub>1 (App e\<^sub>1\<^sub>2 (incr\<^sub>e\<^sub>e 0 e\<^sub>2))"
| ev_let1 [simp]: "e\<^sub>2 \<leadsto> e\<^sub>2' \<Longrightarrow> Let e\<^sub>1 e\<^sub>2 \<leadsto> Let e\<^sub>1 e\<^sub>2'"
| ev_let2 [simp]: "e\<^sub>1 \<leadsto> e\<^sub>1' \<Longrightarrow> head_var e\<^sub>2 = Some 0 \<Longrightarrow> Let e\<^sub>1 e\<^sub>2 \<leadsto> Let e\<^sub>1' e\<^sub>2"
| ev_let3 [simp]: "is_value e\<^sub>1 \<Longrightarrow> head_var e\<^sub>2 = Some 0 \<Longrightarrow>
    Let e\<^sub>1 e\<^sub>2 \<leadsto> Let e\<^sub>1 (subst\<^sub>e\<^sub>e 0 (incr\<^sub>e\<^sub>e 0 e\<^sub>1) e\<^sub>2)"
| ev_proj1 [simp]: "e \<leadsto> e' \<Longrightarrow> Proj e l \<leadsto> Proj e' l"
| ev_proj2 [simp]: "lookup fs l = Some x \<Longrightarrow> Proj (Rec fs) l \<leadsto> Var x"
| ev_proj_let [simp]: "is_value e\<^sub>2 \<Longrightarrow> Proj (Let e\<^sub>1 e\<^sub>2) l \<leadsto> Let e\<^sub>1 (Proj e\<^sub>2 l)"
| ev_case1 [simp]: "e \<leadsto> e' \<Longrightarrow> Case e t cs \<leadsto> Case e' t cs"
| ev_case2 [simp]: "lookup cs l = Some e \<Longrightarrow> Case (Inj l ts x) t cs \<leadsto> Let (Var x) e"
| ev_case_let [simp]: "is_value e\<^sub>2 \<Longrightarrow>
    Case (Let e\<^sub>1 e\<^sub>2) t cs \<leadsto> Let e\<^sub>1 (Case e\<^sub>2 t (map (incr\<^sub>e\<^sub>e (Suc 0)) cs))"
| ev_unfold1 [simp]: "e \<leadsto> e' \<Longrightarrow> Unfold t e \<leadsto> Unfold t e'"
| ev_unfold2 [simp]: "Unfold t (Fold t e) \<leadsto> Var e"
| ev_unfold_let [simp]: "is_value e\<^sub>2 \<Longrightarrow> Unfold t (Let e\<^sub>1 e\<^sub>2) \<leadsto> Let e\<^sub>1 (Unfold t e\<^sub>2)"
| ev_tyapp1 [simp]: "e \<leadsto> e' \<Longrightarrow> TyApp e t \<leadsto> TyApp e' t"
| ev_tyapp2 [simp]: "TyApp (TyAbs k e) t \<leadsto> subst\<^sub>t\<^sub>e 0 t e"
| ev_tyapp_let [simp]: "is_value e\<^sub>2 \<Longrightarrow> TyApp (Let e\<^sub>1 e\<^sub>2) t \<leadsto> Let e\<^sub>1 (TyApp e\<^sub>2 t)"
| ev_tylet [simp]: "TyLet t e \<leadsto> subst\<^sub>t\<^sub>e 0 t e"

lemma progress': "\<Delta>,\<Gamma> \<turnstile> e : t \<Longrightarrow>
  is_value e \<or> (\<exists>e'. e \<leadsto> e') \<or> (\<exists>x < length \<Gamma>. head_var e = Some x)"
    and "\<Delta>,\<Gamma> \<turnstile>\<^sub>c cs : ts \<rightarrow> t \<Longrightarrow> l < length ts \<Longrightarrow> \<exists>c. lookup cs l = Some c"
  proof (induction \<Delta> \<Gamma> e t and \<Delta> \<Gamma> cs ts t arbitrary: and l rule: typecheck_typecheck_cs.inducts)
  case tc_var
    thus ?case by (metis lookup_less_than head_var.simps(1))
  next case tc_app
    thus ?case by (metis canonical_arrow ev_app1 ev_app2 ev_app_let head_var.simps(3))
  next case (tc_let \<Delta> \<Gamma> e\<^sub>1 t\<^sub>1 e\<^sub>2 t\<^sub>2)
    thus ?case
      proof (cases "is_value e\<^sub>2")
      case False note F = False
        thus ?thesis
          proof (cases "\<exists>e\<^sub>2'. e\<^sub>2 \<leadsto> e\<^sub>2'")
          case False
            with tc_let F obtain x where X: "x < Suc (length \<Gamma>) \<and> head_var e\<^sub>2 = Some x" by fastforce
            thus ?thesis
              proof (cases x)
              case 0
                with X show ?thesis
                  proof (cases "is_value e\<^sub>1")
                  case False
                    with tc_let X 0 ev_let2 show ?thesis by fastforce
                  qed (metis ev_let3)
              qed simp_all
          qed (metis ev_let1)
      qed simp_all
  next case tc_proj
    thus ?case
      by (metis canonical_record ev_proj1 ev_proj2 ev_proj_let lookup_in_tc head_var.simps(6))
  next case tc_case
    thus ?case by (metis canonical_variant ev_case1 ev_case2 ev_case_let head_var.simps(8))
  next case tc_unfold
    thus ?case by (metis canonical_inductive ev_unfold1 ev_unfold2 ev_unfold_let head_var.simps(10))
  next case tc_tyapp
    thus ?case by simp (metis canonical_forall ev_tyapp1 ev_tyapp2 ev_tyapp_let)
  next case tc_tylet
    thus ?case by (metis ev_tylet)
  next case tcc_cons
    thus ?case by (induction l) simp_all
  qed simp_all

theorem progress: "\<Delta>,[] \<turnstile> e : t \<Longrightarrow> is_value e \<or> (\<exists>e'. e \<leadsto> e')"
  using progress' by fastforce

theorem preservation: "e \<leadsto> e' \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> e : t \<Longrightarrow> \<Delta>,\<Gamma> \<turnstile> e' : t"
  proof (induction e e' arbitrary: \<Delta> \<Gamma> t rule: evaluate.induct)
  case (ev_proj2 l xs x)
    hence "lookup \<Gamma> x = Some t" by fastforce
    thus ?case by simp
  next case (ev_case2 cs l e ts x t')
    then obtain tt where "(lookup \<Gamma> x = Some tt) \<and> lookup ts l = Some tt \<and>
      (\<forall>tt \<in> set ts. \<Delta> \<turnstile>\<^sub>k tt : Star) \<and> (\<Delta>,\<Gamma> \<turnstile>\<^sub>c cs : ts \<rightarrow> t') \<and> t' = t" by fastforce
    moreover with ev_case2 have "\<Delta>,insert_at 0 tt \<Gamma> \<turnstile> e : t" by fastforce
    ultimately show ?case by (metis tc_let tc_var)
  next case (ev_tyapp2 k e t')
    then obtain tt where T: "(insert_at 0 k \<Delta>,map (incr\<^sub>t\<^sub>t 0) \<Gamma> \<turnstile> e : tt) \<and> (\<Delta> \<turnstile>\<^sub>k t' : k) \<and>
      t = subst\<^sub>t\<^sub>t 0 t' tt" by fastforce
    moreover hence "\<Delta>,map (subst\<^sub>t\<^sub>t 0 t') (map (incr\<^sub>t\<^sub>t 0) \<Gamma>) \<turnstile> subst\<^sub>t\<^sub>e 0 t' e : subst\<^sub>t\<^sub>t 0 t' tt"
      using tc_subst\<^sub>t\<^sub>e by fastforce
    ultimately show ?case by simp
  qed fastforce+

*)

end


(*  Title:      HOL/Option.thy
    Author:     Folklore
*)

section \<open>Datatype option\<close>

theory Option
  imports Lifting
begin

datatype 'a option =
    None
  | Some (the: 'a)

datatype_compat option

lemma [case_names None Some, cases type: option]:
  \<comment> \<open>for backward compatibility -- names of variables differ\<close>
  "(y = None \<Longrightarrow> P) \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> P) \<Longrightarrow> P"
  by (rule option.exhaust)

lemma [case_names None Some, induct type: option]:
  \<comment> \<open>for backward compatibility -- names of variables differ\<close>
  "P None \<Longrightarrow> (\<And>option. P (Some option)) \<Longrightarrow> P option"
  by (rule option.induct)

text \<open>Compatibility:\<close>
setup \<open>Sign.mandatory_path "option"\<close>
lemmas inducts = option.induct
lemmas cases = option.case
setup \<open>Sign.parent_path\<close>

lemma not_None_eq [iff]: "x \<noteq> None \<longleftrightarrow> (\<exists>y. x = Some y)"
  by (induct x) auto

lemma not_Some_eq [iff]: "(\<forall>y. x \<noteq> Some y) \<longleftrightarrow> x = None"
  by (induct x) auto

lemma comp_the_Some[simp]: "the o Some = id"
by auto

text \<open>Although it may appear that both of these equalities are helpful
only when applied to assumptions, in practice it seems better to give
them the uniform iff attribute.\<close>

lemma inj_Some [simp]: "inj_on Some A"
  by (rule inj_onI) simp

lemma case_optionE:
  assumes c: "(case x of None \<Rightarrow> P | Some y \<Rightarrow> Q y)"
  obtains
    (None) "x = None" and P
  | (Some) y where "x = Some y" and "Q y"
  using c by (cases x) simp_all

lemma split_option_all: "(\<forall>x. P x) \<longleftrightarrow> P None \<and> (\<forall>x. P (Some x))"
  by (auto intro: option.induct)

lemma split_option_ex: "(\<exists>x. P x) \<longleftrightarrow> P None \<or> (\<exists>x. P (Some x))"
  using split_option_all[of "\<lambda>x. \<not> P x"] by blast

lemma UNIV_option_conv: "UNIV = insert None (range Some)"
  by (auto intro: classical)

lemma rel_option_None1 [simp]: "rel_option P None x \<longleftrightarrow> x = None"
  by (cases x) simp_all

lemma rel_option_None2 [simp]: "rel_option P x None \<longleftrightarrow> x = None"
  by (cases x) simp_all

lemma option_rel_Some1: "rel_option A (Some x) y \<longleftrightarrow> (\<exists>y'. y = Some y' \<and> A x y')" (* Option *)
by(cases y) simp_all

lemma option_rel_Some2: "rel_option A x (Some y) \<longleftrightarrow> (\<exists>x'. x = Some x' \<and> A x' y)" (* Option *)
by(cases x) simp_all

lemma rel_option_inf: "inf (rel_option A) (rel_option B) = rel_option (inf A B)"
  (is "?lhs = ?rhs")
proof (rule antisym)
  show "?lhs \<le> ?rhs" by (auto elim: option.rel_cases)
  show "?rhs \<le> ?lhs" by (auto elim: option.rel_mono_strong)
qed

lemma rel_option_reflI:
  "(\<And>x. x \<in> set_option y \<Longrightarrow> P x x) \<Longrightarrow> rel_option P y y"
  by (cases y) auto

subsubsection \<open>Operations\<close>

lemma ospec [dest]: "(\<forall>x\<in>set_option A. P x) \<Longrightarrow> A = Some x \<Longrightarrow> P x"
  by simp

setup \<open>map_theory_claset (fn ctxt => ctxt addSD2 ("ospec", @{thm ospec}))\<close>

lemma elem_set [iff]: "(x \<in> set_option xo) = (xo = Some x)"
  by (cases xo) auto

lemma set_empty_eq [simp]: "(set_option xo = {}) = (xo = None)"
  by (cases xo) auto

lemma map_option_case: "map_option f y = (case y of None \<Rightarrow> None | Some x \<Rightarrow> Some (f x))"
  by (auto split: option.split)

lemma map_option_is_None [iff]: "(map_option f opt = None) = (opt = None)"
  by (simp add: map_option_case split: option.split)

lemma None_eq_map_option_iff [iff]: "None = map_option f x \<longleftrightarrow> x = None"
by(cases x) simp_all

lemma map_option_eq_Some [iff]: "(map_option f xo = Some y) = (\<exists>z. xo = Some z \<and> f z = y)"
  by (simp add: map_option_case split: option.split)

lemma map_option_o_case_sum [simp]:
    "map_option f \<circ> case_sum g h = case_sum (map_option f \<circ> g) (map_option f \<circ> h)"
  by (rule o_case_sum)

lemma map_option_cong: "x = y \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> f a = g a) \<Longrightarrow> map_option f x = map_option g y"
  by (cases x) auto

lemma map_option_idI: "(\<And>y. y \<in> set_option x \<Longrightarrow> f y = y) \<Longrightarrow> map_option f x = x"
by(cases x)(simp_all)

functor map_option: map_option
  by (simp_all add: option.map_comp fun_eq_iff option.map_id)

lemma case_map_option [simp]: "case_option g h (map_option f x) = case_option g (h \<circ> f) x"
  by (cases x) simp_all

lemma None_notin_image_Some [simp]: "None \<notin> Some ` A"
by auto

lemma notin_range_Some: "x \<notin> range Some \<longleftrightarrow> x = None"
by(cases x) auto

lemma rel_option_iff:
  "rel_option R x y = (case (x, y) of (None, None) \<Rightarrow> True
    | (Some x, Some y) \<Rightarrow> R x y
    | _ \<Rightarrow> False)"
  by (auto split: prod.split option.split)

definition combine_options :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
  where "combine_options f x y =
           (case x of None \<Rightarrow> y | Some x \<Rightarrow> (case y of None \<Rightarrow> Some x | Some y \<Rightarrow> Some (f x y)))"

lemma combine_options_simps [simp]:
  "combine_options f None y = y"
  "combine_options f x None = x"
  "combine_options f (Some a) (Some b) = Some (f a b)"
  by (simp_all add: combine_options_def split: option.splits)

lemma combine_options_cases [case_names None1 None2 Some]:
  "(x = None \<Longrightarrow> P x y) \<Longrightarrow> (y = None \<Longrightarrow> P x y) \<Longrightarrow>
     (\<And>a b. x = Some a \<Longrightarrow> y = Some b \<Longrightarrow> P x y) \<Longrightarrow> P x y"
  by (cases x; cases y) simp_all

lemma combine_options_commute:
  "(\<And>x y. f x y = f y x) \<Longrightarrow> combine_options f x y = combine_options f y x"
  using combine_options_cases[of x ]
  by (induction x y rule: combine_options_cases) simp_all

lemma combine_options_assoc:
  "(\<And>x y z. f (f x y) z = f x (f y z)) \<Longrightarrow>
     combine_options f (combine_options f x y) z =
     combine_options f x (combine_options f y z)"
  by (auto simp: combine_options_def split: option.splits)

lemma combine_options_left_commute:
  "(\<And>x y. f x y = f y x) \<Longrightarrow> (\<And>x y z. f (f x y) z = f x (f y z)) \<Longrightarrow>
     combine_options f y (combine_options f x z) =
     combine_options f x (combine_options f y z)"
  by (auto simp: combine_options_def split: option.splits)

lemmas combine_options_ac =
  combine_options_commute combine_options_assoc combine_options_left_commute

context
begin

qualified definition is_none :: "'a option \<Rightarrow> bool"
  where [code_post]: "is_none x \<longleftrightarrow> x = None"

lemma is_none_simps [simp]:
  "is_none None"
  "\<not> is_none (Some x)"
  by (simp_all add: is_none_def)

lemma is_none_code [code]:
  "is_none None = True"
  "is_none (Some x) = False"
  by simp_all

lemma rel_option_unfold:
  "rel_option R x y \<longleftrightarrow>
   (is_none x \<longleftrightarrow> is_none y) \<and> (\<not> is_none x \<longrightarrow> \<not> is_none y \<longrightarrow> R (the x) (the y))"
  by (simp add: rel_option_iff split: option.split)

lemma rel_optionI:
  "\<lbrakk> is_none x \<longleftrightarrow> is_none y; \<lbrakk> \<not> is_none x; \<not> is_none y \<rbrakk> \<Longrightarrow> P (the x) (the y) \<rbrakk>
  \<Longrightarrow> rel_option P x y"
  by (simp add: rel_option_unfold)

lemma is_none_map_option [simp]: "is_none (map_option f x) \<longleftrightarrow> is_none x"
  by (simp add: is_none_def)

lemma the_map_option: "\<not> is_none x \<Longrightarrow> the (map_option f x) = f (the x)"
  by (auto simp add: is_none_def)

qualified primrec bind :: "'a option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option"
where
  bind_lzero: "bind None f = None"
| bind_lunit: "bind (Some x) f = f x"

lemma is_none_bind: "is_none (bind f g) \<longleftrightarrow> is_none f \<or> is_none (g (the f))"
  by (cases f) simp_all

lemma bind_runit[simp]: "bind x Some = x"
  by (cases x) auto

lemma bind_assoc[simp]: "bind (bind x f) g = bind x (\<lambda>y. bind (f y) g)"
  by (cases x) auto

lemma bind_rzero[simp]: "bind x (\<lambda>x. None) = None"
  by (cases x) auto

qualified lemma bind_cong: "x = y \<Longrightarrow> (\<And>a. y = Some a \<Longrightarrow> f a = g a) \<Longrightarrow> bind x f = bind y g"
  by (cases x) auto

lemma bind_split: "P (bind m f) \<longleftrightarrow> (m = None \<longrightarrow> P None) \<and> (\<forall>v. m = Some v \<longrightarrow> P (f v))"
  by (cases m) auto

lemma bind_split_asm: "P (bind m f) \<longleftrightarrow> \<not> (m = None \<and> \<not> P None \<or> (\<exists>x. m = Some x \<and> \<not> P (f x)))"
  by (cases m) auto

lemmas bind_splits = bind_split bind_split_asm

lemma bind_eq_Some_conv: "bind f g = Some x \<longleftrightarrow> (\<exists>y. f = Some y \<and> g y = Some x)"
  by (cases f) simp_all

lemma bind_eq_None_conv: "Option.bind a f = None \<longleftrightarrow> a = None \<or> f (the a) = None"
by(cases a) simp_all

lemma map_option_bind: "map_option f (bind x g) = bind x (map_option f \<circ> g)"
  by (cases x) simp_all

lemma bind_option_cong:
  "\<lbrakk> x = y; \<And>z. z \<in> set_option y \<Longrightarrow> f z = g z \<rbrakk> \<Longrightarrow> bind x f = bind y g"
  by (cases y) simp_all

lemma bind_option_cong_simp:
  "\<lbrakk> x = y; \<And>z. z \<in> set_option y =simp=> f z = g z \<rbrakk> \<Longrightarrow> bind x f = bind y g"
  unfolding simp_implies_def by (rule bind_option_cong)

lemma bind_option_cong_code: "x = y \<Longrightarrow> bind x f = bind y f"
  by simp

lemma bind_map_option: "bind (map_option f x) g = bind x (g \<circ> f)"
by(cases x) simp_all

lemma set_bind_option [simp]: "set_option (bind x f) = (\<Union>((set_option \<circ> f) ` set_option x))"
by(cases x) auto

lemma map_conv_bind_option: "map_option f x = Option.bind x (Some \<circ> f)"
by(cases x) simp_all

end

setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm bind_option_cong_code})\<close>

context
begin

qualified definition these :: "'a option set \<Rightarrow> 'a set"
  where "these A = the ` {x \<in> A. x \<noteq> None}"

lemma these_empty [simp]: "these {} = {}"
  by (simp add: these_def)

lemma these_insert_None [simp]: "these (insert None A) = these A"
  by (auto simp add: these_def)

lemma these_insert_Some [simp]: "these (insert (Some x) A) = insert x (these A)"
proof -
  have "{y \<in> insert (Some x) A. y \<noteq> None} = insert (Some x) {y \<in> A. y \<noteq> None}"
    by auto
  then show ?thesis by (simp add: these_def)
qed

lemma in_these_eq: "x \<in> these A \<longleftrightarrow> Some x \<in> A"
proof
  assume "Some x \<in> A"
  then obtain B where "A = insert (Some x) B" by auto
  then show "x \<in> these A" by (auto simp add: these_def intro!: image_eqI)
next
  assume "x \<in> these A"
  then show "Some x \<in> A" by (auto simp add: these_def)
qed

lemma these_image_Some_eq [simp]: "these (Some ` A) = A"
  by (auto simp add: these_def intro!: image_eqI)

lemma Some_image_these_eq: "Some ` these A = {x\<in>A. x \<noteq> None}"
  by (auto simp add: these_def image_image intro!: image_eqI)

lemma these_empty_eq: "these B = {} \<longleftrightarrow> B = {} \<or> B = {None}"
  by (auto simp add: these_def)

lemma these_not_empty_eq: "these B \<noteq> {} \<longleftrightarrow> B \<noteq> {} \<and> B \<noteq> {None}"
  by (auto simp add: these_empty_eq)

end

lemma finite_range_Some: "finite (range (Some :: 'a \<Rightarrow> 'a option)) = finite (UNIV :: 'a set)"
  by (auto dest: finite_imageD intro: inj_Some)

subsection \<open>Transfer rules for the Transfer package\<close>

context includes lifting_syntax
begin

lemma option_bind_transfer [transfer_rule]:
  "(rel_option A ===> (A ===> rel_option B) ===> rel_option B)
    Option.bind Option.bind"
  unfolding rel_fun_def split_option_all by simp

lemma pred_option_parametric [transfer_rule]:
  "((A ===> (=)) ===> rel_option A ===> (=)) pred_option pred_option"
  by (rule rel_funI)+ (auto simp add: rel_option_unfold Option.is_none_def dest: rel_funD)

end

subsubsection \<open>Interaction with finite sets\<close>

lemma finite_option_UNIV [simp]:
  "finite (UNIV :: 'a option set) = finite (UNIV :: 'a set)"
  by (auto simp add: UNIV_option_conv elim: finite_imageD intro: inj_Some)

instance option :: (finite) finite
  by standard (simp add: UNIV_option_conv)

subsubsection \<open>Code generator setup\<close>

lemma equal_None_code_unfold [code_unfold]:
  "HOL.equal x None \<longleftrightarrow> Option.is_none x"
  "HOL.equal None = Option.is_none"
  by (auto simp add: equal Option.is_none_def)

code_printing
  type_constructor option \<rightharpoonup>
    (SML) "_ option"
    and (OCaml) "_ option"
    and (Haskell) "Maybe _"
    and (Scala) "!Option[(_)]"
| constant None \<rightharpoonup>
    (SML) "NONE"
    and (OCaml) "None"
    and (Haskell) "Nothing"
    and (Scala) "!None"
| constant Some \<rightharpoonup>
    (SML) "SOME"
    and (OCaml) "Some _"
    and (Haskell) "Just"
    and (Scala) "Some"
| class_instance option :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: 'a option \<Rightarrow> 'a option \<Rightarrow> bool" \<rightharpoonup>
    (Haskell) infix 4 "=="

code_reserved SML
  option NONE SOME

code_reserved OCaml
  option None Some

code_reserved Scala
  Option None Some

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
header {* \isaheader{Implementation of a trie with explicit invariants} *}
theory Trie_Impl imports
  "../../Lib/Assoc_List"
begin

subsection {* Type definition and primitive operations *}

datatype ('key, 'val) trie = Trie "'val option" "('key \<times> ('key, 'val) trie) list"

lemma trie_induct [case_names Trie, induct type]:
  "(\<And>vo kvs. (\<And>k t. (k, t) \<in> set kvs \<Longrightarrow> P t) \<Longrightarrow> P (Trie vo kvs)) \<Longrightarrow> P t"
apply(induction_schema)
  apply pat_completeness
 apply(lexicographic_order)
done

definition empty :: "('key, 'val) trie"
where "empty = Trie None []"

fun lookup :: "('key, 'val) trie \<Rightarrow> 'key list \<Rightarrow> 'val option"
where
  "lookup (Trie vo _) [] = vo"
| "lookup (Trie _ ts) (k#ks) = (case map_of ts k of None \<Rightarrow> None | Some t \<Rightarrow> lookup t ks)"

fun update :: "('key, 'val) trie \<Rightarrow> 'key list \<Rightarrow> 'val \<Rightarrow> ('key, 'val) trie"
where
  "update (Trie vo ts) [] v = Trie (Some v) ts"
| "update (Trie vo ts) (k#ks) v = Trie vo (Assoc_List.update_with_aux (Trie None []) k (\<lambda>t. update t ks v) ts)"

primrec isEmpty :: "('key, 'val) trie \<Rightarrow> bool"
where "isEmpty (Trie vo ts) \<longleftrightarrow> vo = None \<and> ts = []"

fun delete :: "('key, 'val) trie \<Rightarrow> 'key list \<Rightarrow> ('key, 'val) trie"
where
  "delete (Trie vo ts) [] = Trie None ts"
| "delete (Trie vo ts) (k#ks) =
   (case map_of ts k of None \<Rightarrow> Trie vo ts
                    | Some t \<Rightarrow> let t' = delete t ks
                                in if isEmpty t'
                                   then Trie vo (Assoc_List.delete_aux k ts)
                                   else Trie vo (AList.update k t' ts))"

fun trie_invar :: "('key, 'val) trie \<Rightarrow> bool"
where "trie_invar (Trie vo kts) = (distinct (map fst kts) \<and> (\<forall>(k, t) \<in> set kts. \<not> isEmpty t \<and> trie_invar t))"

fun iteratei_postfixed :: "'key list \<Rightarrow> ('key, 'val) trie \<Rightarrow>
    ('key list \<times> 'val, '\<sigma>) set_iterator"
where
  "iteratei_postfixed ks (Trie vo ts) c f \<sigma> =
   (if c \<sigma>
    then foldli ts c (\<lambda>(k, t) \<sigma>. iteratei_postfixed (k # ks) t c f \<sigma>)
           (case vo of None \<Rightarrow> \<sigma> | Some v \<Rightarrow> f (ks, v) \<sigma>)
    else \<sigma>)"

definition iteratei :: "('key, 'val) trie \<Rightarrow> ('key list \<times> 'val, '\<sigma>) set_iterator"
where "iteratei t c f \<sigma> = iteratei_postfixed [] t c f \<sigma>"

lemma iteratei_postfixed_interrupt:
  "\<not> c \<sigma> \<Longrightarrow> iteratei_postfixed ks t c f \<sigma> = \<sigma>"
by(cases t) simp

lemma iteratei_interrupt:
  "\<not> c \<sigma> \<Longrightarrow> iteratei t c f \<sigma> = \<sigma>"
unfolding iteratei_def by (simp add: iteratei_postfixed_interrupt)

lemma iteratei_postfixed_alt_def :
  "iteratei_postfixed ks ((Trie vo ts)::('key, 'val) trie) =
   (set_iterator_union
     (case_option set_iterator_emp (\<lambda>v. set_iterator_sng (ks, v)) vo)
     (set_iterator_image snd
     (set_iterator_product (foldli ts)
        (\<lambda>(k, t'). iteratei_postfixed (k # ks) t'))
     ))"
proof -
  have aux: "\<And>c f. (\<lambda>(k, t). iteratei_postfixed (k # ks) t c f) =
              (\<lambda>a. iteratei_postfixed (fst a # ks) (snd a) c f)"
    by auto

  show ?thesis
    apply (rule ext)+ apply (rename_tac c f \<sigma>)
    apply (simp add: set_iterator_product_def set_iterator_image_filter_def
                     set_iterator_union_def set_iterator_sng_def set_iterator_image_alt_def
                     case_prod_beta set_iterator_emp_def
            split: option.splits)
    apply (simp add: aux)
  done
qed

subsection {* Lookup simps *}

lemma lookup_eq_Some_iff :
assumes invar: "trie_invar ((Trie vo kvs) :: ('key, 'val) trie)"
shows "lookup (Trie vo kvs) ks = Some v \<longleftrightarrow>
    (ks = [] \<and> vo = Some v) \<or>
    (\<exists>k t ks'. ks = k # ks' \<and>
        (k, t) \<in> set kvs \<and> lookup t ks' = Some v)"
proof (cases ks)
  case Nil thus ?thesis by simp
next
  case (Cons k ks')
  note ks_eq[simp] = Cons

  show ?thesis
  proof (cases "map_of kvs k")
    case None thus ?thesis
      apply (simp)
      apply (auto simp add: map_of_eq_None_iff image_iff Ball_def)
    done
  next
    case (Some t') note map_eq = this
    from invar have dist_kvs: "distinct (map fst kvs)" by simp

    from map_of_eq_Some_iff[OF dist_kvs, of k] map_eq
    show ?thesis by simp metis
  qed
qed

lemma lookup_eq_None_iff :
assumes invar: "trie_invar ((Trie vo kvs) :: ('key, 'val) trie)"
shows "lookup (Trie vo kvs) ks = None \<longleftrightarrow>
    (ks = [] \<and> vo = None) \<or>
    (\<exists>k ks'. ks = k # ks' \<and> (\<forall>t. (k, t) \<in> set kvs \<longrightarrow> lookup t ks' = None))"
using lookup_eq_Some_iff[of vo kvs ks, OF invar]
  apply (cases ks)
    apply auto[]
  apply (auto split: option.split)
    apply (metis option.simps(3) weak_map_of_SomeI)
    apply (metis option.exhaust)
    apply (metis option.exhaust)
done

subsection {* The empty trie *}

lemma trie_invar_empty [simp, intro!]: "trie_invar empty"
by(simp add: empty_def)

lemma lookup_empty [simp]:
  "lookup empty = Map.empty"
proof
  fix ks show "lookup empty ks = Map.empty ks"
    by(cases ks)(auto simp add: empty_def)
qed

lemma lookup_empty' [simp]:
  "lookup (Trie None []) ks = None"
by(simp add: lookup_empty[unfolded empty_def])

subsection {* Emptyness check *}

lemma isEmpty_conv:
  "isEmpty ts \<longleftrightarrow> ts = Trie None []"
by(cases ts)(simp)

lemma update_not_empty: "\<not> isEmpty (update t ks v)"
apply(cases t)
apply(rename_tac kvs)
apply(cases ks)
apply(case_tac [2] kvs)
apply auto
done

lemma isEmpty_lookup_empty:
  "trie_invar t \<Longrightarrow> isEmpty t \<longleftrightarrow> lookup t = Map.empty"
proof(induct t)
  case (Trie vo kvs)
  thus ?case
    apply(cases kvs)
    apply(auto simp add: fun_eq_iff elim: allE[where x="[]"])
    apply(erule meta_allE)+
    apply(erule meta_impE)
    apply(rule disjI1)
    apply(fastforce intro: exI[where x="a # b" for a b])+
    done
qed

subsection {* Trie update *}

lemma lookup_update:
  "lookup (update t ks v) ks' = (if ks = ks' then Some v else lookup t ks')"
proof(induct t ks v arbitrary: ks' rule: update.induct)
  case (1 vo ts v)
  show ?case by(fastforce simp add: neq_Nil_conv dest: not_sym)
next
  case (2 vo ts k ks v)
  note IH = `\<And>t ks'. lookup (update t ks v) ks' = (if ks = ks' then Some v else lookup t ks')`
  show ?case by(cases ks')(auto simp add: map_of_update_with_aux IH split: option.split)
qed

lemma lookup_update':
  "lookup (update t ks v) = (lookup t)(ks \<mapsto> v)"
by(rule ext)(simp add: lookup_update)

lemma trie_invar_update: "trie_invar t \<Longrightarrow> trie_invar (update t ks v)"
by(induct t ks v rule: update.induct)(auto simp add: set_update_with_aux update_not_empty split: option.splits)

subsection {* Trie removal *}

lemma delete_eq_empty_lookup_other_fail:
  "\<lbrakk> delete t ks = Trie None []; ks' \<noteq> ks \<rbrakk> \<Longrightarrow> lookup t ks' = None"
proof(induct t ks arbitrary: ks' rule: delete.induct)
  case (1 vo ts)
  thus ?case by(auto simp add: neq_Nil_conv)
next
  case (2 vo ts k ks)
  note IH = `\<And>t ks'. \<lbrakk>map_of ts k = Some t; delete t ks = Trie None []; ks' \<noteq> ks\<rbrakk>
           \<Longrightarrow> lookup t ks' = None`
  note ks' = `ks' \<noteq> k # ks`
  note empty = `delete (Trie vo ts) (k # ks) = Trie None []`
  show ?case
  proof(cases "map_of ts k")
    case (Some t)
    from Some empty show ?thesis
    proof(cases ks')
      case (Cons k' ks'')
      with Some empty ks' show ?thesis
      proof(cases "k' = k")
        case False
        from Some Cons empty have "delete_aux k ts = []"
          by(clarsimp simp add: Let_def split: split_if_asm)
        with False have "map_of ts k' = None"
          by(cases "map_of ts k'")(auto dest: map_of_is_SomeD simp add: delete_aux_eq_Nil_conv)
        thus ?thesis using False Some Cons empty by simp
      next
        case True
        with Some empty ks' Cons show ?thesis
          by(clarsimp simp add: IH Let_def isEmpty_conv split: split_if_asm)
      qed
    qed(simp add: Let_def split: split_if_asm)
  next
    case None thus ?thesis using empty by simp
  qed
qed

lemma lookup_delete:
  "trie_invar t \<Longrightarrow> lookup (delete t ks) ks' = (if ks = ks' then None else lookup t ks')"
proof(induct t ks arbitrary: ks' rule: delete.induct)
  case (1 vo ts)
  show ?case by(fastforce dest: not_sym simp add: neq_Nil_conv)
next
  case (2 vo ts k ks)
  note IH = `\<And>t ks'. \<lbrakk> map_of ts k = Some t; trie_invar t \<rbrakk>
           \<Longrightarrow> lookup (delete t ks) ks' = (if ks = ks' then None else lookup t ks')`
  note invar = `trie_invar (Trie vo ts)`
  show ?case
  proof(cases ks')
    case Nil thus ?thesis
      by(simp split: option.split add: Let_def)
  next
    case (Cons k' ks'')[simp]
    show ?thesis
    proof(cases "k' = k")
      case False thus ?thesis using invar
        by(auto simp add: Let_def update_conv' map_of_delete_aux split: option.split)
    next
      case True[simp]
      show ?thesis
      proof(cases "map_of ts k")
        case None thus ?thesis by simp
      next
        case (Some t)
        thus ?thesis
        proof(cases "isEmpty (delete t ks)")
          case True
          with Some invar show ?thesis
            by(auto simp add: map_of_delete_aux isEmpty_conv dest: delete_eq_empty_lookup_other_fail)
        next
          case False
          thus ?thesis using Some IH[of t ks''] invar by(auto simp add: update_conv')
        qed
      qed
    qed
  qed
qed

lemma lookup_delete':
  "trie_invar t \<Longrightarrow> lookup (delete t ks) = (lookup t)(ks := None)"
by(rule ext)(simp add: lookup_delete)

lemma trie_invar_delete:
  "trie_invar t \<Longrightarrow> trie_invar (delete t ks)"
proof(induct t ks rule: delete.induct)
  case (1 vo ts)
  thus ?case by simp
next
  case (2 vo ts k ks)
  note invar = `trie_invar (Trie vo ts)`
  show ?case
  proof(cases "map_of ts k")
    case None
    thus ?thesis using invar by simp
  next
    case (Some t)
    with invar have "trie_invar t" by auto
    with Some have "trie_invar (delete t ks)" by(rule 2)
    from invar Some have distinct: "distinct (map fst ts)" "\<not> isEmpty t" by auto
    show ?thesis
    proof(cases "isEmpty (delete t ks)")
      case True
      { fix k' t'
        assume k't': "(k', t') \<in> set (delete_aux k ts)"
        with distinct have "map_of (delete_aux k ts) k' = Some t'" by simp
        hence "map_of ts k' = Some t'" using distinct
          by (auto
            simp del: map_of_eq_Some_iff map_upd_eq_restrict
            simp add: map_of_delete_aux
            split: split_if_asm)
        with invar  have "\<not> isEmpty t' \<and> trie_invar t'" by auto }
      with invar have "trie_invar (Trie vo (delete_aux k ts))" by auto
      thus ?thesis using True Some by(simp)
    next
      case False
      { fix k' t'
        assume k't':"(k', t') \<in> set (AList.update k (delete t ks) ts)"
        hence "map_of (AList.update k (delete t ks) ts) k' = Some t'"
          using invar by(auto simp add: distinct_update)
        hence eq: "((map_of ts)(k \<mapsto> delete t ks)) k' = Some t'" unfolding update_conv .
        have "\<not> isEmpty t' \<and> trie_invar t'"
        proof(cases "k' = k")
          case True
          with eq have "t' = delete t ks" by simp
          with `trie_invar (delete t ks)` False
          show ?thesis by simp
        next
          case False
          with eq distinct have "(k', t') \<in> set ts" by simp
          with invar show ?thesis by auto
        qed }
      thus ?thesis using Some invar False by(auto simp add: distinct_update)
    qed
  qed
qed

subsection {* Domain of a trie *}

lemma dom_lookup:
  "dom (lookup (Trie vo kts)) =
  (\<Union>k\<in>dom (map_of kts). Cons k ` dom (lookup (the (map_of kts k)))) \<union>
  (if vo = None then {} else {[]})"
unfolding dom_def
apply(rule sym)
apply(safe)
  apply simp
 apply(clarsimp simp add: split_if_asm)
apply(case_tac x)
apply(auto split: option.split_asm)
done

lemma finite_dom_trie_lookup:
  "finite (dom (lookup t))"
proof(induct t)
  case (Trie vo kts)
  have "finite (\<Union>k\<in>dom (map_of kts). Cons k ` dom (lookup (the (map_of kts k))))"
  proof(rule finite_UN_I)
    show "finite (dom (map_of kts))" by(rule finite_dom_map_of)
  next
    fix k
    assume "k \<in> dom (map_of kts)"
    then obtain v where "(k, v) \<in> set kts" "map_of kts k = Some v" by(auto dest: map_of_SomeD)
    hence "finite (dom (lookup (the (map_of kts k))))" by simp(rule Trie)
    thus "finite (Cons k ` dom (lookup (the (map_of kts k))))" by(rule finite_imageI)
  qed
  thus ?case by(simp add: dom_lookup)
qed

lemma dom_lookup_empty_conv: "trie_invar t \<Longrightarrow> dom (lookup t) = {} \<longleftrightarrow> isEmpty t"
proof(induct t)
  case (Trie vo kvs)
  show ?case
  proof
    assume dom: "dom (lookup (Trie vo kvs)) = {}"
    have "vo = None"
    proof(cases vo)
      case (Some v)
      hence "[] \<in> dom (lookup (Trie vo kvs))" by auto
      with dom have False by simp
      thus ?thesis ..
    qed
    moreover have "kvs = []"
    proof(cases kvs)
      case (Cons kt kvs')
      with `trie_invar (Trie vo kvs)`
      have "\<not> isEmpty (snd kt)" "trie_invar (snd kt)" by auto
      from Cons have "(fst kt, snd kt) \<in> set kvs" by simp
      hence "dom (lookup (snd kt)) = {} \<longleftrightarrow> isEmpty (snd kt)"
        using `trie_invar (snd kt)` by(rule Trie)
      with `\<not> isEmpty (snd kt)` have "dom (lookup (snd kt)) \<noteq> {}" by simp
      with dom Cons have False by(auto simp add: dom_lookup)
      thus ?thesis ..
    qed
    ultimately show "isEmpty (Trie vo kvs)" by simp
  next
    assume "isEmpty (Trie vo kvs)"
    thus "dom (lookup (Trie vo kvs)) = {}"
      by(simp add: lookup_empty[unfolded empty_def])
  qed
qed

subsection {* Interuptible iterator *}

lemma iteratei_postfixed_correct :
  assumes invar: "trie_invar (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei_postfixed ks0 t)::('key list \<times> 'val, '\<sigma>) set_iterator)
           ((\<lambda>ksv. (rev (fst ksv) @ ks0, (snd ksv))) ` (map_to_set (lookup t)))"
using invar
proof (induct t arbitrary: ks0)
  case (Trie vo kvs)
  note ind_hyp = Trie(1)
  note invar = Trie(2)

  from invar
  have dist_fst_kvs : "distinct (map fst kvs)"
   and dist_kvs: "distinct kvs"
   and invar_child: "\<And>k t. (k, t) \<in> set kvs \<Longrightarrow> trie_invar t"
  by (simp_all add: Ball_def distinct_map)

  -- "root iterator"
  def it_vo \<equiv> "(case vo of None \<Rightarrow> set_iterator_emp
                        | Some v \<Rightarrow> set_iterator_sng (ks0, v)) ::
                  ('key list \<times> 'val, '\<sigma>) set_iterator"
  def vo_S \<equiv> "case vo of None \<Rightarrow> {} | Some v \<Rightarrow> {(ks0, v)}"
  have it_vo_OK: "set_iterator it_vo vo_S"
    unfolding it_vo_def vo_S_def
    by (simp split: option.split
             add: set_iterator_emp_correct set_iterator_sng_correct)

  -- "children iterator"
  def it_prod \<equiv> "(set_iterator_product (foldli kvs)
      (\<lambda>(k, y). iteratei_postfixed (k # ks0) y))::
          (('key \<times> ('key, 'val) trie) \<times> 'key list \<times> 'val, '\<sigma>) set_iterator"

    def it_prod_S \<equiv> "SIGMA kt:set kvs.
       (\<lambda>ksv. (rev (fst ksv) @ ((fst kt) # ks0), snd ksv)) `
       map_to_set (lookup (snd kt))"

  have it_prod_OK: "set_iterator it_prod it_prod_S"
  proof -
    from set_iterator_foldli_correct[OF dist_kvs]
    have it_foldli: "set_iterator (foldli kvs) (set kvs)" .

    { fix kt
      assume kt_in: "kt \<in> set kvs"
      hence k_t_in: "(fst kt, snd kt) \<in> set kvs" by simp

      note ind_hyp [OF k_t_in, OF invar_child[OF k_t_in], of "fst kt # ks0"]
    } note it_child = this

    show ?thesis
      unfolding it_prod_def it_prod_S_def
      apply (rule set_iterator_product_correct [OF it_foldli])
      apply (insert it_child)
      apply (simp add: case_prod_beta)
    done
  qed

  have it_image_OK : "set_iterator (set_iterator_image snd it_prod) (snd ` it_prod_S)"
  proof (rule set_iterator_image_correct[OF it_prod_OK])
    from dist_fst_kvs
    have "\<And>k v1 v2. (k, v1) \<in> set kvs \<Longrightarrow> (k, v2) \<in> set kvs \<Longrightarrow> v1 = v2"
       by (induct kvs) (auto simp add: image_iff)
    thus "inj_on snd it_prod_S"
      unfolding inj_on_def it_prod_S_def
      apply (simp add: image_iff Ball_def map_to_set_def)
      apply auto
    done
  qed auto

  -- "overall iterator"
  have it_all_OK: "set_iterator
      ((iteratei_postfixed ks0 (Trie vo kvs)):: ('key list \<times> 'val, '\<sigma>) set_iterator)
     (vo_S \<union> snd ` it_prod_S)"
    unfolding iteratei_postfixed_alt_def
       it_vo_def[symmetric]
       it_prod_def[symmetric]
  proof (rule set_iterator_union_correct [OF it_vo_OK it_image_OK])
    show "vo_S \<inter> snd ` it_prod_S = {}"
      unfolding vo_S_def it_prod_S_def
      by (simp split: option.split add: set_eq_iff image_iff)
  qed

  -- "rewrite result set"
  have it_set_rewr: "((\<lambda>ksv. (rev (fst ksv) @ ks0, snd ksv)) `
      map_to_set (lookup (Trie vo kvs))) = (vo_S \<union> snd ` it_prod_S)"
    (is "?ls = ?rs")
    apply (simp add: map_to_set_def lookup_eq_Some_iff[OF invar]
                     set_eq_iff image_iff vo_S_def it_prod_S_def Ball_def Bex_def)
    apply (simp split: option.split del: ex_simps add: ex_simps[symmetric])
    apply (intro allI impI iffI)
    apply auto[]
    apply (metis append_Cons append_Nil append_assoc rev.simps)
  done

  -- "done"
  show ?case
    unfolding it_set_rewr using it_all_OK by fast
qed

definition trie_reverse_key where
  "trie_reverse_key ksv = (rev (fst ksv), (snd ksv))"

lemma trie_reverse_key_alt_def[code] :
  "trie_reverse_key (ks, v) = (rev ks, v)"
unfolding trie_reverse_key_def by auto

lemma trie_reverse_key_reverse[simp] :
  "trie_reverse_key (trie_reverse_key ksv) = ksv"
by (simp add: trie_reverse_key_def)

lemma trie_iteratei_correct:
  assumes invar: "trie_invar (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei t)::('key list \<times> 'val, '\<sigma>) set_iterator)
           (trie_reverse_key ` (map_to_set (lookup t)))"
unfolding trie_reverse_key_def[abs_def] iteratei_def[abs_def]
using iteratei_postfixed_correct [OF invar, of "[]"]
by simp

hide_const (open) empty isEmpty iteratei lookup update delete
hide_type (open) trie

end


theory SKAT_Euclid
  imports SKAT_Eval GCD
begin

datatype alph = mod_alph | plus_alph | mult_alph | minus_alph | nat_alph nat | eq_alph

lemma alph_UNIV: "UNIV = {mod_alph,eq_alph,plus_alph,mult_alph,minus_alph} \<union> (nat_alph ` UNIV)"
  by (auto simp add: image_def, metis alph.exhaust)

instantiation alph :: ranked_alphabet
begin

  fun arity_alph :: "alph \<Rightarrow> nat" where
    "arity_alph mod_alph = 2"
  | "arity_alph plus_alph = 2"
  | "arity_alph mult_alph = 2"
  | "arity_alph minus_alph = 2"
  | "arity_alph eq_alph = 2"
  | "arity_alph is_gcd_alph = 0"
  | "arity_alph (nat_alph _) = 0"

  definition funs_alph :: "alph set" where "funs_alph \<equiv> {mod_alph,plus_alph,mult_alph,minus_alph} \<union> (nat_alph ` UNIV)"

  definition rels_alph :: "alph set" where "rels_alph \<equiv> {eq_alph}"

  definition NULL_alph :: "alph" where "NULL_alph \<equiv> nat_alph 0"

  declare funs_alph_def [alphabet]
    and rels_alph_def [alphabet]
    and NULL_alph_def [alphabet]

  definition output_vars_alph :: "alph itself \<Rightarrow> nat set" where "output_vars_alph x \<equiv> {0}"

  declare output_vars_alph_def [alphabet]

  instance proof
    show "(funs :: alph set) \<inter> rels = {}"
      by (auto simp add: funs_alph_def rels_alph_def)

    show "(funs :: alph set) \<union> rels = UNIV"
      by (auto simp add: funs_alph_def rels_alph_def alph_UNIV)

    show "(funs :: alph set) \<noteq> {}"
      by (simp add: funs_alph_def)

    show "(rels :: alph set) \<noteq> {}"
      by (simp add: rels_alph_def)

    show "NULL \<in> (funs :: alph set)"
      by (simp add: NULL_alph_def funs_alph_def)

    show "arity (NULL::alph) = 0"
      by (simp add: NULL_alph_def)

    show "\<exists>x. x \<in> output_vars TYPE(alph)"
      by (metis (mono_tags) insertI1 output_vars_alph_def)

    show "finite (output_vars TYPE(alph))"
      by (metis (hide_lams, mono_tags) atLeastLessThan0 finite_atLeastLessThan finite_insert output_vars_alph_def)
  qed
end

definition MOD :: "alph trm \<Rightarrow> alph trm \<Rightarrow> alph trm" where
  "MOD a b \<equiv> (App mod_alph [a, b])"

definition PLUS :: "alph trm \<Rightarrow> alph trm \<Rightarrow> alph trm" where
  "PLUS a b = (App plus_alph [a, b])"

definition EQ :: "alph trm \<Rightarrow> alph trm \<Rightarrow> alph pred" where
  "EQ x y \<equiv> Pred eq_alph [x, y]"

definition NAT :: "nat \<Rightarrow> alph trm" where
  "NAT n \<equiv> App (nat_alph n) []"

definition MULT :: "alph trm \<Rightarrow> alph trm \<Rightarrow> alph trm" where
  "MULT a b = (App mult_alph [a, b])"

definition MINUS :: "alph trm \<Rightarrow> alph trm \<Rightarrow> alph trm" where
  "MINUS a b = (App minus_alph [a, b])"

fun euclid_funs :: "alph \<Rightarrow> nat list \<Rightarrow> nat" where
  "euclid_funs mod_alph [x, y] = x mod y"
| "euclid_funs plus_alph [x, y] = x + y"
| "euclid_funs mult_alph [x, y] = x * y"
| "euclid_funs minus_alph [x, y] = x - y"
| "euclid_funs (nat_alph n) [] = n"
| "euclid_funs _ _ = 0"

inductive_set euclid_rels :: "alph \<Rightarrow> nat relation" for a :: "alph" where
  "a = eq_alph \<Longrightarrow> [x,x] \<in> euclid_rels a"

abbreviation EUCLID :: "(alph, nat) interp" where "EUCLID \<equiv> \<lparr>interp_fun = euclid_funs, interp_rel = euclid_rels\<rparr>"

interpretation interp EUCLID done

definition SIMPLE_LOOP :: "alph skat" where
  "SIMPLE_LOOP \<equiv>
   WHILE !(pred (EQ (Var 0) (NAT 5))) DO
     0 := PLUS (Var 0) (NAT 1)
   WEND"

definition GCD :: "alph skat" where
  "GCD \<equiv>
   WHILE !(pred (EQ (Var 1) (NAT 0))) DO
     2 := Var 1;
     1 := MOD (Var 0) (Var 1);
     0 := Var 2
   WEND"

abbreviation hoare_triple_notation :: "nat mems \<Rightarrow> alph skat \<Rightarrow> nat mems \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [54,54,54] 53) where
  "hoare_triple_notation \<equiv> interp.hoare_triple EUCLID"

abbreviation module_notation :: "nat mems \<Rightarrow> alph skat \<Rightarrow> nat mems" (infix "\<Colon>" 75) where
  "module_notation \<Delta> x \<equiv> interp.module EUCLID \<Delta> x"

lemma helper: "\<lbrakk>\<And>x. P x = Q x\<rbrakk> \<Longrightarrow> {x. P x} = {x. Q x}"
  by auto

lemma set_mem_UNIV [simp]: "set_mems x (\<lambda>mem. m) UNIV = {mem. m = mem x}"
  by (auto simp add: set_mems_def image_def set_mem_def) (rule_tac x = xa in exI, auto)

lemma satisfies_assign: "satisfies x (op = m) = UNIV \<Colon> x := NAT m"
  by (simp add: satisfies_def module_def NAT_def, transfer, simp add: assigns_def)

lemma skat_assign3_var: "r = t[x|s] \<Longrightarrow> (x := s \<cdot> x := t) = (x := r)"
  by (metis skat_assign3)

lemma [simp]: "satisfies x P \<subseteq> satisfies x Q \<longleftrightarrow> (\<forall>mem. P (mem x) \<longrightarrow> Q (mem x))"
  by (auto simp add: satisfies_def)

lemma [simp]: "UNIV \<Colon> pred_expr (BLeaf (EQ (Var n) (NAT m))) = satisfies n (op = m)"
  apply (simp add: module_def EQ_def NAT_def satisfies_def)
  apply transfer
  apply auto
  by (metis empty_iff singleton_iff)

lemma [simp]: "UNIV \<Colon> pred_expr (BNot (BLeaf (EQ (Var n) (NAT m)))) = satisfies n (op \<noteq> m)"
  apply (simp add: module_def EQ_def NAT_def satisfies_def)
  apply transfer
  apply auto
  by (metis empty_iff singleton_iff)

declare pred_to_expr [simp]
declare pred_expr_not [simp]

lemma [simp]: "pred_expr (BNot (BNot P)) = pred_expr P"
  apply (subst pred_expr_not[symmetric])+
  by (metis hba.double_neg not_to_not pred_expr_test)

declare pred_expr_closed [simp]

fun initial_mem :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "initial_mem x y 0 = x"
| "initial_mem x y (Suc 0) = y"
| "initial_mem x y _ = 0"

declare pred_to_expr [simp]
declare pred_expr_not [simp]
declare Nat.One_nat_def [simp del]

no_notation
  dioid.one ("1\<index>") and
  dioid.zero ("0\<index>")

ML {*

structure HoareSimpRules = Named_Thms
  (val name = @{binding "hoare_simp"}
   val description = "Simplification rules for the hoare tactic")

structure HoareRules = Named_Thms
  (val name = @{binding "hoare_rule"}
   val description = "Extra Hoare Rules")

fun hoare_step_tac ctxt n =
  rtac @{thm hoare_assignment} n THEN TRY (rtac @{thm subset_refl} n)
  ORELSE (rtac @{thm hoare_while_inv} n THEN asm_full_simp_tac (simpset_of ctxt) 1)
  ORELSE (FIRST' (map (fn thm => rtac thm) (HoareRules.get ctxt)) n)

val hoare_tac = Subgoal.FOCUS (fn {context, ...} =>
  REPEAT (hoare_step_tac context 1)
  THEN auto_tac (map_simpset (fn ss => ss addsimps HoareSimpRules.get context) context))

*}

setup {* HoareSimpRules.setup *}
setup {* HoareRules.setup *}

declare hoare_composition[hoare_rule]
declare hoare_if[hoare_rule]

method_setup hoare_auto = {*
Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT (CHANGED (hoare_tac ctxt 1))))
*}

declare assigns_def [hoare_simp]
declare set_mems_def [hoare_simp]
declare image_def [hoare_simp]
declare set_mem_def [hoare_simp]
declare satisfies_def [hoare_simp]
declare MOD_def [hoare_simp]
declare PLUS_def [hoare_simp]
declare MINUS_def [hoare_simp]
declare MULT_def [hoare_simp]

lemma euclids_algorithm:
  "\<lbrace>{mem. mem 0 = x \<and> mem 1 = y}\<rbrace>
  WHILE !(pred (EQ (Var 1) (NAT 0)))
  INVARIANT {mem. gcd (mem 0) (mem 1) = gcd x y}
  DO
    2 := Var 1;
    1 := MOD (Var 0) (Var 1);
    0 := Var 2
  WEND
  \<lbrace>{mem. mem 0 = gcd x y}\<rbrace>"
  by hoare_auto (metis gcd_red_nat)

lemma [simp]: "eval_trm EUCLID mem (NAT x) = x"
  by (simp add: NAT_def)

lemma [simp]: "UNIV \<Colon> pred_expr (BLeaf (EQ (Var n) (Var m))) = {mem. mem n = mem m}"
  by (auto simp add: mod_pred_expr EQ_def) (metis empty_iff singleton_iff)+

lemma [simp]: "UNIV \<Colon> pred_expr (BNot (BLeaf (EQ (Var n) (Var m)))) = {mem. mem n \<noteq> mem m}"
  by (auto simp add: mod_pred_expr EQ_def) (metis empty_iff singleton_iff)+

lemma repeated_addition:
  "\<lbrace>{mem. mem 0 = x \<and> mem 1 = y}\<rbrace>
  2 := NAT 0;
  3 := NAT 0;
  (WHILE !(pred (EQ (Var 2) (Var 0)))
  INVARIANT {mem. mem 3 = mem 2 * mem 1 \<and> mem 0 = x \<and> mem 1 = y}
  DO
    3 := PLUS (Var 3) (Var 1);
    2 := PLUS (Var 2) (NAT 1)
  WEND)
  \<lbrace>{mem. mem 3 = (x * y)}\<rbrace>"
  by hoare_auto smt

lemma factorial:
  "\<lbrace>{mem. mem 0 = x}\<rbrace>
  1 := NAT 1;
  (WHILE !(pred (EQ (Var 0) (NAT 0)))
  INVARIANT {mem. fact x = mem 1 * fact (mem 0)}
  DO
    1 := MULT (Var 1) (Var 0); 0 := MINUS (Var 0) (NAT 1)
  WEND)
  \<lbrace>{mem. mem 1 = fact x}\<rbrace>"
  by hoare_auto (metis fact_reduce_nat)

end


(*  Title:      CCL/Term.thy
    Author:     Martin Coen
    Copyright   1993  University of Cambridge
*)

section \<open>Definitions of usual program constructs in CCL\<close>

theory Term
imports CCL
begin

definition one :: "i"
  where "one == true"

definition "if" :: "[i,i,i]\<Rightarrow>i"  ("(3if _/ then _/ else _)" [0,0,60] 60)
  where "if b then t else u  == case(b, t, u, \<lambda> x y. bot, \<lambda>v. bot)"

definition inl :: "i\<Rightarrow>i"
  where "inl(a) == <true,a>"

definition inr :: "i\<Rightarrow>i"
  where "inr(b) == <false,b>"

definition split :: "[i,[i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "split(t,f) == case(t, bot, bot, f, \<lambda>u. bot)"

definition "when" :: "[i,i\<Rightarrow>i,i\<Rightarrow>i]\<Rightarrow>i"
  where "when(t,f,g) == split(t, \<lambda>b x. if b then f(x) else g(x))"

definition fst :: "i\<Rightarrow>i"
  where "fst(t) == split(t, \<lambda>x y. x)"

definition snd :: "i\<Rightarrow>i"
  where "snd(t) == split(t, \<lambda>x y. y)"

definition thd :: "i\<Rightarrow>i"
  where "thd(t) == split(t, \<lambda>x p. split(p, \<lambda>y z. z))"

definition zero :: "i"
  where "zero == inl(one)"

definition succ :: "i\<Rightarrow>i"
  where "succ(n) == inr(n)"

definition ncase :: "[i,i,i\<Rightarrow>i]\<Rightarrow>i"
  where "ncase(n,b,c) == when(n, \<lambda>x. b, \<lambda>y. c(y))"

no_syntax
  "_Let" :: "[letbinds, 'a] => 'a"  ("(let (_)/ in (_))" 10)

definition "let" :: "[i,i\<Rightarrow>i]\<Rightarrow>i"
  where "let(t, f) == case(t,f(true),f(false), \<lambda>x y. f(<x,y>), \<lambda>u. f(lam x. u(x)))"

syntax
  "_Let" :: "[letbinds, 'a] => 'a"  ("(let (_)/ in (_))" 10)

definition letrec :: "[[i,i\<Rightarrow>i]\<Rightarrow>i,(i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  where "letrec(h, b) == b(\<lambda>x. fix(\<lambda>f. lam x. h(x,\<lambda>y. f`y))`x)"

definition letrec2 :: "[[i,i,i\<Rightarrow>i\<Rightarrow>i]\<Rightarrow>i,(i\<Rightarrow>i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  where "letrec2 (h, f) ==
    letrec (\<lambda>p g'. split(p,\<lambda>x y. h(x,y,\<lambda>u v. g'(<u,v>))), \<lambda>g'. f(\<lambda>x y. g'(<x,y>)))"

definition letrec3 :: "[[i,i,i,i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i]\<Rightarrow>i,(i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  where "letrec3 (h, f) ==
    letrec (\<lambda>p g'. split(p,\<lambda>x xs. split(xs,\<lambda>y z. h(x,y,z,\<lambda>u v w. g'(<u,<v,w>>)))),
      \<lambda>g'. f(\<lambda>x y z. g'(<x,<y,z>>)))"

syntax
  "_let" :: "[id,i,i]\<Rightarrow>i"  ("(3let _ be _/ in _)" [0,0,60] 60)
  "_letrec" :: "[id,id,i,i]\<Rightarrow>i"  ("(3letrec _ _ be _/ in _)" [0,0,0,60] 60)
  "_letrec2" :: "[id,id,id,i,i]\<Rightarrow>i"  ("(3letrec _ _ _ be _/ in _)" [0,0,0,0,60] 60)
  "_letrec3" :: "[id,id,id,id,i,i]\<Rightarrow>i"  ("(3letrec _ _ _ _ be _/ in _)" [0,0,0,0,0,60] 60)

ML \<open>
(** Quantifier translations: variable binding **)

(* FIXME does not handle "_idtdummy" *)
(* FIXME should use Syntax_Trans.mark_bound, Syntax_Trans.variant_abs' *)

fun let_tr [Free x, a, b] = Const(@{const_syntax let},dummyT) $ a $ absfree x b;
fun let_tr' [a,Abs(id,T,b)] =
     let val (id',b') = Syntax_Trans.variant_abs(id,T,b)
     in Const(@{syntax_const "_let"},dummyT) $ Free(id',T) $ a $ b' end;

fun letrec_tr [Free f, Free x, a, b] =
      Const(@{const_syntax letrec}, dummyT) $ absfree x (absfree f a) $ absfree f b;
fun letrec2_tr [Free f, Free x, Free y, a, b] =
      Const(@{const_syntax letrec2}, dummyT) $ absfree x (absfree y (absfree f a)) $ absfree f b;
fun letrec3_tr [Free f, Free x, Free y, Free z, a, b] =
      Const(@{const_syntax letrec3}, dummyT) $
        absfree x (absfree y (absfree z (absfree f a))) $ absfree f b;

fun letrec_tr' [Abs(x,T,Abs(f,S,a)),Abs(ff,SS,b)] =
     let val (f',b') = Syntax_Trans.variant_abs(ff,SS,b)
         val (_,a'') = Syntax_Trans.variant_abs(f,S,a)
         val (x',a') = Syntax_Trans.variant_abs(x,T,a'')
     in Const(@{syntax_const "_letrec"},dummyT) $ Free(f',SS) $ Free(x',T) $ a' $ b' end;
fun letrec2_tr' [Abs(x,T,Abs(y,U,Abs(f,S,a))),Abs(ff,SS,b)] =
     let val (f',b') = Syntax_Trans.variant_abs(ff,SS,b)
         val ( _,a1) = Syntax_Trans.variant_abs(f,S,a)
         val (y',a2) = Syntax_Trans.variant_abs(y,U,a1)
         val (x',a') = Syntax_Trans.variant_abs(x,T,a2)
     in Const(@{syntax_const "_letrec2"},dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ a' $ b'
      end;
fun letrec3_tr' [Abs(x,T,Abs(y,U,Abs(z,V,Abs(f,S,a)))),Abs(ff,SS,b)] =
     let val (f',b') = Syntax_Trans.variant_abs(ff,SS,b)
         val ( _,a1) = Syntax_Trans.variant_abs(f,S,a)
         val (z',a2) = Syntax_Trans.variant_abs(z,V,a1)
         val (y',a3) = Syntax_Trans.variant_abs(y,U,a2)
         val (x',a') = Syntax_Trans.variant_abs(x,T,a3)
     in Const(@{syntax_const "_letrec3"},dummyT) $ Free(f',SS) $ Free(x',T) $ Free(y',U) $ Free(z',V) $ a' $ b'
      end;
\<close>

parse_translation \<open>
 [(@{syntax_const "_let"}, K let_tr),
  (@{syntax_const "_letrec"}, K letrec_tr),
  (@{syntax_const "_letrec2"}, K letrec2_tr),
  (@{syntax_const "_letrec3"}, K letrec3_tr)]
\<close>

print_translation \<open>
 [(@{const_syntax let}, K let_tr'),
  (@{const_syntax letrec}, K letrec_tr'),
  (@{const_syntax letrec2}, K letrec2_tr'),
  (@{const_syntax letrec3}, K letrec3_tr')]
\<close>

definition nrec :: "[i,i,[i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "nrec(n,b,c) == letrec g x be ncase(x, b, \<lambda>y. c(y,g(y))) in g(n)"

definition nil :: "i"  ("([])")
  where "[] == inl(one)"

definition cons :: "[i,i]\<Rightarrow>i"  (infixr "$" 80)
  where "h$t == inr(<h,t>)"

definition lcase :: "[i,i,[i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "lcase(l,b,c) == when(l, \<lambda>x. b, \<lambda>y. split(y,c))"

definition lrec :: "[i,i,[i,i,i]\<Rightarrow>i]\<Rightarrow>i"
  where "lrec(l,b,c) == letrec g x be lcase(x, b, \<lambda>h t. c(h,t,g(t))) in g(l)"

definition napply :: "[i\<Rightarrow>i,i,i]\<Rightarrow>i"  ("(_ ^ _ ` _)" [56,56,56] 56)
  where "f ^n` a == nrec(n,a,\<lambda>x g. f(g))"

lemmas simp_can_defs = one_def inl_def inr_def
  and simp_ncan_defs = if_def when_def split_def fst_def snd_def thd_def
lemmas simp_defs = simp_can_defs simp_ncan_defs

lemmas ind_can_defs = zero_def succ_def nil_def cons_def
  and ind_ncan_defs = ncase_def nrec_def lcase_def lrec_def
lemmas ind_defs = ind_can_defs ind_ncan_defs

lemmas data_defs = simp_defs ind_defs napply_def
  and genrec_defs = letrec_def letrec2_def letrec3_def

subsection \<open>Beta Rules, including strictness\<close>

lemma letB: "\<not> t=bot \<Longrightarrow> let x be t in f(x) = f(t)"
  apply (unfold let_def)
  apply (erule rev_mp)
  apply (rule_tac t = "t" in term_case)
      apply (simp_all add: caseBtrue caseBfalse caseBpair caseBlam)
  done

lemma letBabot: "let x be bot in f(x) = bot"
  apply (unfold let_def)
  apply (rule caseBbot)
  done

lemma letBbbot: "let x be t in bot = bot"
  apply (unfold let_def)
  apply (rule_tac t = t in term_case)
      apply (rule caseBbot)
     apply (simp_all add: caseBtrue caseBfalse caseBpair caseBlam)
  done

lemma applyB: "(lam x. b(x)) ` a = b(a)"
  apply (unfold apply_def)
  apply (simp add: caseBtrue caseBfalse caseBpair caseBlam)
  done

lemma applyBbot: "bot ` a = bot"
  apply (unfold apply_def)
  apply (rule caseBbot)
  done

lemma fixB: "fix(f) = f(fix(f))"
  apply (unfold fix_def)
  apply (rule applyB [THEN ssubst], rule refl)
  done

lemma letrecB:
    "letrec g x be h(x,g) in g(a) = h(a,\<lambda>y. letrec g x be h(x,g) in g(y))"
  apply (unfold letrec_def)
  apply (rule fixB [THEN ssubst], rule applyB [THEN ssubst], rule refl)
  done

lemmas rawBs = caseBs applyB applyBbot

method_setup beta_rl = \<open>
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (CHANGED o
      simp_tac (ctxt addsimps @{thms rawBs} setloop (fn _ => stac ctxt @{thm letrecB}))))
\<close>

lemma ifBtrue: "if true then t else u = t"
  and ifBfalse: "if false then t else u = u"
  and ifBbot: "if bot then t else u = bot"
  unfolding data_defs by beta_rl+

lemma whenBinl: "when(inl(a),t,u) = t(a)"
  and whenBinr: "when(inr(a),t,u) = u(a)"
  and whenBbot: "when(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma splitB: "split(<a,b>,h) = h(a,b)"
  and splitBbot: "split(bot,h) = bot"
  unfolding data_defs by beta_rl+

lemma fstB: "fst(<a,b>) = a"
  and fstBbot: "fst(bot) = bot"
  unfolding data_defs by beta_rl+

lemma sndB: "snd(<a,b>) = b"
  and sndBbot: "snd(bot) = bot"
  unfolding data_defs by beta_rl+

lemma thdB: "thd(<a,<b,c>>) = c"
  and thdBbot: "thd(bot) = bot"
  unfolding data_defs by beta_rl+

lemma ncaseBzero: "ncase(zero,t,u) = t"
  and ncaseBsucc: "ncase(succ(n),t,u) = u(n)"
  and ncaseBbot: "ncase(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma nrecBzero: "nrec(zero,t,u) = t"
  and nrecBsucc: "nrec(succ(n),t,u) = u(n,nrec(n,t,u))"
  and nrecBbot: "nrec(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma lcaseBnil: "lcase([],t,u) = t"
  and lcaseBcons: "lcase(x$xs,t,u) = u(x,xs)"
  and lcaseBbot: "lcase(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma lrecBnil: "lrec([],t,u) = t"
  and lrecBcons: "lrec(x$xs,t,u) = u(x,xs,lrec(xs,t,u))"
  and lrecBbot: "lrec(bot,t,u) = bot"
  unfolding data_defs by beta_rl+

lemma letrec2B:
  "letrec g x y be h(x,y,g) in g(p,q) = h(p,q,\<lambda>u v. letrec g x y be h(x,y,g) in g(u,v))"
  unfolding data_defs letrec2_def by beta_rl+

lemma letrec3B:
  "letrec g x y z be h(x,y,z,g) in g(p,q,r) =
    h(p,q,r,\<lambda>u v w. letrec g x y z be h(x,y,z,g) in g(u,v,w))"
  unfolding data_defs letrec3_def by beta_rl+

lemma napplyBzero: "f^zero`a = a"
  and napplyBsucc: "f^succ(n)`a = f(f^n`a)"
  unfolding data_defs by beta_rl+

lemmas termBs = letB applyB applyBbot splitB splitBbot fstB fstBbot
  sndB sndBbot thdB thdBbot ifBtrue ifBfalse ifBbot whenBinl whenBinr
  whenBbot ncaseBzero ncaseBsucc ncaseBbot nrecBzero nrecBsucc
  nrecBbot lcaseBnil lcaseBcons lcaseBbot lrecBnil lrecBcons lrecBbot
  napplyBzero napplyBsucc

subsection \<open>Constructors are injective\<close>

lemma term_injs:
  "(inl(a) = inl(a')) \<longleftrightarrow> (a=a')"
  "(inr(a) = inr(a')) \<longleftrightarrow> (a=a')"
  "(succ(a) = succ(a')) \<longleftrightarrow> (a=a')"
  "(a$b = a'$b') \<longleftrightarrow> (a=a' \<and> b=b')"
  by (inj_rl applyB splitB whenBinl whenBinr ncaseBsucc lcaseBcons)

subsection \<open>Constructors are distinct\<close>

ML \<open>
ML_Thms.bind_thms ("term_dstncts",
  mkall_dstnct_thms @{context} @{thms data_defs} (@{thms ccl_injs} @ @{thms term_injs})
    [["bot","inl","inr"], ["bot","zero","succ"], ["bot","nil","cons"]]);
\<close>

subsection \<open>Rules for pre-order \<open>[=\<close>\<close>

lemma term_porews:
  "inl(a) [= inl(a') \<longleftrightarrow> a [= a'"
  "inr(b) [= inr(b') \<longleftrightarrow> b [= b'"
  "succ(n) [= succ(n') \<longleftrightarrow> n [= n'"
  "x$xs [= x'$xs' \<longleftrightarrow> x [= x' \<and> xs [= xs'"
  by (simp_all add: data_defs ccl_porews)

subsection \<open>Rewriting and Proving\<close>

ML \<open>
  ML_Thms.bind_thms ("term_injDs", XH_to_Ds @{thms term_injs});
\<close>

lemmas term_rews = termBs term_injs term_dstncts ccl_porews term_porews

lemmas [simp] = term_rews
lemmas [elim!] = term_dstncts [THEN notE]
lemmas [dest!] = term_injDs

end