(*
Author: Alexander Katovsky
*)

header "Functor"

theory Functors
imports Category
begin

record ('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor =
  CatDom :: "('o1,'m1,'a)Category_scheme"
  CatCod :: "('o2,'m2,'b)Category_scheme"
  MapM :: "'m1 \<Rightarrow> 'm2"

abbreviation
  FunctorMorApp :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme \<Rightarrow> 'm1 \<Rightarrow> 'm2" (infixr "##" 70) where
  "FunctorMorApp F m \<equiv> (MapM F) m"

definition
  MapO :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme \<Rightarrow> 'o1 \<Rightarrow> 'o2"  where
  "MapO F X \<equiv> THE Y . Y \<in> Obj(CatCod F) \<and>  F ## (Id (CatDom F) X) = Id (CatCod F) Y"

abbreviation
  FunctorObjApp :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme \<Rightarrow> 'o1 \<Rightarrow> 'o2" (infixr "@@" 70) where
  "FunctorObjApp F X \<equiv> (MapO F X)"

locale PreFunctor =
  fixes F :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme"  (structure)
  assumes FunctorComp: "f \<approx>>\<^bsub>CatDom F\<^esub> g \<Longrightarrow> F ## (f ;;\<^bsub>CatDom F\<^esub> g) = (F ## f) ;;\<^bsub>CatCod F\<^esub> (F ## g)"
  and     FunctorId:   "X \<in> obj\<^bsub>CatDom F\<^esub> \<Longrightarrow> \<exists> Y \<in> obj\<^bsub>CatCod F\<^esub> . F ## (id\<^bsub>CatDom F\<^esub> X) = id\<^bsub>CatCod F\<^esub> Y"
  and     CatDom[simp]:      "Category(CatDom F)"
  and     CatCod[simp]:      "Category(CatCod F)"

locale FunctorM = PreFunctor +
  assumes     FunctorCompM: "f maps\<^bsub>CatDom F\<^esub> X to Y \<Longrightarrow> (F ## f) maps\<^bsub>CatCod F\<^esub> (F @@ X) to (F @@ Y)"

locale FunctorExt =
  fixes F :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme"  (structure)
  assumes FunctorMapExt: "(MapM F) \<in> extensional (Mor (CatDom F))"

locale Functor = FunctorM + FunctorExt

definition
  MakeFtor :: "('o1, 'o2, 'm1, 'm2, 'a, 'b,'r) Functor_scheme \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a, 'b,'r) Functor_scheme" where
  "MakeFtor F \<equiv> \<lparr>
      CatDom = CatDom F ,
      CatCod = CatCod F ,
      MapM = restrict (MapM F) (Mor (CatDom F)) ,
      \<dots> = Functor.more F
  \<rparr>"

lemma PreFunctorFunctor[simp]: "Functor F \<Longrightarrow> PreFunctor F"
by (simp add: Functor_def FunctorM_def)

lemmas functor_simps = PreFunctor.FunctorComp PreFunctor.FunctorId

definition
  functor_abbrev ("Ftor _ : _ \<longrightarrow> _" [81]) where
  "Ftor F : A \<longrightarrow> B \<equiv> (Functor F) \<and> (CatDom F = A) \<and> (CatCod F = B)"

lemma functor_abbrevE[elim]: "\<lbrakk>Ftor F : A \<longrightarrow> B ; \<lbrakk>(Functor F) ; (CatDom F = A) ; (CatCod F = B)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (auto simp add: functor_abbrev_def)

definition
  functor_comp_def ("_ \<approx>>;;; _" [81]) where
  "functor_comp_def F G \<equiv> (Functor F) \<and> (Functor G) \<and> (CatDom G = CatCod F)"

lemma functor_comp_def[elim]: "\<lbrakk>F \<approx>>;;; G ; \<lbrakk>Functor F ; Functor G ; CatDom G = CatCod F\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (auto simp add: functor_comp_def_def)

lemma (in Functor) FunctorMapsTo:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows   "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))"
proof-
  have "f maps\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> f) to (cod\<^bsub>CatDom F\<^esub> f)" using assms by auto
  thus ?thesis by (simp add: FunctorCompM[of f "dom\<^bsub>CatDom F\<^esub> f" "cod\<^bsub>CatDom F\<^esub> f"])
qed

lemma (in Functor) FunctorCodDom:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows "dom\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> f)" and "cod\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (cod\<^bsub>CatDom F\<^esub> f)"
proof-
  have "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))" using assms by (simp add: FunctorMapsTo)
  thus "dom\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> f)" and "cod\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (cod\<^bsub>CatDom F\<^esub> f)"
    by auto
qed

lemma (in Functor) FunctorCompPreserved: "f \<in> mor\<^bsub>CatDom F\<^esub> \<Longrightarrow> F ## f \<in> mor\<^bsub>CatCod F\<^esub>"
by (auto dest:FunctorMapsTo)

lemma (in Functor) FunctorCompDef:
  assumes "f \<approx>>\<^bsub>CatDom F\<^esub> g" shows "(F ## f) \<approx>>\<^bsub>CatCod F\<^esub> (F ## g)"
proof(auto simp add: CompDefined_def)
  show "F ## f \<in> mor\<^bsub>CatCod F\<^esub>" and "F ## g \<in> mor\<^bsub>CatCod F\<^esub>" using assms by (auto simp add: FunctorCompPreserved)
  have "f \<in> mor\<^bsub>CatDom F\<^esub>" and "g \<in> mor\<^bsub>CatDom F\<^esub>" using assms by auto
  hence a: "cod\<^bsub>CatCod F\<^esub> (F ## f) = F @@ (cod\<^bsub>CatDom F\<^esub> f)" and b: "dom\<^bsub>CatCod F\<^esub>(F ## g) = F @@ (dom\<^bsub>CatDom F\<^esub> g)"
    by (simp add: FunctorCodDom)+
  have "cod\<^bsub>CatCod F\<^esub> (F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> g)" using assms a by auto
  also have "... = dom\<^bsub>CatCod F\<^esub> (F ## g)" using b by simp
  finally show "cod\<^bsub>CatCod F\<^esub> (F ## f) = dom\<^bsub>CatCod F\<^esub> (F ## g)" .
qed

lemma FunctorComp: "\<lbrakk>Ftor F : A \<longrightarrow> B ; f \<approx>>\<^bsub>A\<^esub> g\<rbrakk> \<Longrightarrow> F ## (f ;;\<^bsub>A\<^esub> g) = (F ## f) ;;\<^bsub>B\<^esub> (F ## g)"
by (auto simp add: PreFunctor.FunctorComp)

lemma FunctorCompDef: "\<lbrakk>Ftor F : A \<longrightarrow> B ; f \<approx>>\<^bsub>A\<^esub> g\<rbrakk> \<Longrightarrow> (F ## f) \<approx>>\<^bsub>B\<^esub> (F ## g)"
by (auto simp add: Functor.FunctorCompDef)

lemma FunctorMapsTo:
  assumes "Ftor F : A \<longrightarrow> B" and "f maps\<^bsub>A\<^esub> X to Y"
  shows "(F ## f) maps\<^bsub>B\<^esub> (F @@ X) to (F @@ Y)"
proof-
  have b: "CatCod F = B" and a: "CatDom F = A" and ff: "Functor F" using assms by auto
  have df: "(dom\<^bsub>CatDom F\<^esub> f) = X" and cf: "(cod\<^bsub>CatDom F\<^esub> f) = Y" using a assms by auto
  have "f \<in> mor\<^bsub>CatDom F\<^esub>" using assms by auto
  hence "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))" using ff
    by (simp add: Functor.FunctorMapsTo)
  thus ?thesis using df cf b by simp
qed

lemma (in PreFunctor) FunctorId2:
  assumes "X \<in> obj\<^bsub>CatDom F\<^esub>"
  shows   "F @@ X \<in> obj\<^bsub>CatCod F\<^esub> \<and> F ## (id\<^bsub>CatDom F\<^esub> X) = id\<^bsub>CatCod F\<^esub> (F @@ X)"
proof-
  let ?Q = "\<lambda> E Y . Y \<in> obj\<^bsub>CatCod F\<^esub> \<and> E = id\<^bsub>CatCod F\<^esub> Y"
  let ?P = "?Q (F ## (id\<^bsub>CatDom F\<^esub> X))"
  from assms FunctorId obtain Y where "?P Y" by auto
  moreover  {
    fix y e z have "\<lbrakk>?Q e y ; ?Q e z\<rbrakk> \<Longrightarrow> y = z"
      by (auto intro: Category.IdInj[of "CatCod F" y z])
  }
  ultimately have "\<exists>! Z . ?P Z" by auto
  hence "?P (THE Y . ?P Y)" by (rule theI')
  thus ?thesis by (auto simp add: MapO_def)
qed

lemma FunctorId:
  assumes "Ftor F : C \<longrightarrow> D" and "X \<in> Obj C"
  shows "F ## (Id C X) = Id D (F @@ X)"
proof-
  have "CatDom F = C" and "CatCod F = D" and "PreFunctor F" using assms by auto
  thus ?thesis using assms PreFunctor.FunctorId2[of F X] by simp
qed

lemma (in Functor) DomFunctor: "f \<in> mor\<^bsub>CatDom F\<^esub> \<Longrightarrow> dom\<^bsub>CatCod F\<^esub> (F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> f)"
by (simp add: FunctorCodDom)

lemma (in Functor) FunctorId3Dom:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows   "F ## (id\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## f))"
proof-
  have "(dom\<^bsub>CatDom F\<^esub> f) \<in> obj\<^bsub>CatDom F\<^esub>" using assms by (simp add: Category.Cdom)
  hence "F ## (id\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f))" by (simp add: FunctorId2)
  also have "... = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## f))" using assms by (simp add: DomFunctor)
  finally show ?thesis by simp
qed

lemma (in Functor) FunctorId3Cod:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows   "F ## (id\<^bsub>CatDom F\<^esub> (cod\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## f))"
proof-
  have "(cod\<^bsub>CatDom F\<^esub> f) \<in> obj\<^bsub>CatDom F\<^esub>" using assms by (simp add: Category.Ccod)
  hence "F ## (id\<^bsub>CatDom F\<^esub> (cod\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (F @@ (cod\<^bsub>CatDom F\<^esub> f))" by (simp add: FunctorId2)
  also have "... = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## f))" using assms by (simp add: CodFunctor)
  finally show ?thesis by simp
qed

lemma (in PreFunctor) FmToFo: "\<lbrakk>X \<in> obj\<^bsub>CatDom F\<^esub> ; Y \<in> obj\<^bsub>CatCod F\<^esub> ; F ## (id\<^bsub>CatDom F\<^esub> X) = id\<^bsub>CatCod F\<^esub> Y\<rbrakk> \<Longrightarrow> F @@ X = Y"
  by (auto simp add: FunctorId2 intro: Category.IdInj[of "CatCod F" "F @@ X" Y])

lemma MakeFtorPreFtor:
  assumes "PreFunctor F" shows "PreFunctor (MakeFtor F)"
proof-
  {
    fix X assume a: "X \<in> obj\<^bsub>CatDom F\<^esub>" have "id\<^bsub>CatDom F \<^esub>X \<in> mor\<^bsub>CatDom F\<^esub>"
    proof-
      have "Category (CatDom F)" using assms by (simp add: PreFunctor_def)
      hence "id\<^bsub>CatDom F \<^esub>X maps\<^bsub>CatDom F\<^esub> X to X" using a by (simp add: Category.Cidm)
      thus ?thesis using a by (auto)
    qed
  }
  thus "PreFunctor (MakeFtor F)" using assms
    by(auto simp add: PreFunctor_def MakeFtor_def Category.MapsToMorDomCod)
qed

lemma MakeFtorMor: "f \<in> mor\<^bsub>CatDom F\<^esub> \<Longrightarrow> MakeFtor F ## f = F ## f"
by(simp add: MakeFtor_def)

lemma MakeFtorObj:
  assumes "PreFunctor F" and "X \<in> obj\<^bsub>CatDom F\<^esub>"
  shows "MakeFtor F @@ X = F @@ X"
proof-
  have "X \<in> obj\<^bsub>CatDom (MakeFtor F)\<^esub>" using assms(2) by (simp add: MakeFtor_def)
  moreover have "(F @@ X) \<in> obj\<^bsub>CatCod (MakeFtor F)\<^esub>" using assms by (simp add: PreFunctor.FunctorId2 MakeFtor_def)
  moreover have "MakeFtor F ## id\<^bsub>CatDom (MakeFtor F) \<^esub>X = id\<^bsub>CatCod (MakeFtor F) \<^esub>(F @@ X)"
  proof-
    have "Category (CatDom F)" using assms(1) by (simp add: PreFunctor_def)
    hence "id\<^bsub>CatDom F \<^esub>X  maps\<^bsub>CatDom F\<^esub> X to X" using assms(2) by (auto simp add: Category.Cidm)
    hence "id\<^bsub>CatDom F \<^esub>X \<in> mor\<^bsub>CatDom F\<^esub>" by auto
    hence "MakeFtor F ## id\<^bsub>CatDom (MakeFtor F) \<^esub>X = F ## id\<^bsub>CatDom F \<^esub>X" by (simp add: MakeFtor_def)
    also have "... = id\<^bsub>CatCod F \<^esub>(F @@ X)" using assms by (simp add: PreFunctor.FunctorId2)
    finally show ?thesis by (simp add: MakeFtor_def)
  qed
  moreover have "PreFunctor (MakeFtor F)" using assms(1) by (simp add: MakeFtorPreFtor)
  ultimately show ?thesis by (simp add: PreFunctor.FmToFo)
qed

lemma MakeFtor: assumes "FunctorM F" shows "Functor (MakeFtor F)"
proof(intro_locales)
  show "PreFunctor (MakeFtor F)" using assms by (simp add: MakeFtorPreFtor FunctorM_def)
  show "FunctorM_axioms (MakeFtor F)"
  proof(auto simp add: FunctorM_axioms_def)
    {
      fix f X Y assume aa: "f maps\<^bsub>CatDom (MakeFtor F)\<^esub> X to Y"
      show "((MakeFtor F) ## f) maps\<^bsub>CatCod (MakeFtor F)\<^esub> ((MakeFtor F) @@ X) to ((MakeFtor F) @@ Y)"
      proof-
        have "((MakeFtor F) ## f) = F ## f" using aa by (auto simp add: MakeFtor_def)
        moreover have "((MakeFtor F) @@ X) = F @@ X" and "((MakeFtor F) @@ Y) = F @@ Y"
        proof-
          have "Category (CatDom F)" using assms by (simp add: FunctorM_def PreFunctor_def)
          hence "X \<in> obj\<^bsub>CatDom F\<^esub>" and "Y \<in> obj\<^bsub>CatDom F\<^esub>"
            using aa by (auto simp add: Category.MapsToObj MakeFtor_def)
          moreover have "PreFunctor F" using assms(1) by (simp add: FunctorM_def)
          ultimately show "((MakeFtor F) @@ X) = F @@ X" and "((MakeFtor F) @@ Y) = F @@ Y"
            by (simp add: MakeFtorObj)+
        qed
        moreover have "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ X) to (F @@ Y)" using assms(1) aa
          by (simp add: FunctorM.FunctorCompM MakeFtor_def)
        ultimately show ?thesis by (simp add: MakeFtor_def)
      qed
    }
  qed
  show "FunctorExt (MakeFtor F)" by(simp add: FunctorExt_def MakeFtor_def)
qed

definition
  IdentityFunctor' :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,'o,'m,'m,'a,'a) Functor" ("FId' _" [70]) where
  "IdentityFunctor' C \<equiv> \<lparr>CatDom = C , CatCod = C , MapM = (\<lambda> f . f) \<rparr>"

definition
  IdentityFunctor ("FId _" [70]) where
  "IdentityFunctor C \<equiv> MakeFtor(IdentityFunctor' C)"

lemma IdFtor'PreFunctor: "Category C \<Longrightarrow> PreFunctor (FId' C)"
by(auto simp add: PreFunctor_def IdentityFunctor'_def)

lemma IdFtor'Obj:
  assumes "Category C" and "X \<in> obj\<^bsub>CatDom (FId' C)\<^esub>"
  shows "(FId' C) @@ X = X"
proof-
  have "(FId' C) ## id\<^bsub>CatDom (FId' C)\<^esub> X = id\<^bsub>CatCod (FId' C)\<^esub> X" by(simp add: IdentityFunctor'_def)
  moreover have "X \<in> obj\<^bsub>CatCod (FId' C)\<^esub>" using assms by (simp add: IdentityFunctor'_def)
  ultimately show ?thesis using assms by (simp add: PreFunctor.FmToFo IdFtor'PreFunctor)
qed

lemma IdFtor'FtorM:
  assumes "Category C" shows "FunctorM (FId' C)"
proof(auto simp add: FunctorM_def IdFtor'PreFunctor assms FunctorM_axioms_def)
  {
    fix f X Y assume a: "f maps\<^bsub>CatDom (FId' C)\<^esub> X to Y"
    show "((FId' C) ## f) maps\<^bsub>CatCod (FId' C)\<^esub> ((FId' C) @@ X) to ((FId' C) @@ Y)"
    proof-
      have "X \<in> obj\<^bsub>CatDom (FId' C)\<^esub>" and "Y \<in> obj\<^bsub>CatDom (FId' C)\<^esub>"
        using a assms by (simp add: Category.MapsToObj IdentityFunctor'_def)+
      moreover have "(FId' C) ## f = f" and "CatDom (FId' C) = CatCod (FId' C)" by (simp add: IdentityFunctor'_def)+
      ultimately show ?thesis using assms a by(simp add: IdFtor'Obj)
    qed
  }
qed

lemma IdFtorFtor:  "Category C \<Longrightarrow> Functor (FId C)"
by (auto simp add: IdentityFunctor_def IdFtor'FtorM intro: MakeFtor)

definition
  ConstFunctor' :: "('o1,'m1,'a) Category_scheme \<Rightarrow>
                  ('o2,'m2,'b) Category_scheme \<Rightarrow> 'o2 \<Rightarrow> ('o1,'o2,'m1,'m2,'a,'b) Functor"  where
  "ConstFunctor' A B b \<equiv> \<lparr>
         CatDom = A ,
         CatCod = B ,
         MapM = (\<lambda> f . (Id B) b)
  \<rparr>"

definition "ConstFunctor A B b \<equiv> MakeFtor(ConstFunctor' A B b)"

lemma ConstFtor' :
  assumes "Category A" "Category B" "b \<in> (Obj B)"
  shows   "PreFunctor (ConstFunctor' A B b)"
  and     "FunctorM (ConstFunctor' A B b)"
proof-
  show "PreFunctor (ConstFunctor' A B b)" using assms
    apply (subst PreFunctor_def)
    apply (rule conjI)+
    by (auto simp add: ConstFunctor'_def Category.Simps Category.CatIdCompId)
  moreover
  {
    fix X  assume "X \<in> obj\<^bsub>A\<^esub>" "b \<in> obj\<^bsub>B\<^esub>" "PreFunctor (ConstFunctor' A B b)"
    hence "(ConstFunctor' A B b) @@ X = b"
      by (auto simp add: ConstFunctor'_def PreFunctor.FmToFo Category.Simps)
  }
  ultimately show "FunctorM (ConstFunctor' A B b)" using assms
    by (intro_locales, auto simp add: ConstFunctor'_def Category.Simps FunctorM_axioms_def)
qed

lemma ConstFtor:
  assumes "Category A" "Category B" "b \<in> (Obj B)"
  shows "Functor (ConstFunctor A B b)"
by (auto simp add: assms ConstFtor' ConstFunctor_def MakeFtor)

definition
  UnitFunctor :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,unit,'m,unit,'a,unit) Functor"  where
  "UnitFunctor C \<equiv> ConstFunctor C UnitCategory ()"

lemma UnitFtor:
  assumes "Category C"
  shows "Functor(UnitFunctor C)"
proof-
  have "() \<in> obj\<^bsub>UnitCategory\<^esub>" by (simp add: UnitCategory_def MakeCatObj)
  hence "Functor(ConstFunctor C UnitCategory ())" using assms
    by (simp add: ConstFtor)
  thus ?thesis by (simp add: UnitFunctor_def)
qed

definition
  FunctorComp' :: "('o1,'o2,'m1,'m2,'a1,'a2) Functor \<Rightarrow> ('o2,'o3,'m2,'m3,'b1,'b2) Functor
                    \<Rightarrow> ('o1,'o3,'m1,'m3,'a1,'b2) Functor" (infixl ";;:" 71) where
  "FunctorComp' F G \<equiv> \<lparr>
        CatDom = CatDom F ,
        CatCod = CatCod G ,
        MapM   = \<lambda> f . (MapM G)((MapM F) f)
  \<rparr>"

definition FunctorComp (infixl ";;;" 71) where "FunctorComp F G \<equiv> MakeFtor (FunctorComp' F G)"

lemma FtorCompComp':
  assumes "f \<approx>>\<^bsub>CatDom F\<^esub> g"
  and "F \<approx>>;;; G"
  shows "G ## (F ## (f ;;\<^bsub>CatDom F\<^esub> g)) = (G ## (F ## f)) ;;\<^bsub>CatCod G\<^esub> (G ## (F ## g))"
proof-
  have [simp]: "PreFunctor G \<and> PreFunctor F" using assms by auto
  have [simp]: "(F ## f) \<approx>>\<^bsub>CatDom G\<^esub> (F ## g)" using assms by (auto simp add: Functor.FunctorCompDef[of F f g])
  have "F ## (f ;;\<^bsub>CatDom F\<^esub> g) = (F ## f) ;;\<^bsub>CatCod F\<^esub> (F ## g)" using assms
    by (auto simp add: PreFunctor.FunctorComp)
  hence "G ## (F ## (f ;;\<^bsub>CatDom F\<^esub> g)) = G ## ((F ## f) ;;\<^bsub>CatCod F\<^esub> (F ## g))" by simp
  also have "... = G ## ((F ## f) ;;\<^bsub>CatDom G\<^esub> (F ## g))" using assms by auto
  also have "... = (G ## (F ## f)) ;;\<^bsub>CatCod G\<^esub> (G ## (F ## g))"
    by (simp add: PreFunctor.FunctorComp[of G "(F ## f)" "(F ## g)"])
  finally show ?thesis by simp
qed

lemma FtorCompId:
  assumes a: "X \<in> (Obj (CatDom F))"
  and "F \<approx>>;;; G"
  shows "G ## (F ## (id\<^bsub>CatDom F \<^esub>X)) = id\<^bsub>CatCod G\<^esub>(G @@ (F @@ X)) \<and> G @@ (F @@ X) \<in> (Obj (CatCod G))"
proof-
  have [simp]: "PreFunctor G \<and> PreFunctor F" using assms by auto
  have b: "(F @@ X) \<in> obj\<^bsub>CatDom G\<^esub>" using assms
    by (auto simp add: PreFunctor.FunctorId2)
  have "G ## F ## (id\<^bsub>CatDom F \<^esub>X) = G ## (id\<^bsub>CatCod F\<^esub>(F @@ X))" using b a
    by (simp add: PreFunctor.FunctorId2[of F "X"])
  also have "... = G ## (id\<^bsub>CatDom G\<^esub>(F @@ X))" using assms by auto
  also have "... = id\<^bsub>CatCod G\<^esub>(G @@ (F @@ X)) \<and> G @@ (F @@ X) \<in> (Obj (CatCod G))" using b
    by (simp add: PreFunctor.FunctorId2[of G "(F @@ X)"])
  finally show ?thesis by simp
qed

lemma FtorCompIdDef:
  assumes a: "X \<in> (Obj (CatDom F))" and b: "PreFunctor (F ;;: G)"
  and "F \<approx>>;;; G"
  shows "(F ;;: G) @@ X = (G @@ (F @@ X))"
proof-
  have "(F ;;: G) ## (id\<^bsub>CatDom (F ;;: G)\<^esub>(X)) = G ## (F ## (id\<^bsub>CatDom F\<^esub>(X)))" using assms
    by (simp add: FunctorComp'_def)
  also have "... = id\<^bsub>CatCod G\<^esub>(G @@ (F @@ (X)))" using assms a
    by(auto simp add: FtorCompId[of _ F G])
  finally have "(F ;;: G) ## (id\<^bsub>CatDom (F ;;: G)\<^esub>(X)) = id\<^bsub>CatCod (F ;;: G)\<^esub>(G @@ (F @@ X))" using assms
    by (simp add: FunctorComp'_def)
  moreover have "G @@ (F @@ (X)) \<in> (Obj (CatCod (F ;;: G)))" using assms a
    by(auto simp add: FtorCompId[of _ F G] FunctorComp'_def)
  moreover have "X \<in> obj\<^bsub>CatDom (F ;;: G)\<^esub>" using a by (simp add: FunctorComp'_def)
  ultimately show ?thesis using b
    by (simp add: PreFunctor.FmToFo[of "F ;;: G" X "G @@ (F @@ X)"])
qed

lemma FunctorCompMapsTo:
  assumes "f \<in> mor\<^bsub>CatDom (F ;;: G)\<^esub>" and "F \<approx>>;;; G"
  shows "(G ## (F ## f)) maps\<^bsub>CatCod G\<^esub> (G @@ (F @@ (dom\<^bsub>CatDom F\<^esub> f))) to (G @@ (F @@ (cod\<^bsub>CatDom F\<^esub> f)))"
proof-
  have "f \<in> mor\<^bsub>CatDom F \<^esub>\<and> Functor F" using assms by (auto simp add: FunctorComp'_def)
  hence "(F ## f) maps\<^bsub>CatDom G\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))" using assms
    by (auto simp add: Functor.FunctorMapsTo[of F f])
  moreover have "FunctorM G" using assms by (auto simp add: FunctorComp_def Functor_def)
  ultimately show ?thesis by(simp add: FunctorM.FunctorCompM[of G "F ## f" "F @@ (dom\<^bsub>CatDom F\<^esub> f)" "F @@ (cod\<^bsub>CatDom F\<^esub> f)"])
qed

lemma FunctorCompMapsTo2:
  assumes "f \<in> mor\<^bsub>CatDom (F ;;: G)\<^esub>"
  and "F \<approx>>;;; G"
  and "PreFunctor (F ;;: G)"
  shows "((F ;;: G) ## f) maps\<^bsub>CatCod (F ;;: G)\<^esub> ((F ;;: G) @@ (dom\<^bsub>CatDom (F ;;: G)\<^esub> f)) to
                                               ((F ;;: G) @@ (cod\<^bsub>CatDom (F ;;: G)\<^esub> f))"
proof-
  have "Category (CatDom (F ;;: G))" using assms by (simp add: PreFunctor_def)
  hence 1: "(dom\<^bsub>CatDom (F ;;: G)\<^esub> f) \<in> obj\<^bsub>CatDom F \<^esub>\<and> (cod\<^bsub>CatDom (F ;;: G)\<^esub> f) \<in> obj\<^bsub>CatDom F\<^esub>" using assms
    by (auto simp add: Category.Simps FunctorComp'_def)
  have "(G ## (F ## f)) maps\<^bsub>CatCod G\<^esub> (G @@ (F @@ (dom\<^bsub>CatDom F\<^esub> f))) to (G @@ (F @@ (cod\<^bsub>CatDom F\<^esub> f)))"
    using assms by (auto simp add: FunctorCompMapsTo[of f F G])
  moreover have "CatDom F = CatDom(F ;;: G) \<and> CatCod G = CatCod(F ;;: G) \<and> (G ## (F ## f)) = ((F ;;: G) ## f)" using assms
    by (simp add: FunctorComp'_def)
  moreover have "(F ;;: G) @@ (dom\<^bsub>CatDom (F ;;: G)\<^esub> f) = (G @@ (F @@ (dom\<^bsub>CatDom(F ;;: G)\<^esub> f))) \<and>
        (F ;;: G) @@ (cod\<^bsub>CatDom (F ;;: G)\<^esub> f) = (G @@ (F @@ (cod\<^bsub>CatDom(F ;;: G)\<^esub> f)))"
    by (auto simp add: FtorCompIdDef[of _ F G] 1 assms)
  ultimately show ?thesis by auto
qed

lemma FunctorCompMapsTo3:
  assumes "f maps\<^bsub>CatDom (F ;;: G)\<^esub> X to Y"
  and "F \<approx>>;;; G"
  and "PreFunctor (F ;;: G)"
  shows "F ;;: G ## f maps\<^bsub>CatCod (F ;;: G)\<^esub> F ;;: G @@ X to F ;;: G @@ Y"
proof-
  have  "f \<in> mor\<^bsub>CatDom (F ;;: G)\<^esub>"
    and "dom\<^bsub>CatDom (F ;;: G)\<^esub> f = X"
    and "cod\<^bsub>CatDom (F ;;: G)\<^esub> f = Y" using assms by auto
  thus ?thesis using assms by (auto intro: FunctorCompMapsTo2)
qed

lemma FtorCompPreFtor:
  assumes "F \<approx>>;;; G"
  shows   "PreFunctor (F ;;: G)"
proof-
  have 1: "PreFunctor G \<and> PreFunctor F" using assms by auto
  show "PreFunctor (F ;;: G)" using assms
  proof(auto simp add: PreFunctor_def FunctorComp'_def Category.Simps
       FtorCompId[of _ F G] intro:FtorCompComp')
    show "Category (CatDom F)" and "Category (CatCod G)" using assms 1 by (auto simp add: PreFunctor_def)
  qed
qed

lemma FtorCompM :
  assumes "F \<approx>>;;; G"
  shows   "FunctorM (F ;;: G)"
proof(auto simp only: FunctorM_def)
  show 1: "PreFunctor (F ;;: G)" using assms by (rule FtorCompPreFtor)
  {
    fix X Y f assume a: "f maps\<^bsub>CatDom (F ;;: G)\<^esub> X to Y"
    have "F ;;: G ## f maps\<^bsub>CatCod (F ;;: G)\<^esub> F ;;: G @@ X to F ;;: G @@ Y"
      using a assms 1 by (rule FunctorCompMapsTo3)
  }
  thus "FunctorM_axioms (F ;;: G)"
    by(auto simp add: 1 FunctorM_axioms_def)
qed

lemma FtorComp:
  assumes "F \<approx>>;;; G"
  shows   "Functor (F ;;; G)"
proof-
  have "FunctorM (F ;;: G)" using assms by (rule FtorCompM)
  thus ?thesis by (simp add: FunctorComp_def MakeFtor)
qed

lemma (in Functor) FunctorPreservesIso:
  assumes     "ciso\<^bsub>CatDom F\<^esub> k"
  shows       "ciso\<^bsub>CatCod F\<^esub> (F ## k)"
proof-
  have [simp]: "k \<in> mor\<^bsub>CatDom F\<^esub>" using assms by (simp add: Category.IsoIsMor)
  have "cinv\<^bsub>CatCod F\<^esub> (F ## k) (F ## (Cinv\<^bsub>CatDom F\<^esub> k))"
    proof(rule Category.Inverse_relI)
      show "Category (CatCod F)" by simp
      show "(F ## k) \<approx>>\<^bsub>CatCod F\<^esub> (F ## (Cinv\<^bsub>CatDom F\<^esub> k))"
        by (rule FunctorCompDef, simp add: Category.IsoCompInv assms)
      show "(F ## k) ;;\<^bsub>CatCod F\<^esub> (F ## (Cinv\<^bsub>CatDom F\<^esub> k)) = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## k))"
      proof-
        have      "(F ## k) ;;\<^bsub>CatCod F\<^esub> (F ## (Cinv\<^bsub>CatDom F\<^esub> k)) = F ## (k ;;\<^bsub>CatDom F\<^esub> (Cinv\<^bsub>CatDom F\<^esub> k))" using assms
          by(auto simp add: FunctorComp Category.IsoCompInv)
        also have "... = F ## (id\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> k))" using assms by (simp add: Category.IsoInvId2)
        also have "... = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## k))" by (simp add: FunctorId3Dom)
        finally show ?thesis by simp
      qed
      show "(F ## (Cinv\<^bsub>CatDom F\<^esub> k)) ;;\<^bsub>CatCod F\<^esub> (F ## k) = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## k))"
      proof-
        have      "(F ## (Cinv\<^bsub>CatDom F\<^esub> k)) ;;\<^bsub>CatCod F\<^esub> (F ## k) = F ## ((Cinv\<^bsub>CatDom F\<^esub> k) ;;\<^bsub>CatDom F\<^esub>  k)" using assms
          by(auto simp add: FunctorComp Category.InvCompIso)
        also have "... = F ## (id\<^bsub>CatDom F\<^esub> (cod\<^bsub>CatDom F\<^esub> k))" using assms by (simp add: Category.IsoInvId1)
        also have "... = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## k))" using assms by (simp add: FunctorId3Cod)
        finally show ?thesis by simp
      qed
    qed
  thus ?thesis by(auto simp add: isomorphism_def)
qed

declare PreFunctor.CatDom[simp] PreFunctor.CatCod [simp]

lemma FunctorMFunctor[simp]: "Functor F \<Longrightarrow> FunctorM F"
by (simp add: Functor_def)

locale Equivalence = Functor +
  assumes Full: "\<lbrakk>A \<in> Obj (CatDom F) ; B \<in> Obj (CatDom F) ;
                  h maps\<^bsub>CatCod F\<^esub> (F @@ A) to (F @@ B)\<rbrakk> \<Longrightarrow>
                 \<exists> f . (f maps\<^bsub>CatDom F\<^esub> A to B) \<and> (F ## f = h)"
  and Faithful: "\<lbrakk>f maps\<^bsub>CatDom F\<^esub> A to B ; g maps\<^bsub>CatDom F\<^esub> A to B ; F ## f = F ## g\<rbrakk> \<Longrightarrow> f = g"
  and IsoDense: "C \<in> Obj (CatCod F) \<Longrightarrow> \<exists> A \<in> Obj (CatDom F) . ObjIso (CatCod F) (F @@ A) C"

end


(*  Title:      ZF/Resid/Confluence.thy
    Author:     Ole Rasmussen
    Copyright   1995  University of Cambridge
*)

theory Confluence imports Reduction begin

definition
  confluence    :: "i=>o"  where
    "confluence(R) ==
       \<forall>x y. <x,y> \<in> R \<longrightarrow> (\<forall>z.<x,z> \<in> R \<longrightarrow> (\<exists>u.<y,u> \<in> R & <z,u> \<in> R))"

definition
  strip         :: "o"  where
    "strip == \<forall>x y. (x ===> y) \<longrightarrow>
                    (\<forall>z.(x =1=> z) \<longrightarrow> (\<exists>u.(y =1=> u) & (z===>u)))"

(* ------------------------------------------------------------------------- *)
(*        strip lemmas                                                       *)
(* ------------------------------------------------------------------------- *)

lemma strip_lemma_r:
    "[|confluence(Spar_red1)|]==> strip"
apply (unfold confluence_def strip_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule Spar_red.induct, fast)
apply (fast intro: Spar_red.trans)
done

lemma strip_lemma_l:
    "strip==> confluence(Spar_red)"
apply (unfold confluence_def strip_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule Spar_red.induct, blast)
apply clarify
apply (blast intro: Spar_red.trans)
done

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

lemma parallel_moves: "confluence(Spar_red1)"
apply (unfold confluence_def, clarify)
apply (frule simulation)
apply (frule_tac n = z in simulation, clarify)
apply (frule_tac v = va in paving)
apply (force intro: completeness)+
done

lemmas confluence_parallel_reduction =
      parallel_moves [THEN strip_lemma_r, THEN strip_lemma_l]

lemma lemma1: "[|confluence(Spar_red)|]==> confluence(Sred)"
by (unfold confluence_def, blast intro: par_red_red red_par_red)

lemmas confluence_beta_reduction =
       confluence_parallel_reduction [THEN lemma1]

(**** Conversion ****)

consts
  Sconv1        :: "i"
  Sconv         :: "i"

abbreviation
  Sconv1_rel (infixl "<-1->" 50) where
  "a<-1->b == <a,b> \<in> Sconv1"

abbreviation
  Sconv_rel (infixl "<-\<longrightarrow>" 50) where
  "a<-\<longrightarrow>b == <a,b> \<in> Sconv"

inductive
  domains       "Sconv1" \<subseteq> "lambda*lambda"
  intros
    red1:        "m -1-> n ==> m<-1->n"
    expl:        "n -1-> m ==> m<-1->n"
  type_intros    red1D1 red1D2 lambda.intros bool_typechecks

declare Sconv1.intros [intro]

inductive
  domains       "Sconv" \<subseteq> "lambda*lambda"
  intros
    one_step:    "m<-1->n  ==> m<-\<longrightarrow>n"
    refl:        "m \<in> lambda ==> m<-\<longrightarrow>m"
    trans:       "[|m<-\<longrightarrow>n; n<-\<longrightarrow>p|] ==> m<-\<longrightarrow>p"
  type_intros    Sconv1.dom_subset [THEN subsetD] lambda.intros bool_typechecks

declare Sconv.intros [intro]

lemma conv_sym: "m<-\<longrightarrow>n ==> n<-\<longrightarrow>m"
apply (erule Sconv.induct)
apply (erule Sconv1.induct, blast+)
done

(* ------------------------------------------------------------------------- *)
(*      Church_Rosser Theorem                                                *)
(* ------------------------------------------------------------------------- *)

lemma Church_Rosser: "m<-\<longrightarrow>n ==> \<exists>p.(m -\<longrightarrow>p) & (n -\<longrightarrow> p)"
apply (erule Sconv.induct)
apply (erule Sconv1.induct)
apply (blast intro: red1D1 redD2)
apply (blast intro: red1D1 redD2)
apply (blast intro: red1D1 redD2)
apply (cut_tac confluence_beta_reduction)
apply (unfold confluence_def)
apply (blast intro: Sred.trans)
done

end


(* Title:   Scan.thy
   Author:  Akama Hitoshi
*)

theory Scan
  imports HOL.List "../Util/Sum_Util"
begin

lemma pair_induct [case_names Nil PairCons]:
  assumes head: "P []"
  assumes pair: "\<And>x as xas. P xas \<Longrightarrow> P ((x, as)#xas)"
  shows "P xas"
proof (induct xas)
  case Nil
  then show ?case by (simp add: head)
next
  case (Cons ax xas)
  then show ?case proof (cases ax)
    case (Pair x as)
    then show ?thesis by (simp add: pair Cons)
  qed
qed

lemma pair_rev_induct [case_names Nil PairSnoc]:
  assumes head: "P []"
  assumes pair: "\<And>x as xas. P xas \<Longrightarrow> P (xas @ [(x, as)])"
  shows "P xas"
proof (induct xas rule: rev_induct)
  case Nil
  then show ?case by (simp add: head)
next
  case (snoc ax xas)
  then show ?case proof (cases ax)
    case (Pair x as)
    then show ?thesis by (simp add: pair snoc)
  qed
qed

subsubsection \<open>Scanned string\<close>

text \<open>Scanned string\<close>
type_synonym ('y, 'b) scanned_tail = "('y \<times> 'b list) list"
type_synonym ('y, 'b) scanned = "'b list \<times> ('y, 'b) scanned_tail"

fun length_scanned :: "('y, 'b) scanned \<Rightarrow> nat" where
  "length_scanned (w, xas) = Suc (length xas)"

definition append_scanned :: "('y, 'b) scanned \<Rightarrow> ('y, 'b) scanned_tail \<Rightarrow> ('y, 'b) scanned" (infixl "@@@" 80) where
  "append_scanned = (\<lambda>(w, xas) yas. (w, xas @ yas))"

lemma append_scanned_assoc: "(xas @@@ yas) @@@ zas = xas @@@ (yas @ zas)"
  by (cases xas, simp add: append_scanned_def)

lemma append_scanned_simp: "(w, xas) @@@ yas = (w, xas @ yas)"
  unfolding append_scanned_def by simp

lemma append_scanned_Nil[simp]: "xas @@@ [] = xas"
  by (cases xas, simp add: append_scanned_def)

lemma fst_append_scanned[simp]: "fst (a @@@ b) = fst a"
  by (cases a, simp add: append_scanned_simp)

lemma length_scanned_gt: "length_scanned xas > 0"
  by (cases xas, simp)

lemma length_append_scanned_1: "length_scanned (xas @@@ [p]) = Suc (length_scanned xas)"
proof (cases xas)
  case (Pair w xs)
  then show ?thesis by (induct xs, simp_all add: append_scanned_simp)
qed

lemma length_Cons_scanned_1: "length_scanned (w, x # xas) = Suc (length_scanned (w, xas))"
  by (induct xas, simp_all add: append_scanned_simp)

lemma length_append_scanned[simp]:
  "length_scanned (xas @@@ ys) = length_scanned xas + length ys"
proof (induct ys arbitrary: xas rule: rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  then show ?case by (simp add: append_scanned_assoc[symmetric] length_append_scanned_1)
qed

lemma scanned_induct_aux:
  assumes head: "\<And>w. P (w, [])"
  assumes pair: "\<And>w x as xas. (\<And>u. P (u, xas)) \<Longrightarrow> P ((w, [(x, as)]) @@@ xas)"
  shows "P (w, xs)"
proof (induct xs arbitrary: w rule: pair_induct)
  case Nil
  then show ?case using head by simp
next
  case (PairCons x as xas)
  then show ?case proof -
    have "P ((w, [(x, as)]) @@@ xas)" by (simp add: PairCons pair)
    then show ?thesis by (simp add: append_scanned_simp)
  qed
qed

lemma scanned_induct[case_names Nil PairCons]:
  assumes head: "\<And>w. P (w, [])"
  assumes pair: "\<And>w x as xas. (\<And>u. P (u, xas)) \<Longrightarrow> P ((w, [(x, as)]) @@@ xas)"
  shows "P sc"
  apply (cases sc)
  apply simp
  apply (rule scanned_induct_aux)
   apply (simp add: head)
  apply (simp add: pair)
  done

lemma scanned_rev_induct_aux:
  assumes head: "\<And>w. P (w, [])"
  assumes pair: "\<And>x as sc. P sc \<Longrightarrow> P (sc @@@ [(x, as)])"
  shows "P (w, xs)"
proof (induct xs rule: pair_rev_induct)
  case Nil
  then show ?case using head by simp
next
  case (PairSnoc x as xas)
  then show ?case proof -
    have "P ((w, xas) @@@ [(x, as)])" by (simp add: PairSnoc pair)
    then show ?thesis by (simp add: append_scanned_simp)
  qed
qed

lemma scanned_rev_induct[case_names Nil PairSnoc]:
  assumes head: "\<And>w. P (w, [])"
  assumes pair: "\<And>x as sc. P sc \<Longrightarrow> P (sc @@@ [(x, as)])"
  shows "P sc"
  using assms by (cases sc, simp add: scanned_rev_induct_aux)

subsubsection \<open>Scan\<close>

text \<open>scan var-alphabet list, and split it into a scanned string\<close>

fun scan_pair_rec :: "'y \<Rightarrow> 'b list \<Rightarrow> ('y + 'b) list \<Rightarrow> ('y, 'b) scanned_tail" where
  "scan_pair_rec x as [] = [(x, as)]" |
  "scan_pair_rec x as (Inl y#u) = (x, as) # scan_pair_rec y [] u" |
  "scan_pair_rec x as (Inr a#u) = scan_pair_rec x (as @ [a]) u"

fun scan_head :: "'b list \<Rightarrow> ('y + 'b) list \<Rightarrow> ('y, 'b) scanned" where
  "scan_head as [] = (as, [])" |
  "scan_head as (Inl x#u) = (as, scan_pair_rec x [] u)" |
  "scan_head as (Inr a#u) = scan_head (as @ [a]) u"

definition scan :: "('y + 'b) list \<Rightarrow> ('y, 'b) scanned" where
  "scan u = scan_head [] u"

definition scan_pair :: "('y + 'b) list \<Rightarrow> ('y \<times> 'b list) list" where
  "scan_pair u = snd (scan u)"

definition keys_pair :: "('y \<times> 'b list) list \<Rightarrow> 'y list" where
  "keys_pair ps = map fst ps"

fun map_value_pair :: "('b \<Rightarrow> 'c list) \<Rightarrow> ('y \<times> 'b list) list \<Rightarrow> ('y \<times> 'c list) list" where
  "map_value_pair f Nil = []" |
  "map_value_pair f ((y, bs)#ybs) = (y, concat (map f bs)) # map_value_pair f ybs"

definition map_value_scanned where
  "map_value_scanned f scanned = (map f (fst scanned), map_value_pair f (snd scanned))"

fun concat_value_pair where
  "concat_value_pair Nil = []" |
  "concat_value_pair ((x, as)#xas) = as @ concat_value_pair xas"

lemma concat_value_pair_last_simp[simp]:
  "concat_value_pair (xas @ [(x, as)]) = concat_value_pair xas @ as"
  by (induct xas rule: pair_induct, simp_all)

definition concat_value_scanned where
  "concat_value_scanned scanned = fst scanned @ concat_value_pair (snd scanned)"

lemma concat_value_scanned_Nil[simp]:
  "concat_value_scanned (as, []) = as"
  unfolding concat_value_scanned_def by simp

lemma concat_value_scanned_last_simp[simp]:
  "concat_value_scanned (sc @@@ [(x, as)]) = concat_value_scanned sc @ as"
proof (induct sc rule: scanned_induct)
  case (Nil w)
  then show ?case by (simp add: concat_value_scanned_def append_scanned_def)
next
  case (PairCons w x as xas)
  then show ?case by (simp add: concat_value_scanned_def append_scanned_def)
qed

lemma map_value_pair_last_simp[simp]:
  "map_value_pair f (ybs @ [(y, bs)]) = map_value_pair f ybs @ [(y, concat (map f bs))]"
  by (induct ybs rule: pair_induct, simp_all)

lemma keys_pair_map_value_pair:
  "keys_pair (map_value_pair f xas) = keys_pair xas"
  by (induct xas rule: pair_induct, simp_all add: keys_pair_def)

lemma keys_pair_Nil[simp]: "keys_pair [] = []"
  unfolding keys_pair_def by simp

lemma keys_pair_Cons[simp]: "keys_pair ((x, as)#xas) = x # keys_pair xas"
  unfolding keys_pair_def by simp

lemma keys_pair_snoc[simp]: "keys_pair (xas @ [(x, as)]) = keys_pair xas @ [x]"
  unfolding keys_pair_def by simp

lemma scan_word_simp[simp]:
  "scan (map Inr w) = (w, [])"
proof -
  { fix as
    have "scan_head as (map Inr w) = (as @ w, [])"
      by (induct w arbitrary: as, simp_all)
  }
  note that = this
  then show ?thesis by (simp add: that scan_def)
qed

lemma scan_last_simp[simp]:
  "scan (u @ Inl x # map Inr w) = scan u @@@ [(x :: 'x, w)]"
proof -
  { fix y :: 'x and bs
    have "scan_pair_rec y bs (map Inr w) = [(y, bs @ w)]" by (induct w arbitrary: bs, simp_all)
  } note pair_alphabet = this
  { fix x y :: 'x and as u
    have "scan_pair_rec x as (u @ Inl y # map Inr w) = scan_pair_rec x as u @ [(y, w)]"
      by (induct u arbitrary: x y as rule: xa_induct, simp_all add: pair_alphabet)
  } note pair = this
  { fix as
    have "scan_head as (u @ Inl x # map Inr w) = scan_head as u @@@ [(x, w)]"
      by (induct u arbitrary: as rule: xa_induct, simp_all add: pair_alphabet pair append_scanned_simp)
  }
  thus ?thesis by (simp add: scan_def)
qed

corollary scan_nil_simp[simp]:
  "scan [] = ([], [])"
  by (simp add: scan_word_simp[of "[]", simplified])

corollary scan_last_var_simp[simp]:
  "scan (u @ [Inl x]) = scan u @@@ [(x, [])]"
  by (simp add: scan_last_simp[of "u" "x" "[]", simplified])

corollary scan_last_single_simp[simp]:
  "scan (Inl x # map Inr w) = ([], [(x, w)])"
  by (simp add: scan_last_simp[of "[]", simplified] append_scanned_simp)

corollary scan_var_simp[simp]: "scan [Inl x] = ([], [(x, [])])"
  by (simp add: scan_last_var_simp[of "[]" "x", simplified] append_scanned_simp)

lemma scan_pair_nil_simp[simp]: "scan_pair [] = []"
  unfolding scan_pair_def by simp

lemma scan_pair_var_simp[simp]: "scan_pair [Inl x] = [(x, [])]"
  unfolding scan_pair_def by simp

lemma scan_pair_alpha_simp[simp]: "scan_pair (Inr a#u) = scan_pair u"
  unfolding scan_pair_def scan_def
proof (simp)
  fix as bs
  show "snd (scan_head as u) = snd (scan_head bs u)"
    by (induct u arbitrary: as bs rule: xa_induct, simp_all)
qed

lemma scan_pair_word_simp[simp]: "scan_pair (map Inr as) = []"
  unfolding scan_pair_def by simp

lemma scan_pair_last_simp[simp]:
  "scan_pair (u @ Inl x # map Inr w) = scan_pair u @ [(x :: 'x, w)]"
  unfolding scan_pair_def
  by (cases "scan u", simp add: append_scanned_simp)

lemma snd_scan:
  "snd (scan u) = scan_pair u"
  unfolding scan_pair_def by simp

subsubsection \<open>Flat\<close>

text \<open>flatten pairs\<close>

fun flat_rec :: "('y, 'b) scanned_tail \<Rightarrow> ('y + 'b) list" where
  "flat_rec [] = []" |
  "flat_rec ((x, as)#xas) = Inl x # map Inr as @ flat_rec xas"

definition flat :: "('y, 'b) scanned \<Rightarrow> ('y + 'b) list" where
  "flat = (\<lambda>(b0, xas). map Inr b0 @ flat_rec xas)"

lemma flat_simp:
  "flat (b0, xas) = map Inr b0 @ flat_rec xas"
  unfolding flat_def by simp

lemma flat_rec_append[simp]: "flat_rec (xs @ ys) = flat_rec xs @ flat_rec ys"
  by (induct xs arbitrary: ys rule: pair_rev_induct, simp_all)

lemma flat_word_simp[simp]: "flat (w, []) = map Inr w"
  by (induct w, simp_all add: flat_def)

lemma flat_append[simp]: "flat (xas @@@ xs) = flat xas @ flat_rec xs"
proof (induct xas arbitrary: xs rule: scanned_rev_induct)
  case (Nil w)
  then show ?case by (simp add: append_scanned_simp flat_def)
next
  case (PairSnoc y bs sc)
  then show ?case by (simp add: append_scanned_simp append_scanned_assoc)
qed

theorem scan_inverse: "flat (scan u) = u"
  by (induct u rule: xw_induct, simp_all)

end


theory Tut06
  imports "HOL-IMP.Compiler" Complex_Main
begin

value "ccomp (IF Less (V ''x'') (N 5) THEN ''y'' ::= N 3 ELSE SKIP)"

fun ccomp2 :: "com \<Rightarrow> instr list" where
  "ccomp2 SKIP = []" |
  "ccomp2 (x ::= a) = acomp a @ [STORE x]" |
  "ccomp2 (c\<^sub>1;;c\<^sub>2) = ccomp2 c\<^sub>1 @ ccomp2 c\<^sub>2" |
  "ccomp2 (WHILE b DO c) =
    (let cc = ccomp2 c; cb = bcomp b False (size cc + 1)
    in cb @ cc @ [JMP (-(size cb + size cc + 1))])" |
  "ccomp2 (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (if c\<^sub>2 = SKIP then
    (let cc\<^sub>1 = ccomp2 c\<^sub>1; cb = bcomp b False (size cc\<^sub>1)
    in cb @ cc\<^sub>1)
  else
    (let cc\<^sub>1 = ccomp2 c\<^sub>1; cc\<^sub>2 = ccomp2 c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
     in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2))"

value "ccomp2 (IF Less (V ''x'') (N 5) THEN ''y'' ::= N 3 ELSE SKIP)"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp2 c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp2 c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp2 c1"  let ?cc2 = "ccomp2 c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp2 c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp2 (WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using \<open>bval b s1\<close> by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end


section \<open>Optimized MRU Vote Model\<close>

theory MRU_Vote_Opt
imports MRU_Vote
begin

subsection \<open>Model definition\<close>
(******************************************************************************)

record opt_mru_state =
  next_round :: round
  mru_vote :: "(process, round \<times> val) map"
  decisions :: "(process, val)map"

definition opt_mru_init where
  "opt_mru_init = { \<lparr> next_round = 0, mru_vote = Map.empty, decisions = Map.empty \<rparr> }"

context quorum_process begin

definition opt_mru_vote :: "(process, round \<times> val)map \<Rightarrow> (process set, round \<times> val)map" where
  "opt_mru_vote lvs Q = option_Max_by fst (ran (lvs |` Q))"

definition opt_mru_guard :: "(process, round \<times> val)map \<Rightarrow> process set \<Rightarrow> val \<Rightarrow> bool" where
  "opt_mru_guard mru_votes Q v \<equiv> Q \<in> Quorum \<and>
    (let mru = opt_mru_vote mru_votes Q in mru = None \<or> (\<exists>r. mru = Some (r, v)))"

definition opt_mru_round
  :: "round \<Rightarrow> process set \<Rightarrow> process set \<Rightarrow> val \<Rightarrow> (process, val)map \<Rightarrow> (opt_mru_state \<times> opt_mru_state) set"
  where
  "opt_mru_round r Q S v r_decisions = {(s, s').
     \<comment> \<open>guards\<close>
     r = next_round s
     \<and> (S \<noteq> {} \<longrightarrow> opt_mru_guard (mru_vote s) Q v)
     \<and> d_guard r_decisions (const_map v S)
     \<and> \<comment> \<open>actions\<close>
     s' = s\<lparr>
       mru_vote := mru_vote s ++ const_map (r, v) S
       , next_round := Suc r
       , decisions := decisions s ++ r_decisions
     \<rparr>
  }"

lemmas lv_evt_defs = opt_mru_round_def opt_mru_guard_def

definition mru_opt_trans :: "(opt_mru_state \<times> opt_mru_state) set" where
  "mru_opt_trans = (\<Union>r Q S v D. opt_mru_round r Q S v D) \<union> Id"

definition mru_opt_TS :: "opt_mru_state TS" where
  "mru_opt_TS = \<lparr> init = opt_mru_init, trans = mru_opt_trans \<rparr>"

lemmas mru_opt_TS_defs = mru_opt_TS_def opt_mru_init_def mru_opt_trans_def

subsection \<open>Refinement\<close>
(******************************************************************************)

definition lv_ref_rel :: "(v_state \<times> opt_mru_state)set" where
  "lv_ref_rel = {(sa, sc).
    sc = \<lparr>
      next_round = v_state.next_round sa
      , mru_vote = process_mru (votes sa)
      , decisions = v_state.decisions sa
    \<rparr>
  }"

subsubsection \<open>The concrete guard implies the abstract guard\<close>
(******************************************************************************)

definition voters :: "(round \<Rightarrow> (process, val)map) \<Rightarrow> process set" where
  "voters vs = {a|a r v. ((r, a), v) \<in> map_graph (case_prod vs)}"

lemma vote_set_as_Union:
  "vote_set vs Q = (\<Union>a\<in>(Q \<inter> voters vs). vote_set vs {a})"
  by(auto simp add: vote_set_def voters_def)

lemma empty_ran:
  "(ran f = {}) = (\<forall>x. f x = None)"
  apply(auto simp add: ran_def)
  by (metis option.collapse)

lemma empty_ran_restrict:
  "(ran (f |` A) = {}) = (\<forall>x \<in> A. f x = None)"
  by(auto simp add: empty_ran restrict_map_def)

lemma option_Max_by_eqI:
  "\<lbrakk> (S = {}) \<longleftrightarrow> (S' = {}); S \<noteq> {} \<and> S' \<noteq> {} \<Longrightarrow> Max_by f S = Max_by g S' \<rbrakk>
  \<Longrightarrow>  option_Max_by f S = option_Max_by g S'"
  by(auto simp add: option_Max_by_def)

lemma ran_process_mru_only_voters:
  "ran (process_mru vs |` Q) = ran (process_mru vs |` (Q \<inter> voters vs))"
  by(auto simp add: ran_def restrict_map_def voters_def process_mru_def
    mru_of_set_def option_Max_by_def vote_set_def)

lemma SV_inv3_inj_on_fst_vote_set:
  "s \<in> SV_inv3 \<Longrightarrow> inj_on fst (vote_set (votes s) Q)"
  by(clarsimp simp add: SV_inv3_def inj_on_def vote_set_def)

lemma opt_mru_vote_mru_of_set:
  assumes
    inv1: "s \<in> Vinv1"
    and inv3: "s \<in> SV_inv3"
  defines "vs \<equiv> votes s"
  shows
    "opt_mru_vote (process_mru vs) Q = mru_of_set vs Q"
proof(simp add: opt_mru_vote_def mru_of_set_def, intro option_Max_by_eqI, clarsimp_all)
  show "(ran (process_mru vs |` Q) = {}) = (vote_set vs Q = {})"
    apply(clarsimp simp add: empty_ran_restrict process_mru_def mru_of_set_def option_Max_by_def
      vote_set_def)
    by (metis option.collapse option.distinct(1))
next
  assume nempty: "ran (process_mru vs |` Q) \<noteq> {}" "vote_set vs Q \<noteq> {}"

  hence nempty': "Q \<inter> voters vs \<noteq> {}"
    by(auto simp add: vote_set_def voters_def)

  have nempty'': "{} \<notin> (\<lambda>a. vote_set vs {a}) ` (Q \<inter> voters vs)"
    by(auto simp add: vote_set_def voters_def)

  note fin=Vinv1_finite_vote_set[OF inv1]

  have ran_eq:
    "ran (process_mru vs |` Q) = Max_by fst ` (\<lambda>a. \<Union>a\<in>{a} \<inter> voters vs. vote_set vs {a}) ` (Q \<inter> voters vs)"
    apply(subst ran_process_mru_only_voters)
    apply(auto simp add: image_def process_mru_def ran_def restrict_map_def mru_of_set_def option_Max_by_def)
    by (metis (erased, lifting) Set.set_insert image_eqI insertI1 insert_inter_insert nempty'')

  note inj=inv3[THEN SV_inv3_inj_on_fst_vote_set]

  show "Max_by fst (ran (process_mru vs |` Q)) = Max_by fst (vote_set vs Q)"
    apply(subst vs_def
      Max_by_UNION_distrib[OF fin vote_set_as_Union nempty'[simplified vs_def]
        nempty''[simplified vs_def] inj])+
    apply(subst vote_set_as_Union)
    by(metis ran_eq vs_def)
qed

lemma opt_mru_guard_imp_mru_guard:
  assumes invs:
    "s \<in> Vinv1" "s \<in> SV_inv3"
    and c_guard: "opt_mru_guard (process_mru (votes s)) Q v"
  shows "mru_guard s Q v" using c_guard
  by(simp add: opt_mru_vote_mru_of_set[OF invs] opt_mru_guard_def mru_guard_def Let_def)

subsubsection \<open>The concrete action refines the abstract action\<close>
(******************************************************************************)

lemma act_ref:
  assumes
    "s \<in> Vinv1"
  shows
    "process_mru (votes s) ++ const_map (v_state.next_round s, v) S
    = process_mru ((votes s)(v_state.next_round s := const_map v S))"
    by(auto simp add: process_mru_map_add[OF assms(1)] map_add_def const_map_def
      restrict_map_def
      split:option.split)

subsubsection \<open>The complete refinement\<close>
(******************************************************************************)

lemma opt_mru_guard_imp_Quorum:
  "opt_mru_guard vs Q v \<Longrightarrow> Q \<in> Quorum"
  by (simp add: opt_mru_guard_def Let_def)

lemma opt_mru_round_refines:
  "{lv_ref_rel \<inter> (Vinv1 \<inter> SV_inv3 \<inter> SV_inv4) \<times> UNIV}
    sv_round r S v d_f, opt_mru_round r Q S v d_f
  {> lv_ref_rel}"
  apply(clarsimp simp add: PO_rhoare_defs lv_ref_rel_def opt_mru_round_def sv_round_def
    act_ref del: disjCI)
  apply(auto intro!: opt_mru_guard_imp_mru_guard[where Q=Q]  mru_vote_implies_safe[where Q=Q]
    dest: opt_mru_guard_imp_Quorum)
  done

lemma Opt_MRU_Vote_Refines:
  "PO_refines (lv_ref_rel \<inter> (Vinv1 \<inter> Vinv2 \<inter> SV_inv3 \<inter> SV_inv4) \<times> UNIV) sv_TS mru_opt_TS"
proof(rule refine_using_invariants)
  show "init mru_opt_TS \<subseteq> lv_ref_rel `` init sv_TS"
    by(auto simp add: mru_opt_TS_defs sv_TS_defs lv_ref_rel_def
      process_mru_def mru_of_set_def vote_set_def option_Max_by_def)
next
  show
    "{lv_ref_rel \<inter> (Vinv1 \<inter> Vinv2 \<inter> SV_inv3 \<inter> SV_inv4) \<times> UNIV} trans sv_TS, trans mru_opt_TS {> lv_ref_rel}"
    by(auto simp add: sv_TS_defs mru_opt_TS_defs intro!: opt_mru_round_refines)
next
  show
    "{Vinv1 \<inter> Vinv2 \<inter> SV_inv3 \<inter> SV_inv4 \<inter> Domain (lv_ref_rel \<inter> UNIV \<times> UNIV)}
      trans sv_TS
    {> Vinv1 \<inter> Vinv2 \<inter> SV_inv3 \<inter> SV_inv4}"
    using SV_inv1_inductive(2) SV_inv2_inductive(2) SV_inv3_inductive(2) SV_inv4_inductive(2)
    by blast
qed(auto intro!: SV_inv1_inductive(1) SV_inv2_inductive(1) SV_inv3_inductive(1) SV_inv4_inductive(1))

subsection \<open>Invariants\<close>
(******************************************************************************)

definition OMRU_inv1 :: "opt_mru_state set" where
  "OMRU_inv1 = {s. \<forall>p. (case mru_vote s p of
      Some (r, _) \<Rightarrow> r < next_round s
      | None \<Rightarrow> True)
  }"

lemma OMRU_inv1_inductive:
  "init mru_opt_TS \<subseteq> OMRU_inv1"
  "{OMRU_inv1} trans mru_opt_TS {> OMRU_inv1}"
  by(fastforce simp add: mru_opt_TS_def opt_mru_init_def PO_hoare_def OMRU_inv1_def mru_opt_trans_def
    opt_mru_round_def const_map_is_Some less_Suc_eq
    split: option.split_asm option.split)+

lemmas OMRU_inv1I = OMRU_inv1_def [THEN setc_def_to_intro, rule_format]
lemmas OMRU_inv1E [elim] = OMRU_inv1_def [THEN setc_def_to_elim, rule_format]
lemmas OMRU_inv1D = OMRU_inv1_def [THEN setc_def_to_dest, rule_format]

end

end


theory Resolution_Sound
imports Resolution CNF_Formulas_Sema
begin

(* there is one theory where we show Resolution completeness entirely without the relation to
normal formulas. We haven't done the same for soundness, because we do not want too many theory files. *)

lemma Resolution_insert: "S \<turnstile> R \<Longrightarrow> cnf_semantics \<A> S \<Longrightarrow> cnf_semantics \<A> {R}"
by(induction  rule: Resolution.induct;
   clarsimp simp add: cnf_semantics_def clause_semantics_def lit_semantics_cases split: literal.splits;
   blast)

(* Schöning's resolution lemma. We don't use it. *)
lemma "S \<turnstile> R \<Longrightarrow> cnf_semantics \<A> S \<longleftrightarrow> cnf_semantics \<A> (R \<triangleright> S)"
  using Resolution_insert cnf_semantics_def by (metis insert_iff)

corollary Resolution_cnf_sound: assumes "S \<turnstile> \<box>" shows "\<not> cnf_semantics \<A> S"
proof(rule notI)
  assume "cnf_semantics \<A> S"
  with Resolution_insert assms have "cnf_semantics \<A> {\<box>}" .
  thus False by(simp add: cnf_semantics_def clause_semantics_def)
qed

corollary Resolution_sound:
  assumes rp: "cnf (nnf F) \<turnstile> \<box>"
  shows "\<not> \<A> \<Turnstile> F"
proof -
  from Resolution_cnf_sound rp have "\<not> cnf_semantics \<A> (cnf (nnf F))" .
  hence "\<not>\<A> \<Turnstile> nnf F" unfolding cnf_semantics[OF is_nnf_nnf] .
  thus ?thesis unfolding nnf_semantics .
qed

end


theory IpAddresses
imports IP_Addresses.IP_Address_toString
  IP_Addresses.CIDR_Split
  "../Common/WordInterval_Lists"
begin

\<comment> \<open>Misc\<close>
(*we dont't have an empty ip space, but a space which only contains the 0 address. We will use the option type to denote the empty space in some functions.*)
lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 33 = {0}"
  by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_large_pfxlen)

  (*helper we use for spoofing protection specification*)
  definition all_but_those_ips :: "('i::len word \<times> nat) list \<Rightarrow> ('i word \<times> nat) list" where
    "all_but_those_ips cidrips = cidr_split (wordinterval_invert (l2wi (map ipcidr_to_interval cidrips)))"

  lemma all_but_those_ips:
    "ipcidr_union_set (set (all_but_those_ips cidrips)) =
      UNIV - (\<Union> (ip,n) \<in> set cidrips. ipset_from_cidr ip n)"
    apply simp
    unfolding ipcidr_union_set_uncurry all_but_those_ips_def
    apply(simp add: cidr_split_prefix)
    apply(simp add: l2wi)
    apply(simp add: ipcidr_to_interval_def)
    using ipset_from_cidr_ipcidr_to_interval by blast

section\<open>IPv4 Addresses\<close>

subsection\<open>IPv4 Addresses in IPTables Notation (how we parse it)\<close>
  context
    notes [[typedef_overloaded]]
  begin
    datatype 'i ipt_iprange =
                          \<comment> \<open>Singleton IP Address\<close>
                          IpAddr "'i::len word"

                          \<comment> \<open>CIDR notation: addr/xx\<close>
                          | IpAddrNetmask "'i word" nat

                          \<comment> \<open>-m iprange --src-range a.b.c.d-e.f.g.h\<close>
                          | IpAddrRange  "'i word" "'i word"
                              (*the range is inclusive*)
  end

  fun ipt_iprange_to_set :: "'i::len ipt_iprange \<Rightarrow> 'i word set" where
    "ipt_iprange_to_set (IpAddrNetmask base m) = ipset_from_cidr base m" |
    "ipt_iprange_to_set (IpAddr ip) = { ip }" |
    "ipt_iprange_to_set (IpAddrRange ip1 ip2) = { ip1 .. ip2 }"

  text\<open>@{term ipt_iprange_to_set} can only represent an empty set if it is an empty range.\<close>
  lemma ipt_iprange_to_set_nonempty: "ipt_iprange_to_set ip = {} \<longleftrightarrow>
    (\<exists>ip1 ip2. ip = IpAddrRange ip1 ip2 \<and> ip1 > ip2)"
    apply(cases ip)
      apply(simp; fail)
     apply(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last; fail)
    apply(simp add:linorder_not_le; fail)
    done

  text\<open>maybe this is necessary as code equation?\<close>
  context
    includes bit_operations_syntax
  begin

  lemma element_ipt_iprange_to_set[code_unfold]: "(addr::'i::len word) \<in> ipt_iprange_to_set X = (
    case X of (IpAddrNetmask pre len) \<Rightarrow>
                  (pre AND ((mask len) << (len_of (TYPE('i)) - len))) \<le> addr \<and>
                  addr \<le> pre OR (mask (len_of (TYPE('i)) - len))
    | IpAddr ip \<Rightarrow> (addr = ip)
    | IpAddrRange ip1 ip2 \<Rightarrow> ip1 \<le> addr \<and> ip2 \<ge> addr)"
  apply(cases X)
    apply(simp; fail)
   apply(simp add: ipset_from_cidr_alt; fail)
  apply(simp; fail)
  done

  end

  lemma ipt_iprange_to_set_uncurry_IpAddrNetmask:
    "ipt_iprange_to_set (uncurry IpAddrNetmask a) = uncurry ipset_from_cidr a"
    by(simp split: uncurry_splits)

  text\<open>IP address ranges to \<open>(start, end)\<close> notation\<close>
  fun ipt_iprange_to_interval :: "'i::len ipt_iprange \<Rightarrow> ('i word \<times> 'i word)" where
    "ipt_iprange_to_interval (IpAddr addr) = (addr, addr)" |
    "ipt_iprange_to_interval (IpAddrNetmask pre len) = ipcidr_to_interval (pre, len)" |
    "ipt_iprange_to_interval (IpAddrRange ip1 ip2) = (ip1, ip2)"

  lemma ipt_iprange_to_interval: "ipt_iprange_to_interval ip = (s,e) \<Longrightarrow> {s .. e} = ipt_iprange_to_set ip"
    apply(cases ip)
      apply(auto simp add: ipcidr_to_interval)
    done

  text\<open>A list of IP address ranges to a @{typ "'i::len wordinterval"}.
        The nice thing is: the usual set operations are defined on this type.
        We can use the existing function @{const l2wi_intersect} if we want the intersection of the supplied list\<close>
  lemma "wordinterval_to_set (l2wi_intersect (map ipt_iprange_to_interval ips)) =
            (\<Inter> ip \<in> set ips. ipt_iprange_to_set ip)"
    apply(simp add: l2wi_intersect)
    using ipt_iprange_to_interval by blast

  text\<open>We can use @{const l2wi} if we want the union of the supplied list\<close>
  lemma "wordinterval_to_set (l2wi (map ipt_iprange_to_interval ips)) = (\<Union> ip \<in> set ips. ipt_iprange_to_set ip)"
    apply(simp add: l2wi)
    using ipt_iprange_to_interval by blast

  text\<open>A list of (negated) IP address to a @{typ "'i::len wordinterval"}.\<close>
  definition ipt_iprange_negation_type_to_br_intersect ::
    "'i::len ipt_iprange negation_type list \<Rightarrow> 'i wordinterval" where
    "ipt_iprange_negation_type_to_br_intersect l = l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval l)"

  lemma ipt_iprange_negation_type_to_br_intersect: "wordinterval_to_set (ipt_iprange_negation_type_to_br_intersect l) =
      (\<Inter> ip \<in> set (getPos l). ipt_iprange_to_set ip) - (\<Union> ip \<in> set (getNeg l). ipt_iprange_to_set ip)"
    apply(simp add: ipt_iprange_negation_type_to_br_intersect_def l2wi_negation_type_intersect NegPos_map_simps)
    using ipt_iprange_to_interval by blast

  text\<open>The @{typ "'i::len wordinterval"} can be translated back into a list of IP ranges.
        If a list of intervals is enough, we can use @{const wi2l}.
        If we need it in @{typ "'i::len ipt_iprange"}, we can use this function.\<close>
  definition wi_2_cidr_ipt_iprange_list :: "'i::len wordinterval \<Rightarrow> 'i ipt_iprange list" where
    "wi_2_cidr_ipt_iprange_list r = map (uncurry IpAddrNetmask) (cidr_split r)"

  lemma wi_2_cidr_ipt_iprange_list:
    "(\<Union> ip \<in> set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) = wordinterval_to_set r"
    proof -
    have "(\<Union> ip \<in> set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) =
           (\<Union>x\<in>set (cidr_split r). uncurry ipset_from_cidr x)"
      unfolding wi_2_cidr_ipt_iprange_list_def by force
    thus ?thesis using cidr_split_prefix by metis
  qed

  text\<open>For example, this allows the following transformation\<close>
  definition ipt_iprange_compress :: "'i::len ipt_iprange negation_type list \<Rightarrow> 'i ipt_iprange list" where
    "ipt_iprange_compress = wi_2_cidr_ipt_iprange_list \<circ> ipt_iprange_negation_type_to_br_intersect"

  lemma ipt_iprange_compress: "(\<Union> ip \<in> set (ipt_iprange_compress l). ipt_iprange_to_set ip) =
      (\<Inter> ip \<in> set (getPos l). ipt_iprange_to_set ip) - (\<Union> ip \<in> set (getNeg l). ipt_iprange_to_set ip)"
    by (metis wi_2_cidr_ipt_iprange_list comp_apply ipt_iprange_compress_def ipt_iprange_negation_type_to_br_intersect)

  definition normalized_cidr_ip :: "'i::len ipt_iprange \<Rightarrow> bool" where
    "normalized_cidr_ip ip \<equiv> case ip of IpAddrNetmask _ _ \<Rightarrow> True | _ \<Rightarrow> False"

  lemma wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask:
    "\<forall>a'\<in>set (wi_2_cidr_ipt_iprange_list as). normalized_cidr_ip a'"
    apply(clarify)
    apply(simp add: wi_2_cidr_ipt_iprange_list_def normalized_cidr_ip_def)
    by force

  lemma ipt_iprange_compress_normalized_IpAddrNetmask:
    "\<forall>a'\<in>set (ipt_iprange_compress as). normalized_cidr_ip a'"
    by(simp add: ipt_iprange_compress_def wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask)

  definition ipt_iprange_to_cidr :: "'i::len ipt_iprange \<Rightarrow> ('i word \<times> nat) list" where
    "ipt_iprange_to_cidr ips = cidr_split (iprange_interval (ipt_iprange_to_interval ips))"

  lemma ipt_ipvange_to_cidr: "ipcidr_union_set (set (ipt_iprange_to_cidr ips)) = (ipt_iprange_to_set ips)"
    apply(simp add: ipt_iprange_to_cidr_def)
    apply(simp add: ipcidr_union_set_uncurry)
    apply(case_tac "(ipt_iprange_to_interval ips)")
    apply(simp add: ipt_iprange_to_interval cidr_split_prefix_single)
    done

(* actually, these are toString pretty printing helpers*)
definition interval_to_wi_to_ipt_iprange :: "'i::len word \<Rightarrow> 'i word \<Rightarrow> 'i ipt_iprange" where
  "interval_to_wi_to_ipt_iprange s e \<equiv>
    if s = e
    then IpAddr s
    else case cidr_split (WordInterval s e) of [(ip,nmask)] \<Rightarrow> IpAddrNetmask ip nmask
                                            |   _ \<Rightarrow> IpAddrRange s e"

lemma interval_to_wi_to_ipt_ipv4range: "ipt_iprange_to_set (interval_to_wi_to_ipt_iprange s e) = {s..e}"
  proof -
    from cidr_split_prefix_single[of s e] have
      "cidr_split (WordInterval s e) = [(a, b)] \<Longrightarrow> ipset_from_cidr a b = {s..e}" for a b
        by(simp add: iprange_interval.simps)
    thus ?thesis
      by(simp add: interval_to_wi_to_ipt_iprange_def split: list.split)
  qed

fun wi_to_ipt_iprange :: "'i::len wordinterval \<Rightarrow> 'i ipt_iprange list" where
  "wi_to_ipt_iprange (WordInterval s e) = (if s > e then [] else
      [interval_to_wi_to_ipt_iprange s e])" |
  "wi_to_ipt_iprange (RangeUnion a b) = wi_to_ipt_iprange a @ wi_to_ipt_iprange b"

lemma wi_to_ipt_ipv4range: "\<Union>(set (map ipt_iprange_to_set (wi_to_ipt_iprange wi))) = wordinterval_to_set wi"
  apply(induction wi)
   apply(simp add: interval_to_wi_to_ipt_ipv4range)
  apply(simp)
  done

end