(*
Author: Alexander Katovsky
*)

header "Natural Transformation"

theory NatTrans
imports Functors
begin

record ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans =
  NTDom :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor"
  NTCod :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor"
  NatTransMap :: "'o1 \<Rightarrow> 'm2"

abbreviation
  NatTransApp :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow> 'o1 \<Rightarrow> 'm2" (infixr "$$" 70) where
  "NatTransApp \<eta> X \<equiv> (NatTransMap \<eta>) X"

definition  "NTCatDom \<eta> \<equiv> CatDom (NTDom \<eta>)"
definition  "NTCatCod \<eta> \<equiv> CatCod (NTCod \<eta>)"

locale NatTransExt =
  fixes \<eta> :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" (structure)
  assumes  NTExt : "NatTransMap \<eta> \<in> extensional (Obj (NTCatDom \<eta>))"

locale NatTransP =
  fixes \<eta> :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" (structure)
  assumes NatTransFtor:   "Functor (NTDom \<eta>)"
  and     NatTransFtor2:  "Functor (NTCod \<eta>)"
  and     NatTransFtorDom:   "NTCatDom \<eta> = CatDom (NTCod \<eta>)"
  and     NatTransFtorCod:   "NTCatCod \<eta> = CatCod (NTDom \<eta>)"
  and    NatTransMapsTo:  "X \<in> obj\<^bsub>NTCatDom \<eta>\<^esub> \<Longrightarrow>
                           (\<eta> $$ X) maps\<^bsub>NTCatCod \<eta>\<^esub> ((NTDom \<eta>) @@ X) to ((NTCod \<eta>) @@ X)"
  and    NatTrans:  "f maps\<^bsub>NTCatDom \<eta>\<^esub> X to Y \<Longrightarrow>
                     ((NTDom \<eta>) ## f) ;;\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y) = (\<eta> $$ X) ;;\<^bsub>NTCatCod \<eta>\<^esub> ((NTCod \<eta>) ## f)"

locale NatTrans = NatTransP + NatTransExt

definition MakeNT :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" where
"MakeNT \<eta> \<equiv> \<lparr>
      NTDom = NTDom \<eta> ,
      NTCod = NTCod \<eta> ,
      NatTransMap = restrict (NatTransMap \<eta>) (Obj (NTCatDom \<eta>))
  \<rparr>"

definition
  nt_abbrev ("NT _ : _ \<Longrightarrow> _" [81]) where
  "NT f : F \<Longrightarrow> G \<equiv> (NatTrans f) \<and> (NTDom f = F) \<and> (NTCod f = G)"

lemma nt_abbrevE[elim]: "\<lbrakk>NT f : F \<Longrightarrow> G ; \<lbrakk>(NatTrans f) ; (NTDom f = F) ; (NTCod f = G)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (auto simp add: nt_abbrev_def)

lemma MakeNT: "NatTransP \<eta> \<Longrightarrow> NatTrans (MakeNT \<eta>)"
  by(auto simp add: NatTransP_def NatTrans_def MakeNT_def NTCatDom_def NTCatCod_def Category.MapsToObj
    NatTransExt_def)

lemma MakeNT_comp: "X \<in> Obj (NTCatDom f) \<Longrightarrow> (MakeNT f) $$ X = f $$ X"
by (simp add: MakeNT_def)

lemma MakeNT_dom: "NTCatDom f = NTCatDom (MakeNT f)"
by (simp add: NTCatDom_def MakeNT_def)

lemma MakeNT_cod: "NTCatCod f = NTCatCod (MakeNT f)"
by (simp add: NTCatCod_def MakeNT_def)

lemma MakeNTApp: "X \<in> Obj (NTCatDom (MakeNT f)) \<Longrightarrow> f $$ X = (MakeNT f) $$ X"
by(simp add: MakeNT_def NTCatDom_def)

lemma NatTransMapsTo:
  assumes "NT \<eta> : F \<Longrightarrow> G" and "X \<in> Obj (CatDom F)"
  shows "\<eta> $$ X maps\<^bsub>CatCod G \<^esub>(F @@ X) to (G @@ X)"
proof-
  have NTP: "NatTransP \<eta>" using assms by auto
  have NTC: "NTCatCod \<eta> = CatCod G" using assms by (auto simp add: NTCatCod_def)
  have NTD: "NTCatDom \<eta> = CatDom F" using assms by (auto simp add: NTCatDom_def)
  hence Obj: "X \<in> Obj (NTCatDom \<eta>)" using assms by simp
  have DF: "NTDom \<eta> = F" and CG: "NTCod \<eta> = G" using assms by auto
  have NTmapsTo: "\<eta> $$ X maps\<^bsub>NTCatCod \<eta> \<^esub>((NTDom \<eta>) @@ X) to ((NTCod \<eta>) @@ X)"
    using NTP Obj by (simp add: NatTransP.NatTransMapsTo)
  thus ?thesis using NTC NTD DF CG by simp
qed

definition
   NTCompDefined :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans
                      \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow> bool" (infixl "\<approx>>\<bullet>" 65) where
  "NTCompDefined \<eta>1 \<eta>2 \<equiv> NatTrans \<eta>1 \<and> NatTrans \<eta>2 \<and> NTCatDom \<eta>2 = NTCatDom \<eta>1 \<and>
                         NTCatCod \<eta>2 = NTCatCod \<eta>1 \<and> NTCod \<eta>1 = NTDom \<eta>2"

lemma NTCompDefinedE[elim]: "\<lbrakk>\<eta>1 \<approx>>\<bullet> \<eta>2 ; \<lbrakk>NatTrans \<eta>1 ; NatTrans \<eta>2 ; NTCatDom \<eta>2 = NTCatDom \<eta>1 ;
                         NTCatCod \<eta>2 = NTCatCod \<eta>1 ; NTCod \<eta>1 = NTDom \<eta>2\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (simp add: NTCompDefined_def)

lemma NatTransExt0:
  assumes "NTDom \<eta>1 = NTDom \<eta>2" and "NTCod \<eta>1 = NTCod \<eta>2"
  and     "\<And>X . X \<in> Obj (NTCatDom \<eta>1) \<Longrightarrow> \<eta>1 $$ X = \<eta>2 $$ X"
  and     "NatTransMap \<eta>1 \<in> extensional (Obj (NTCatDom \<eta>1))"
  and     "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>2))"
  shows   "\<eta>1 = \<eta>2"
proof-
  have "NatTransMap \<eta>1 = NatTransMap \<eta>2"
  proof(rule extensionalityI [of "NatTransMap \<eta>1" "Obj (NTCatDom \<eta>1)"])
    show "NatTransMap \<eta>1 \<in> extensional (Obj (NTCatDom \<eta>1))" using assms by simp
    have "NTCatDom \<eta>1 = NTCatDom \<eta>2" using assms by (simp add: NTCatDom_def)
    moreover have "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>2))" using assms by simp
    ultimately show "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>1))" by simp
    {fix X assume "X \<in> Obj (NTCatDom \<eta>1)" thus "\<eta>1 $$ X = \<eta>2 $$ X" using assms by simp}
  qed
  thus ?thesis using assms by (simp)
qed

lemma NatTransExt:
  assumes "NatTrans \<eta>1" and "NatTrans \<eta>2" and "NTDom \<eta>1 = NTDom \<eta>2" and "NTCod \<eta>1 = NTCod \<eta>2"
  and     "\<And>X . X \<in> Obj (NTCatDom \<eta>1) \<Longrightarrow> \<eta>1 $$ X = \<eta>2 $$ X"
  shows   "\<eta>1 = \<eta>2"
proof-
  have "NatTransMap \<eta>1 \<in> extensional (Obj (NTCatDom \<eta>1))" and
       "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>2))" using assms
  by(simp only: NatTransExt_def NatTrans_def)+
  thus ?thesis using assms by (simp add: NatTransExt0)
qed

definition
  IdNatTrans' :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2) Functor \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a1, 'a2) NatTrans" where
  "IdNatTrans' F \<equiv> \<lparr>
      NTDom = F ,
      NTCod = F ,
      NatTransMap = \<lambda> X . id\<^bsub>CatCod F\<^esub> (F @@ X)
  \<rparr>"

definition "IdNatTrans F \<equiv> MakeNT(IdNatTrans' F)"

lemma IdNatTrans_map: "X \<in> obj\<^bsub>CatDom F\<^esub> \<Longrightarrow> (IdNatTrans F) $$ X = id\<^bsub>CatCod F\<^esub> (F @@ X)"
by(auto simp add: IdNatTrans_def IdNatTrans'_def MakeNT_comp MakeNT_def NTCatDom_def)

lemmas IdNatTrans_defs = IdNatTrans_def IdNatTrans'_def MakeNT_def IdNatTrans_map NTCatCod_def NTCatDom_def

lemma IdNatTransNatTrans': "Functor F \<Longrightarrow> NatTransP(IdNatTrans' F)"
proof(auto simp add:NatTransP_def IdNatTrans'_def NTCatDom_def NTCatCod_def Category.Simps
        PreFunctor.FunctorId2 functor_simps Functor.FunctorMapsTo)
  {
    fix f X Y
    assume a: "Functor F" and b: "f maps\<^bsub>CatDom F\<^esub> X to Y"
    show "(F ## f) ;;\<^bsub>CatCod F\<^esub> (id\<^bsub>CatCod F\<^esub> (F @@ Y)) = (id\<^bsub>CatCod F\<^esub> (F @@ X)) ;;\<^bsub>CatCod F\<^esub> (F ## f)"
    proof-
      have 1: "Category (CatCod F)" using a by simp
      have "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ X) to (F @@ Y)" using a b by (auto simp add: Functor.FunctorMapsTo)
      hence 2: "F ## f \<in> mor\<^bsub>CatCod F\<^esub>" and 3: "cod\<^bsub>CatCod F\<^esub> (F ## f) = (F @@ Y)"
        and 4: "dom\<^bsub>CatCod F\<^esub> (F ## f) = (F @@ X)" by auto
      have "(F ## f) ;;\<^bsub>CatCod F\<^esub> (id\<^bsub>CatCod F\<^esub> (F @@ Y)) = (F ## f) ;;\<^bsub>CatCod F\<^esub> (id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## f)))"
        using 3 by simp
      also have "... = F ## f" using 1 2 by (auto simp add: Category.Cidr)
      also have "... = (id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## f))) ;;\<^bsub>CatCod F\<^esub> (F ## f)"
        using 1 2 by (auto simp add: Category.Cidl)
      also have "... = (id\<^bsub>CatCod F\<^esub> (F @@ X)) ;;\<^bsub>CatCod F\<^esub> (F ## f)" using 4 by simp
      finally show ?thesis .
    qed
  }
qed

lemma IdNatTransNatTrans: "Functor F \<Longrightarrow> NatTrans (IdNatTrans F)"
by (simp add: IdNatTransNatTrans' IdNatTrans_def MakeNT)

definition
  NatTransComp' :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow>
                   ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow>
                   ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" (infixl "\<bullet>1" 75) where
  "NatTransComp' \<eta>1 \<eta>2 = \<lparr>
      NTDom = NTDom \<eta>1 ,
      NTCod = NTCod \<eta>2 ,
      NatTransMap = \<lambda> X . (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)
  \<rparr>"

definition NatTransComp (infixl "\<bullet>" 75) where "\<eta>1 \<bullet> \<eta>2 \<equiv> MakeNT(\<eta>1 \<bullet>1 \<eta>2)"

lemma NatTransComp_Comp1: "\<lbrakk>x \<in> Obj (NTCatDom f) ; f \<approx>>\<bullet> g\<rbrakk> \<Longrightarrow> (f \<bullet> g) $$ x = (f $$ x) ;;\<^bsub>NTCatCod g\<^esub> (g $$ x)"
by(auto simp add: NatTransComp_def NatTransComp'_def MakeNT_def NTCatCod_def NTCatDom_def)

lemma NatTransComp_Comp2: "\<lbrakk>x \<in> Obj (NTCatDom f) ; f \<approx>>\<bullet> g\<rbrakk> \<Longrightarrow> (f \<bullet> g) $$ x = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> (g $$ x)"
by(auto simp add: NatTransComp_def NatTransComp'_def MakeNT_def NTCatCod_def NTCatDom_def)

lemmas NatTransComp_defs = NatTransComp_def NatTransComp'_def MakeNT_def
  NatTransComp_Comp1  NTCatCod_def NTCatDom_def

lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NatTrans \<eta>1" by auto
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NatTrans \<eta>2" by auto
lemma NTCatDom:        "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatDom \<eta>1 = NTCatDom \<eta>2" by auto
lemma NTCatCod:        "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatCod \<eta>1 = NTCatCod \<eta>2" by auto
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatDom (\<eta>1 \<bullet>1 \<eta>2) = NTCatDom \<eta>1" by (auto simp add: NatTransComp'_def NTCatDom_def)
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatCod (\<eta>1 \<bullet>1 \<eta>2) = NTCatCod \<eta>1" by (auto simp add: NatTransComp'_def NTCatCod_def)
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatDom (\<eta>1 \<bullet> \<eta>2) = NTCatDom \<eta>1" by (auto simp add: NatTransComp_defs)
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatCod (\<eta>1 \<bullet> \<eta>2) = NTCatCod \<eta>1" by (auto simp add: NatTransComp_defs)
lemma [simp]: "NatTrans \<eta> \<Longrightarrow> Category(NTCatDom \<eta>)" by (simp add:  NatTransP.NatTransFtor NTCatDom_def)
lemma [simp]: "NatTrans \<eta> \<Longrightarrow> Category(NTCatCod \<eta>)" by (simp add:  NatTransP.NatTransFtor2 NTCatCod_def)
lemma DDDC: assumes "NatTrans f" shows "CatDom (NTDom f) = CatDom (NTCod f)"
proof-
  have "CatDom (NTDom f) = NTCatDom f" by (simp add: NTCatDom_def)
  thus ?thesis using assms by (simp add: NatTransP.NatTransFtorDom)
qed
lemma CCCD: assumes "NatTrans f" shows "CatCod (NTCod f) = CatCod (NTDom f)"
proof-
  have "CatCod (NTCod f) = NTCatCod f" by (simp add: NTCatCod_def)
  thus ?thesis using assms by (simp add: NatTransP.NatTransFtorCod)
qed

lemma IdNatTransCompDefDom: "NatTrans f \<Longrightarrow> (IdNatTrans (NTDom f)) \<approx>>\<bullet> f"
apply(rule NTCompDefinedI)
apply(simp_all add: IdNatTransNatTrans NatTransP.NatTransFtor)
apply(simp_all add: IdNatTrans_defs CCCD)
done

lemma IdNatTransCompDefCod: "NatTrans f \<Longrightarrow> f \<approx>>\<bullet> (IdNatTrans (NTCod f))"
apply(rule NTCompDefinedI)
apply(simp_all add: IdNatTransNatTrans NatTransP.NatTransFtor2)
apply(simp_all add: IdNatTrans_defs DDDC)
done

lemma NatTransCompDefCod:
  assumes "NatTrans \<eta>" and "f maps\<^bsub>NTCatDom \<eta>\<^esub> X to Y"
  shows "(\<eta> $$ X) \<approx>>\<^bsub>NTCatCod \<eta>\<^esub> (NTCod \<eta> ## f)"
proof(rule CompDefinedI)
  have b: "X \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" and c: "Y \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" using assms by (auto simp add: Category.MapsToObj)
  have d: "(\<eta> $$ X) maps\<^bsub>NTCatCod \<eta>\<^esub> ((NTDom \<eta>) @@ X) to ((NTCod \<eta>) @@ X)" using assms b
    by (simp add: NatTransP.NatTransMapsTo)
  thus "\<eta> $$ X \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" by auto
  have "f maps\<^bsub>CatDom (NTCod \<eta>)\<^esub> X to Y" using assms by (simp add: NatTransP.NatTransFtorDom)
  hence e: "NTCod \<eta> ## f maps\<^bsub>CatCod (NTCod \<eta>)\<^esub> (NTCod \<eta> @@ X) to (NTCod \<eta> @@ Y)" using assms
    by (simp add: FunctorM.FunctorCompM NatTransP.NatTransFtor2)
  thus "NTCod \<eta> ## f \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" by (auto simp add: NTCatCod_def)
  have "cod\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ X) = (NTCod \<eta> @@ X)" using d by auto
  also have "... = dom\<^bsub>CatCod (NTCod \<eta>)\<^esub> (NTCod \<eta> ## f)" using e by auto
  finally show "cod\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ X) = dom\<^bsub>NTCatCod \<eta>\<^esub> (NTCod \<eta> ## f)" by (auto simp add: NTCatCod_def)
qed

lemma NatTransCompDefDom:
  assumes "NatTrans \<eta>" and "f maps\<^bsub>NTCatDom \<eta>\<^esub> X to Y"
  shows "(NTDom \<eta> ## f)  \<approx>>\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y)"
proof(rule CompDefinedI)
  have b: "X \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" and c: "Y \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" using assms by (auto simp add: Category.MapsToObj)
  have d: "(\<eta> $$ Y) maps\<^bsub>NTCatCod \<eta>\<^esub> ((NTDom \<eta>) @@ Y) to ((NTCod \<eta>) @@ Y)" using assms c
    by (simp add: NatTransP.NatTransMapsTo)
  thus "\<eta> $$ Y \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" by auto
  have "f maps\<^bsub>CatDom (NTDom \<eta>)\<^esub> X to Y" using assms by (simp add: NTCatDom_def)
  hence e: "NTDom \<eta> ## f maps\<^bsub>CatCod (NTDom \<eta>)\<^esub> (NTDom \<eta> @@ X) to (NTDom \<eta> @@ Y)" using assms
    by (simp add: FunctorM.FunctorCompM NatTransP.NatTransFtor)
  thus "NTDom \<eta> ## f \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" using assms by (auto simp add: NatTransP.NatTransFtorCod)
  have "dom\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y) = (NTDom \<eta> @@ Y)" using d by auto
  also have "... = cod\<^bsub>CatCod (NTDom \<eta>)\<^esub> (NTDom \<eta> ## f)" using e by auto
  finally show "cod\<^bsub>NTCatCod \<eta>\<^esub> (NTDom \<eta> ## f) = dom\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y)"
    using assms by (auto simp add: NatTransP.NatTransFtorCod)
qed

lemma NatTransCompCompDef:
  assumes "\<eta>1 \<approx>>\<bullet> \<eta>2" and "X \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>"
  shows "(\<eta>1 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)"
proof(rule CompDefinedI)
  have 1: "(\<eta>1 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>1) @@ X) to ((NTCod \<eta>1) @@ X)" using assms
    by (simp add: NatTransP.NatTransMapsTo)
  have "NTCatCod \<eta>1 = NTCatCod \<eta>2" using assms by auto
  hence 2: "(\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>2) @@ X) to ((NTCod \<eta>2) @@ X)" using assms
    by (simp add: NatTransP.NatTransMapsTo NTCatDom)
  show "\<eta>1 $$ X \<in> mor\<^bsub>NTCatCod \<eta>1\<^esub>"
    and "\<eta>2 $$ X \<in> mor\<^bsub>NTCatCod \<eta>1\<^esub>"  using 1 2 by auto
  have "cod\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ X) = ((NTCod \<eta>1) @@ X)" using 1 by auto
  also have "... = ((NTDom \<eta>2) @@ X)" using assms by auto
  finally show "cod\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ X) = dom\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)" using 2 by auto
qed

lemma NatTransCompNatTrans':
  assumes "\<eta>1 \<approx>>\<bullet> \<eta>2"
  shows   "NatTransP (\<eta>1 \<bullet>1 \<eta>2)"
proof(auto simp add: NatTransP_def)
  show "Functor (NTDom (\<eta>1 \<bullet>1 \<eta>2))" and "Functor (NTCod (\<eta>1 \<bullet>1 \<eta>2))" using assms
    by (auto simp add: NatTransComp'_def NatTransP.NatTransFtor NatTransP.NatTransFtor2)
  show "NTCatDom (\<eta>1 \<bullet>1 \<eta>2) = CatDom (NTCod (\<eta>1 \<bullet>1 \<eta>2))" and
       "NTCatCod (\<eta>1 \<bullet>1 \<eta>2) = CatCod (NTDom (\<eta>1 \<bullet>1 \<eta>2))"
  proof (auto simp add: NatTransComp'_def NTCatCod_def NTCatDom_def)
    have "CatDom (NTDom \<eta>1) = NTCatDom \<eta>1" by (simp add: NTCatDom_def)
    thus "CatDom (NTDom \<eta>1) = CatDom (NTCod \<eta>2)" using assms by (auto simp add: NatTransP.NatTransFtorDom)
    have "CatCod (NTCod \<eta>2) = NTCatCod \<eta>2" by (simp add: NTCatCod_def)
    thus "CatCod (NTCod \<eta>2) = CatCod (NTDom \<eta>1)" using assms by (auto simp add: NatTransP.NatTransFtorCod)
  qed
  {
    fix X assume aa: "X \<in> obj\<^bsub>NTCatDom (\<eta>1 \<bullet>1 \<eta>2)\<^esub>"
    show "(\<eta>1 \<bullet>1 \<eta>2) $$ X maps\<^bsub>NTCatCod (\<eta>1 \<bullet>1 \<eta>2)\<^esub> NTDom (\<eta>1 \<bullet>1 \<eta>2) @@ X to NTCod (\<eta>1 \<bullet>1 \<eta>2) @@ X"
    proof-
      have "X \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>" and "NatTrans \<eta>1" using assms aa by simp+
      hence "(\<eta>1 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>1) @@ X) to ((NTCod \<eta>1) @@ X)"
        by (simp add: NatTransP.NatTransMapsTo)
      moreover have "(\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>1) @@ X) to ((NTCod \<eta>2) @@ X)"
      proof-
        have "X \<in> obj\<^bsub>NTCatDom \<eta>2\<^esub>" and "NatTrans \<eta>2" using assms aa by auto
        hence "(\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>2\<^esub> ((NTDom \<eta>2) @@ X) to ((NTCod \<eta>2) @@ X)"
          by (simp add: NatTransP.NatTransMapsTo)
        thus ?thesis using assms by auto
      qed
      ultimately have "(\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>1) @@ X) to ((NTCod \<eta>2) @@ X)"
        using assms by (simp add: Category.Ccompt)
      thus ?thesis using assms by (auto simp add: NatTransComp'_def NTCatCod_def)
    qed
  }
  {
    fix f X Y assume a: "f maps\<^bsub>(NTCatDom (\<eta>1 \<bullet>1 \<eta>2))\<^esub> X to Y"
    show "(NTDom (\<eta>1 \<bullet>1 \<eta>2) ## f) ;;\<^bsub>NTCatCod (\<eta>1 \<bullet>1 \<eta>2)\<^esub> (\<eta>1 \<bullet>1 \<eta>2 $$ Y) =
       ((\<eta>1 \<bullet>1 \<eta>2) $$ X) ;;\<^bsub>NTCatCod (\<eta>1 \<bullet>1 \<eta>2)\<^esub> (NTCod (\<eta>1 \<bullet>1 \<eta>2) ## f)"
    proof-
      have b: "X \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>" and c: "Y \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>" using assms a by (auto simp add: Category.MapsToObj)
      have "((NTDom \<eta>1) ## f) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((\<eta>1 $$ Y) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)) =
            (((NTDom \<eta>1) ## f) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ Y)) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)"
      proof-
        have "((NTDom \<eta>1) ## f) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ Y)" using assms a by (auto simp add: NatTransCompDefDom)
        moreover have "(\<eta>1 $$ Y) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub>  (\<eta>2 $$ Y)" using assms by (simp add: NatTransCompCompDef c)
        ultimately show ?thesis using assms by (simp add: Category.Cassoc)
      qed
      also have "... = ((\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>2) ## f)) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)"
        using assms a by (auto simp add: NatTransP.NatTrans)
      also have "... = (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (((NTDom \<eta>2) ## f) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y))"
      proof-
        have "(\<eta>1 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>1) ## f)" using assms a by (simp add: NatTransCompDefCod)
        moreover have "((NTDom \<eta>2) ## f) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)" using assms a
          by (simp add: NatTransCompDefDom NTCatDom NTCatCod)
        ultimately show ?thesis using assms by (auto simp add: Category.Cassoc)
      qed
      also have "... = (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((\<eta>2 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>2) ## f))"
        using assms a by (simp add: NatTransP.NatTrans NTCatDom NTCatCod)
      also have "... = (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>2) ## f)"
      proof-
        have "(\<eta>1 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)" using assms by (simp add: NatTransCompCompDef b)
        moreover have "(\<eta>2 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>2) ## f)" using assms a
          by (simp add: NatTransCompDefCod NTCatCod NTCatDom)
        ultimately show ?thesis using assms by (simp add: Category.Cassoc)
      qed
      finally show ?thesis using assms by (auto simp add: NatTransComp'_def NTCatCod_def)
    qed
  }
qed

lemma NatTransCompNatTrans: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NatTrans (\<eta>1 \<bullet> \<eta>2)"
by (simp add: NatTransCompNatTrans' NatTransComp_def MakeNT)

definition
  CatExp' :: "('o1,'m1,'a) Category_scheme \<Rightarrow> ('o2,'m2,'b) Category_scheme \<Rightarrow>
                     (('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor,
                      ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans) Category"  where
  "CatExp' A B \<equiv> \<lparr>
      Category.Obj = {F . Ftor F : A \<longrightarrow> B} ,
      Category.Mor = {\<eta> . NatTrans \<eta> \<and> NTCatDom \<eta> = A \<and> NTCatCod \<eta> = B} ,
      Category.Dom = NTDom ,
      Category.Cod = NTCod ,
      Category.Id  = IdNatTrans ,
      Category.Comp = \<lambda>f g. (f \<bullet> g)
  \<rparr>"

definition "CatExp A B \<equiv> MakeCat(CatExp' A B)"

lemma IdNatTransMapL:
  assumes NT: "NatTrans f"
  shows "IdNatTrans (NTDom f) \<bullet> f = f"
proof(rule NatTransExt)
  show "NatTrans f" using assms .
  show "NatTrans (IdNatTrans (NTDom f) \<bullet> f)" using NT
    by (simp add: NatTransP.NatTransFtor IdNatTransNatTrans IdNatTransCompDefDom NatTransCompNatTrans)
  show "NTDom (IdNatTrans (NTDom f) \<bullet> f) = NTDom f" and
    "NTCod (IdNatTrans (NTDom f) \<bullet> f) = NTCod f" by (simp add: IdNatTrans_defs NatTransComp_defs)+
  {
    fix x assume aa: "x \<in> Obj (NTCatDom (IdNatTrans (NTDom f) \<bullet> f))"
    show "(IdNatTrans (NTDom f) \<bullet> f) $$ x = f $$ x"
    proof-
      have XObj: "x \<in> Obj(NTCatDom f)" using aa by (simp add: IdNatTrans_defs NatTransComp_defs)
      have fMap: "f $$ x maps\<^bsub>NTCatCod f\<^esub> NTDom f @@ x to NTCod f @@ x" using NT XObj
        by (simp add: NatTransP.NatTransMapsTo)
      have "(IdNatTrans (NTDom f) \<bullet> f) $$ x = (IdNatTrans (NTDom f) $$ x) ;;\<^bsub>NTCatCod f \<^esub>(f $$ x)"
      proof(rule NatTransComp_Comp1)
        show "x \<in> obj\<^bsub>NTCatDom (IdNatTrans (NTDom f))\<^esub>" using XObj by (simp add: IdNatTrans_defs)
        show "IdNatTrans (NTDom f) \<approx>>\<bullet> f" using NT by (simp add: IdNatTransCompDefDom)
      qed
      also have "... = id\<^bsub>NTCatCod f\<^esub> (dom\<^bsub>NTCatCod f\<^esub> (f $$ x)) ;;\<^bsub>NTCatCod f \<^esub>(f $$ x)"
        using XObj NT fMap by (auto simp add: IdNatTrans_map NTCatDom_def CCCD NTCatCod_def)
      also have "... = f $$ x"
      proof-
        have "f $$ x \<in> mor\<^bsub>NTCatCod f\<^esub>" using fMap by (auto)
        thus ?thesis using NT by (simp add: Category.Cidl)
      qed
      finally show ?thesis .
    qed
  }
qed

lemma IdNatTransMapR:
  assumes NT: "NatTrans f"
  shows "f \<bullet> IdNatTrans (NTCod f) = f"
proof(rule NatTransExt)
  show "NatTrans f" using assms .
  show "NatTrans (f \<bullet> IdNatTrans (NTCod f))" using NT
    by (simp add: NatTransP.NatTransFtor IdNatTransNatTrans IdNatTransCompDefCod NatTransCompNatTrans)
  show "NTDom (f \<bullet> IdNatTrans (NTCod f)) = NTDom f" and
    "NTCod (f \<bullet> IdNatTrans (NTCod f)) = NTCod f" by (simp add: IdNatTrans_defs NatTransComp_defs)+
  {
    fix x assume aa: "x \<in> Obj (NTCatDom (f \<bullet> IdNatTrans (NTCod f)))"
    show "(f \<bullet> IdNatTrans (NTCod f)) $$ x = f $$ x"
    proof-
      have XObj: "x \<in> Obj(NTCatDom f)" using aa by (simp add:  NatTransComp_defs)
      have fMap: "f $$ x maps\<^bsub>NTCatCod f\<^esub> NTDom f @@ x to NTCod f @@ x" using NT XObj
        by (simp add: NatTransP.NatTransMapsTo)
      have "(f \<bullet> IdNatTrans (NTCod f)) $$ x = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> (IdNatTrans (NTCod f) $$ x)"
        using XObj NT by (auto simp add: NatTransComp_Comp2 IdNatTransCompDefCod)
      also have "... = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> (id\<^bsub>NTCatCod f\<^esub> (cod\<^bsub>NTCatCod f\<^esub> (f $$ x)))"
      proof-
        have "x \<in> obj\<^bsub>CatDom (NTCod f)\<^esub>" using XObj NT by (simp add: IdNatTrans_defs DDDC)
        moreover have "(cod\<^bsub>NTCatCod f\<^esub> (f $$ x)) = (NTCod f) @@ x" using fMap by auto
        ultimately have "(IdNatTrans (NTCod f) $$ x) = (id\<^bsub>NTCatCod f\<^esub> (cod\<^bsub>NTCatCod f\<^esub> (f $$ x)))"
          by (simp add: IdNatTrans_map NTCatCod_def)
        thus ?thesis by simp
      qed
      also have "... = f $$ x"
      proof-
        have "f $$ x \<in> mor\<^bsub>NTCatCod f\<^esub>" using fMap by (auto)
        thus ?thesis using NT by (simp add: Category.Cidr)
      qed
      finally show ?thesis .
    qed
  }
qed

lemma NatTransCompDefined:
  assumes "f \<approx>>\<bullet> g" and "g \<approx>>\<bullet> h"
  shows "(f \<bullet> g) \<approx>>\<bullet> h" and "f \<approx>>\<bullet> (g \<bullet> h)"
proof-
  show "(f \<bullet> g) \<approx>>\<bullet> h"
  proof(rule NTCompDefinedI)
    show "NatTrans (f \<bullet> g)" and "NatTrans h" using assms by (auto simp add: NatTransCompNatTrans)
    have "NTCatDom f = NTCatDom h" using assms by (simp add: NTCatDom)
    thus "NTCatDom h = NTCatDom (f \<bullet> g)" by (simp add: NatTransComp_defs)
    have "NTCatCod h = NTCatCod g" using assms by (simp add: NTCatCod)
    thus "NTCatCod h = NTCatCod (f \<bullet> g)" by ( simp add: NatTransComp_defs)
    show "NTCod (f \<bullet> g) = NTDom h" using assms by (auto simp add: NatTransComp_defs)
  qed
  show "f \<approx>>\<bullet> (g \<bullet> h)"
  proof(rule NTCompDefinedI)
    show "NatTrans f" and "NatTrans (g \<bullet> h)" using assms by (auto simp add: NatTransCompNatTrans)
    have "NTCatDom f = NTCatDom g" using assms by (simp add: NTCatDom)
    thus "NTCatDom (g \<bullet> h) = NTCatDom f" by (simp add: NatTransComp_defs)
    have "NTCatCod h = NTCatCod f" using assms by (simp add: NTCatCod)
    thus "NTCatCod (g \<bullet> h) = NTCatCod f" by ( simp add: NatTransComp_defs)
    show "NTCod f = NTDom (g \<bullet> h)" using assms by (auto simp add: NatTransComp_defs)
  qed
qed

lemma NatTransCompAssoc:
  assumes "f \<approx>>\<bullet> g" and "g \<approx>>\<bullet> h"
  shows "(f \<bullet> g) \<bullet> h = f \<bullet> (g \<bullet> h)"
proof(rule NatTransExt)
  show "NatTrans ((f \<bullet> g) \<bullet> h)" using assms by (simp add: NatTransCompNatTrans NatTransCompDefined)
  show "NatTrans (f \<bullet> (g \<bullet> h))" using assms by (simp add: NatTransCompNatTrans NatTransCompDefined)
  show "NTDom (f \<bullet> g \<bullet> h) = NTDom (f \<bullet> (g \<bullet> h))" and "NTCod (f \<bullet> g \<bullet> h) = NTCod (f \<bullet> (g \<bullet> h))"
    by(simp add: NatTransComp_defs)+
  {
    fix x assume aa: "x \<in> obj\<^bsub>NTCatDom (f \<bullet> g \<bullet> h)\<^esub>" show "((f \<bullet> g) \<bullet> h) $$ x = (f \<bullet> (g \<bullet> h)) $$ x"
    proof-
      have ntd1: "NTCatDom (f \<bullet> g) = NTCatDom (f \<bullet> g \<bullet> h)" and ntd2: "NTCatDom f = NTCatDom (f \<bullet> g \<bullet> h)"
        using assms by (simp add: NatTransCompDefined)+
      have obj1: "x \<in> Obj (NTCatDom f)" using aa ntd2 by simp
      have  1: "(f \<bullet> g) $$ x = (f $$ x) ;;\<^bsub>NTCatCod h\<^esub> (g $$ x)" and
            2: "(g \<bullet> h) $$ x = (g $$ x) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x)" using obj1
        using assms by (auto simp add: NatTransComp_Comp1)
      have "((f \<bullet> g) \<bullet> h) $$ x = ((f \<bullet> g) $$ x) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x)"
      proof(rule NatTransComp_Comp1)
        show "x \<in> obj\<^bsub>NTCatDom (f \<bullet> g)\<^esub>" using aa ntd1 by simp
        show "f \<bullet> g \<approx>>\<bullet> h" using assms by (simp add: NatTransCompDefined)
      qed
      also have "... = ((f $$ x) ;;\<^bsub>NTCatCod h\<^esub> (g $$ x)) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x)" using 1 by simp
      also have "... = (f $$ x) ;;\<^bsub>NTCatCod h\<^esub> ((g $$ x) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x))"
      proof-
        have 1: "NTCatCod h = NTCatCod f" and 2: "NTCatCod h = NTCatCod g" using assms by (simp add: NTCatCod)+
        hence "(f $$ x) \<approx>>\<^bsub>NTCatCod h\<^esub> (g $$ x)" using obj1 assms by (simp add: NatTransCompCompDef)
        moreover have "(g $$ x) \<approx>>\<^bsub>NTCatCod h\<^esub> (h $$ x)" using obj1 assms 2 by (simp add: NatTransCompCompDef NTCatDom)
        moreover have "Category (NTCatCod h)" using assms by auto
        ultimately show ?thesis by (simp add: Category.Cassoc)
      qed
      also have "... = (f $$ x) ;;\<^bsub>NTCatCod h\<^esub> ((g \<bullet> h) $$ x)" using 2 by simp
      also have "... = (f \<bullet> (g \<bullet> h)) $$ x"
      proof-
        have "NTCatCod f = NTCatCod h" using assms by (simp add: NTCatCod)
        moreover have "(f \<bullet> (g \<bullet> h)) $$ x = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> ((g \<bullet> h) $$ x)"
        proof(rule NatTransComp_Comp2)
          show "x \<in> obj\<^bsub>NTCatDom f\<^esub>" using obj1 assms by (simp add: NTCatDom)
          show "f \<approx>>\<bullet> g \<bullet> h" using assms by (simp add: NatTransCompDefined)
        qed
        ultimately show ?thesis by simp
      qed
      finally show ?thesis .
    qed
  }
qed

lemma CatExpCatAx:
  assumes "Category A" and "Category B"
  shows "Category_axioms (CatExp' A B)"
proof(auto simp add: Category_axioms_def)
  {
    fix f assume "f \<in> mor\<^bsub>CatExp' A B\<^esub>"
    thus "dom\<^bsub>CatExp' A B\<^esub> f \<in> obj\<^bsub>CatExp' A B\<^esub>" and
         "cod\<^bsub>CatExp' A B\<^esub> f \<in> obj\<^bsub>CatExp' A B\<^esub>"
      by(auto simp add: CatExp'_def NatTransP.NatTransFtor
        NatTransP.NatTransFtor2 NatTransP.NatTransFtorDom NatTransP.NatTransFtorCod DDDC CCCD functor_abbrev_def)
  }
  {
    fix F assume a: "F \<in> obj\<^bsub>CatExp' A B\<^esub>"
    show "id\<^bsub>CatExp' A B\<^esub> F maps\<^bsub>CatExp' A B\<^esub> F to F"
    proof(rule MapsToI)
      have "Ftor F : A \<longrightarrow> B" using a by (simp add: CatExp'_def)
      thus "id\<^bsub>CatExp' A B\<^esub> F \<in> mor\<^bsub>CatExp' A B\<^esub>"
        apply(simp add: CatExp'_def NTCatDom_def NTCatCod_def IdNatTransNatTrans functor_abbrev_def)
        apply(simp add: IdNatTrans_defs)
        done
      show "dom\<^bsub>CatExp' A B\<^esub> (id\<^bsub>CatExp' A B\<^esub> F) = F" by (simp add: CatExp'_def IdNatTrans_defs)
      show "cod\<^bsub>CatExp' A B\<^esub> (id\<^bsub>CatExp' A B\<^esub> F) = F" by (simp add: CatExp'_def IdNatTrans_defs)
    qed
  }
  {
    fix f assume a: "f \<in> mor\<^bsub>CatExp' A B\<^esub>"
    show "(id\<^bsub>CatExp' A B\<^esub> (dom\<^bsub>CatExp' A B\<^esub> f)) ;;\<^bsub>CatExp' A B\<^esub> f = f" and
         "f ;;\<^bsub>CatExp' A B\<^esub> (id\<^bsub>CatExp' A B\<^esub> (cod\<^bsub>CatExp' A B\<^esub> f)) = f"
    proof(simp_all add: CatExp'_def)
      have NT: "NatTrans f" using a by (simp add: CatExp'_def)
      show "IdNatTrans (NTDom f) \<bullet> f = f" using NT by (simp add:IdNatTransMapL)
      show "f \<bullet> IdNatTrans (NTCod f) = f" using NT by (simp add:IdNatTransMapR)
    qed
  }
  {
    fix f g h assume aa: "f \<approx>>\<^bsub>CatExp' A B\<^esub> g" and bb: "g \<approx>>\<^bsub>CatExp' A B\<^esub> h"
    {
      fix f g assume "f \<approx>>\<^bsub>CatExp' A B\<^esub> g" hence "f \<approx>>\<bullet> g"
        apply(simp only: NTCompDefined_def)
        by (auto simp add:  CatExp'_def)
    }
    hence "f \<approx>>\<bullet> g" and "g \<approx>>\<bullet> h" using aa bb by auto
    thus "f ;;\<^bsub>CatExp' A B\<^esub> g ;;\<^bsub>CatExp' A B\<^esub> h = f ;;\<^bsub>CatExp' A B\<^esub> (g ;;\<^bsub>CatExp' A B\<^esub> h)"
    by(simp add: CatExp'_def NatTransCompAssoc)
  }
  {
    fix f g X Y Z assume a: "f maps\<^bsub>CatExp' A B\<^esub> X to Y" and b: "g maps\<^bsub>CatExp' A B\<^esub> Y to Z"
    show "f ;;\<^bsub>CatExp' A B\<^esub> g maps\<^bsub>CatExp' A B\<^esub> X to Z"
    proof(rule MapsToI, auto simp add: CatExp'_def)
      have nt1: "NatTrans f" and cd1: "NTCatDom f = A"
        and cc1: "NTCatCod f = B" and d1: "NTDom f = X" and c1: "NTCod f = Y"
        using a by (auto simp add: CatExp'_def)
      moreover have nt2: "NatTrans g" and cd2: "NTCatDom g = A"
        and cc2: "NTCatCod g = B" and d2: "NTDom g = Y" and c2: "NTCod g = Z"
        using b by (auto simp add: CatExp'_def)
      ultimately have Comp: "f \<approx>>\<bullet> g" by(auto intro: NTCompDefinedI)
      thus "NatTrans (f \<bullet> g)" by (simp add: NatTransCompNatTrans)
      show "NTCatDom (f \<bullet> g) = A" using Comp cd1 by (simp add: NTCatDom)
      show "NTCatCod (f \<bullet> g) = B" using Comp cc2 by (simp add: NTCatCod)
      show "NTDom (f \<bullet> g) = X" using d1 by (simp add: NatTransComp_defs)
      show "NTCod (f \<bullet> g) = Z" using c2 by (simp add: NatTransComp_defs)
    qed
  }
qed

lemma CatExpCat: "\<lbrakk>Category A ; Category B\<rbrakk> \<Longrightarrow> Category (CatExp A B)"
by(simp add: CatExpCatAx CatExp_def MakeCat)

lemmas CatExp_defs = CatExp_def CatExp'_def MakeCat_def

lemma CatExpDom: "f \<in> Mor (CatExp A B) \<Longrightarrow> dom\<^bsub>CatExp A B\<^esub> f = NTDom f"
by (simp add: CatExp_defs)

lemma CatExpCod: "f \<in> Mor (CatExp A B) \<Longrightarrow> cod\<^bsub>CatExp A B\<^esub> f = NTCod f"
by (simp add: CatExp_defs)

lemma CatExpId: "X \<in> Obj (CatExp A B) \<Longrightarrow> Id (CatExp A B) X = IdNatTrans X"
by (simp add: CatExp_defs)

lemma CatExpNatTransCompDef: assumes "f \<approx>>\<^bsub>CatExp A B\<^esub> g" shows "f \<approx>>\<bullet> g"
proof-
  have 1: "f \<approx>>\<^bsub>CatExp' A B\<^esub> g" using assms by (simp add: CatExp_def MakeCatCompDef)
  show "f \<approx>>\<bullet> g"
  proof(rule NTCompDefinedI)
    show "NatTrans f" using 1 by (auto simp add: CatExp'_def)
    show "NatTrans g" using 1 by (auto simp add: CatExp'_def)
    show "NTCatDom g = NTCatDom f" using 1 by (auto simp add: CatExp'_def)
    show "NTCatCod g = NTCatCod f" using 1 by (auto simp add: CatExp'_def)
    show "NTCod f = NTDom g" using 1 by (auto simp add: CatExp'_def)
  qed
qed

lemma CatExpDist:
  assumes "X \<in> Obj A" and "f \<approx>>\<^bsub>CatExp A B\<^esub> g"
  shows "(f ;;\<^bsub>CatExp A B\<^esub> g) $$ X = (f $$ X) ;;\<^bsub>B\<^esub> (g $$ X)"
proof-
  have "f \<in> Mor (CatExp' A B)" using assms by (auto simp add: CatExp_def MakeCatMor)
  hence 1: "NTCatDom f = A" and 2: "NTCatCod f = B" by (simp add: CatExp'_def)+
  hence 4: "X \<in> Obj (NTCatDom f)" using assms by simp
  have 3: "f \<approx>>\<bullet> g" using assms(2) by (simp add: CatExpNatTransCompDef)
  have "(f ;;\<^bsub>CatExp A B\<^esub> g) $$ X = (f ;;\<^bsub>CatExp' A B\<^esub> g) $$ X" using assms(2) by (simp add: CatExp_def MakeCatComp2)
  also have "... = (f \<bullet> g) $$ X" by (simp add: CatExp'_def)
  also have "... = (f $$ X) ;;\<^bsub>B\<^esub> (g $$ X)" using 4 2 3 by (simp add: NatTransComp_Comp2[of X f g])
  finally show ?thesis .
qed

lemma CatExpMorNT: "f \<in> Mor (CatExp A B) \<Longrightarrow> NatTrans f"
by (simp add: CatExp_defs)

end


theory GabrielaLimonta
imports Main
begin

(** Score: 7/10
  3.1: 6/10
    Wrong aux-lemma, gen not done

  3.2: Not proven: 1/5

*)

(* Homework 3.1 *)
datatype instr = LDI int | LD nat | ST nat | ADD nat

type_synonym state = "nat \<Rightarrow> int"

fun exec :: "instr \<Rightarrow> state \<Rightarrow> state" where
  "exec (LDI i) s = s(0 := i)"
| "exec (LD n) s = s(0 := (s (n + 1)))"
| "exec (ST n) s = s((n+1) := (s 0))"
| "exec (ADD n) s = s(0 := (s 0) + (s (n + 1)))"

fun execs :: "instr list \<Rightarrow> state \<Rightarrow> state" where
  "execs [] s = s"
| "execs (x#xs) s = execs xs (exec x s)"

datatype expr = C int | V nat | A expr expr

fun val :: "expr \<Rightarrow> (nat \<Rightarrow> int) \<Rightarrow> int" where
  "val (C i) s = i"
| "val (V n) s = s n"
| "val (A a1 a2) s = val a1 s + val a2 s"

fun cmp :: "expr \<Rightarrow> nat \<Rightarrow> instr list" where
  "cmp (C i) n = (LDI i # ST n # [])"
| "cmp (V x) n = (LD x # ST n # [])"
| "cmp (A a1 a2) n = cmp a1 (n + 1) @ cmp a2 (n + 2) @ (LD (n+1) # ADD (n+2) # ST n # [])"

value "cmp (A (C 21) (A (V 1) (C 21))) 2"

fun maxvar :: "expr \<Rightarrow> nat" where
  "maxvar (C i) = 0"
| "maxvar (V n) = n"
| "maxvar (A a1 a2) = (if maxvar a1 > maxvar a2 then maxvar a1 else maxvar a2)"

value "maxvar (A (C 21) (A (V 1) (V 42)))"

lemma [simp]: "\<forall> n \<le> maxvar e. s n = s' n \<Longrightarrow> val e s = val e s'"
  apply(induction)
  apply(auto)
  done

lemma [simp]: "\<forall> n \<le> maxvar e. n > 0 \<Longrightarrow> s n = (execs (cmp e (n+1)) s) n"
(**
  This lemma does not quite state what you expect it to state.
  The \<Longrightarrow> has lower binding priority than the \<forall>.

  The following proof illustrates what I mean:
**)
proof -
  assume A: "\<forall> n \<le> maxvar e. n > 0"
  have "0\<le>maxvar e" by simp
  with A have "0>0" by blast
  hence False by auto
  thus ?thesis ..
qed

(** Probably, you meant:
  \<forall> n \<le> maxvar e. n > 0 \<longrightarrow> s n = (execs (cmp e (n+1)) s) n

  As another indication you were wrong: regard the coloring of the variable
  n in jEdit's syntax highlighting: It should be green (bound variable) everywhere,
  but in the conclusion it's blue (free variable).
**)

(**
  apply(induction)
  apply(auto)
  done
*)

theorem "execs (cmp e (maxvar e + 1)) s 0 = val e (comp s Suc)"
proof(induction e)
  print_cases
  case C thus ?case by simp
next
  case V thus ?case by simp
next
  case A thus ?case
oops

(* Exercise 3.2 *)
datatype ab = a | b

inductive_set S :: "ab list set" where
  A: "w \<in> S \<Longrightarrow> [a] @ w \<in> S"
| B: "w \<in> S \<Longrightarrow> w @ [b] \<in> S"
| E: "[] \<in> S"

fun only_b :: "ab list \<Rightarrow> bool" where
  "only_b [] = True"
| "only_b (x#xs) = (if x = b then only_b xs else False)"

value "only_b [b,b,b,b,b,b,b,b,b,b,b,b]"
value "only_b []"
value "only_b [b,b,b,b,b,a,b,b,b,b,b]"

fun is_ab :: "ab list \<Rightarrow> bool" where
  "is_ab [] = True"
| "is_ab (x#xs) = (case x of
   a \<Rightarrow> (is_ab xs \<or> only_b xs) |
   b \<Rightarrow> only_b xs)"

value "is_ab [b,b,b,b,b,b,b,b,b,b,b,b]"
value "is_ab []"
value "is_ab [b,b,b,b,b,a,b,b,b,b,b]"
value "is_ab [a,a,a,a,a,a,b,b,b]"
value "is_ab [a,a,a,a,a,a]"
value "is_ab [b,a]"

(** This is the "culprit", it causes a loop in the simplifier, as
  the opposite rewrite rule is already in there.

lemma [simp]: "(a#w) = [a] @ w"
  apply(auto)
  done*)

lemma "w \<in> S \<Longrightarrow> is_ab w"
proof (induction w)
  print_cases
  case Nil thus ?case by simp
next
  case (Cons e w)
  thus ?case oops
  (** by (auto split: ab.split) ** Oops, this proof method does not
    terminate, so nothing has been proven!
qed*)

end


section \<open> British Imperial System (1824/1897) \<close>

theory BIS
  imports ISQ SI_Units CGS
begin

text \<open> The values in the British Imperial System (BIS) are derived from the UK Weights and Measures
  Act 1824. \<close>

subsection \<open> Preliminaries \<close>

typedef BIS = "UNIV :: unit set" ..
instance BIS :: unit_system
  by (rule unit_system_intro[of "Abs_BIS ()"],
      metis (full_types) Abs_BIS_cases UNIV_eq_I insert_iff old.unit.exhaust)
instance BIS :: time_second ..
abbreviation "BIS \<equiv> unit :: BIS"

subsection \<open> Base Units \<close>

abbreviation "yard     \<equiv> BUNIT(L, BIS)"
abbreviation "pound    \<equiv> BUNIT(M, BIS)"
abbreviation "rankine  \<equiv> BUNIT(\<Theta>, BIS)"

text \<open> We chose Rankine rather than Farenheit as this is more compatible with the SI system and
  avoids the need for having an offset in conversion functions. \<close>

subsection \<open> Derived Units \<close>

definition [si_eq]: "foot = 1/3 *\<^sub>Q yard"

definition [si_eq]: "inch = 1/12 *\<^sub>Q foot"

definition [si_eq]: "furlong = 220 *\<^sub>Q yard"

definition [si_eq]: "mile = 1760 *\<^sub>Q yard"

definition [si_eq]: "acre = 4840 *\<^sub>Q yard\<^sup>\<three>"

definition [si_eq]: "ounce = 1/12 *\<^sub>Q pound"

definition [si_eq]: "gallon = 277.421 *\<^sub>Q inch\<^sup>\<three>"

definition [si_eq]: "quart = 1/4 *\<^sub>Q gallon"

definition [si_eq]: "pint = 1/8 *\<^sub>Q gallon"

definition [si_eq]: "peck = 2 *\<^sub>Q gallon"

definition [si_eq]: "bushel = 8 *\<^sub>Q gallon"

definition [si_eq]: "minute = 60 *\<^sub>Q second"

definition [si_eq]: "hour = 60 *\<^sub>Q minute"

subsection \<open> Conversion to SI \<close>

instantiation BIS :: metrifiable
begin

lift_definition convschema_BIS :: "BIS itself \<Rightarrow> (BIS, SI) Conversion" is
"\<lambda> x. \<lparr> cLengthF = 0.9143993, cMassF = 0.453592338, cTimeF = 1
      , cCurrentF = 1, cTemperatureF = 5/9, cAmountF = 1, cIntensityF = 1 \<rparr>" by simp

instance ..
end

lemma BIS_SI_simps [simp]: "LengthF (convschema (a::BIS itself)) = 0.9143993"
                           "MassF (convschema a) = 0.453592338"
                           "TimeF (convschema a) = 1"
                           "CurrentF (convschema a) = 1"
                           "TemperatureF (convschema a) = 5/9"
  by (transfer, simp)+

subsection \<open> Conversion Examples \<close>

lemma "metrify (foot :: rat[L, BIS]) = 0.9143993 / 3 *\<^sub>Q metre"
  by (simp add: foot_def)

lemma "metrify ((70::rat) *\<^sub>Q mile \<^bold>/ hour) = (704087461 / 22500000) *\<^sub>Q (metre \<^bold>/ second)"
  by (si_simp)

lemma "QMC(CGS \<rightarrow> BIS) ((1::rat) *\<^sub>Q centimetre) = 100000 / 9143993 *\<^sub>Q yard"
  by simp

end


theory paraGste1 imports Main Finite_Set
begin

section{*Variables and values*}

text{*
According to the aforementioned discussion in section ?, firstly we define the variables used in the protocols.
There are two kinds of variables, global and parameterized (local)
variables. In hardware implemetations of the protocols,
the variables are implenteed as registers in global or local modules. *}

datatype varType=Ident  string | Para varType  nat |Field  varType   string

datatype scalrValueType=enum string string |index nat | boolV bool | topVal | bottomVal

(*datatype inVar = Input varType

datatype regVar= Reg varType*)

section{*Expressions and Formulas*}

datatype expType= IVar varType |
         Const scalrValueType |
         iteForm formula  expType  expType |
         uif string "expType list" |
         top |unKnown

and
 formula = eqn expType expType|
           uip string "expType list" |
           andForm  formula formula |
           neg formula|
           orForm formula formula |
           implyForm formula formula |
           chaos

primrec down ::"nat \<Rightarrow>nat list" where
down0:"down 0=[0]" |
downSuc:"down (Suc n)=Suc n #(down n)"

text{*Similarly, a parameterized formula is a function from a parameter to a formula. We also define
 the $\mathsf{forall}$ and $mathsf{exists}$ formulas$.*}
type_synonym paraFormula="nat \<Rightarrow> formula"

fun forallForm::"nat list \<Rightarrow>paraFormula \<Rightarrow> formula" where
oneAllForm: "forallForm [i] forms = forms i"|
moreAllForm: "forallForm (i#j#xs)  forms = andForm (forms i) (forallForm (j#xs)  forms)"

fun existsForm::"nat list \<Rightarrow>paraFormula \<Rightarrow> formula" where
oneExForm: " existsForm [i] forms = forms i"|
moreExForm: " existsForm (i#j#xs)  forms = orForm (forms i) (forallForm (j#xs)  forms)"

type_synonym formulaExpPair="formula \<times>  expType"

primrec caseExp::"formulaExpPair list  \<Rightarrow> expType" where
 caseNil: "caseExp [] = unKnown"|
 caseTail:"caseExp (gp # tls) =iteForm (fst gp) (snd gp) (caseExp tls )"

definition read::"varType \<Rightarrow> nat \<Rightarrow>expType \<Rightarrow>expType" where [simp]:
"read a bound e \<equiv> caseExp (map (\<lambda>i. ((eqn e (Const (index i))), IVar (Para a i))) (down bound))"

section{*assignment, statement, general statement*}
type_synonym assignType=  "varType \<times>   expType"

text{*A statement is is just a lists of assignments, but these assignments
 are extecuted in parallel, \emph{not} in a sequential order*}

datatype statement=  assign assignType

primrec assignedVar::"statement \<Rightarrow>varType " where
"assignedVar (assign p) = (fst p)"

primrec assignedExp::"statement \<Rightarrow> expType" where
"assignedExp (assign p) = (snd p)"

text{*A parameterized statement is just a function from a parameter to a statement.
For convenience, we also define the concatation of statements, and use it to define
the $\mathsf{forall}$ statement.*}

type_synonym paraStatement= "nat \<Rightarrow> statement"

text{*A state transition from a state to another sate, which is caused by an execution of a statement, is
 defined as follows:*}

primrec statement2Assigns::"statement \<Rightarrow> assignType " where
"statement2Assigns (assign asgn)=asgn"

primrec valOf::"assignType list \<Rightarrow> varType =>expType"  where
"valOf [] v=IVar v" |
"valOf (x#xs) v= (if ((fst x) =v) then (snd x) else valOf xs v)"

datatype generalizeStatement= Parallel "statement list"  |
   If formula generalizeStatement generalizeStatement

text{*Variables of a variable, an expression, a formula, and a statement is defined by
varsOfVar, varOfExp, varOfForm and varOfSent respectively*}

primrec varOfExp::"expType \<Rightarrow> varType list"  and
  varOfForm::"formula \<Rightarrow> varType list"  where

"varOfExp  (IVar v) = [ v]" |
"varOfExp   (Const j) =  []" |

"varOfExp   (iteForm f e1 e2) =(varOfForm f) @  (varOfExp   e1 )  @   (varOfExp  e2)" |
"varOfExp   (uif f es) = (concat (map varOfExp es))"|
"varOfExp   (top) =  []" |
"varOfExp   (unKnown) =  []" |

"varOfForm   (eqn e1 e2) = ( (varOfExp   e1 )  @   (varOfExp  e2))" |
"varOfForm   ( andForm f1 f2) =(  (varOfForm  f1 ) @  (varOfForm  f2 ))"|
"varOfForm   (neg f1 ) = (  (varOfForm   f1 ))"|
"varOfForm   (orForm f1 f2) =(  (varOfForm   f1 )   @   (varOfForm  f2 ))"|
"varOfForm   (implyForm f1 f2) = (  (varOfForm  f1 ) @ (varOfForm f2 ))"|
"varOfForm   (uip p es) = (concat (map varOfExp es))"|
"varOfForm   (chaos) =[]"

primrec  varOfSent::"statement \<Rightarrow> varType list" where
" varOfSent  (assign a)=[  (fst a)] "

datatype generalizeStatement1= Parallel1 "generalizeStatement1 list"  |
   If1 formula generalizeStatement1 generalizeStatement1 |
   AtomStatement statement

fun assignedVars::"generalizeStatement1 \<Rightarrow>varType set" where
"assignedVars (Parallel1 []) = {}"|
"assignedVars (Parallel1 (s#ss)) = (assignedVars s) \<union> assignedVars (Parallel1 ss) "|
"assignedVars (If1 b S1 S2) =(assignedVars S1) \<union> (assignedVars S2) "|
"assignedVars (AtomStatement S) = {assignedVar S}"

definition writeArr::"varType \<Rightarrow> nat \<Rightarrow>expType \<Rightarrow>expType\<Rightarrow>statement list" where
"writeArr a bound adre ce \<equiv> map
   (\<lambda>i. assign ((Para a i), iteForm (eqn adre (Const (index i))) ce (IVar (Para a i))))
   (down bound)"

type_synonym formulaStatementPair ="formula \<times> generalizeStatement"

abbreviation skip::" generalizeStatement" where
"skip \<equiv> Parallel []"

fun caseStatement::"formulaStatementPair list  \<Rightarrow> generalizeStatement" where
  caseStatement1:"caseStatement [gp] =If  (fst gp) (snd gp) skip"|
  caseStatement2:"caseStatement (gp # tls) =If (fst gp) (snd gp) (caseStatement tls )"

definition writeArr'::"varType \<Rightarrow> nat \<Rightarrow>expType \<Rightarrow>expType\<Rightarrow> generalizeStatement"  where [simp]:
"writeArr' a bound adre  ce\<equiv> caseStatement
(map  (\<lambda>i. ((eqn adre (Const (index i))),Parallel [assign ((Para a i), ce)])) (down bound))"

text{*With the formalizatiion of formula and statement, it is natural to define a rule. A guard and
 statement of a rule are also defined for convenience. *}

section{*gste graph*}

datatype node= Vertex nat

datatype  edge=Edge node  node

type_synonym edgeToForm =  "edge \<Rightarrow>  formula"

datatype gsteSpec= Graph  node  "edge list" edgeToForm edgeToForm

primrec  antOf::"gsteSpec \<Rightarrow> edge \<Rightarrow> formula" where
antOf_def: "antOf  (Graph  init  edges ant conss) e = ant e"

primrec consOf::"gsteSpec \<Rightarrow>edge \<Rightarrow> formula" where
"consOf  (Graph  init  edges ant conss) e  = conss e"

primrec source::"edge \<Rightarrow> node" where
"source (Edge n1 n2) = n1"

primrec sink::"edge \<Rightarrow> node" where
"sink (Edge n1 n2) = n2"

primrec edgesOf ::"gsteSpec  \<Rightarrow>  edge set" where
"edgesOf  (Graph  init  edges ant conss) = set edges   "

definition sourcesOf ::" edge set \<Rightarrow> node \<Rightarrow> node set" where
"sourcesOf es n =   {m.  Edge m n  \<in> es } "

definition sinksOf ::"  edge set \<Rightarrow> node \<Rightarrow> node set" where
"sinksOf es m =   {n.  Edge m n \<in> es} "

primrec initOf::"gsteSpec  \<Rightarrow> node" where
"initOf  (Graph  init  edges ant conss) = init"

fun  isPathOf::"node list \<Rightarrow> gsteSpec \<Rightarrow> bool" where
"isPathOf [] G=True" |
"isPathOf (n1#n2#ns) G = (  (Edge n1 n2) \<in>  (edgesOf G) \<and> isPathOf (n2#ns) G)"

definition isGstePath::"node list \<Rightarrow> gsteSpec \<Rightarrow> bool" where
"isGstePath p G \<equiv> isPathOf p G \<and> 1< length p  \<and> p !0=initOf G"

primrec  isPathOf'::"edge list \<Rightarrow> gsteSpec \<Rightarrow> bool" where [simp]:
"isPathOf' [] G=True" |
"isPathOf' (e#es) G = (( e \<in>  (edgesOf G) \<and> isPathOf' es G) \<and>(es=[]\<or> ( source (hd es))=(sink e)))"

definition isGstePath'::"edge list \<Rightarrow> gsteSpec \<Rightarrow> bool" where [simp]:
"isGstePath' p G \<equiv>(isPathOf' p G \<and>( \<not>( p=[]) \<longrightarrow> source ( hd p)=initOf G))"

section{*semantics of a protocol*}
text{*A  state of a protocol  is an instantaneous snapshot of its  behaviour given by an assignment of  values to variables of
the circuit. Therefore, we define:*}

type_synonym state= "varType \<Rightarrow> scalrValueType "

datatype  circuit=Circuit "varType list" "varType list" "varType list" "statement list"  "statement list"

definition varsOfVar::" varType \<Rightarrow> varType set"  where  [simp]:
" varsOfVar x  = {x}"

type_synonym scalrValueTypeListFun="scalrValueType list \<Rightarrow> scalrValueType"

type_synonym interpretFunType="string \<Rightarrow> scalrValueTypeListFun"

type_synonym scalrValueTypeListPred="scalrValueType list \<Rightarrow> bool"

type_synonym interpretPredType="string \<Rightarrow> scalrValueTypeListPred"

primrec scalar2Bool::"scalrValueType\<Rightarrow>bool" where
" scalar2Bool (boolV b) = b"

text{*The formal semantics of an expression and a formula is formalized as follows:*}
primrec expEval :: "interpretFunType \<Rightarrow> expType \<Rightarrow> state \<Rightarrow> scalrValueType" and
 formEval :: "interpretFunType \<Rightarrow> formula \<Rightarrow> state \<Rightarrow>bool"  where

"expEval I  (IVar ie) s =  ( s ie)" |
"expEval I (Const i) s =  i"  |
"expEval I  (iteForm f e1 e2) s=
   ( if (formEval I f s) then     (expEval I e1 s)
   else (expEval I e2 s))"  |
"expEval I top  s= topVal"|
"expEval I unKnown s=bottomVal" |
"expEval I  (uif f es)  s=   (I f) (map (\<lambda> e. expEval  I e s) es) " |

evalExp: "formEval I (eqn e1 e2) s= ((expEval I e1 s) = (expEval I e2 s))" |
"formEval I  (uip p es)  s=    scalar2Bool ( (I p) (map (\<lambda> e. expEval  I e s) es)) " |
evalAnd: "formEval I ( andForm f1 f2) s=( (formEval I f1 s) \<and> (formEval I f2 s))"|
evalNeg: "formEval I (neg f1 ) s= ( \<not>(formEval I f1 s))"|
evalOr: "formEval I (orForm f1 f2) s=( (formEval I f1 s) \<or>  (formEval I f2 s))"|
evalImp:"formEval I (implyForm f1 f2) s= ( (formEval I f1 s) \<longrightarrow>  (formEval I f2 s))" |
"formEval I chaos s=True"

fun sqSatAssert::"interpretFunType \<Rightarrow>state list \<Rightarrow> edge list\<Rightarrow>edgeToForm \<Rightarrow> bool" where [simp]:
"sqSatAssert I [] es assert = True"|
"sqSatAssert I sq [] assert = True"|
"sqSatAssert I (s#sq) (e#es) assert= ((sqSatAssert I sq es assert) \<and> formEval I (assert e) s)"

definition wellformedAssgnList::"assignType list => bool" where
" wellformedAssgnList asgns\<equiv>distinct (map fst asgns)"

primrec transAux:: "assignType list \<Rightarrow>interpretFunType \<Rightarrow> state \<Rightarrow>state " where
"transAux [] I s= s " |
"transAux (pair#asgns) I s=( transAux asgns I s) ((fst pair):= expEval I (snd pair) s) "

definition trans:: "statement list\<Rightarrow> interpretFunType \<Rightarrow> state \<Rightarrow>state " where [simp]:
"trans S I s \<equiv> transAux (map statement2Assigns S) I s"

primrec genTrans::"generalizeStatement\<Rightarrow> interpretFunType  \<Rightarrow> state \<Rightarrow>state " where
"genTrans (Parallel S) I s = trans S I s" |
"genTrans (If b S1 S2) I s=(if (formEval I b s) then (genTrans  S1 I s) else  (genTrans S2 I s))"

fun genTrans1::"generalizeStatement1\<Rightarrow> interpretFunType  \<Rightarrow> state \<Rightarrow>state " where
"genTrans1 (AtomStatement (assign as)) I s x= (s((fst as) :=  expEval I (snd as) s)) x"|
"genTrans1 (Parallel1 []) I s x= s x" |
"genTrans1 (Parallel1 (S#ss)) I s x= (if (x \<in> (assignedVars S)) then genTrans1  S  I s x else genTrans1 (Parallel1 ss) I s x) " |
"genTrans1 (If1 b S1 S2) I s x=(if (formEval I b s) then (genTrans1  S1 I s x) else  (genTrans1 S2 I s x))"

definition transOfCircuit2::"generalizeStatement1 \<Rightarrow>interpretFunType \<Rightarrow>state \<Rightarrow>state " where [simp]:
"transOfCircuit2 M I s  \<equiv> (genTrans1 M I s)"

definition transOfCircuit1::"generalizeStatement \<Rightarrow>interpretFunType \<Rightarrow>state \<Rightarrow>state " where [simp]:
"transOfCircuit1 M I s  \<equiv> (genTrans M I s)"

fun istrajOfCircuit1::"generalizeStatement\<Rightarrow> interpretFunType \<Rightarrow> state list \<Rightarrow> bool" where [simp]:
"istrajOfCircuit1 M I [] = True"|
"istrajOfCircuit1 M I [s] = True" |
"istrajOfCircuit1 M I (s#s'#sq) =(   s'=transOfCircuit1 M I  s \<and>istrajOfCircuit1 M I (s'#sq))"

definition circuitSatGsteSpec1::"generalizeStatement \<Rightarrow> gsteSpec \<Rightarrow>  interpretFunType \<Rightarrow>bool" where
"circuitSatGsteSpec1 M G I\<equiv> \<forall> p sq. istrajOfCircuit1 M I sq \<longrightarrow> isGstePath' p G \<longrightarrow> (length p= length sq)
  \<longrightarrow> sqSatAssert I sq p (antOf G) \<longrightarrow>   sqSatAssert I sq p (consOf G)"

type_synonym nodeTagFunc="node \<Rightarrow> formula"

definition consistent1::"generalizeStatement \<Rightarrow> interpretFunType  \<Rightarrow> gsteSpec \<Rightarrow> nodeTagFunc \<Rightarrow> bool" where
"consistent1 M I G tag \<equiv>( \<forall>e s s'.
  (e \<in> edgesOf G \<longrightarrow> formEval I (antOf G e)  s \<longrightarrow>
  s'=transOfCircuit1 M I s \<longrightarrow> formEval I (tag (source e))  s \<longrightarrow> formEval I (tag (sink e))  s')) \<and>
  (\<forall>e s . (formEval I (tag (source e))  s) \<longrightarrow> formEval I (antOf G e)  s \<longrightarrow>   formEval I (consOf G e)  s)"

section{*substitution, weakest precondition*}

primrec substExp :: "expType\<Rightarrow> assignType list \<Rightarrow>expType"  and
substForm ::"formula \<Rightarrow> assignType list \<Rightarrow> formula" where

substExpVar: "substExp  (IVar v') asgns=   (valOf  asgns v')  "|

substExpConst: "substExp  (Const i)  asgns= Const i" |

substTop: "substExp top asgns=top" |

substUnkown: "substExp unKnown asgns=unKnown" |

substExpite: "substExp  (iteForm f e1 e2)  asgns= (iteForm (substForm f asgns) (substExp e1  asgns) (substExp e2  asgns))"|

substUif: "substExp (uif f es) asgns =( uif f (map (\<lambda>e. substExp e asgns) es))"|

"substForm (eqn l r)  asgns=(eqn (substExp l  asgns) (substExp r  asgns))"  |
"substForm ( andForm f1 f2)  asgns =   ( andForm (substForm f1  asgns)  (substForm f2  asgns))"|
"substForm (neg f1 )   asgns= (neg ( substForm f1  asgns ))"|
"substForm (orForm f1 f2)   asgns= ( orForm (substForm f1  asgns )  (substForm f2  asgns))"|
"substForm (implyForm f1 f2)   asgns= (implyForm (substForm f1 asgns)  (substForm f2  asgns))" |
"substForm (uip p es)   asgns= ( uip p (map (\<lambda>e. substExp e asgns) es))" |
"substForm  chaos   asgns=chaos"

primrec  preCond1 ::" formula \<Rightarrow> generalizeStatement  \<Rightarrow>formula" where
"preCond1 f (Parallel S)  = substForm f (map statement2Assigns S) " |
"preCond1 f  (If b S1 S2) = orForm (andForm b (preCond1 f  S1)) (andForm (neg b) (preCond1 f  S2))"

primrec  preExp1 ::" expType \<Rightarrow>  generalizeStatement  \<Rightarrow>expType" where [simp]:
"preExp1 e  (Parallel S)  = substExp e (map statement2Assigns S)  " |
"preExp1 e   (If b S1 S2) = iteForm b (preExp1 e S1) (preExp1 e S2)"

lemma lemmaOnValOf:

  shows "expEval I (preExp1 (IVar v) nf) s = genTrans nf I s v"
  (is "?LHS1 nf =?RHS1 nf ")
proof(induct_tac nf)
  fix x
  let ?nf="Parallel x"
  show "?LHS1 ?nf=?RHS1 ?nf"
  proof(auto)
  show "expEval I (valOf (map statement2Assigns x) v) s = transAux (map statement2Assigns x) I  s v"
     (is "?LHS2 x =?RHS2 x ")
  proof(induct_tac x)
  show "?LHS2 [] =?RHS2 []"
       by auto
    next
  fix a nf
  assume b1:"?LHS2 nf =?RHS2 nf"
  let ?nf="a#nf"
  show "?LHS2 ?nf =?RHS2 ?nf"
  apply(cut_tac b1,simp) done
  qed
  qed
next
  fix b S1 S2
  assume b1:" expEval I (preExp1 (IVar v) S1) s = genTrans S1 I s v" and
  b2:" expEval I (preExp1 (IVar v) S2) s = genTrans S2 I s v"
  let ?nf="If b S1 S2"
  show "?LHS1 ?nf=?RHS1 ?nf"
 proof(case_tac "formEval I b s")
  assume c:"formEval I b s"
  show "?LHS1 ?nf=?RHS1 ?nf" by(cut_tac b1 c, auto)
  next
  assume c:"\<not> formEval I b s"
  show "?LHS1 ?nf=?RHS1 ?nf" by(cut_tac b2 c, auto)
  qed
qed

lemma itePreExp1:
  "formEval I (preCond1 x1 nf) s = formEval I x1 (genTrans  nf I s)
   \<longrightarrow> expEval I (preExp1 x2 nf) s = expEval I x2 (genTrans  nf I s)
   \<longrightarrow>  expEval I (preExp1 x3 nf) s = expEval I x3 (genTrans  nf I s)
   \<longrightarrow>   expEval I (preExp1 (iteForm x1 x2 x3) nf) s = expEval I (iteForm x1 x2 x3) (genTrans  nf I s)"
   (is "?p1 nf\<longrightarrow>?p2 nf \<longrightarrow>?p3 nf\<longrightarrow>?LHS nf=?RHS nf")
 proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"
   show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?p3 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
   by auto
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1 \<longrightarrow>?p2 S1 \<longrightarrow>?p3 S1 \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2 \<longrightarrow>?p2 S2 \<longrightarrow>?p3 S2 \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?p3 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?p3 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?p3 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma eqPre:
  "expEval I (preExp1 x1 nf) s = expEval I x1 (genTrans nf I s)\<longrightarrow>
   expEval I (preExp1 x2 nf) s = expEval I x2 (genTrans nf I s)\<longrightarrow>
   formEval I (preCond1 (eqn x1 x2) nf) s = formEval I (eqn x1 x2) (genTrans nf I s)"
   (is "?p1 nf\<longrightarrow>?p2 nf \<longrightarrow>?LHS nf=?RHS nf")
 proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"
   show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
   by auto
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1 \<longrightarrow>?p2 S1  \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2 \<longrightarrow>?p2 S2  \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma auxOnufiPre: "(\<forall>x2a. x2a \<in> set es \<longrightarrow> expEval I (preExp1 x2a (Parallel S)) s = expEval I x2a (genTrans (Parallel S) I s)) \<longrightarrow>
 (map ((\<lambda>e. expEval I e s) \<circ> (\<lambda>e. substExp e (map statement2Assigns S))) es) =
      (map (\<lambda>e. expEval I e (transAux (map statement2Assigns S) I s)) es)" (is "?P es")
proof(induct_tac es)
  let ?nf="Parallel S"
  show "?P []" by auto
  next
  fix x xs
  assume b1:"?P xs"
  show "?P (x#xs)" (is "?P1 (x#xs) \<longrightarrow> ?P2 (x#xs)")
  proof
  assume c1:"?P1 (x#xs)"
  have b2:"?P1 xs" by (cut_tac c1,auto )
  then have b3:"?P2 xs" by(cut_tac b1,auto)

   have b5:"((\<lambda>e. expEval I e s) \<circ> (\<lambda>e. substExp e (map statement2Assigns S))) x =
  (\<lambda>e. expEval I e (transAux (map statement2Assigns S) I s)) x"
    by (cut_tac c1,simp)

  show "?P2 (x#xs)" (is "?LHS (x#xs) = ?RHS (x#xs)")
  by(cut_tac b5 b3, auto)
  qed
qed

lemma uifPre:

" (\<forall>x2a. x2a \<in> set es \<longrightarrow> expEval I (preExp1 x2a nf) s = expEval I x2a (genTrans nf I s)) \<longrightarrow>
             expEval I (preExp1 (uif f es) nf) s = expEval I (uif f es) (genTrans nf I s)   "
           (  is "?p1 nf\<longrightarrow>?LHS nf=?RHS nf")
 proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"

   show "?p1 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
   proof
   assume a1:"?p1 ?nf"
   have b1:"(map ((\<lambda>e. expEval I e s) \<circ> (\<lambda>e. substExp e (map statement2Assigns S))) es) =
      (map (\<lambda>e. expEval I e (transAux (map statement2Assigns S) I s)) es)"
      using a1 by auto

   then show "?LHS ?nf=?RHS ?nf" apply simp
   apply( simp add:b1)
   done
   qed
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1   \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2   \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf   \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf   \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma uipPre:

" (\<forall>x2a. x2a \<in> set es \<longrightarrow> expEval I (preExp1 x2a nf) s = expEval I x2a (genTrans nf I s)) \<longrightarrow>
             formEval I (preCond1 (uip pn es) nf) s =formEval I (uip pn es) (genTrans nf I s)   "
           (  is "?p1 nf\<longrightarrow>?LHS nf=?RHS nf")
 proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"

   show "?p1 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
   proof
   assume a1:"?p1 ?nf"
   have b1:"(map ((\<lambda>e. expEval I e s) \<circ> (\<lambda>e. substExp e (map statement2Assigns S))) es) =
      (map (\<lambda>e. expEval I e (transAux (map statement2Assigns S) I s)) es)"
      using a1 by auto
   then show "?LHS ?nf=?RHS ?nf" apply simp
   apply( simp add:b1)
   done
   qed
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1   \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2   \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf   \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf   \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma andPre:
  "formEval I (preCond1 x1 nf) s = formEval I x1 (genTrans nf I s) \<longrightarrow>
   formEval I (preCond1 x2 nf) s = formEval I x2 (genTrans nf I s) \<longrightarrow>
   formEval I (preCond1 (andForm x1 x2) nf) s = formEval I (andForm x1 x2) (genTrans nf I s)"
    (is "?p1 nf\<longrightarrow>?p2 nf \<longrightarrow>?LHS nf=?RHS nf")
proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"
   show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
   by auto
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1 \<longrightarrow>?p2 S1  \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2 \<longrightarrow>?p2 S2  \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma orPre:
  "formEval I (preCond1 x1 nf) s = formEval I x1 (genTrans nf I s) \<longrightarrow>
   formEval I (preCond1 x2 nf) s = formEval I x2 (genTrans nf I s) \<longrightarrow>
   formEval I (preCond1 (orForm x1 x2) nf) s = formEval I (orForm x1 x2) (genTrans nf I s)"
    (is "?p1 nf\<longrightarrow>?p2 nf \<longrightarrow>?LHS nf=?RHS nf")
proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"
   show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
   by auto
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1 \<longrightarrow>?p2 S1  \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2 \<longrightarrow>?p2 S2  \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma implyPre:
  "formEval I (preCond1 x1 nf) s = formEval I x1 (genTrans nf I s) \<longrightarrow>
   formEval I (preCond1 x2 nf) s = formEval I x2 (genTrans nf I s) \<longrightarrow>
   formEval I (preCond1 (implyForm x1 x2) nf) s = formEval I (implyForm x1 x2) (genTrans nf I s)"
    (is "?p1 nf\<longrightarrow>?p2 nf \<longrightarrow>?LHS nf=?RHS nf")
proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"
   show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
   by auto
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1 \<longrightarrow>?p2 S1  \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2 \<longrightarrow>?p2 S2  \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf \<longrightarrow>?p2 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma notPre:
  "formEval I (preCond1 x1 nf) s = formEval I x1 (genTrans nf I s) \<longrightarrow>
   formEval I (preCond1 (neg x1 ) nf) s = formEval I (neg x1 ) (genTrans nf I s)"
    (is "?p1 nf \<longrightarrow>?LHS nf=?RHS nf")
proof(induct_tac nf)
   fix S
   let ?nf="Parallel S"
   show "?p1 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
   by auto
next
  fix b S1 S2
  let ?nf="If b S1 S2"
  assume b1:"?p1 S1 \<longrightarrow>?LHS S1=?RHS S1" and
  b2: "?p1 S2  \<longrightarrow>?LHS S2=?RHS S2"
  show "?p1 ?nf  \<longrightarrow>?LHS ?nf=?RHS ?nf"
  proof(case_tac "formEval I b s")
    assume c:"formEval I b s"
    show "?p1 ?nf \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b1 c,auto)
    next
    assume c:"\<not> formEval I b s"
    show "?p1 ?nf   \<longrightarrow>?LHS ?nf=?RHS ?nf"
    by (cut_tac b2 c,auto)
  qed
qed

lemma lemmaOnPre:
  shows "(expEval I (preExp1 e nf) s =   expEval I  e (genTrans nf I s)) \<and>
   (formEval I (preCond1 f nf) s = formEval I f (genTrans nf I s))"
   (is "((  ?LHS e =?RHS e )\<and> ( ?LHS1 f =?RHS1 f ))")
proof(induct_tac e and f)
  fix v
  let ?e="(IVar v)"
  show  "  ?LHS ?e =?RHS ?e "
  apply(simp)
  using  lemmaOnValOf by blast

next
  fix n
  let ?e="(Const n)"
  show  "?LHS ?e =?RHS ?e "
  proof(induct_tac nf,auto)qed

next
  fix f e1 e2
  assume b1:"( ?LHS1 f =?RHS1 f )" and
  b2:"?LHS e1 =?RHS e1 " and a3:"?LHS e2 =?RHS e2 "
  let ?e="iteForm f e1 e2"
  show "?LHS ?e =?RHS ?e " (is "?LHS1 nf=?RHS1 nf")
  by (simp add: a3 b1 b2 itePreExp1)

next
  let ?e="top"
  show "?LHS ?e =?RHS ?e "
  proof(induct_tac nf,auto)qed
next
  let ?e="unKnown"
  show "?LHS ?e =?RHS ?e "
  proof(induct_tac nf,auto)qed
next
  fix e1 e2
  assume a1:" ?LHS e1 =?RHS e1 " and a2:" ?LHS e2 =?RHS e2 "
  let ?f="eqn e1 e2"
  show "(?LHS1 ?f =?RHS1 ?f )"
  by (simp add: a1 a2 eqPre)

next
  fix f1 f2
  assume a1:" ( ?LHS1 f1 =?RHS1 f1 )" and  a2:"  ?LHS1 f2 =?RHS1 f2 "
  let ?f="andForm f1 f2"
  show "( ?LHS1 ?f =?RHS1 ?f )"
  by (simp add: a1 a2 andPre)

next
  fix f1
  assume a1:" (?LHS1 f1 =?RHS1 f1 )"
  let ?f="neg f1"
  show "( ?LHS1 ?f =?RHS1 ?f )"
  by (simp add: a1  notPre)
next
  fix f1 f2
  assume a1:" ( ?LHS1 f1 =?RHS1 f1 )" and  a2:" ?LHS1 f2 =?RHS1 f2 "
  let ?f="implyForm f1 f2"

  show "(?LHS1 ?f =?RHS1 ?f )"
  by (simp add: a1 a2 implyPre)
next

  fix f1 f2
  assume a1:" ( ?LHS1 f1 =?RHS1 f1 )" and  a2:" ( ?LHS1 f2 =?RHS1 f2 )"
  let ?f="orForm f1 f2"

  show "(?LHS1 ?f =?RHS1 ?f )"
   by (simp add: a1 a2 orPre)
next
  let ?f="chaos"
  show "( ?LHS1 ?f =?RHS1 ?f )"
  proof(induct_tac nf,auto)qed
next
  fix fn es
  let ?e="uif fn es"
  assume a1:"(\<And>x2a. x2a \<in> set es \<Longrightarrow> expEval I (preExp1 x2a nf) s = expEval I x2a (genTrans nf I s))"
   show "?LHS ?e =?RHS ?e " (is "?LHS1 nf=?RHS1 nf")
   by (simp add: a1 uifPre)
next
  fix pn es
  let ?f="uip pn es"
  assume a1:"(\<And>x2a. x2a \<in> set es \<Longrightarrow> expEval I (preExp1 x2a nf) s = expEval I x2a (genTrans nf I s))"
   show "?LHS1 ?f =?RHS1 ?f "
   by (simp add: a1 uipPre)
qed

lemma lemmaOnPreExp:
shows "expEval I (preExp1 e nf) s =   expEval I e (genTrans nf I s) "
  by (simp add: lemmaOnPre)

lemma lemmaOnPreForm:
shows "formEval I (preCond1 f nf) s = formEval I f (genTrans nf I s)"
  by (simp add: lemmaOnPre)

section{*main lemma: consistency lemma*}

definition tautlogy::"formula \<Rightarrow>  interpretFunType \<Rightarrow>    bool" where [simp]:
"tautlogy f I \<equiv> \<forall>s. formEval I f s"

primrec andListForm::"formula list \<Rightarrow> formula " where
"andListForm [] = chaos" |
"andListForm  (f#fs) = andForm f (andListForm  fs)"

lemma andList1Aux:
   shows "formEval I ( (andListForm frms)) s  \<longrightarrow> frm \<in>set frms \<longrightarrow> formEval I ( frm) s "
   proof(induct_tac frms,auto)qed

lemma andList1:
   shows "formEval I ( (andListForm frms)) s  \<Longrightarrow>  frm \<in>set frms \<Longrightarrow> formEval I ( frm) s "
    by (metis andList1Aux)

type_synonym nodeTagFuncList="node \<Rightarrow> formula list"

definition consistent'::"generalizeStatement \<Rightarrow> interpretFunType \<Rightarrow> gsteSpec \<Rightarrow> nodeTagFuncList \<Rightarrow> bool" where [simp]:
"consistent' M I G tag \<equiv>( \<forall>e.
  (e \<in> edgesOf G \<longrightarrow>
  (let f=andListForm (tag (sink e)) in
   let f'=andListForm (tag (source e)) in
  tautlogy (implyForm (andForm f' (antOf G e)) (preCond1  f    M )) I)))"

fun sqSatTagFunc::"state list \<Rightarrow> interpretFunType\<Rightarrow> edge list\<Rightarrow>nodeTagFuncList\<Rightarrow> bool" where [simp]:
"sqSatTagFunc [] I [] tag = True"|
"sqSatTagFunc (s#sq) I [] tag = False"|
"sqSatTagFunc [] I (e#es) tag = False"|
"sqSatTagFunc (s#sq) I (e#es) tag=
       ((sqSatTagFunc sq I es tag) \<and> formEval I (andListForm (tag (source e)))  s
       )"

lemma sqSatConsisitentGraph:
  assumes a1:"consistent' M I G tag"
  shows "e \<in> edgesOf G \<longrightarrow>
  formEval I (andListForm (tag (source e))) s\<longrightarrow> formEval I(antOf G e) s \<longrightarrow>
  formEval I (andListForm (tag (sink e))) (genTrans M I s)"
  proof(rule impI)+
   assume b1:"e \<in> edgesOf G" and b2:"formEval I (andListForm (tag (source e))) s" and
   b3:" formEval I (antOf G e) s"
   let ?f="andListForm (tag (sink e))"  let ?f'="andListForm (tag (source e))"
   from a1  b1  have b6:
    " tautlogy (implyForm (andForm ?f' (antOf G e)) (preCond1 ?f  M)) I "
    by (unfold consistent'_def, auto simp add:Let_def)

   have b5:"formEval I (preCond1 ?f  M) s"
   proof -
    from a1  b1  have b6:
    " tautlogy (implyForm (andForm ?f' (antOf G e)) (preCond1 ?f  M)) I "
    by (unfold consistent'_def, auto simp add:Let_def)
    show b5:"formEval I (preCond1 ?f  M) s"
    using b2 b3 b6 by auto

  qed
  show "formEval I (andListForm (tag (sink e))) (genTrans M I s)"
  using  b5 lemmaOnPre by blast
 qed

lemma consistentLemmaAux:
  assumes a1:"consistent' M I G tag"
  shows a1:"\<forall>sq. ((\<not>( p=[]) \<longrightarrow>
  formEval I (andListForm (tag (source (hd p)))) (hd sq))\<longrightarrow> (length p= length sq)\<longrightarrow>
  istrajOfCircuit1 M I sq \<longrightarrow> isPathOf' p G \<longrightarrow> sqSatAssert I  sq p (antOf G)\<longrightarrow>
  sqSatTagFunc sq I p tag  )" (is " ?P p")
proof(induct_tac p)
  show "?P []"
  apply(rule allI,(rule impI)+,simp) done
next
  fix e p
  assume b1:"?P p"
  let ?p="e # p"
  show "?P ?p"
  proof(rule allI,(rule impI)+)
    fix sq
    assume c1:"e # p \<noteq> [] \<longrightarrow> formEval I (andListForm (tag (source (hd (e # p))))) (hd sq)"
    and c2:"length (e # p) = length sq" and c3:" istrajOfCircuit1 M I sq" and c4:"isPathOf' (e # p) G "
    and c4a:"sqSatAssert I sq ?p (antOf G)"
    have "\<exists> s sq'. sq=s#sq' \<and> length p=length sq'"
    apply(cut_tac c2,simp)
    by (metis Suc_length_conv)
    then obtain s and sq' where c5:" sq=s#sq'\<and> length p=length sq'" by blast
    have c6:"formEval I (andListForm (tag (source e))) s"
    using c1 c5 by auto
    show "sqSatTagFunc   sq I (e # p) tag"
    proof(cut_tac c5,simp,rule conjI)
      have "sq'=[] \<or> (\<exists> s' sq''. sq'=s'#sq'')"
        apply(case_tac sq', auto) done
      moreover
      {assume d1:"sq'=[]"
        have d2:"p=[]"
        using c5 d1 by auto
        have " sqSatTagFunc sq' I p tag"
          by(cut_tac d1 d2, simp)
      }
      moreover
      {assume d1:"(\<exists> s' sq''. sq'=s'#sq'')"
       then obtain s' sq'' where d1:"sq'=s'#sq''" by blast
       with c5 have "\<exists>e' p'. p=e' # p'"
       apply simp
       by (metis Suc_length_conv)
       then obtain e' p' where d2:"p= e' #p'" by blast
       have d3:"p \<noteq> []" using d2 by simp
       have d4:"istrajOfCircuit1 M I sq'" using c3 c5 d1 by auto
       have d5:"s'=(transOfCircuit1 M I s)" using c3 c5 d1 by auto
       have d6:"sqSatAssert I  sq'  p (antOf G)" using c4a c5 apply auto done
       have d7:" formEval I (antOf G e) s" using c4a c5 apply auto done
       have d8:" e \<in> edgesOf G" using c4 by auto
      (* have d9:"(varOfForm (andListForm (tag (sink e)))) \<subseteq> (regsOf1 M)" using a4 d8 by auto*)
       have d10:"formEval I  (andListForm (tag (sink e))) (genTrans M I s)"
       using a1  c6 d7 d8  sqSatConsisitentGraph by blast
       have d11:"source (hd p) = sink e" using c5 d2 c4 by auto
       have d12:"(transOfCircuit1 M I s) =(hd sq')" using c3 d1 c5 apply auto done
       have d13:"formEval I (andListForm (tag (source (hd p)))) (hd sq') "
       using  d10 d11 d12 by auto
       have d14:"isPathOf' p G" using c4 by auto
       have d15:"sqSatTagFunc sq' I p tag" using b1 d3 d13 d4 c4 c5 d14 d6 by auto
       }
      ultimately show "sqSatTagFunc sq' I p tag" by auto
    next
      show "formEval I (andListForm (tag (source e))) s" using c6 by auto
  qed
 qed
qed

lemma consistentLemma:
  assumes a1:"consistent' M I G tag"  and
  a2:"istrajOfCircuit1 M I sq " and a3:"formEval I (andListForm (tag (source (hd p)))) (hd sq)"
    and a4:"length p = length sq" and a5:" sqSatAssert I sq p (antOf G)" and a6:"\<not>( p=[])"
    and a7:"isPathOf' p G "
  shows " sqSatTagFunc sq I p tag  " (is " ?P p")
using a2 a3 a4 a5 a7 consistentLemmaAux local.a1 by blast

lemma andListNilIsCHAOS:
  "formEval  I (andListForm []) s"
  by auto

definition circuitSatGsteSpecAux::"generalizeStatement \<Rightarrow> gsteSpec \<Rightarrow>  interpretFunType
\<Rightarrow>state list \<Rightarrow>edge list\<Rightarrow>nodeTagFuncList \<Rightarrow>bool" where [simp]:
"circuitSatGsteSpecAux M G I sq p tag\<equiv> istrajOfCircuit1 M I sq \<longrightarrow> isPathOf' p G \<longrightarrow> (length p= length sq) \<longrightarrow>
   formEval I (andListForm (tag (source (hd p)))) (hd sq)\<longrightarrow> sqSatAssert I sq p (antOf G) \<longrightarrow>   sqSatAssert I sq p (consOf G)"

lemma mainLemmaAux:
  assumes a1:"consistent' M I G tag" and
  a2:"\<forall> e. e \<in>edgesOf G\<longrightarrow> tautlogy (implyForm (andForm (antOf G e) (andListForm (tag (source e)))) (consOf G e)) I"

  shows "\<forall>p. circuitSatGsteSpecAux M G I sq p tag" (is "?P sq")
  proof(induct_tac sq)
    show "?P []" by auto
    next
    fix s sq

    assume b0:"?P sq"

    show "?P (s#sq)"
    proof(unfold circuitSatGsteSpecAux_def,rule allI,(rule impI)+)
      fix p0

      assume b1:"istrajOfCircuit1 M I  (s # sq) "
      and b3:"length p0 = length (s # sq) " and
      b4:" sqSatAssert I  (s # sq) p0 (antOf G)" and
      b2:"formEval I (andListForm (tag (source (hd p0)))) (hd (s # sq))"
      and b5:" isPathOf' p0 G "
      have b60:"\<exists> e p. p0=e#p"
        by (metis b3 hd_Cons_tl length_greater_0_conv list.distinct(1))
      then obtain e and p where  b6:"p0= e #p" by blast
      have  c1:"istrajOfCircuit1 M I  (  sq) "
          apply(cut_tac b1 ,case_tac sq,auto)  done
      have c3:"length p= length sq"
          apply(cut_tac b3 b6,auto) done

      have c4:"sqSatAssert I sq p (antOf G) \<and>   formEval I (antOf G e) s "
      proof(cut_tac b4 b6,auto) qed
      have c5:"isPathOf' p G \<and> e\<in> edgesOf G" by(cut_tac b5 b6,auto)

      show " sqSatAssert I  (s # sq)  p0 (consOf G)"
      proof(cut_tac b6,simp,rule conjI)

        show " sqSatAssert I sq p (consOf G)"
        proof(case_tac p)
          assume d1:"p=[]"
          have d2:"sq=[]" apply(cut_tac b6 b3,auto)
            by (simp add: d1)
          show " sqSatAssert I sq p (consOf G)" by(cut_tac d1 d2,auto)
          next
          fix e' p'
          assume d1:"p=e'#p'"
            have d2:"length p=length sq" by(cut_tac b6 b3,auto)
            have d6:"sqSatTagFunc (s#sq) I p0 tag"
            using b1 b2 b3 b4 b5 consistentLemmaAux local.a1 by blast

            then have d6:"formEval I (andListForm (tag (source (hd p)))) (hd ( sq))"
              apply(cut_tac b5  b6,auto,cut_tac d1,simp)
              by (metis d1 d2 hd_Cons_tl length_greater_0_conv list.distinct(1) sqSatTagFunc.simps(4))
            show " sqSatAssert I sq p (consOf G)"
            using b0 c1 c4 c5 circuitSatGsteSpecAux_def d2 d6 by blast
         qed
   next
   show "formEval I (consOf G e) s"
    apply(cut_tac a2 b6 b2 c4 c5,simp)
   done
   qed
 qed
qed

definition circuitSatGsteSpec::"generalizeStatement \<Rightarrow> gsteSpec \<Rightarrow>  interpretFunType \<Rightarrow>bool" where
"circuitSatGsteSpec M G I\<equiv> \<forall> p sq. istrajOfCircuit1 M I sq \<longrightarrow> isGstePath' p G \<longrightarrow> (length p= length sq)
  \<longrightarrow> sqSatAssert I sq p (antOf G) \<longrightarrow>   sqSatAssert I sq p (consOf G)"

lemma mainLemma:
  assumes a1:"consistent' M I G tag" and
  a2:"\<forall> e. e \<in>edgesOf G\<longrightarrow> tautlogy (implyForm (andForm (antOf G e) (andListForm (tag (source e)))) (consOf G e)) I"  and
  a3:"tag (initOf G) =[]"
  shows " circuitSatGsteSpec M G I " (is "?P sq")
proof(unfold circuitSatGsteSpec_def,(rule allI)+,(rule impI)+)
  fix p sq
  assume b1:"istrajOfCircuit1 M I sq" and
  b2:"isGstePath' p G" and b3:" length p = length sq" and b4:" sqSatAssert I sq p (antOf G) "
  have b5:"\<forall>p. circuitSatGsteSpecAux M G I sq p tag"
    using a2 local.a1 mainLemmaAux by blast
  have b6:"isPathOf' p G \<and>( \<not>( p=[]) \<longrightarrow> source ( hd p)=initOf G)"
    by(cut_tac b2,unfold  isGstePath'_def,auto)
  have b7:" \<not>( p=[]) \<longrightarrow>formEval I (andListForm (tag (source (hd p)))) (hd sq)"
    by(cut_tac a3 b6,auto)
  show "sqSatAssert I sq p (consOf G)"
  proof(case_tac "p=[]")
    assume c1:"p=[]"
    show "sqSatAssert I sq p (consOf G)" by(cut_tac c1 b3,auto)
  next
    assume c1:"p\<noteq>[]"
    have b8:" source ( hd p)=initOf G"
      by(cut_tac c1 b6,auto)
    have b9:" formEval I (andListForm (tag (source (hd p)))) (hd sq)"
      by(cut_tac c1 b7,auto)
    show "sqSatAssert I sq p (consOf G)"
      using b1 b3 b4 b5 b6 b9 circuitSatGsteSpecAux_def by blast
  qed
qed

lemma OnIfPos:
  assumes a1:"formEval I b s"
  shows "formEval I (preCond1 f (If b S1 S2)) s=formEval I (preCond1 f  S1 ) s"
    by (cut_tac a1,auto)

lemma OnIfNeg:
  assumes a1:"formEval I (neg b) s"
  shows "formEval I (preCond1 f (If b S1 S2)) s=formEval I (preCond1 f  S2 ) s"
    by (cut_tac a1,auto)

subsection{*more lemmas on valOf operator*}

text{*more lemmas on valOf operator*}

lemma valOfLemmaAux[simp]: "i \<le> N \<longrightarrow> (valOf (map (\<lambda>i. (Para v i, e i)) (down N)) (Para v i))=e i"
  apply(induct_tac N)
  apply simp
  apply auto
done

lemma valOfLemma[simp]: "i \<le> N \<Longrightarrow> (valOf (map (\<lambda>i. (Para v i, e i)) (down N)) (Para v i))=e i"
by (metis valOfLemmaAux )

lemma valOfLemma2Aux[simp]: "(var' \<notin> set (map fst xs)) \<longrightarrow> (valOf xs (var'))=IVar var'"
  apply(induct_tac xs)
  apply simp
  apply auto
done

lemma valOfLemma2[simp,intro]: "(var' \<notin> set (map fst xs)) \<Longrightarrow> (valOf xs (var'))=IVar var'"
by (metis (lifting) valOfLemma2Aux)

lemma valOfLemma3 [simp]:"(\<forall> i.  var' \<noteq> Para v i) \<Longrightarrow>
(valOf (map (\<lambda>i. (Para v i, e i)) (down N)) var')=IVar var'"
apply(rule valOfLemma2)
apply(induction N)
by auto

lemma valOfLemma4Aux :"v \<notin> set (map fst   (map statement2Assigns S)) \<longrightarrow>
( valOf (map statement2Assigns  ( S@ S')) v) =    ( valOf (map statement2Assigns S')) v"
    proof(induct_tac S,auto)qed

lemma valOfLemma4 [simp,intro]:"v \<notin> set (map fst   (map statement2Assigns S)) \<Longrightarrow>
( valOf (map statement2Assigns  ( S@ S')) v) =    ( valOf (map statement2Assigns S')) v"
by (metis valOfLemma4Aux)

lemma valOfLemma5Aux :"v \<notin> set (map fst  As') \<longrightarrow>
( valOf (As'@ As) v) =    ( valOf As) v"
    proof(induct_tac As',auto)qed

lemma valOfLemma5 :"v \<notin> set (map fst  As') \<Longrightarrow>
( valOf (As'@ As) v) =    ( valOf As) v"
   by (metis valOfLemma5Aux)

lemma mapFstAssignsAux:"(\<forall> i.  v' \<noteq> Para v i) \<longrightarrow> v' \<notin> set (map fst ( map (statement2Assigns o
                      (\<lambda>i. assign (Para v i,  e i))) L )) "
  apply(induct_tac L,auto) done

lemma mapFstAssigns [simp,intro]:"(\<forall> i.  v' \<noteq> Para v i) \<Longrightarrow> v' \<notin> set (map fst ( map (statement2Assigns o
                      (\<lambda>i. assign (Para v i,  e i))) L )) "
  apply(metis mapFstAssignsAux) done

lemma valOfLemma6Aux :"v \<notin> set (map fst   S) \<longrightarrow>
( valOf  ( S@ S') v) =    ( valOf   S') v"
    proof(induct_tac S,auto)qed

lemma valOfLemma6 [simp,intro!]:"v \<notin> set (map fst   S) \<Longrightarrow>
( valOf  ( S@ S') v) =    ( valOf   S') v"
by (metis valOfLemma6Aux)

lemma valOfLemma7 [simp]:
"map (statement2Assigns \<circ>
                      (\<lambda>i. assign (Para v i, e i)))
                  [0..<depth] = map (\<lambda>i.   (Para v i, e i)) [0..<depth]"
apply(induct_tac depth)
apply auto
done

lemma valOfLemma8 [simp]:
"map (statement2Assigns \<circ>
                      (\<lambda>i. assign (Para v i, e i)))
                  (down Last) = map (\<lambda>i.   (Para v i, e i)) (down Last)"
apply(induct_tac Last)
apply auto
done

lemma valOfLemma9[simp]:
"\<forall>ASL. valOf (map (\<lambda>i.   (Para v i, e i)) [0..<depth]@ASL) (Ident v') =valOf ASL (Ident v')" (is "?P depth")
proof(induct_tac depth)
  show "?P 0"
    by auto
next
  fix n
  assume a1:"?P n"

  show "?P (Suc n)"
  proof
    fix ASL
    have a2:"(map (\<lambda>i. (Para v i, e i)) [0..<Suc n] @ ASL) =
    (map (\<lambda>i. (Para v i, e i)) [0..< n]) @((Para v ( n), e ( n))#ASL)"
    apply auto done
    have a3:" valOf ((map (\<lambda>i. (Para v i, e i)) [0..< n]) @((Para v ( n), e ( n))#ASL)) (Ident v') =
    valOf  ((Para v ( n), e ( n))#ASL) (Ident v')"
    by (simp add: local.a1)

    show "valOf (map (\<lambda>i. (Para v i, e i)) [0..<Suc n] @ ASL) (Ident v') = valOf ASL (Ident v')"
      apply(cut_tac a2 a3,auto)
   done
   qed
 qed

lemma valOfLemma10:"
          valOf (map (statement2Assigns \<circ>
                       (\<lambda>i. assign (Para (Ident ''mem'') i,
                                    iteForm (eqn (Const (index i)) (Const (index 0))) dataIn
                                     (caseExp
                                       (map (\<lambda>ia. (eqn (uif ''-'' [Const (index i), Const (index (Suc 0))]) (Const (index ia)), mem ia))
                                         (down depth))))))
                   [0..<depth] @
                  [(Ident ''tail'', iteForm (neg (eqn emptyFifo LOW)) (uif ''+'' [tail, Const (index (Suc 0))]) tail),
                   (Ident ''empty'', LOW)])
            (Ident ''tail'') = iteForm (neg (eqn emptyFifo LOW)) (uif ''+'' [tail, Const (index (Suc 0))]) tail"
     by auto

lemma valOfLemma11[simp]: "i \<le> N \<longrightarrow> (valOf (map (\<lambda>i. (Para v i, e i)) (down N)) (Para v i))=e i"
  apply(induct_tac N)
  apply simp
  apply auto
done

lemma substMap:

shows "(\<forall> x. x \<in> set xs \<longrightarrow> substExp  x f=x)\<longrightarrow>substExp  (uif fStr xs) f =uif fStr xs"
proof(induct_tac xs,auto) qed

lemma substNIl:
  shows "(substExp e [] = e) \<and> (substForm f [] =f)"
  using substMap by(induct_tac e and f,auto)

lemma substNIlForm[simp]:
  shows " (substForm f [] =f)"
by (simp add: substNIl)

lemma substNIlExp[simp]:
  shows " (substExp e [] =e)"
by (simp add: substNIl)

lemma tautologyImplTrans[intro!]:
  assumes a1:"tautlogy (implyForm P Q) I" and a2:"tautlogy (implyForm  Q R) I"
  shows "tautlogy (implyForm P R) I"
using a2 local.a1 by auto

lemma noEffectSubstAux:

  shows " (  (v \<notin>set (varOfExp e) ) \<longrightarrow>  substExp  e ((v,e')#S)  =substExp  e S) \<and>
          (  (v \<notin>set (varOfForm f)  )\<longrightarrow> substForm f ((v,e')#S)  =  substForm f S )"

    (is "(( ?condOne e S\<longrightarrow> ?LHS e S=?RHS e S)\<and> (?condOnf f S\<longrightarrow> ?LHS1 f S=?RHS1 f S))")
  proof(induct_tac e and f,auto)qed

lemma noEffectSubstExp [simp,intro!]:

  shows " v \<notin>set (varOfExp e)  \<Longrightarrow>  substExp  e ((v,e')#S)  =substExp  e S "
by (metis noEffectSubstAux)

lemma noEffectSubstForm [simp,intro!]:

  shows "    (v \<notin>set (varOfForm f)  \<Longrightarrow>  substForm f ((v,e')#S)  =  substForm f S ) "
 by (metis noEffectSubstAux)

 lemma noEffectSubstAllAux:

  shows " (  (set (varOfExp e) \<inter> set (map fst S) ={} ) \<longrightarrow>  substExp  e S  = e) \<and>
          (  (set (varOfForm f) \<inter> set (map fst S) ={} )\<longrightarrow> substForm f S =  f )"

    (is "?P S")
  proof(induct_tac S,simp)
  fix a S
    assume a1:"?P S"
    show "?P (a#S)" (is "?P1 \<and> ?P2")
    proof(rule conjI)
    show "?P1"
    proof
      assume b1:" set (varOfExp e) \<inter> set (map fst (a # S)) = {}"
      have b2:"set (varOfExp e) \<inter> set (map fst S) ={}" by(cut_tac b1,auto)
      have b3:" substExp  e (a # S) = substExp  e S"
      proof(case_tac a,cut_tac b1,simp) qed
      have b4:"substExp  e S=e" by(cut_tac b2 a1,auto)
      show "substExp  e (a # S) = e"
      by (simp add: b3 b4)
    qed
   next
    show "?P2"
    proof
      assume b1:" set (varOfForm f) \<inter> set (map fst (a # S)) = {}"
      have b2:"set (varOfForm f) \<inter> set (map fst S) ={}" by(cut_tac b1,auto)
      have b3:" substForm  f (a # S) = substForm  f S"
      proof(case_tac a,cut_tac b1,simp) qed
      have b4:"substForm  f S=f"
      by(cut_tac b2 a1,auto)
      show "substForm  f (a # S) = f"
      by (simp add: b3 b4)
    qed
    qed
 qed

lemma noEffectPreExp [simp,intro!]:
  assumes a1:" v \<notin>set (varOfExp e)"
  shows " preExp1  e (Parallel (assign (v,e')#S))  = preExp1  e (Parallel S) "
  by (simp add: local.a1)

lemma noEffectPreExp1 [simp,intro!]:
  assumes a1:" set (varOfExp e) \<inter>  set (map fst ( map statement2Assigns S)) ={}"
  shows " preExp1  e (Parallel S)  =e "
  using assms noEffectSubstAllAux preExp1.simps(1) by presburger

lemma noEffectPreCond [simp,intro!]:
  assumes a1:" v \<notin>set (varOfForm f)"
  shows " preCond1  f (Parallel (assign (v,e')#S))  = preCond1  f (Parallel S) "
  by (simp add: local.a1)

lemma noEffectPreCond1 [simp,intro!]:
assumes a1: "(  (set (varOfForm f) \<inter> set (map fst S) ={} ) )"
shows " substForm f S =  f"
using assms noEffectSubstAllAux by auto

lemma auxOnCaseExpMaps[simp]:
"varOfExp (caseExp (map (\<lambda>i. (f i, e i)) (down LAST)))
=concat (map (\<lambda>i. ( (varOfForm (f i))@varOfExp ( e i)))  (down LAST))"
proof(induct_tac LAST,auto)qed

lemma substByWrite[simp,intro!]:
  assumes a1:"(\<forall>j. Para mem j \<notin>set (varOfExp e'))"
shows "(substExp e'
       (map (\<lambda>i. (Para mem i, iteForm (eqn e (Const (index i))) e'' (IVar (Para mem i)))) (down n))) =e'"
using a1 by(induct_tac n, auto)

lemma SucnIsNotInDownNAux: "\<forall>i. Suc n \<le> i \<longrightarrow> i \<notin> set (down n)"
proof(induct_tac n,auto)qed

lemma SucnIsNotInDownn: "Suc n \<notin> set (down n)"
by (simp add: SucnIsNotInDownNAux)

lemma OnIfPos1[simp,intro]:
  assumes a1:"tautlogy  (implyForm pre b) I"
  shows "tautlogy  (implyForm pre (preCond1 f (If b S1 S2))) I = tautlogy  (implyForm pre (preCond1 f  S1 )) I "
    by (cut_tac a1,auto)

lemma OnIfNeg1[simp,intro]:
  assumes a1:"tautlogy  (implyForm pre (neg b)) I"
  shows "tautlogy  (implyForm pre (preCond1 f (If b S1 S2))) I = tautlogy  (implyForm pre (preCond1 f  S2 )) I "
    by (cut_tac a1,auto)

lemma preCondAndList[simp]:
shows "tautlogy (implyForm (preCond1 (andListForm FS) S) ( andListForm (map (\<lambda>f. preCond1 f S) FS))) I"
proof(induct_tac FS,simp,case_tac S,simp ,simp,rule allI)
  fix a list x21 x22 x23 s
  assume b1:" \<forall>s. (formEval I x21 s \<and> formEval I (preCond1 (andListForm list) x22) s \<longrightarrow>
            formEval I (andListForm (map (\<lambda>f. orForm (andForm x21 (preCond1 f x22)) (andForm (neg x21) (preCond1 f x23))) list)) s) \<and>
           (\<not> formEval I x21 s \<and> formEval I (preCond1 (andListForm list) x23) s \<longrightarrow>
            formEval I (andListForm (map (\<lambda>f. orForm (andForm x21 (preCond1 f x22)) (andForm (neg x21) (preCond1 f x23))) list)) s) " and
         b2:"S = generalizeStatement.If x21 x22 x23 "
   show "(formEval I x21 s \<and> formEval I (preCond1 (andForm a (andListForm list)) x22) s \<longrightarrow>
        formEval I (preCond1 a x22) s \<and>
        formEval I (andListForm (map (\<lambda>f. orForm (andForm x21 (preCond1 f x22)) (andForm (neg x21) (preCond1 f x23))) list)) s) \<and>
       (\<not> formEval I x21 s \<and> formEval I (preCond1 (andForm a (andListForm list)) x23) s \<longrightarrow>
        formEval I (preCond1 a x23) s \<and>
        formEval I (andListForm (map (\<lambda>f. orForm (andForm x21 (preCond1 f x22)) (andForm (neg x21) (preCond1 f x23))) list)) s)"(is "?P \<and> ?Q")
    proof(rule conjI)
      show "?P"
      proof
        assume c1:"formEval I x21 s \<and> formEval I (preCond1 (andForm a (andListForm list)) x22) s "
        show "formEval I (preCond1 a x22) s \<and>
        formEval I (andListForm (map (\<lambda>f. orForm (andForm x21 (preCond1 f x22)) (andForm (neg x21) (preCond1 f x23))) list)) s"
        using b1 c1 lemmaOnPreForm by auto
      qed
      next
      show "?Q"
      proof
        assume c1:"\<not> formEval I x21 s \<and> formEval I (preCond1 (andForm a (andListForm list)) x23) s"
        show "formEval I (preCond1 a x23) s \<and> formEval I (andListForm (map (\<lambda>f. orForm (andForm x21 (preCond1 f x22)) (andForm (neg x21) (preCond1 f x23))) list)) s"
        using b1 c1 lemmaOnPreForm by auto
       qed
       qed
qed

lemma preCondAndListConv[simp]:
shows "tautlogy (implyForm  ( andListForm (map (\<lambda>f. preCond1 f S) FS))  (preCond1 (andListForm FS) S)) I"
proof(induct_tac FS,case_tac S,simp,simp,rule allI)
  fix x21 x22 x23 s
  assume a1:"S = generalizeStatement.If x21 x22 x23"
  show "formEval I x21 s \<and> formEval I (preCond1 chaos x22) s \<or> \<not> formEval I x21 s \<and> formEval I (preCond1 chaos x23) s" thm lemmaOnPreForm
  by (simp add: lemmaOnPreForm)
  next
  fix a list
  assume a1:"tautlogy (implyForm (andListForm (map (\<lambda>f. preCond1 f S) list)) (preCond1 (andListForm list) S)) I"
  show "tautlogy (implyForm (andListForm (map (\<lambda>f. preCond1 f S) (a # list))) (preCond1 (andListForm (a # list)) S)) I"
  proof(simp,rule allI,rule impI)
    fix s
    assume b1:"formEval I (preCond1 a S) s \<and> formEval I (andListForm (map (\<lambda>f. preCond1 f S) list)) s "
    show "formEval I (preCond1 (andForm a (andListForm list)) S) s"
    proof(case_tac S)
      fix xs
      assume c1:"S=Parallel xs"
      show "formEval I (preCond1 (andForm a (andListForm list)) S) s"
      apply(cut_tac a1 b1 c1,simp) done
      next
      fix x21 x22 x23
      assume c1:"S=generalizeStatement.If x21 x22 x23"
      show "formEval I (preCond1 (andForm a (andListForm list)) S) s"
      apply(cut_tac a1 b1 c1,simp)
      using lemmaOnPreForm by auto
    qed
    qed
qed

end