(*
This file is a part of IsarMathLib -
a library of formalized mathematics for Isabelle/Isar.

Copyright (C) 2021  Slawomir Kolodynski

This program is free software; Redistribution and use in source and binary forms,
with or without modification, are permitted provided that the
following conditions are met:

1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open> Loops \<close>

theory Loop_ZF imports Quasigroup_ZF

begin

text\<open>This theory specifies the definition and proves basic  properites of loops.
  Loops are very similar to groups, the only property that is missing is associativity
  of the operation.\<close>

subsection\<open> Definitions and notation \<close>

text\<open> In this section we define the notions of identity element and left and right inverse. \<close>

text\<open> A loop is a quasigroup with an identity elemen. \<close>

definition "IsAloop(G,A) \<equiv> IsAquasigroup(G,A) \<and> (\<exists>e\<in>G. \<forall>x\<in>G. A`\<langle>e,x\<rangle> = x \<and> A`\<langle>x,e\<rangle> = x)"

text\<open> The neutral element for a binary operation $A:G\times G \rightarrow G $ is defined
  as the only element $e$ of $G$ such that $A\langle x,e\rangle = x$ and $A\langle e,x\rangle = x$
  for all $x\in G$. Note that although the loop definition guarantees the existence of (some)
  such element(s) at this point we do not know if this element is unique.
  We can define this notion   h ere but it will become usable only after we prove uniqueness. \<close>

definition
 "TheNeutralElement(G,f) \<equiv>
  ( THE e. e\<in>G \<and> (\<forall> g\<in>G. f`\<langle>e,g\<rangle> = g \<and> f`\<langle>g,e\<rangle> = g))"

text\<open>We will reuse the notation defined in the \<open>quasigroup0\<close> locale,
  just adding the assumption about the existence of a neutral element and notation for it.\<close>

locale loop0 = quasigroup0 +
  assumes ex_ident: "\<exists>e\<in>G. \<forall>x\<in>G. e\<cdot>x = x \<and> x\<cdot>e = x"

  fixes neut ("\<one>")
  defines neut_def[simp]: "\<one> \<equiv> TheNeutralElement(G,A)"

text\<open> In the loop context the pair \<open>(G,A)\<close> forms a loop. \<close>

lemma (in loop0) is_loop: shows "IsAloop(G,A)"
  unfolding IsAloop_def using ex_ident qgroupassum by simp

text\<open>If we know that a pair \<open>(G,A)\<close> forms a loop then the assumptions of the \<open>loop0\<close> locale hold. \<close>

lemma loop_loop0_valid: assumes "IsAloop(G,A)" shows "loop0(G,A)"
  using assms unfolding IsAloop_def loop0_axioms_def quasigroup0_def loop0_def
  by auto

text\<open>The neutral element is unique in the loop. \<close>

lemma (in loop0) neut_uniq_loop: shows
  "\<exists>!e. e\<in>G \<and> (\<forall>x\<in>G. e\<cdot>x = x \<and> x\<cdot>e = x)"
proof
  from ex_ident show "\<exists>e. e \<in> G \<and> (\<forall>x\<in>G. e \<cdot> x = x \<and> x \<cdot> e = x)" by auto
next
  fix e y
  assume "e \<in> G \<and> (\<forall>x\<in>G. e \<cdot> x = x \<and> x \<cdot> e = x)"  "y \<in> G \<and> (\<forall>x\<in>G. y \<cdot> x = x \<and> x \<cdot> y = x)"
  then have "e\<cdot>y =y" and "e\<cdot>y = e" by auto
  thus "e=y" by simp
qed

text\<open> The neutral element as defined in the \<open>loop0\<close> locale is indeed neutral. \<close>

lemma (in loop0) neut_props_loop: shows "\<one>\<in>G" and "\<forall>x\<in>G. \<one>\<cdot>x =x \<and> x\<cdot>\<one> = x"
proof -
  let ?n = "THE e. e\<in>G \<and> (\<forall>x\<in>G. e\<cdot>x = x \<and> x\<cdot>e = x)"
  have "\<one> = TheNeutralElement(G,A)" by simp
  then have "\<one> = ?n" unfolding TheNeutralElement_def by simp
  moreover have "?n\<in>G \<and> (\<forall>x\<in>G. ?n\<cdot>x = x \<and> x\<cdot>?n = x)" using neut_uniq_loop theI
    by simp
  ultimately show "\<one>\<in>G" and "\<forall>x\<in>G. \<one>\<cdot>x = x \<and> x\<cdot>\<one> = x"
    by auto
qed

text\<open>Every element of a loop has unique left and right inverse (which need not be the same).
  Here we define the left inverse as a function on $G$. \<close>

definition
  "LeftInv(G,A) \<equiv> {\<langle>x,\<Union>{y\<in>G. A`\<langle>y,x\<rangle> = TheNeutralElement(G,A)}\<rangle>. x\<in>G}"

text\<open>Definition of the right inverse as a function on $G$: \<close>

definition
  "RightInv(G,A) \<equiv> {\<langle>x,\<Union>{y\<in>G. A`\<langle>x,y\<rangle> = TheNeutralElement(G,A)}\<rangle>. x\<in>G}"

text\<open>In a loop $G$ right and left inverses are functions on $G$. \<close>

lemma (in loop0) lr_inv_fun: shows "LeftInv(G,A):G\<rightarrow>G" "RightInv(G,A):G\<rightarrow>G"
  unfolding LeftInv_def RightInv_def
  using neut_props_loop lrdiv_props(1,4) ZF1_1_L9 ZF_fun_from_total
  by auto

text\<open>Right and left inverses have desired properties.\<close>

lemma (in loop0) lr_inv_props: assumes "x\<in>G"
  shows
    "LeftInv(G,A)`(x) \<in> G" "(LeftInv(G,A)`(x))\<cdot>x = \<one>"
    "RightInv(G,A)`(x) \<in> G" "x\<cdot>(RightInv(G,A)`(x)) = \<one>"
proof -
  from assms show "LeftInv(G,A)`(x) \<in> G" and "RightInv(G,A)`(x) \<in> G"
    using lr_inv_fun apply_funtype by auto
  from assms have "\<exists>!y. y\<in>G \<and> y\<cdot>x = \<one>"
    using neut_props_loop(1) lrdiv_props(1) by simp
  then have "(\<Union>{y\<in>G.  y\<cdot>x = \<one>})\<cdot>x = \<one>"
    by (rule ZF1_1_L9)
  with assms show "(LeftInv(G,A)`(x))\<cdot>x = \<one>"
    using lr_inv_fun(1) ZF_fun_from_tot_val unfolding LeftInv_def by simp
  from assms have "\<exists>!y. y\<in>G \<and> x\<cdot>y = \<one>"
    using neut_props_loop(1) lrdiv_props(4) by simp
  then have "x\<cdot>(\<Union>{y\<in>G.  x\<cdot>y = \<one>}) = \<one>"
    by (rule ZF1_1_L9)
  with assms show "x\<cdot>(RightInv(G,A)`(x)) = \<one>"
    using lr_inv_fun(2) ZF_fun_from_tot_val unfolding RightInv_def by simp
qed

end


theory KAT_Module
  imports KAT
begin

context complete_boolean_lattice
begin

  lemma double_neg: "x \<in> carrier A \<Longrightarrow> !(!x) = x"
    by (metis (lifting) ccompl_bot ccompl_closed ccompl_top ccompl_uniq join_comm meet_comm)

end

locale kat_module' =
  fixes K :: "'a test_algebra"
  and A :: "('b, 'c) ord_scheme"
  and scalar_product :: "'b \<Rightarrow> 'a \<Rightarrow> 'b"
  assumes kat_subalg: "kat K"
  and cbl_subalg: "complete_boolean_lattice A"
  and mk_type: "scalar_product : carrier A \<rightarrow> carrier K \<rightarrow> carrier A"

sublocale kat_module' \<subseteq> kat K using kat_subalg .
sublocale kat_module' \<subseteq> A: complete_boolean_lattice A using cbl_subalg .

no_notation
  Groups.plus_class.plus (infixl "+" 65) and
  Groups.zero_class.zero ("0") and
  Dioid.plus (infixl "+\<index>" 70) and
  Dioid.mult (infixl "\<cdot>\<index>" 80) and
  Dioid.one ("1\<index>") and
  Dioid.zero ("0") and
  Kleene_Algebra.star ("_\<^sup>\<star>\<index>" [101] 100) and
  KAT.kat.complement ("!")

context kat_module'
begin

  abbreviation plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "+" 70) where
    "p + q \<equiv> dioid.plus K p q"

  abbreviation mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<cdot>" 80) where
     "p\<cdot>q \<equiv> dioid.mult K p q"

  abbreviation one :: "'a" ("1") where "1 \<equiv> Dioid.one K"

  abbreviation zero :: "'a" ("0") where "0 \<equiv> Dioid.zero K"

  abbreviation module :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "\<Colon>" 75) where
    "m \<Colon> p \<equiv> scalar_product m p"

  abbreviation star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100) where
    "x\<^sup>\<star> \<equiv> Kleene_Algebra.star K x"

  notation
    nat_order (infixl "\<preceq>" 50)

  notation
    complement ("!")

end

locale kat_module = kat_module' +
  assumes mod_plus: "\<lbrakk>p \<in> carrier K; q \<in> carrier K; m \<in> carrier A\<rbrakk> \<Longrightarrow> m \<Colon> (p + q) = m \<Colon> p \<squnion> m \<Colon> q"
  and mod_mult: "\<lbrakk>p \<in> carrier K; q \<in> carrier K; m \<in> carrier A\<rbrakk> \<Longrightarrow> m \<Colon> (p\<cdot>q) = m \<Colon> p \<Colon> q"
  and mod_join: "\<lbrakk>p \<in> carrier K; P \<in> carrier A; Q \<in> carrier A\<rbrakk> \<Longrightarrow> (P \<squnion> Q) \<Colon> p = P \<Colon> p \<squnion> Q \<Colon> p"
  and mod_zero: "m \<in> carrier A \<Longrightarrow> m \<Colon> 0 = complete_join_semilattice.bot A"
  and mod_star: "\<lbrakk>m \<in> carrier A; n \<in> carrier A; p \<in> carrier K\<rbrakk> \<Longrightarrow> m \<squnion> n \<Colon> p \<sqsubseteq>\<^bsub>A\<^esub> n \<Longrightarrow> m \<Colon> p\<^sup>\<star> \<sqsubseteq>\<^bsub>A\<^esub> n"
  and mod_one: "m \<in> carrier A \<Longrightarrow> m \<Colon> 1 = m"
  and mod_test: "\<lbrakk>a \<in> tests K; m \<in> carrier A\<rbrakk> \<Longrightarrow> m \<Colon> a = m \<sqinter> \<top> \<Colon> a"

begin

  lemma one_element: "\<lbrakk>m \<in> carrier A; \<And>a m. \<lbrakk>a \<in> tests K; m \<in> carrier A\<rbrakk> \<Longrightarrow> !(m \<Colon> a) = m \<Colon> !a\<rbrakk> \<Longrightarrow> m = \<top>"
  proof -
    assume mc: "m \<in> carrier A" and mod_not: "\<And>a m. \<lbrakk>a \<in> tests K; m \<in> carrier A\<rbrakk> \<Longrightarrow> !(m \<Colon> a) = m \<Colon> !a"
    have "m = !(!m)"
      by (metis double_neg mc)
    also have "... = !(!(m \<Colon> 1))"
      by (metis (lifting) mc mod_one)
    also have "... = !(m \<Colon> !1)"
      by (metis mc mod_not test.top_closed)
    also have "... = !(m \<Colon> 0)"
      by (metis test_not_one)
    also have "... = !\<bottom>"
      by (metis mc mod_zero)
    also have "... = \<top>"
      by (metis A.bot_closed bot_onel ccompl_closed ccompl_top)
    finally show ?thesis .
  qed

  lemma mod_bot: "p \<in> carrier K \<Longrightarrow> \<bottom> \<Colon> p = \<bottom>"
  proof -
    assume pc: "p \<in> carrier K"
    have "\<bottom> \<Colon> p = \<bottom> \<Colon> 0 \<Colon> p"
      by (metis A.bot_closed mod_zero)
    also have "... = \<bottom> \<Colon> 0"
      by (metis A.bot_closed mod_mult mult_zerol pc zero_closed)
    also have "... = \<bottom>"
      by (metis A.bot_closed mod_zero)
    finally show ?thesis .
  qed

  lemma mod_closed [intro]: "\<lbrakk>p \<in> carrier K; P \<in> carrier A\<rbrakk> \<Longrightarrow> P \<Colon> p \<in> carrier A"
    by (metis mk_type typed_application)

  lemma mod_A_iso: "\<lbrakk>p \<in> carrier K; P \<in> carrier A; Q \<in> carrier A\<rbrakk> \<Longrightarrow> P \<sqsubseteq>\<^bsub>A\<^esub> Q \<Longrightarrow> P \<Colon> p \<sqsubseteq>\<^bsub>A\<^esub> Q \<Colon> p"
    by (metis A.leq_def A.leq_def_left mod_closed mod_join)

  lemma mod_K_iso: "\<lbrakk>p \<in> carrier K; q \<in> carrier K; P \<in> carrier A\<rbrakk> \<Longrightarrow> p \<preceq> q \<Longrightarrow> P \<Colon> p \<sqsubseteq>\<^bsub>A\<^esub> P \<Colon> q"
    by (metis A.leq_def mod_closed mod_plus nat_order_def)

  declare A.order_refl [intro]
  declare A.bot_closed [intro]

  lemma mod_zero_bot: "\<lbrakk>p \<in> carrier K; M \<in> carrier A; p \<preceq> 0\<rbrakk> \<Longrightarrow> M \<Colon> p \<sqsubseteq>\<^bsub>A\<^esub> \<bottom>"
    by (subgoal_tac "p = 0", auto simp add: mod_zero) (metis add_zeror nat_order_def)

  definition hoare_triple :: "'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [54,54,54] 53) where
    "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace> \<equiv> P \<Colon> p \<sqsubseteq>\<^bsub>A\<^esub> Q"

  lemma hoare_composition:
    assumes pc: "p \<in> carrier K" and qc: "q \<in> carrier K"
    and Pc: "P \<in> carrier A" and Qc: "Q \<in> carrier A" and Rc: "R \<in> carrier A"
    and p_triple: "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>" and q_triple: "\<lbrace>Q\<rbrace> q \<lbrace>R\<rbrace>"
    shows "\<lbrace>P\<rbrace> p \<cdot> q \<lbrace>R\<rbrace>"
    by (smt A.join_assoc A.leq_def Pc Qc Rc hoare_triple_def mod_closed mod_join mod_mult p_triple pc q_triple qc)

  lemma hoare_skip: shows "P \<in> carrier A \<Longrightarrow> \<lbrace>P\<rbrace> 1 \<lbrace>P\<rbrace>"
    by (metis A.order_refl hoare_triple_def mod_one)

  lemma hoare_weakening:
    assumes Pc[intro]: "P \<in> carrier A" and P'c[intro]: "P' \<in> carrier A"
    and Qc[intro]: "Q \<in> carrier A" and Q'c[intro]: "Q' \<in> carrier A"
    and pc[intro]: "p \<in> carrier K"
    shows "\<lbrakk>\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>; P' \<sqsubseteq>\<^bsub>A\<^esub> P; Q \<sqsubseteq>\<^bsub>A\<^esub> Q'\<rbrakk> \<Longrightarrow> \<lbrace>P'\<rbrace> p \<lbrace>Q'\<rbrace>"
  proof -
    assume "Q \<sqsubseteq>\<^bsub>A\<^esub> Q'"
    hence a: "\<lbrace>Q\<rbrace> 1 \<lbrace>Q'\<rbrace>"
      by (metis Qc hoare_triple_def mod_one)
    assume "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>" and "P' \<sqsubseteq>\<^bsub>A\<^esub> P"
    hence b: "\<lbrace>P'\<rbrace> p \<lbrace>Q\<rbrace>"
      by (simp add: hoare_triple_def, rule_tac y = "P \<Colon> p" in A.order_trans) (metis P'c Pc mod_A_iso pc, auto)
    have "\<lbrace>P'\<rbrace> p \<cdot> 1 \<lbrace>Q'\<rbrace>"
      by (metis (lifting) P'c Q'c Qc a b hoare_composition one_closed pc)
    thus ?thesis
      by (metis mult_oner pc)
  qed

  declare mod_closed[intro]

  lemma hoare_plus:
    assumes pc [intro]: "p \<in> carrier K" and qc [intro]: "q \<in> carrier K"
    and Pc [intro]: "P \<in> carrier A" and Qc [intro]: "Q \<in> carrier A"
    and then_branch: "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>"
    and else_branch: "\<lbrace>P\<rbrace> q \<lbrace>Q\<rbrace>"
    shows "\<lbrace>P\<rbrace> p + q \<lbrace>Q\<rbrace>"
  proof -
    have "P \<Colon> p \<sqsubseteq>\<^bsub>A\<^esub> Q" and "P \<Colon> q \<sqsubseteq>\<^bsub>A\<^esub> Q"
      by (insert then_branch else_branch) (simp add: hoare_triple_def)+
    hence "P \<Colon> (p + q) \<sqsubseteq>\<^bsub>A\<^esub> Q"
      by (simp add: mod_plus[OF pc qc Pc], subst A.bin_lub_var, auto)
    thus ?thesis
      by (simp add: hoare_triple_def)
  qed

  (* by (metis A.bin_lub_var Pc Qc else_branch hoare_triple_def mod_closed mod_plus pc qc then_branch) *)

  lemma hoare_if:
    assumes b_test: "b \<in> tests K"
    and pc: "p \<in> carrier K" and qc: "q \<in> carrier K"
    and Pc: "P \<in> carrier A" and Qc: "Q \<in> carrier A"
    and then_branch: "\<lbrace>P \<sqinter> (\<top> \<Colon> b)\<rbrace> p \<lbrace>Q\<rbrace>"
    and else_branch: "\<lbrace>P \<sqinter> (\<top> \<Colon> !b)\<rbrace> q \<lbrace>Q\<rbrace>"
    shows "\<lbrace>P\<rbrace> b\<cdot>p + !b\<cdot>q \<lbrace>Q\<rbrace>"
    apply (rule hoare_plus)
    apply (metis (lifting) b_test mult_closed pc test_subset_var)
    apply (metis b_test local.complement_closed mult_closed qc test_subset_var)
    apply (metis Pc)
    apply (metis Qc)
    apply (rule_tac Q = "P \<sqinter> (\<top> \<Colon> b)" in hoare_composition)
    apply (metis b_test test_subset_var)
    apply (metis pc)
    apply (metis Pc)
    apply (metis A.meet_closed A.top_closed Pc b_test mod_closed test_subset_var)
    apply (metis (lifting) Qc)
    apply (metis A.eq_refl Pc b_test hoare_triple_def mod_closed mod_test test_subset_var)
    apply (metis then_branch)
    apply (rule_tac Q = "P \<sqinter> \<top> \<Colon> !b" in hoare_composition)
    apply (metis b_test local.complement_closed test_subset_var)
    apply (metis (lifting) qc)
    apply (metis (lifting) Pc)
    apply (metis (lifting) A.meet_closed A.top_closed Pc b_test local.complement_closed mod_closed test_subset_var)
    apply (metis (lifting) Qc)
    apply (metis A.eq_refl Pc b_test hoare_triple_def kat.complement_closed kat_subalg mod_closed mod_test test_subset_var)
    by (metis (lifting) else_branch)

  lemma hoare_star:
    assumes pc: "p \<in> carrier K"
    and Pc: "P \<in> carrier A"
    and p_triple: "\<lbrace>P\<rbrace> p \<lbrace>P\<rbrace>"
    shows "\<lbrace>P\<rbrace> p\<^sup>\<star> \<lbrace>P\<rbrace>"
    by (metis (lifting) A.bin_lub_var A.order_refl Pc hoare_triple_def mod_closed mod_star p_triple pc)

  declare star_closed [intro]
  declare mult_closed [intro]
  declare test_subset_var [intro]
  declare complement_closed [intro]
  declare meet_closed [intro!]
  declare top_closed [intro]

  lemma [intro]: "\<lbrakk>b \<in> tests K; P \<in> carrier A\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> b \<lbrace>P \<sqinter>\<^bsub>A\<^esub> \<top> \<Colon> b\<rbrace>"
    by (metis A.eq_refl hoare_triple_def mod_closed mod_test test_subset_var)

  lemma hoare_while:
    assumes b_test [intro]: "b \<in> tests K" and pc [intro]: "p \<in> carrier K"
    and Pc [intro]: "P \<in> carrier A"
    and loop_condition [intro]: "\<lbrace>P \<sqinter> (\<top> \<Colon> b)\<rbrace> p \<lbrace>P\<rbrace>"
    shows "\<lbrace>P\<rbrace> (b\<cdot>p)\<^sup>\<star>\<cdot>!b \<lbrace>P \<sqinter> (\<top> \<Colon> !b)\<rbrace>"
  proof (rule hoare_composition[where ?Q = P], auto)
    show "\<lbrace>P\<rbrace> (b \<cdot> p)\<^sup>\<star> \<lbrace>P\<rbrace>"
      by (blast intro: hoare_star hoare_composition[where ?Q = "P \<sqinter> \<top> \<Colon> b"])
  qed

lemma derived_rule1:
  assumes p: "{P1,P2,Q1,Q2} \<subseteq> carrier A" and q: "p \<in> carrier K"
  and "\<lbrace>P1\<rbrace> p \<lbrace>Q1\<rbrace>" and "\<lbrace>P2\<rbrace> p \<lbrace>Q2\<rbrace>"
  shows "\<lbrace>P1 \<sqinter> P2\<rbrace> p \<lbrace>Q1 \<sqinter> Q2\<rbrace>"
  using assms
  apply (auto intro: simp add: hoare_triple_def assms, subst A.bin_glb_var)
  by (metis A.absorb1 A.bin_lub_var A.meet_closed A.meet_comm mod_closed mod_join)+

lemma derived_rule2:
  assumes "P \<in> carrier A" and "p \<in> carrier K" and "P \<Colon> p = (\<top> \<Colon> p) \<sqinter> P"
  shows "\<lbrace>P\<rbrace> p \<lbrace>P\<rbrace>"
  using assms
  by (metis (lifting) A.bin_glb_var A.eq_refl A.top_closed hoare_triple_def mod_closed)

lemma derived_rule3:
  assumes "{P,Q,R} \<subseteq> carrier A" and "p \<in> carrier K" and "P \<Colon> p = (\<top> \<Colon> p) \<sqinter> P"
  and "\<lbrace>Q\<rbrace> p \<lbrace>R\<rbrace>"
  shows "\<lbrace>P \<sqinter> Q\<rbrace> p \<lbrace>P \<sqinter> R\<rbrace>"
  by (insert assms) (smt derived_rule1 derived_rule2 insert_subset)

end

lemma "range f = (\<Union>x. {f x})" and "(\<Union>x. {f x}) = {f i|i. True}" by auto

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Transport for Natural Functors\<close>
theory Transport_Natural_Functors
  imports
    Transport_Natural_Functors_Galois
    Transport_Natural_Functors_Galois_Relator
    Transport_Natural_Functors_Order_Base
    Transport_Natural_Functors_Order_Equivalence
begin

paragraph \<open>Summary\<close>
text \<open>Summary of results for a fixed natural functor with 3 parameters. All
apply-style proofs are written such that they also apply to functors with other
arities. An automatic derivation of these results for all natural functors needs
to be implemented in the BNF package. This is future work.\<close>

context transport_natural_functor
begin

interpretation flip :
  transport_natural_functor R1 L1 r1 l1 R2 L2 r2 l2 R3 L3 r3 l3 .

theorem preorder_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "((\<le>\<^bsub>L3\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R3\<^esub>)) l3 r3"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  apply (insert assms)
  apply (elim transport.preorder_equivalence_galois_equivalenceE)
  apply (intro preorder_equivalence_if_galois_equivalenceI
    galois_equivalenceI
    preorder_on_in_field_leftI flip.preorder_on_in_field_leftI)
  apply assumption+
  done

theorem partial_equivalence_rel_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "((\<le>\<^bsub>L3\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R3\<^esub>)) l3 r3"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  apply (insert assms)
  apply (elim transport.partial_equivalence_rel_equivalenceE
    transport.preorder_equivalence_galois_equivalenceE
    preorder_on_in_fieldE)
  apply (intro partial_equivalence_rel_equivalence_if_galois_equivalenceI
    galois_equivalenceI
    partial_equivalence_rel_leftI flip.partial_equivalence_rel_leftI
    partial_equivalence_relI)
  apply assumption+
  done

text \<open>For the simplification of the Galois relator see
@{thm "Galois_eq_Frel_Galois"}.\<close>

end

end


(*  Title:      statecharts/Examples/CarAudioSystem.thy

    Author:     Steffen Helke and Florian Kammüller, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

section \<open>Example Specification for a Car Audio System\<close>

theory CarAudioSystem
imports HAKripke HAOps
begin

subsection \<open>Definitions\<close>

subsubsection \<open>Data space for two Integer-Variables\<close>

datatype d = V0 int
             | V1 int

primrec
 Sel0 :: "d => int" where
  "Sel0 (V0 i) = i"

primrec
 Sel1 :: "d => int" where
  "Sel1 (V1 i) = i"

(* Selectors for the two Integer-Variables *)
definition
  Select0 :: "[d data] => int" where
  "Select0 d = Sel0 (DataPart d 0)"

definition
  Select1 :: "[d data] => int" where
  "Select1 d = Sel1 (DataPart d 1)"

(* Data Space for tthe two Integer-Variables *)
definition
  DSpace :: "d dataspace" where
  "DSpace = Abs_dataspace ([range V0, range V1])"

(* Lift in InitData *)
definition
  LiftInitData :: "(d list) => d data" where
  "LiftInitData L = Abs_data (L,DSpace)"

(* Lift in PUpdate-Function *)
definition
  LiftPUpdate :: "(d data => ((d option) list)) => d pupdate" where
  "LiftPUpdate L = Abs_pupdate
                        (\<lambda> d. if ((DataSpace d) = DSpace) then
                                   Abs_pdata (L d, DSpace)
                              else (Data2PData d))"

subsubsection \<open>Sequential Automaton  \<open>Root_CTRL\<close>\<close>

definition
 Root_CTRL_States :: "string set" where
 "Root_CTRL_States = {''CarAudioSystem''}"

definition
 Root_CTRL_Init :: "string" where
 "Root_CTRL_Init = ''CarAudioSystem''"

definition
 Root_CTRL_Labels :: "(string,string,d)label set" where
 "Root_CTRL_Labels = {}"

definition
 Root_CTRL_Delta :: "(string,string,d)trans set" where
 "Root_CTRL_Delta = {}"

definition
 Root_CTRL :: "(string,string,d)seqauto" where
 "Root_CTRL = Abs_seqauto (Root_CTRL_States, Root_CTRL_Init,
                            Root_CTRL_Labels, Root_CTRL_Delta)"

subsubsection \<open>Sequential Automaton  \<open>CDPlayer_CTRL\<close>\<close>

definition
 CDPlayer_CTRL_States :: "string set" where
 "CDPlayer_CTRL_States = {''ReadTracks'',''CDFull'',''CDEmpty''}"

definition
 CDPlayer_CTRL_Init :: "string" where
 "CDPlayer_CTRL_Init = ''CDEmpty''"

definition
 CDPlayer_CTRL_Update1 :: "d pupdate" where
 "CDPlayer_CTRL_Update1 = LiftPUpdate (% d. [None, Some (V1 ((Select0 d) + 1))])"

definition
 CDPlayer_CTRL_Action1 :: "(string,d)action" where
 "CDPlayer_CTRL_Action1 = ({},CDPlayer_CTRL_Update1)"

definition
 CDPlayer_CTRL_Update2 :: "d pupdate" where
 "CDPlayer_CTRL_Update2 = LiftPUpdate (% d. [Some (V0 ((Select0 d) + 1)), None])"

definition
 CDPlayer_CTRL_Action2 :: "(string,d)action" where
 "CDPlayer_CTRL_Action2 = ({},CDPlayer_CTRL_Update2)"

definition
 CDPlayer_CTRL_Update3 :: "d pupdate" where
 "CDPlayer_CTRL_Update3 = LiftPUpdate (% d. [Some (V0 0), None])"

definition
 CDPlayer_CTRL_Action3 :: "(string,d)action" where
 "CDPlayer_CTRL_Action3 = ({},CDPlayer_CTRL_Update3)"

definition
 CDPlayer_CTRL_Labels :: "(string,string,d)label set" where
 "CDPlayer_CTRL_Labels = {(En ''LastTrack'', defaultguard, CDPlayer_CTRL_Action1),
                          (En ''NewTrack'', defaultguard, CDPlayer_CTRL_Action2),
                          (And (En ''CDEject'') (In ''On''), defaultguard, CDPlayer_CTRL_Action3),
                          (En ''CDIn'', defaultguard, defaultaction)}"

definition
 CDPlayer_CTRL_Delta :: "(string,string,d)trans set" where
 "CDPlayer_CTRL_Delta = {(''ReadTracks'',(En ''LastTrack'', defaultguard, CDPlayer_CTRL_Action1),
                          ''CDFull''),
                         (''CDFull'',(And (En ''CDEject'') (In ''On''), defaultguard, CDPlayer_CTRL_Action3),
                          ''CDEmpty''),
                         (''ReadTracks'',(En ''NewTrack'', defaultguard, CDPlayer_CTRL_Action2),
                          ''ReadTracks''),
                         (''CDEmpty'',(En ''CDIn'', defaultguard, defaultaction),
                          ''ReadTracks'')}"

definition
 CDPlayer_CTRL :: "(string,string,d)seqauto" where
 "CDPlayer_CTRL  = Abs_seqauto (CDPlayer_CTRL_States, CDPlayer_CTRL_Init,
                                CDPlayer_CTRL_Labels, CDPlayer_CTRL_Delta)"

subsubsection \<open>Sequential Automaton  \<open>AudioPlayer_CTRL\<close>\<close>

definition
 AudioPlayer_CTRL_States :: "string set" where
 "AudioPlayer_CTRL_States = {''Off'',''On''}"

definition
 AudioPlayer_CTRL_Init :: "string" where
 "AudioPlayer_CTRL_Init = ''Off''"

definition
 AudioPlayer_CTRL_Labels :: "(string,string,d)label set" where
 "AudioPlayer_CTRL_Labels = {(En ''O'', defaultguard, defaultaction)}"

definition
 AudioPlayer_CTRL_Delta :: "(string,string,d)trans set" where
 "AudioPlayer_CTRL_Delta = {(''Off'', (En ''O'', defaultguard, defaultaction), ''On''),
                            (''On'', (En ''O'', defaultguard, defaultaction), ''Off'')}"

definition
 AudioPlayer_CTRL :: "(string,string,d)seqauto" where
 "AudioPlayer_CTRL = Abs_seqauto (AudioPlayer_CTRL_States, AudioPlayer_CTRL_Init,
                                  AudioPlayer_CTRL_Labels, AudioPlayer_CTRL_Delta)"

subsubsection \<open>Sequential Automaton  \<open>On_CTRL\<close>\<close>

definition
 On_CTRL_States :: "string set" where
 "On_CTRL_States = {''TunerMode'',''CDMode''}"

definition
 On_CTRL_Init :: "string" where
 "On_CTRL_Init = ''TunerMode''"

definition
 On_CTRL_Labels :: "(string,string,d)label set" where
 "On_CTRL_Labels = {(And (En ''Src'') (In ''CDFull''), defaultguard, defaultaction),
                    (En ''Src'', defaultguard, defaultaction),
                    (En ''CDEject'', defaultguard, defaultaction),
                    (En ''EndOfTitle'', (\<lambda> d. (DataPart d 0) =  (DataPart d 1)), defaultaction)}"

definition
 On_CTRL_Delta :: "(string,string,d)trans set" where
 "On_CTRL_Delta = {(''TunerMode'',(And (En ''Src'') (In ''CDFull''), defaultguard, defaultaction),''CDMode''),
                   (''CDMode'', (En ''Src'', defaultguard, defaultaction), ''TunerMode''),
                   (''CDMode'', (En ''CDEject'', defaultguard, defaultaction), ''TunerMode''),
                   (''CDMode'', (En ''EndOfTitle'', (\<lambda> d. (DataPart d 0) =  (DataPart d 1)), defaultaction),
                    ''TunerMode'')}"

definition
 On_CTRL :: "(string,string,d)seqauto" where
 "On_CTRL = Abs_seqauto (On_CTRL_States, On_CTRL_Init,
                         On_CTRL_Labels, On_CTRL_Delta)"

subsubsection \<open>Sequential Automaton  \<open>TunerMode_CTRL\<close>\<close>

definition
 TunerMode_CTRL_States :: "string set" where
 "TunerMode_CTRL_States = {''1'',''2'',''3'',''4''}"

definition
 TunerMode_CTRL_Init :: "string" where
 "TunerMode_CTRL_Init = ''1''"

definition
 TunerMode_CTRL_Labels :: "(string,string,d)label set" where
 "TunerMode_CTRL_Labels = {(En ''Next'', defaultguard, defaultaction),
                       (En ''Back'', defaultguard, defaultaction)}"

definition
 TunerMode_CTRL_Delta :: "(string,string,d)trans set" where
 "TunerMode_CTRL_Delta = {(''1'', (En ''Next'', defaultguard, defaultaction), ''2''),
                      (''2'', (En ''Next'', defaultguard, defaultaction), ''3''),
                      (''3'', (En ''Next'', defaultguard, defaultaction), ''4''),
                      (''4'', (En ''Next'', defaultguard, defaultaction), ''1''),
                      (''1'', (En ''Back'', defaultguard, defaultaction), ''4''),
                      (''4'', (En ''Back'', defaultguard, defaultaction), ''3''),
                      (''3'', (En ''Back'', defaultguard, defaultaction), ''2''),
                      (''2'', (En ''Back'', defaultguard, defaultaction), ''1'')}"

definition
 TunerMode_CTRL :: "(string,string,d)seqauto" where
 "TunerMode_CTRL  = Abs_seqauto (TunerMode_CTRL_States, TunerMode_CTRL_Init,
                                  TunerMode_CTRL_Labels, TunerMode_CTRL_Delta)"

subsubsection \<open>Sequential Automaton  \<open>CDMode_CTRL\<close>\<close>

definition
 CDMode_CTRL_States :: "string set" where
 "CDMode_CTRL_States = {''Playing'',''SelectingNextTrack'',
                        ''SelectingPreviousTrack''}"

definition
 CDMode_CTRL_Init :: "string" where
 "CDMode_CTRL_Init = ''Playing''"

definition
 CDMode_CTRL_Update1 :: "d pupdate" where
 "CDMode_CTRL_Update1 = LiftPUpdate (% d. [ Some (V0 ((Select0 d) + 1)), None ])"

definition
 CDMode_CTRL_Action1 :: "(string,d)action" where
 "CDMode_CTRL_Action1 = ({},CDMode_CTRL_Update1)"

definition
 CDMode_CTRL_Update2 :: "d pupdate" where
 "CDMode_CTRL_Update2 = LiftPUpdate (% d. [ Some (V0 ((Select0 d) - 1)), None ])"

definition
 CDMode_CTRL_Action2 :: "(string,d)action" where
 "CDMode_CTRL_Action2 = ({},CDMode_CTRL_Update2)"

definition
 CDMode_CTRL_Labels :: "(string,string,d)label set" where
 "CDMode_CTRL_Labels = {(En ''Next'', defaultguard, defaultaction),
                        (En ''Back'', defaultguard, defaultaction),
                        (En ''Ready'', defaultguard, CDMode_CTRL_Action1),
                        (En ''Ready'', defaultguard, CDMode_CTRL_Action2),
                        (En ''EndOfTitle'',(\<lambda> (d:: d data). (Select0 d) < (Select1 d)), defaultaction)}"

definition
 CDMode_CTRL_Delta :: "(string,string,d)trans set" where
 "CDMode_CTRL_Delta = {(''Playing'', (En ''Next'', defaultguard, defaultaction) , ''SelectingNextTrack''),
                       (''SelectingNextTrack'', (En ''Ready'', defaultguard, CDMode_CTRL_Action1) ,''Playing''),
                       (''Playing'', (En ''Back'', defaultguard, defaultaction) ,''SelectingPreviousTrack''),
                       (''SelectingPreviousTrack'', (En ''Ready'', defaultguard, CDMode_CTRL_Action2),
                        ''Playing''),
                       (''Playing'', (En ''EndOfTitle'', (\<lambda> (d:: d data). (Select0 d) < (Select1 d)), defaultaction),
                        ''SelectingNextTrack'')}"

definition
 CDMode_CTRL :: "(string,string,d)seqauto" where
 "CDMode_CTRL  = Abs_seqauto (CDMode_CTRL_States, CDMode_CTRL_Init,
                               CDMode_CTRL_Labels, CDMode_CTRL_Delta)"

subsubsection \<open>Hierarchical Automaton  \<open>CarAudioSystem\<close>\<close>

definition
     CarAudioSystem :: "(string,string,d)hierauto" where
     "CarAudioSystem = ((PseudoHA Root_CTRL (LiftInitData [V0 0, V1 0]))
                  [++] (''CarAudioSystem'',CDPlayer_CTRL)
                  [++] (''CarAudioSystem'',AudioPlayer_CTRL)
                  [++] (''On'', TunerMode_CTRL)
                  [++] (''On'', CDMode_CTRL))"

subsection \<open>Lemmas\<close>

subsubsection \<open>Sequential Automaton \<open>CDMode_CTRL\<close>\<close>

lemma check_Root_CTRL:
  "(Root_CTRL_States,Root_CTRL_Init,Root_CTRL_Labels,Root_CTRL_Delta) : seqauto"
apply (unfold seqauto_def SeqAuto_def Root_CTRL_States_def Root_CTRL_Init_def Root_CTRL_Labels_def Root_CTRL_Delta_def)
apply simp
done

lemma States_Root_CTRL:
  "States Root_CTRL = Root_CTRL_States"
apply (simp add: Root_CTRL_def)
apply (unfold States_def)
apply (simp add: Abs_seqauto_inverse check_Root_CTRL)
done

lemma Init_State_Root_CTRL:
  "InitState Root_CTRL = Root_CTRL_Init"
apply (simp add: Root_CTRL_def)
apply (unfold InitState_def)
apply (simp add: Abs_seqauto_inverse check_Root_CTRL)
done

lemma Labels_Root_CTRL:
  "Labels Root_CTRL = Root_CTRL_Labels"
apply (simp add: Root_CTRL_def)
apply (unfold Labels_def)
apply (simp add: Abs_seqauto_inverse check_Root_CTRL)
done

lemma Delta_Root_CTRL:
  "Delta Root_CTRL = Root_CTRL_Delta"
apply (simp add: Root_CTRL_def)
apply (unfold Delta_def)
apply (simp add: Abs_seqauto_inverse check_Root_CTRL)
done

schematic_goal Events_Root_CTRL:
  "SAEvents Root_CTRL = ?X"
apply (unfold SAEvents_def expr_def)
apply (rule trans)
apply (simp add: expr_def Delta_Root_CTRL Root_CTRL_Delta_def)
apply (rule refl)
done

subsubsection \<open>Sequential Automaton \<open>CDPlayer_CTRL\<close>\<close>

lemma check_CDPlayer_CTRL:
  "(CDPlayer_CTRL_States,CDPlayer_CTRL_Init,CDPlayer_CTRL_Labels,CDPlayer_CTRL_Delta) : seqauto"
apply (unfold seqauto_def SeqAuto_def CDPlayer_CTRL_States_def CDPlayer_CTRL_Init_def CDPlayer_CTRL_Labels_def CDPlayer_CTRL_Delta_def)
apply simp
done

lemma States_CDPlayer_CTRL:
  "States CDPlayer_CTRL = CDPlayer_CTRL_States"
apply (simp add: CDPlayer_CTRL_def)
apply (unfold States_def)
apply (simp add: Abs_seqauto_inverse check_CDPlayer_CTRL)
done

lemma Init_State_CDPlayer_CTRL:
  "InitState CDPlayer_CTRL = CDPlayer_CTRL_Init"
apply (simp add: CDPlayer_CTRL_def)
apply (unfold InitState_def)
apply (simp add: Abs_seqauto_inverse check_CDPlayer_CTRL)
done

lemma Labels_CDPlayer_CTRL:
  "Labels CDPlayer_CTRL = CDPlayer_CTRL_Labels"
apply (simp add: CDPlayer_CTRL_def)
apply (unfold Labels_def)
apply (simp add: Abs_seqauto_inverse check_CDPlayer_CTRL)
done

lemma Delta_CDPlayer_CTRL:
  "Delta CDPlayer_CTRL = CDPlayer_CTRL_Delta"
apply (simp add: CDPlayer_CTRL_def)
apply (unfold Delta_def)
apply (simp add: Abs_seqauto_inverse check_CDPlayer_CTRL)
done

schematic_goal Events_CDPlayer_CTRL:
  "SAEvents CDPlayer_CTRL = ?X"
apply (unfold SAEvents_def)
apply (rule trans)
apply (simp add: expr_def Delta_CDPlayer_CTRL CDPlayer_CTRL_Delta_def CDPlayer_CTRL_Action1_def CDPlayer_CTRL_Action2_def CDPlayer_CTRL_Action3_def Label_def)
apply (rule refl)
done

subsubsection \<open>Sequential Automaton \<open>AudioPlayer_CTRL\<close>\<close>

lemma check_AudioPlayer_CTRL:
  "(AudioPlayer_CTRL_States,AudioPlayer_CTRL_Init,AudioPlayer_CTRL_Labels,AudioPlayer_CTRL_Delta) : seqauto"
apply (unfold seqauto_def SeqAuto_def AudioPlayer_CTRL_States_def AudioPlayer_CTRL_Init_def AudioPlayer_CTRL_Labels_def AudioPlayer_CTRL_Delta_def)
apply simp
done

lemma States_AudioPlayer_CTRL:
  "States AudioPlayer_CTRL = AudioPlayer_CTRL_States"
apply (simp add: AudioPlayer_CTRL_def)
apply (unfold States_def)
apply (simp add: Abs_seqauto_inverse check_AudioPlayer_CTRL)
done

lemma Init_State_AudioPlayer_CTRL:
  "InitState AudioPlayer_CTRL = AudioPlayer_CTRL_Init"
apply (simp add: AudioPlayer_CTRL_def)
apply (unfold InitState_def)
apply (simp add: Abs_seqauto_inverse check_AudioPlayer_CTRL)
done

lemma Labels_AudioPlayer_CTRL:
  "Labels AudioPlayer_CTRL = AudioPlayer_CTRL_Labels"
apply (simp add: AudioPlayer_CTRL_def)
apply (unfold Labels_def)
apply (simp add: Abs_seqauto_inverse check_AudioPlayer_CTRL)
done

lemma Delta_AudioPlayer_CTRL:
  "Delta AudioPlayer_CTRL = AudioPlayer_CTRL_Delta"
apply (simp add: AudioPlayer_CTRL_def)
apply (unfold Delta_def)
apply (simp add: Abs_seqauto_inverse check_AudioPlayer_CTRL)
done

schematic_goal Events_AudioPlayer_CTRL:
  "SAEvents AudioPlayer_CTRL = ?X"
apply (unfold SAEvents_def)
apply (rule trans)
apply (simp add: expr_def Delta_AudioPlayer_CTRL AudioPlayer_CTRL_Delta_def Label_def)
apply (rule refl)
done

subsubsection \<open>Sequential Automaton \<open>On_CTRL\<close>\<close>

lemma check_On_CTRL:
  "(On_CTRL_States,On_CTRL_Init,On_CTRL_Labels,On_CTRL_Delta) : seqauto"
apply (unfold seqauto_def SeqAuto_def On_CTRL_States_def On_CTRL_Init_def On_CTRL_Labels_def On_CTRL_Delta_def)
apply simp
done

lemma States_On_CTRL:
  "States On_CTRL = On_CTRL_States"
apply (simp add: On_CTRL_def)
apply (unfold States_def)
apply (simp add: Abs_seqauto_inverse check_On_CTRL)
done

lemma Init_State_On_CTRL:
  "InitState On_CTRL = On_CTRL_Init"
apply (simp add: On_CTRL_def)
apply (unfold InitState_def)
apply (simp add: Abs_seqauto_inverse check_On_CTRL)
done

lemma Labels_On_CTRL:
  "Labels On_CTRL = On_CTRL_Labels"
apply (simp add: On_CTRL_def)
apply (unfold Labels_def)
apply (simp add: Abs_seqauto_inverse check_On_CTRL)
done

lemma Delta_On_CTRL:
  "Delta On_CTRL = On_CTRL_Delta"
apply (simp add: On_CTRL_def)
apply (unfold Delta_def)
apply (simp add: Abs_seqauto_inverse check_On_CTRL)
done

schematic_goal Events_On_CTRL:
  "SAEvents On_CTRL = ?X"
apply (unfold SAEvents_def)
apply (rule trans)
apply (simp add: expr_def Delta_On_CTRL On_CTRL_Delta_def Label_def)
apply (rule refl)
done

subsubsection \<open>Sequential Automaton \<open>TunerMode_CTRL\<close>\<close>

lemma check_TunerMode_CTRL:
  "(TunerMode_CTRL_States,TunerMode_CTRL_Init,TunerMode_CTRL_Labels,TunerMode_CTRL_Delta) : seqauto"
apply (unfold seqauto_def SeqAuto_def TunerMode_CTRL_States_def TunerMode_CTRL_Init_def TunerMode_CTRL_Labels_def TunerMode_CTRL_Delta_def)
apply simp
done

lemma States_TunerMode_CTRL:
  "States TunerMode_CTRL = TunerMode_CTRL_States"
apply (simp add: TunerMode_CTRL_def)
apply (unfold States_def)
apply (simp add: Abs_seqauto_inverse check_TunerMode_CTRL)
done

lemma Init_State_TunerMode_CTRL:
  "InitState TunerMode_CTRL = TunerMode_CTRL_Init"
apply (simp add: TunerMode_CTRL_def)
apply (unfold InitState_def)
apply (simp add: Abs_seqauto_inverse check_TunerMode_CTRL)
done

lemma Delta_TunerMode_CTRL:
  "Delta TunerMode_CTRL = TunerMode_CTRL_Delta"
apply (simp add: TunerMode_CTRL_def)
apply (unfold Delta_def)
apply (simp add: Abs_seqauto_inverse check_TunerMode_CTRL)
done

schematic_goal Events_TunerMode_CTRL:
  "SAEvents TunerMode_CTRL = ?X"
apply (unfold SAEvents_def)
apply (rule trans)
apply (simp add: expr_def Delta_TunerMode_CTRL TunerMode_CTRL_Delta_def Label_def)
apply (rule refl)
done

subsubsection \<open>Sequential Automaton \<open>CDMode_CTRL\<close>\<close>

lemma check_CDMode_CTRL:
  "(CDMode_CTRL_States,CDMode_CTRL_Init,CDMode_CTRL_Labels,CDMode_CTRL_Delta) : seqauto"
apply (unfold seqauto_def SeqAuto_def CDMode_CTRL_States_def CDMode_CTRL_Init_def CDMode_CTRL_Labels_def CDMode_CTRL_Delta_def)
apply simp
done

lemma States_CDMode_CTRL:
  "States CDMode_CTRL = CDMode_CTRL_States"
apply (simp add: CDMode_CTRL_def)
apply (unfold States_def)
apply (simp add: Abs_seqauto_inverse check_CDMode_CTRL)
done

lemma Init_State_CDMode_CTRL:
  "InitState CDMode_CTRL = CDMode_CTRL_Init"
apply (simp add: CDMode_CTRL_def)
apply (unfold InitState_def)
apply (simp add: Abs_seqauto_inverse check_CDMode_CTRL)
done

lemma Labels_CDMode_CTRL:
  "Labels CDMode_CTRL = CDMode_CTRL_Labels"
apply (simp add: CDMode_CTRL_def)
apply (unfold Labels_def)
apply (simp add: Abs_seqauto_inverse check_CDMode_CTRL)
done

lemma Delta_CDMode_CTRL:
  "Delta CDMode_CTRL = CDMode_CTRL_Delta"
apply (simp add: CDMode_CTRL_def)
apply (unfold Delta_def)
apply (simp add: Abs_seqauto_inverse check_CDMode_CTRL)
done

schematic_goal Events_CDMode_CTRL:
  "SAEvents CDMode_CTRL = ?X"
apply (unfold SAEvents_def)
apply (rule trans)
apply (simp add: expr_def Label_def Delta_CDMode_CTRL CDMode_CTRL_Delta_def CDMode_CTRL_Action1_def CDMode_CTRL_Action2_def)
apply (rule refl)
done

subsubsection \<open>Hierarchical Automaton \<open>CarAudioSystem\<close>\<close>

lemmas CarAudioSystemStates = States_Root_CTRL States_CDPlayer_CTRL States_AudioPlayer_CTRL States_On_CTRL
                              States_TunerMode_CTRL States_CDMode_CTRL
                              Root_CTRL_States_def CDPlayer_CTRL_States_def AudioPlayer_CTRL_States_def
                              On_CTRL_States_def TunerMode_CTRL_States_def CDMode_CTRL_States_def

lemmas CarAudioSystemInitState = Init_State_Root_CTRL Init_State_CDPlayer_CTRL Init_State_AudioPlayer_CTRL
                                 Init_State_On_CTRL Init_State_TunerMode_CTRL Init_State_CDMode_CTRL
                                 Root_CTRL_Init_def CDPlayer_CTRL_Init_def AudioPlayer_CTRL_Init_def
                                 On_CTRL_Init_def TunerMode_CTRL_Init_def CDMode_CTRL_Init_def

lemmas CarAudioSystemEvents = Events_Root_CTRL Events_CDPlayer_CTRL Events_AudioPlayer_CTRL Events_On_CTRL
                              Events_TunerMode_CTRL Events_CDMode_CTRL

lemmas CarAudioSystemthms = CarAudioSystemStates CarAudioSystemEvents CarAudioSystemInitState

(* -------------------------------------------------------------- *)
(*                  States of \<guillemotright> CarAudioSystem \<guillemotleft>                  *)
(* -------------------------------------------------------------- *)

schematic_goal CarAudioSystem_StatesRoot:
  "HAStates (PseudoHA Root_CTRL (LiftInitData [V0 0, V1 0])) = ?X"
apply (wellformed CarAudioSystemthms)+
done

lemmas CarAudioSystemthms_1 = CarAudioSystemthms CarAudioSystem_StatesRoot

schematic_goal CarAudioSystem_StatesCDPlayer:
  "HAStates (PseudoHA Root_CTRL (LiftInitData [V0 0, V1 0]) [++]
            (''CarAudioSystem'',CDPlayer_CTRL)) = ?X"
apply (wellformed CarAudioSystemthms_1)+
done

lemmas CarAudioSystemthms_2 = CarAudioSystemthms_1 CarAudioSystem_StatesCDPlayer

schematic_goal CarAudioSystem_StatesAudioPlayer:
  "HAStates (PseudoHA Root_CTRL (LiftInitData [V0 0, V1 0])
                  [++] (''CarAudioSystem'',CDPlayer_CTRL)
                  [++] (''CarAudioSystem'',AudioPlayer_CTRL)) = ?X"
apply (wellformed CarAudioSystemthms_2)+
done

lemmas CarAudioSystemthms_3 = CarAudioSystemthms_2 CarAudioSystem_StatesAudioPlayer

schematic_goal CarAudioSystem_StatesTunerMode:
  "HAStates (PseudoHA Root_CTRL (LiftInitData [V0 0, V1 0])
                  [++] (''CarAudioSystem'',CDPlayer_CTRL)
                  [++] (''CarAudioSystem'',AudioPlayer_CTRL)
                  [++] (''On'', TunerMode_CTRL )) = ?X"
apply (wellformed CarAudioSystemthms_3)+
done

lemmas CarAudioSystemthms_4 = CarAudioSystemthms_3 CarAudioSystem_StatesTunerMode

schematic_goal CarAudioSystem_StatesCDMode:
  "HAStates (PseudoHA Root_CTRL (LiftInitData [V0 0, V1 0])
                  [++] (''CarAudioSystem'',CDPlayer_CTRL)
                  [++] (''CarAudioSystem'',AudioPlayer_CTRL)
                  [++] (''On'', TunerMode_CTRL )
                  [++] (''On'', CDMode_CTRL)) = ?X"
apply (wellformed CarAudioSystemthms_4)+
done

lemmas CarAudioSystemthms_5 = CarAudioSystemthms_4 CarAudioSystem_StatesCDMode

schematic_goal SAsCarAudioSystem:
  "SAs CarAudioSystem = ?X"
apply (unfold CarAudioSystem_def)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal EventsCarAudioSystem:
 "HAEvents CarAudioSystem = ?X"
apply (unfold CarAudioSystem_def)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal CompFunCarAudioSystem:
  "CompFun CarAudioSystem = ?X"
apply (unfold CarAudioSystem_def)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal StatesCarAudioSystem:
  "HAStates CarAudioSystem = ?X"
apply (unfold CarAudioSystem_def)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal ValueCarAudioSystem:
  "HAInitValue CarAudioSystem = ?X"
apply (unfold CarAudioSystem_def)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal HAInitStatesCarAudioSystem:
  "HAInitStates CarAudioSystem = ?X"
by (simp add: HAInitStates_def SAsCarAudioSystem CarAudioSystemInitState)

schematic_goal HARootCarAudioSystem:
  "HARoot CarAudioSystem = ?X"
apply (unfold CarAudioSystem_def)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal HAInitStateCarAudioSystem:
  "HAInitState CarAudioSystem = ?X"
by (simp add: HARootCarAudioSystem HAInitState_def CarAudioSystemInitState)

(* -------------------------------------------------------------- *)
(*      Components of the initial data space assignement          *)
(* -------------------------------------------------------------- *)

lemma check_DataSpace [simp]:
  "[range V0, range V1] \<in> dataspace"
apply (unfold dataspace_def DataSpace.DataSpace_def)
apply auto
apply (rename_tac D)
apply (case_tac "D")
apply auto
done

lemma PartNum_DataSpace [simp]:
  "PartNum (DSpace) = 2"
apply (unfold PartNum_def DSpace_def)
apply (simp add: Abs_dataspace_inverse)
done

lemma PartDom_DataSpace_V0 [simp]:
  "(PartDom DSpace 0) = range V0"
apply (unfold PartDom_def DSpace_def)
apply (simp add: Abs_dataspace_inverse)
done

lemma PartDom_DataSpace_V1 [simp]:
  "(PartDom DSpace (Suc 0)) = range V1"
apply (unfold PartDom_def DSpace_def)
apply (simp add: Abs_dataspace_inverse)
done

lemma check_InitialData [simp]:
  "([V0 0, V1 0],DSpace) \<in> data"
apply (unfold data_def Data.Data_def)
apply auto
apply (rename_tac d)
apply (case_tac "d=0 \<or> d = 1")
apply auto
done

lemma Select0_InitData [simp]:
  "Select0 (LiftInitData [V0 0, V1 0]) = 0"
apply (unfold LiftInitData_def Select0_def DataPart_def DataValue_def)
apply (simp add: Abs_data_inverse)
done

lemma Select1_InitData [simp]:
  "Select1 (LiftInitData [V0 0, V1 0]) = 0"
apply (unfold LiftInitData_def Select1_def DataPart_def DataValue_def)
apply (simp add: Abs_data_inverse)
done

lemma HAInitValue1_CarAudioSystem:
  "CarAudioSystem |=H= Atom (VAL (\<lambda> d. (Select0 d) = 0))"
apply (simp add: ValueCarAudioSystem)
done

lemma HAInitValue2_CarAudioSystem:
  "CarAudioSystem |=H= Atom (VAL (\<lambda> d. (Select1 d) = 0))"
apply (simp add: ValueCarAudioSystem)
done

lemma HAInitValue_DSpace_CarAudioSystem [simp]:
  "Data.DataSpace (LiftInitData [V0 0, V1 0]) = DSpace"
apply (unfold LiftInitData_def Data.DataSpace_def)
apply (simp add: Abs_data_inverse)
done

lemma check_InitStatus [simp]:
  "(CarAudioSystem, InitConf CarAudioSystem, {},LiftInitData [V0 0, V1 0]) \<in> status"
apply (unfold status_def Status_def)
apply (simp add: ValueCarAudioSystem)
done

lemma InitData_InitStatus [simp]:
  "Value (InitStatus CarAudioSystem) = LiftInitData [V0 0, V1 0]"
apply (simp add: ValueCarAudioSystem)
done

lemma Events_InitStatus [simp]:
  "Events (InitStatus CarAudioSystem) = {}"
apply (unfold InitStatus_def Events_def)
apply (simp add: Abs_status_inverse)
done

lemma Conf_InitStatus [simp]:
  "Conf (InitStatus CarAudioSystem) = InitConf CarAudioSystem"
apply (unfold InitStatus_def Conf_def)
apply (simp add: Abs_status_inverse)
done

lemma CompFunCarAudioSystem_the:
  "the (CompFun CarAudioSystem ''On'') =  {CDMode_CTRL,TunerMode_CTRL}"
apply (unfold CarAudioSystem_def)
apply (subst AddSA_CompFun_the)
prefer 3
apply (subst AddSA_CompFun_the)
prefer 3
apply (subst AddSA_CompFun_the2)
apply (wellformed CarAudioSystemthms_5)+
done

lemma CompFunCarAudioSystem_the2:
  "the (CompFun CarAudioSystem ''CarAudioSystem'') =  {AudioPlayer_CTRL, CDPlayer_CTRL}"
apply (unfold CarAudioSystem_def)
apply (subst AddSA_CompFun_the3)
prefer 5
apply (subst AddSA_CompFun_the3)
prefer 5
apply (subst AddSA_CompFun_the)
prefer 3
apply (subst AddSA_CompFun_the)
prefer 3
apply (subst PseudoHA_CompFun_the)
apply (wellformed CarAudioSystemthms_5)+
done

lemma CompFunCarAudioSystem_the3:
  "the (CompFun CarAudioSystem ''Off'') =  {}"
apply (unfold CarAudioSystem_def)
apply (subst AddSA_CompFun_the3)
prefer 5
apply (subst AddSA_CompFun_the3)
prefer 5
apply (subst AddSA_CompFun_the2)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal CompFunCarAudioSystem_ran:
  "ran (CompFun CarAudioSystem) = ?X"
apply (unfold CarAudioSystem_def)
apply (rule AddSA_CompFun_ran3_IFF)
prefer 6
apply (subst AddSA_CompFun_PseudoHA_ran2)
prefer 4
apply (simp add: insert_commute)
apply (wellformed CarAudioSystemthms_5)+
done

lemma Root_CTRL_CDPlayer_CTRL_noteq [simp]:
  "Root_CTRL \<noteq> CDPlayer_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma Root_CTRL_TunerMode_CTRL_noteq [simp]:
  "Root_CTRL \<noteq> TunerMode_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma Root_CTRL_CDMode_CTRL_noteq [simp]:
  "Root_CTRL \<noteq> CDMode_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma CDPlayer_CTRL_AudioPlayer_CTRL_noteq [simp]:
  "CDPlayer_CTRL \<noteq> AudioPlayer_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma CDPlayer_CTRL_TunerMode_CTRL_noteq [simp]:
  "CDPlayer_CTRL \<noteq> TunerMode_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma CDPlayer_CTRL_CDMode_CTRL_noteq [simp]:
  "CDPlayer_CTRL \<noteq> CDMode_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma AudioPlayer_CTRL_TunerMode_CTRL_noteq [simp]:
  "AudioPlayer_CTRL \<noteq>  TunerMode_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma AudioPlayer_CTRL_CDMode_CTRL_noteq [simp]:
  "AudioPlayer_CTRL \<noteq> CDMode_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

lemma TunerMode_CTRL_CDMode_CTRL_noteq [simp]:
  "TunerMode_CTRL \<noteq>  CDMode_CTRL"
apply (rule SA_States_disjunct)
apply (wellformed CarAudioSystemthms_5)+
done

schematic_goal Chi_CarAudioSystem:
  "Chi CarAudioSystem ''CarAudioSystem'' = ?X"
apply (unfold Chi_def)
apply (rule trans)
apply (simp add: SAsCarAudioSystem StatesCarAudioSystem restrict_def CompFunCarAudioSystem_the2)
apply (rule trans)
apply (simp add: not_sym)
apply (simp add: CarAudioSystemStates insert_or)
done

schematic_goal Chi_CarAudioSystem_On:
  "Chi CarAudioSystem ''On'' = ?X"
apply (unfold Chi_def)
apply (rule trans)
apply (simp add: SAsCarAudioSystem StatesCarAudioSystem restrict_def CompFunCarAudioSystem_the)
apply (rule trans)
apply (simp add: not_sym)
apply (simp add: CarAudioSystemStates insert_or)
done

schematic_goal Chi_CarAudioSystem_Off:
  "Chi CarAudioSystem ''Off'' = ?X"
apply (unfold Chi_def)
apply (simp add: SAsCarAudioSystem StatesCarAudioSystem restrict_def CompFunCarAudioSystem_the3)
done

schematic_goal InitConf_CarAudioSystem:
  "InitConf CarAudioSystem = ?X"
apply (unfold CarAudioSystem_def)
apply (rule AddSA_InitConf_IFF)+
apply simp
apply (wellformed CarAudioSystemthms_5)
apply fast
apply (wellformed CarAudioSystemthms_5)
apply simp
apply (simp add: CarAudioSystemthms_5)
apply (wellformed CarAudioSystemthms_5)
apply fast
apply (wellformed CarAudioSystemthms_5)
apply fast
apply simp
apply (wellformed CarAudioSystemthms_5)
apply fast
apply (wellformed CarAudioSystemthms_5)
apply fast
apply simp
apply (wellformed CarAudioSystemthms_5)
apply force
apply (wellformed CarAudioSystemthms_5)
apply fast
apply (simp add: CarAudioSystemthms_5)
done

lemma Initial_State_CarAudioSystem:
  "CarAudioSystem |=H= Atom (IN ''Off'')"
apply (simp add: InitConf_CarAudioSystem )
done

end


(*  Title:      HOL/Proofs/Lambda/NormalForm.thy
    Author:     Stefan Berghofer, TU Muenchen, 2003
*)

section {* Inductive characterization of lambda terms in normal form *}

theory NormalForm
imports ListBeta
begin

subsection {* Terms in normal form *}

definition
  listall :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "listall P xs \<equiv> (\<forall>i. i < length xs \<longrightarrow> P (xs ! i))"

declare listall_def [extraction_expand_def]

theorem listall_nil: "listall P []"
  by (simp add: listall_def)

theorem listall_nil_eq [simp]: "listall P [] = True"
  by (iprover intro: listall_nil)

theorem listall_cons: "P x \<Longrightarrow> listall P xs \<Longrightarrow> listall P (x # xs)"
  apply (simp add: listall_def)
  apply (rule allI impI)+
  apply (case_tac i)
  apply simp+
  done

theorem listall_cons_eq [simp]: "listall P (x # xs) = (P x \<and> listall P xs)"
  apply (rule iffI)
  prefer 2
  apply (erule conjE)
  apply (erule listall_cons)
  apply assumption
  apply (unfold listall_def)
  apply (rule conjI)
  apply (erule_tac x=0 in allE)
  apply simp
  apply simp
  apply (rule allI)
  apply (erule_tac x="Suc i" in allE)
  apply simp
  done

lemma listall_conj1: "listall (\<lambda>x. P x \<and> Q x) xs \<Longrightarrow> listall P xs"
  by (induct xs) simp_all

lemma listall_conj2: "listall (\<lambda>x. P x \<and> Q x) xs \<Longrightarrow> listall Q xs"
  by (induct xs) simp_all

lemma listall_app: "listall P (xs @ ys) = (listall P xs \<and> listall P ys)"
  apply (induct xs)
   apply (rule iffI, simp, simp)
  apply (rule iffI, simp, simp)
  done

lemma listall_snoc [simp]: "listall P (xs @ [x]) = (listall P xs \<and> P x)"
  apply (rule iffI)
  apply (simp add: listall_app)+
  done

lemma listall_cong [cong, extraction_expand]:
  "xs = ys \<Longrightarrow> listall P xs = listall P ys"
  -- {* Currently needed for strange technical reasons *}
  by (unfold listall_def) simp

text {*
@{term "listsp"} is equivalent to @{term "listall"}, but cannot be
used for program extraction.
*}

lemma listall_listsp_eq: "listall P xs = listsp P xs"
  by (induct xs) (auto intro: listsp.intros)

inductive NF :: "dB \<Rightarrow> bool"
where
  App: "listall NF ts \<Longrightarrow> NF (Var x \<degree>\<degree> ts)"
| Abs: "NF t \<Longrightarrow> NF (Abs t)"
monos listall_def

lemma nat_eq_dec: "\<And>n::nat. m = n \<or> m \<noteq> n"
  apply (induct m)
  apply (case_tac n)
  apply (case_tac [3] n)
  apply (simp only: nat.simps, iprover?)+
  done

lemma nat_le_dec: "\<And>n::nat. m < n \<or> \<not> (m < n)"
  apply (induct m)
  apply (case_tac n)
  apply (case_tac [3] n)
  apply (simp del: simp_thms, iprover?)+
  done

lemma App_NF_D: assumes NF: "NF (Var n \<degree>\<degree> ts)"
  shows "listall NF ts" using NF
  by cases simp_all

subsection {* Properties of @{text NF} *}

lemma Var_NF: "NF (Var n)"
  apply (subgoal_tac "NF (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule NF.App)
  apply simp
  done

lemma Abs_NF:
  assumes NF: "NF (Abs t \<degree>\<degree> ts)"
  shows "ts = []" using NF
proof cases
  case (App us i)
  thus ?thesis by (simp add: Var_apps_neq_Abs_apps [THEN not_sym])
next
  case (Abs u)
  thus ?thesis by simp
qed

lemma subst_terms_NF: "listall NF ts \<Longrightarrow>
    listall (\<lambda>t. \<forall>i j. NF (t[Var i/j])) ts \<Longrightarrow>
    listall NF (map (\<lambda>t. t[Var i/j]) ts)"
  by (induct ts) simp_all

lemma subst_Var_NF: "NF t \<Longrightarrow> NF (t[Var i/j])"
  apply (induct arbitrary: i j set: NF)
  apply simp
  apply (frule listall_conj1)
  apply (drule listall_conj2)
  apply (drule_tac i=i and j=j in subst_terms_NF)
  apply assumption
  apply (rule_tac m1=x and n1=j in nat_eq_dec [THEN disjE])
  apply simp
  apply (erule NF.App)
  apply (rule_tac m1=j and n1=x in nat_le_dec [THEN disjE])
  apply simp
  apply (iprover intro: NF.App)
  apply simp
  apply (iprover intro: NF.App)
  apply simp
  apply (iprover intro: NF.Abs)
  done

lemma app_Var_NF: "NF t \<Longrightarrow> \<exists>t'. t \<degree> Var i \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  apply (induct set: NF)
  apply (simplesubst app_last)  --{*Using @{text subst} makes extraction fail*}
  apply (rule exI)
  apply (rule conjI)
  apply (rule rtranclp.rtrancl_refl)
  apply (rule NF.App)
  apply (drule listall_conj1)
  apply (simp add: listall_app)
  apply (rule Var_NF)
  apply (rule exI)
  apply (rule conjI)
  apply (rule rtranclp.rtrancl_into_rtrancl)
  apply (rule rtranclp.rtrancl_refl)
  apply (rule beta)
  apply (erule subst_Var_NF)
  done

lemma lift_terms_NF: "listall NF ts \<Longrightarrow>
    listall (\<lambda>t. \<forall>i. NF (lift t i)) ts \<Longrightarrow>
    listall NF (map (\<lambda>t. lift t i) ts)"
  by (induct ts) simp_all

lemma lift_NF: "NF t \<Longrightarrow> NF (lift t i)"
  apply (induct arbitrary: i set: NF)
  apply (frule listall_conj1)
  apply (drule listall_conj2)
  apply (drule_tac i=i in lift_terms_NF)
  apply assumption
  apply (rule_tac m1=x and n1=i in nat_le_dec [THEN disjE])
  apply simp
  apply (rule NF.App)
  apply assumption
  apply simp
  apply (rule NF.App)
  apply assumption
  apply simp
  apply (rule NF.Abs)
  apply simp
  done

text {*
@{term NF} characterizes exactly the terms that are in normal form.
*}

lemma NF_eq: "NF t = (\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t')"
proof
  assume "NF t"
  then have "\<And>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  proof induct
    case (App ts t)
    show ?case
    proof
      assume "Var t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> t'"
      then obtain rs where "ts => rs"
        by (iprover dest: head_Var_reduction)
      with App show False
        by (induct rs arbitrary: ts) auto
    qed
  next
    case (Abs t)
    show ?case
    proof
      assume "Abs t \<rightarrow>\<^sub>\<beta> t'"
      then show False using Abs by cases simp_all
    qed
  qed
  then show "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'" ..
next
  assume H: "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  then show "NF t"
  proof (induct t rule: Apps_dB_induct)
    case (1 n ts)
    then have "\<forall>ts'. \<not> ts => ts'"
      by (iprover intro: apps_preserves_betas)
    with 1(1) have "listall NF ts"
      by (induct ts) auto
    then show ?case by (rule NF.App)
  next
    case (2 u ts)
    show ?case
    proof (cases ts)
      case Nil
      from 2 have "\<forall>u'. \<not> u \<rightarrow>\<^sub>\<beta> u'"
        by (auto intro: apps_preserves_beta)
      then have "NF u" by (rule 2)
      then have "NF (Abs u)" by (rule NF.Abs)
      with Nil show ?thesis by simp
    next
      case (Cons r rs)
      have "Abs u \<degree> r \<rightarrow>\<^sub>\<beta> u[r/0]" ..
      then have "Abs u \<degree> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> u[r/0] \<degree>\<degree> rs"
        by (rule apps_preserves_beta)
      with Cons have "Abs u \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> u[r/0] \<degree>\<degree> rs"
        by simp
      with 2 show ?thesis by iprover
    qed
  qed
qed

end