(*  Title:      HOL/Examples/Ackermann.thy
    Author:     Larry Paulson
*)

section \<open>A Tail-Recursive, Stack-Based Ackermann's Function\<close>

theory Ackermann imports Main

begin

text\<open>This theory investigates a stack-based implementation of Ackermann's function.
Let's recall the traditional definition,
as modified by R{\'o}zsa P\'eter and Raphael Robinson.\<close>

fun ack :: "[nat,nat] \<Rightarrow> nat" where
  "ack 0 n             = Suc n"
| "ack (Suc m) 0       = ack m 1"
| "ack (Suc m) (Suc n) = ack m (ack (Suc m) n)"

text\<open>Here is the stack-based version, which uses lists.\<close>

function (domintros) ackloop :: "nat list \<Rightarrow> nat" where
  "ackloop (n # 0 # l)         = ackloop (Suc n # l)"
| "ackloop (0 # Suc m # l)     = ackloop (1 # m # l)"
| "ackloop (Suc n # Suc m # l) = ackloop (n # Suc m # m # l)"
| "ackloop [m] = m"
| "ackloop [] =  0"
  by pat_completeness auto

text\<open>
The key task is to prove termination. In the first recursive call, the head of the list gets bigger
while the list gets shorter, suggesting that the length of the list should be the primary
termination criterion. But in the third recursive call, the list gets longer. The idea of trying
a multiset-based termination argument is frustrated by the second recursive call when m = 0:
the list elements are simply permuted.

Fortunately, the function definition package allows us to define a function and only later identify its domain of termination.
Instead, it makes all the recursion equations conditional on satisfying
the function's domain predicate. Here we shall eventually be able
to show that the predicate is always satisfied.\<close>

text\<open>@{thm [display] ackloop.domintros[no_vars]}\<close>
declare ackloop.domintros [simp]

text \<open>Termination is trivial if the length of the list is less then two.
The following lemma is the key to proving termination for longer lists.\<close>
lemma "ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
proof (induction m arbitrary: n l)
  case 0
  then show ?case
    by auto
next
  case (Suc m)
  show ?case
    using Suc.prems
    by (induction n arbitrary: l) (simp_all add: Suc)
qed

text \<open>The proof above (which actually is unused) can be expressed concisely as follows.\<close>
lemma ackloop_dom_longer:
  "ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
  by (induction m n arbitrary: l rule: ack.induct) auto

text\<open>This function codifies what @{term ackloop} is designed to do.
Proving the two functions equivalent also shows that @{term ackloop} can be used
to compute Ackermann's function.\<close>
fun acklist :: "nat list \<Rightarrow> nat" where
  "acklist (n#m#l) = acklist (ack m n # l)"
| "acklist [m] = m"
| "acklist [] =  0"

text\<open>The induction rule for @{term acklist} is @{thm [display] acklist.induct[no_vars]}.\<close>

lemma ackloop_dom: "ackloop_dom l"
  by (induction l rule: acklist.induct) (auto simp: ackloop_dom_longer)

termination ackloop
  by (simp add: ackloop_dom)

text\<open>This result is trivial even by inspection of the function definitions
(which faithfully follow the definition of Ackermann's function).
All that we needed was termination.\<close>
lemma ackloop_acklist: "ackloop l = acklist l"
  by (induction l rule: ackloop.induct) auto

theorem ack: "ack m n = ackloop [n,m]"
  by (simp add: ackloop_acklist)

end


theory Concrete_semantic
imports Main
begin
(*2.2.1 P7*)
datatype bool=True|False
fun conj::"bool\<Rightarrow>bool\<Rightarrow>bool"
  where
"conj True True=True"|
"conj _ _=False"

(*------------------*)
(*2.2.2 P8*)
fun add::"nat\<Rightarrow>nat\<Rightarrow>nat"
where
"add 0 n =n"|
"add(Suc m) n=Suc(add m n)"
lemma add_02:"add m 0=m"
apply(induction m)
apply(auto)
  done
(*------------------*)

(*2.2.3 P10,11*)
datatype 'a list = Nil | Cons 'a "'a list"

fun app::"'a list\<Rightarrow>'a list \<Rightarrow>'a list"
where
"app Nil ys = ys" |
"app(Cons x xs) ys=Cons x(app xs ys)"

fun rev::" 'a list\<Rightarrow>'a list"
where
"rev Nil = Nil " |
"rev(Cons x xs)=app(rev xs)(Cons x Nil)"
value "rev(Cons True (Cons False Nil))"
value "rev(Cons a (Cons b Nil))"
lemma app_Nil2 [simp]:"app xs Nil = xs"
  apply(induction xs)
  apply(auto)
  done
lemma app_assoc [simp]: "app (app xs ys) zs = app xs (app ys zs)"
  apply(induction xs)
  apply(auto)
  done
lemma rev_app [simp]:"rev(app xs ys) = app(rev ys)(rev xs)"
apply (induction xs)
   apply(auto)
  done
lemma rev_rev [simp]: "rev (rev xs) =xs"
  apply (induction xs)
   apply(auto)
  done
(*-------------------*)

(*2.2.5 P14*)
fun map::"('a\<Rightarrow>'b) \<Rightarrow> 'a list \<Rightarrow>'b list"
  where
"map f Nil=Nil"|
"map f (Cons x xs) = Cons (f x) (map f xs)"
(*-------------------*)

(*Exercises P15*)

(*2.1*)
value"1+(2::nat)"
value"1+(2::int)"
value"1-(2::nat)"
value"1-(2::int)"
(*--------------*)

(*exercise2.2*)
fun double::"nat \<Rightarrow>nat" where
"double 0=add 0 0"|
"double n=add(add n 0) n"
lemma add_com: "add m n=add n m"
apply(induction m)
   apply(auto)
fun add_1::"nat\<Rightarrow>nat"where
"add_1 add (add 0 n)p=add 0(add n p)"|
"add_1 add (add (Suc m)n) p=add (Sucm) (add n p)"

(*2.3.1 P16*)
(*e1*)
datatype 'a tree=Tip | Node "'a tree" 'a "'a tree"
fun mirror::"'a tree\<Rightarrow>'a tree"
  where
"mirror Tip=Tip"|
"mirror(Node l a r) = Node (mirror r) a (mirror l)"
lemma "mirror(mirror t) =t"
  apply(induction t)
   apply(auto)
  done
(*e2*)
datatype 'a option=None | Some 'a
fun lookup::"('a *'b)list \<Rightarrow> 'a \<Rightarrow> 'b option"
  where
"lookup [] x= None"|
"lookup ((a,b)#ps)x= (if a=x then Some b else lookup ps x)"

(*-------------------*)

(*2.3.2 P17*)
definition sq::"nat\<Rightarrow>nat"where
"sq n=n*n"
(*-------------------*)

(*2.3.3 P17*)
abbreviation sq' :: "nat\<Rightarrow>nat" where(*? ? ?*)
"sq' n=n*n"
(*------------------*)

(*2.3.4*)
fun div2::"nat\<Rightarrow>nat"where
"div2 0= 0"|
"div2 (Suc 0) = 0"|
"div2 (Suc (Suc n)) =Suc(div2 n)"
lemma "div2(n) = n div 2"
  apply(induction n rule:div2.induct)
  apply(auto)
  done
(*-------------------*)

(*2.4 P20*)
fun itrev::"'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
"itrev []      ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"
lemma "itrev xs [] = rev xs"
  apply(induction xs)
  apply(auto)
lemma "itrev xs ys=rev xs @ ys"
  apply(induction xs arbitrary: ys)
  apply(auto)
  done
(*---------------*)

(*3.12 P29*)
type_synonym vname=string
datatype aexp=N int | V vname | Plud aexp aexp
type_synonym val=int
type_synonym state = vname\<Rightarrow>val(*? ? ?*)
fun aval::"aexp \<Rightarrow> state \<Rightarrow> val"
  where
"aval (N n) s =n"|
"aval (V x) s=s x"|
"aval (Plus a b)s=aval a s +aval b s"

value "aval (Plus (N 3)(V ''x'')) (\<lambda>x.0)"


text \<open>Authors: Anthony Bordg and Lawrence Paulson,
with some contributions from Wenda Li\<close>

theory Topological_Space
  imports Complex_Main
          "Jacobson_Basic_Algebra.Set_Theory"
          Set_Extras
          Sketch_and_Explore
          HOL.Filter

begin

section \<open>Topological Spaces\<close>

locale topological_space = fixes S :: "'a set" and is_open :: "'a set \<Rightarrow> bool"
  assumes open_space [simp, intro]: "is_open S" and open_empty [simp, intro]: "is_open {}"
    and open_imp_subset: "is_open U \<Longrightarrow> U \<subseteq> S"
    and open_inter [intro]: "\<lbrakk>is_open U; is_open V\<rbrakk> \<Longrightarrow> is_open (U \<inter> V)"
    and open_union [intro]: "\<And>F::('a set) set. (\<And>x. x \<in> F \<Longrightarrow> is_open x) \<Longrightarrow> is_open (\<Union>x\<in>F. x)"

begin

definition is_closed :: "'a set \<Rightarrow> bool"
  where "is_closed U \<equiv> U \<subseteq> S \<and> is_open (S - U)"

definition neighborhoods:: "'a \<Rightarrow> ('a set) set"
  where "neighborhoods x \<equiv> {U. is_open U \<and> x \<in> U}"

text \<open>Note that by a neighborhood we mean what some authors call an open neighborhood.\<close>

lemma open_union' [intro]: "\<And>F::('a set) set. (\<And>x. x \<in> F \<Longrightarrow> is_open x) \<Longrightarrow> is_open (\<Union>F)"
  using open_union by auto

lemma open_preimage_identity [simp]: "is_open B \<Longrightarrow> identity S \<^sup>\<inverse> S B = B"
  by (metis inf.orderE open_imp_subset preimage_identity_self)

definition is_connected:: "bool" where
"is_connected \<equiv> \<not> (\<exists>U V. is_open U \<and> is_open V \<and> (U \<noteq> {}) \<and> (V \<noteq> {}) \<and> (U \<inter> V = {}) \<and> (U \<union> V = S))"

definition is_hausdorff:: "bool" where
"is_hausdorff \<equiv>
\<forall>x y. (x \<in> S \<and> y \<in> S \<and> x \<noteq> y) \<longrightarrow> (\<exists>U V. U \<in> neighborhoods x \<and> V \<in> neighborhoods y \<and> U \<inter> V = {})"

end (* topological_space *)

text \<open>T2 spaces are also known as Hausdorff spaces.\<close>

locale t2_space = topological_space +
  assumes hausdorff: "is_hausdorff"

subsection \<open>Topological Basis\<close>

inductive generated_topology :: "'a set \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> bool"
    for S :: "'a set" and B :: "'a set set"
  where
    UNIV: "generated_topology S B S"
  | Int: "generated_topology S B (U \<inter> V)"
            if "generated_topology S B U" and "generated_topology S B V"
  | UN: "generated_topology S B (\<Union>K)" if "(\<And>U. U \<in> K \<Longrightarrow> generated_topology S B U)"
  | Basis: "generated_topology S B b" if "b \<in> B \<and> b \<subseteq> S"

lemma generated_topology_empty [simp]: "generated_topology S B {}"
  by (metis UN Union_empty empty_iff)

lemma generated_topology_subset: "generated_topology S B U \<Longrightarrow> U \<subseteq> S"
  by (induct rule:generated_topology.induct) auto

lemma generated_topology_is_topology:
  fixes S:: "'a set" and B:: "'a set set"
  shows "topological_space S (generated_topology S B)"
  by (simp add: Int UN UNIV generated_topology_subset topological_space_def)

subsection \<open>Covers\<close>

locale cover_of_subset =
  fixes X:: "'a set" and U:: "'a set" and index:: "real set" and cover:: "real \<Rightarrow> 'a set"
(* We use real instead of index::"'b set" otherwise we get some troubles with locale sheaf_of_rings
in Comm_Ring_Theory.thy *)
  assumes is_subset: "U \<subseteq> X" and are_subsets: "\<And>i. i \<in> index \<Longrightarrow> cover i \<subseteq> X"
and covering: "U \<subseteq> (\<Union>i\<in>index. cover i)"
begin

lemma
  assumes "x \<in> U"
  shows "\<exists>i\<in>index. x \<in> cover i"
  using assms covering by auto

definition select_index:: "'a \<Rightarrow> real"
  where "select_index x \<equiv> SOME i. i \<in> index \<and> x \<in> cover i"

lemma cover_of_select_index:
  assumes "x \<in> U"
  shows "x \<in> cover (select_index x)"
  using assms by (metis (mono_tags, lifting) UN_iff covering select_index_def someI_ex subset_iff)

lemma select_index_belongs:
  assumes "x \<in> U"
  shows "select_index x \<in> index"
  using assms by (metis (full_types, lifting) UN_iff covering in_mono select_index_def tfl_some)

end (* cover_of_subset *)

locale open_cover_of_subset = topological_space X is_open + cover_of_subset X U I C
  for X and is_open and U and I and C +
  assumes are_open_subspaces: "\<And>i. i\<in>I \<Longrightarrow> is_open (C i)"
begin

lemma cover_of_select_index_is_open:
  assumes "x \<in> U"
  shows "is_open (C (select_index x))"
  using assms by (simp add: are_open_subspaces select_index_belongs)

end (* open_cover_of_subset *)

locale open_cover_of_open_subset = open_cover_of_subset X is_open U I C
  for X and is_open and U and I and C +
  assumes is_open_subset: "is_open U"

subsection \<open>Induced Topology\<close>

locale ind_topology = topological_space X is_open for X and is_open +
  fixes S:: "'a set"
  assumes is_subset: "S \<subseteq> X"
begin

definition ind_is_open:: "'a set \<Rightarrow> bool"
  where "ind_is_open U \<equiv> U \<subseteq> S \<and> (\<exists>V. V \<subseteq> X \<and> is_open V \<and> U = S \<inter> V)"

lemma ind_is_open_S [iff]: "ind_is_open S"
    by (metis ind_is_open_def inf.orderE is_subset open_space order_refl)

lemma ind_is_open_empty [iff]: "ind_is_open {}"
    using ind_is_open_def by auto

lemma ind_space_is_top_space:
  shows "topological_space S (ind_is_open)"
proof
  fix U V
  assume "ind_is_open U" then obtain UX where "UX \<subseteq> X" "is_open UX" "U = S \<inter> UX"
    using ind_is_open_def by auto
  moreover
  assume "ind_is_open V" then obtain VX where "VX \<subseteq> X" "is_open VX" "V = S \<inter> VX"
    using ind_is_open_def by auto
  ultimately have "is_open (UX \<inter> VX) \<and> (U \<inter> V = S \<inter> (UX \<inter> VX))" using open_inter by auto
  then show "ind_is_open (U \<inter> V)"
    by (metis \<open>UX \<subseteq> X\<close> ind_is_open_def le_infI1 subset_refl)
next
  fix F
  assume F: "\<And>x. x \<in> F \<Longrightarrow> ind_is_open x"
  obtain F' where F': "\<And>x. x \<in> F \<and> ind_is_open x \<Longrightarrow> is_open (F' x) \<and> x = S \<inter> (F' x)"
    using ind_is_open_def by metis
  have "is_open (\<Union> (F' ` F))"
    by (metis (mono_tags, lifting) F F' imageE image_ident open_union)
  moreover
  have "(\<Union>x\<in>F. x) = S \<inter> \<Union> (F' ` F)"
    using F' \<open>\<And>x. x \<in> F \<Longrightarrow> ind_is_open x\<close> by fastforce
  ultimately show "ind_is_open (\<Union>x\<in>F. x)"
    by (metis ind_is_open_def inf_sup_ord(1) open_imp_subset)
next
  show "\<And>U. ind_is_open U \<Longrightarrow> U \<subseteq> S"
    by (simp add: ind_is_open_def)
qed auto

lemma is_open_from_ind_is_open:
  assumes "is_open S" and "ind_is_open U"
  shows "is_open U"
  using assms open_inter ind_is_open_def is_subset by auto

lemma open_cover_from_ind_open_cover:
  assumes "is_open S" and "open_cover_of_open_subset S ind_is_open U I C"
  shows "open_cover_of_open_subset X is_open U I C"
proof
  show "is_open U"
    using assms is_open_from_ind_is_open open_cover_of_open_subset.is_open_subset by blast
  show "\<And>i. i \<in> I \<Longrightarrow> is_open (C i)"
    using assms is_open_from_ind_is_open open_cover_of_open_subset_def open_cover_of_subset.are_open_subspaces by blast
  show "\<And>i. i \<in> I \<Longrightarrow> C i \<subseteq> X"
    using assms(2) is_subset
    by (meson cover_of_subset_def open_cover_of_open_subset_def open_cover_of_subset_def subset_trans)
  show "U \<subseteq> X"
    by (simp add: \<open>is_open U\<close> open_imp_subset)
  show "U \<subseteq> \<Union> (C ` I)"
    by (meson assms(2) cover_of_subset_def open_cover_of_open_subset_def open_cover_of_subset_def)
qed

end (* induced topology *)

lemma (in topological_space) ind_topology_is_open_self [iff]: "ind_topology S is_open S"
  by (simp add: ind_topology_axioms_def ind_topology_def topological_space_axioms)

lemma (in topological_space) ind_topology_is_open_empty [iff]: "ind_topology S is_open {}"
  by (simp add: ind_topology_axioms_def ind_topology_def topological_space_axioms)

lemma (in topological_space) ind_is_open_iff_open:
  shows "ind_topology.ind_is_open S is_open S U \<longleftrightarrow> is_open U \<and> U \<subseteq> S"
  by (metis ind_topology.ind_is_open_def ind_topology_is_open_self inf.absorb_iff2)

subsection \<open>Continuous Maps\<close>

locale continuous_map = source: topological_space S is_open + target: topological_space S' is_open'
+ map f S S'
  for S and is_open and S' and is_open' and f +
  assumes is_continuous: "\<And>U. is_open' U \<Longrightarrow> is_open (f\<^sup>\<inverse> S U)"
begin

lemma open_cover_of_open_subset_from_target_to_source:
  assumes "open_cover_of_open_subset S' is_open' U I C"
  shows "open_cover_of_open_subset S is_open (f\<^sup>\<inverse> S U) I (\<lambda>i. f\<^sup>\<inverse> S (C i))"
proof
  show "f \<^sup>\<inverse> S U \<subseteq> S" by simp
  show "f \<^sup>\<inverse> S (C i) \<subseteq> S" if "i \<in> I" for i
    using that by simp
  show "is_open (f \<^sup>\<inverse> S U)"
    by (meson assms is_continuous open_cover_of_open_subset.is_open_subset)
  show "\<And>i. i \<in> I \<Longrightarrow> is_open (f \<^sup>\<inverse> S (C i))"
    by (meson assms is_continuous open_cover_of_open_subset_def open_cover_of_subset.are_open_subspaces)
  show "f \<^sup>\<inverse> S U \<subseteq> (\<Union>i\<in>I. f \<^sup>\<inverse> S (C i))"
    using assms unfolding open_cover_of_open_subset_def cover_of_subset_def open_cover_of_subset_def
    by blast
qed

end (* continuous map *)

subsection \<open>Homeomorphisms\<close>

text \<open>The topological isomorphisms between topological spaces are called homeomorphisms.\<close>

locale homeomorphism =
  continuous_map + bijective_map f S S' +
  continuous_map S' is_open' S is_open "inverse_map f S S'"

lemma (in topological_space) id_is_homeomorphism:
  shows "homeomorphism S is_open S is_open (identity S)"
proof
  show "inverse_map (identity S) S S \<in> S \<rightarrow>\<^sub>E S"
    by (simp add: inv_into_into inverse_map_def)
qed (auto simp: open_inter bij_betwI')

subsection \<open>Topological Filters\<close> (* Imported from HOL.Topological_Spaces *)

definition (in topological_space) nhds :: "'a \<Rightarrow> 'a filter"
  where "nhds a = (INF S\<in>{S. is_open S \<and> a \<in> S}. principal S)"

abbreviation (in topological_space)
  tendsto :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b filter \<Rightarrow> bool"  (infixr "\<longlongrightarrow>" 55)
  where "(f \<longlongrightarrow> l) F \<equiv> filterlim f (nhds l) F"

definition (in t2_space) Lim :: "'f filter \<Rightarrow> ('f \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "Lim A f = (THE l. (f \<longlongrightarrow> l) A)"

end


theory Prog_Prove_3_5
  imports Main
begin

inductive ev:: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc (Suc n)) = evn n"

lemma "ev m \<Longrightarrow> evn m"
apply(induction rule: ev.induct)
  by(simp_all)

lemma "ev(Suc(Suc(Suc(Suc 0))))"
  apply(rule evSS)
  apply(rule evSS)
  apply(rule ev0)
  done

lemma "evn n \<Longrightarrow> ev n"
  apply(induction n rule: evn.induct)
  by(simp_all add: ev0 evSS)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
  apply(assumption)
  apply(metis step)
  done

lemma star_pre: "\<lbrakk>r x y; star r y z\<rbrakk> \<Longrightarrow> star r x z"
  by (rule step)

lemma star_ap: "\<lbrakk>star r x y; r y z\<rbrakk> \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(auto intro: star.intros)
  done

inductive palindrome:: "'a list \<Rightarrow> bool" where
emp: "palindrome []" |
sing: "palindrome [x]" |
list: "palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply(induction rule: palindrome.induct)
  by(simp_all)

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma star'_ap: "\<lbrakk>star' r y z; r x y\<rbrakk> \<Longrightarrow> star' r x z"
  apply(induction rule: star'.induct)
   apply(auto intro: star'.intros)
  done

(*
why this lemma couldn't be shown?
lemma star'_pre: "\<lbrakk>r x y; star' r y z\<rbrakk> \<Longrightarrow> star' r x z"
  apply(induction rule: star'.induct)
  done
*)

lemma "star' r x y \<Longrightarrow> star r x y"
  apply(induction rule: star'.induct)
   apply(rule refl)
    apply(auto intro:  star_ap)
  done

lemma "star r x y \<Longrightarrow> star' r x y"
  apply(induction rule: star.induct)
   apply(rule refl')
    apply(auto intro: star'_ap)
  done

inductive iter:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter_refl: "iter r n x x" |
iter_step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r n x z"

lemma iter_ap: "\<lbrakk> r x y; iter r n y z\<rbrakk> \<Longrightarrow> iter r n x z"
  by (rule iter_step)

lemma "star r x y \<Longrightarrow> iter r n x y"
  apply(induction rule: star.induct)
   apply(rule iter_refl)
  apply(auto intro: iter_ap)
  done

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
s_emp: "S[]" |
s_list: "S xs \<Longrightarrow> S (a # xs @ [b])" |
s_const: "S xs \<Longrightarrow> S ys \<Longrightarrow> S(xs@ys)"

inductive T :: "alpha list \<Rightarrow> bool" where
t_emp: "T[]" |
t_const: "T xs \<Longrightarrow> T ys \<Longrightarrow>  T(a # xs @ b # ys)"

lemma s_formed_for_t: "S xs \<Longrightarrow> S ys \<Longrightarrow> S (a # xs @ b # ys)"
  using s_const s_emp s_list apply force
  done

lemma TS: "T w \<Longrightarrow> S w"
  apply(induction rule: T.induct)
   apply(rule s_emp)
  apply(auto intro: s_formed_for_t)
  done

lemma t_formed_for_s: " T xs \<Longrightarrow>  T ys \<Longrightarrow> T (xs @ ys)"
  apply(induction rule: T.induct)
   apply simp
  by (simp add: t_const)

lemma ST: "S w \<Longrightarrow> T w"
  apply(induction rule: S.induct)
  apply(rule t_emp)
   apply(auto intro: t_formed_for_s)
  by (simp add: t_const t_emp)

corollary SeqT: "S w \<longleftrightarrow> T w"
  using ST TS by blast

(* Exercise 4.6 *)

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus x y) s = aval x s + aval y s"

inductive aval_rel2 :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
rel_nat: "aval_rel2 (N n) s n" |
rel_var: "s x = n \<Longrightarrow> aval_rel2 (V x) s n" |
rel_plus: "(aval_rel2 x s n1) \<Longrightarrow>  (aval_rel2 y s n2) \<Longrightarrow> aval_rel2 (Plus x y) s (n1 + n2)"

lemma aval_rel_to_aval: "aval_rel2 x s v \<Longrightarrow> (aval x s = v)"
  apply(induction rule: aval_rel2.induct)
  apply(auto)
  done

lemma aval_to_aval_rel: "(aval x s = v) \<Longrightarrow> aval_rel2 x s v"
  apply(induction x arbitrary: v)
(*    apply (simp add: rel_nat)
   apply (simp add: rel_var)
 apply (simp add: rel_plus) *)
  apply(auto intro: rel_nat rel_var rel_plus)
  done

lemma "(aval_rel2 x s v) \<longleftrightarrow> (aval x s = v)"
  apply(auto simp add: aval_rel_to_aval)
  apply(auto simp add: aval_to_aval_rel)
  done

(* Exercise 4.7. *)

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = n # stk" |
"exec1 (LOAD x) s stk = s(x) # stk" |
"exec1 ADD _ (j # i # stk) = (i + j) # stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i#is) s stk = exec is s (exec1 i s stk)"

lemma exec_division: "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk)"
  apply(induction is1 arbitrary:stk)
   apply(auto)
  done

lemma exec_append: "exec is\<^sub>1 s stk = stk' \<Longrightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s stk'"
apply(induction is\<^sub>1 arbitrary: stk)
apply(auto)
done

fun comp:: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma "exec (comp x) s stk = aval x s # stk"
  apply(induction x arbitrary:stk)
    apply(auto simp add: exec_division )
  done

(* the size of the execution become + 1 when LOADI or LOAD
but when ADD which is compiled and become -1.
*)
inductive  ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
ok_emp: "ok n [] n" |
ok_LOADI: "ok n is n'  \<Longrightarrow> ok n (is @ [LOADI _]) (n' + 1)" |
ok_LOAD: "ok n is n'  \<Longrightarrow> ok n (is @ [LOAD _]) (n' + 1)" |
(* when n' = 0 or 1, n' -1 would be not nat*)
ok_ADD: "ok n is (n' + 2)   \<Longrightarrow> ok n (is @ [ADD]) (n' + 1)"

(*
lemma "length (exec is s stk) = Suc (Suc n') \<Longrightarrow>
       length (exec1 ADD s (exec is s stk)) = Suc n'"
  by (smt Nitpick.size_list_simp(2) add_diff_cancel_left' exec1.elims instr.distinct(3) instr.distinct(5) list.sel(3) nat.distinct(1) null_rec(1) null_rec(2) plus_1_eq_Suc)
*)

lemma "\<lbrakk>ok n is n'; length stk = n \<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
  apply(induction rule: ok.induct)
    apply(auto simp add: exec_division)
  by (smt exec1.elims instr.distinct(3) instr.distinct(5) length_Cons list.size(3) nat.distinct(1) nat.inject)

 (* The followings are timed-out:
  by (smt exec1.elims instr.distinct(3) instr.distinct(5) length_Cons list.size(3) nat.distinct(1) nat.inject)
  by (smt Nitpick.size_list_simp(2) add_left_cancel exec1.elims instr.distinct(3) instr.distinct(5) length_Cons nat.distinct(1) plus_1_eq_Suc)
*)

(* the followings are copied and pasted from following github:
https://github.com/cmr/ConcreteSemantics/blob/master/CS_Ch4.thy

I couldn't understand what have done and how to know this proof.
*)

(* TODO: try again!*)
lemma ok_append: "ok n (e2) n' \<Longrightarrow> ok n'' (e1) n \<Longrightarrow> ok n'' (e1 @ e2) n'"
apply(induction rule: ok.induct)
apply(simp)
apply (metis append_assoc ok.simps)
apply (metis append_assoc ok.simps)
apply (metis append_assoc ok.simps)
done

lemma "ok n (comp x) (Suc n)"
apply(induction x arbitrary: n)

using ok_LOADI ok_emp apply fastforce
using ok_LOAD ok_emp apply fastforce
using ok_ADD ok_append apply fastforce
  done

end