(*  Title:      ZF/UNITY/Guar.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Guarantees, etc.

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Revised by Sidi Ehmety on January 2001

Added \<in> Compatibility, weakest guarantees, etc.

and Weakest existential property,
from Charpentier and Chandy "Theorems about Composition",
Fifth International Conference on Mathematics of Program, 2000.

Theory ported from HOL.
*)

section\<open>The Chandy-Sanders Guarantees Operator\<close>

theory Guar imports Comp begin

(* To be moved to theory WFair???? *)
lemma leadsTo_Basis': "[| F \<in> A co A \<union> B; F \<in> transient(A); st_set(B) |] ==> F \<in> A \<longmapsto> B"
apply (frule constrainsD2)
apply (drule_tac B = "A-B" in constrains_weaken_L, blast)
apply (drule_tac B = "A-B" in transient_strengthen, blast)
apply (blast intro: ensuresI [THEN leadsTo_Basis])
done

  (*Existential and Universal properties.  We formalize the two-program
    case, proving equivalence with Chandy and Sanders's n-ary definitions*)

definition
   ex_prop :: "i => o"  where
   "ex_prop(X) == X<=program &
    (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<in> X | G \<in> X \<longrightarrow> (F \<squnion> G) \<in> X)"

definition
  strict_ex_prop  :: "i => o"  where
  "strict_ex_prop(X) == X<=program &
   (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> (F \<in> X | G \<in> X) \<longleftrightarrow> (F \<squnion> G \<in> X))"

definition
  uv_prop  :: "i => o"  where
   "uv_prop(X) == X<=program &
    (SKIP \<in> X & (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<in> X & G \<in> X \<longrightarrow> (F \<squnion> G) \<in> X))"

definition
 strict_uv_prop  :: "i => o"  where
   "strict_uv_prop(X) == X<=program &
    (SKIP \<in> X & (\<forall>F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow>(F \<in> X & G \<in> X) \<longleftrightarrow> (F \<squnion> G \<in> X)))"

definition
  guar :: "[i, i] => i" (infixl "guarantees" 55)  where
              (*higher than membership, lower than Co*)
  "X guarantees Y == {F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<squnion> G \<in> X \<longrightarrow> F \<squnion> G \<in> Y}"

definition
  (* Weakest guarantees *)
   wg :: "[i,i] => i"  where
  "wg(F,Y) == \<Union>({X \<in> Pow(program). F:(X guarantees Y)})"

definition
  (* Weakest existential property stronger than X *)
   wx :: "i =>i"  where
   "wx(X) == \<Union>({Y \<in> Pow(program). Y<=X & ex_prop(Y)})"

definition
  (*Ill-defined programs can arise through "\<squnion>"*)
  welldef :: i  where
  "welldef == {F \<in> program. Init(F) \<noteq> 0}"

definition
  refines :: "[i, i, i] => o" ("(3_ refines _ wrt _)" [10,10,10] 10)  where
  "G refines F wrt X ==
   \<forall>H \<in> program. (F ok H  & G ok H & F \<squnion> H \<in> welldef \<inter> X)
    \<longrightarrow> (G \<squnion> H \<in> welldef \<inter> X)"

definition
  iso_refines :: "[i,i, i] => o"  ("(3_ iso'_refines _ wrt _)" [10,10,10] 10)  where
  "G iso_refines F wrt X ==  F \<in> welldef \<inter> X \<longrightarrow> G \<in> welldef \<inter> X"

(*** existential properties ***)

lemma ex_imp_subset_program: "ex_prop(X) ==> X\<subseteq>program"
by (simp add: ex_prop_def)

lemma ex1 [rule_format]:
 "GG \<in> Fin(program)
  ==> ex_prop(X) \<longrightarrow> GG \<inter> X\<noteq>0 \<longrightarrow> OK(GG, (%G. G)) \<longrightarrow>(\<Squnion>G \<in> GG. G) \<in> X"
apply (unfold ex_prop_def)
apply (erule Fin_induct)
apply (simp_all add: OK_cons_iff)
apply (safe elim!: not_emptyE, auto)
done

lemma ex2 [rule_format]:
"X \<subseteq> program ==>
 (\<forall>GG \<in> Fin(program). GG \<inter> X \<noteq> 0 \<longrightarrow> OK(GG,(%G. G))\<longrightarrow>(\<Squnion>G \<in> GG. G) \<in> X)
   \<longrightarrow> ex_prop(X)"
apply (unfold ex_prop_def, clarify)
apply (drule_tac x = "{F,G}" in bspec)
apply (simp_all add: OK_iff_ok)
apply (auto intro: ok_sym)
done

(*Chandy & Sanders take this as a definition*)

lemma ex_prop_finite:
     "ex_prop(X) \<longleftrightarrow> (X\<subseteq>program &
  (\<forall>GG \<in> Fin(program). GG \<inter> X \<noteq> 0 & OK(GG,(%G. G))\<longrightarrow>(\<Squnion>G \<in> GG. G) \<in> X))"
apply auto
apply (blast intro: ex1 ex2 dest: ex_imp_subset_program)+
done

(* Equivalent definition of ex_prop given at the end of section 3*)
lemma ex_prop_equiv:
"ex_prop(X) \<longleftrightarrow>
  X\<subseteq>program & (\<forall>G \<in> program. (G \<in> X \<longleftrightarrow> (\<forall>H \<in> program. (G component_of H) \<longrightarrow> H \<in> X)))"
apply (unfold ex_prop_def component_of_def, safe, force, force, blast)
apply (subst Join_commute)
apply (blast intro: ok_sym)
done

(*** universal properties ***)

lemma uv_imp_subset_program: "uv_prop(X)==> X\<subseteq>program"
apply (unfold uv_prop_def)
apply (simp (no_asm_simp))
done

lemma uv1 [rule_format]:
     "GG \<in> Fin(program) ==>
      (uv_prop(X)\<longrightarrow> GG \<subseteq> X & OK(GG, (%G. G)) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X)"
apply (unfold uv_prop_def)
apply (erule Fin_induct)
apply (auto simp add: OK_cons_iff)
done

lemma uv2 [rule_format]:
     "X\<subseteq>program  ==>
      (\<forall>GG \<in> Fin(program). GG \<subseteq> X & OK(GG,(%G. G)) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X)
      \<longrightarrow> uv_prop(X)"
apply (unfold uv_prop_def, auto)
apply (drule_tac x = 0 in bspec, simp+)
apply (drule_tac x = "{F,G}" in bspec, simp)
apply (force dest: ok_sym simp add: OK_iff_ok)
done

(*Chandy & Sanders take this as a definition*)
lemma uv_prop_finite:
"uv_prop(X) \<longleftrightarrow> X\<subseteq>program &
  (\<forall>GG \<in> Fin(program). GG \<subseteq> X & OK(GG, %G. G) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in>  X)"
apply auto
apply (blast dest: uv_imp_subset_program)
apply (blast intro: uv1)
apply (blast intro!: uv2 dest:)
done

(*** guarantees ***)
lemma guaranteesI:
     "[| (!!G. [| F ok G; F \<squnion> G \<in> X; G \<in> program |] ==> F \<squnion> G \<in> Y);
         F \<in> program |]
    ==> F \<in> X guarantees Y"
by (simp add: guar_def component_def)

lemma guaranteesD:
     "[| F \<in> X guarantees Y;  F ok G;  F \<squnion> G \<in> X; G \<in> program |]
      ==> F \<squnion> G \<in> Y"
by (simp add: guar_def component_def)

(*This version of guaranteesD matches more easily in the conclusion
  The major premise can no longer be  F\<subseteq>H since we need to reason about G*)

lemma component_guaranteesD:
     "[| F \<in> X guarantees Y;  F \<squnion> G = H;  H \<in> X;  F ok G; G \<in> program |]
      ==> H \<in> Y"
by (simp add: guar_def, blast)

lemma guarantees_weaken:
     "[| F \<in> X guarantees X'; Y \<subseteq> X; X' \<subseteq> Y' |] ==> F \<in> Y guarantees Y'"
by (simp add: guar_def, auto)

lemma subset_imp_guarantees_program:
     "X \<subseteq> Y ==> X guarantees Y = program"
by (unfold guar_def, blast)

(*Equivalent to subset_imp_guarantees_UNIV but more intuitive*)
lemma subset_imp_guarantees:
     "[| X \<subseteq> Y; F \<in> program |] ==> F \<in> X guarantees Y"
by (unfold guar_def, blast)

lemma component_of_Join1: "F ok G ==> F component_of (F \<squnion> G)"
by (unfold component_of_def, blast)

lemma component_of_Join2: "F ok G ==> G component_of (F \<squnion> G)"
apply (subst Join_commute)
apply (blast intro: ok_sym component_of_Join1)
done

(*Remark at end of section 4.1 *)
lemma ex_prop_imp:
     "ex_prop(Y) ==> (Y = (program guarantees Y))"
apply (simp (no_asm_use) add: ex_prop_equiv guar_def component_of_def)
apply clarify
apply (rule equalityI, blast, safe)
apply (drule_tac x = x in bspec, assumption, force)
done

lemma guarantees_imp: "(Y = program guarantees Y) ==> ex_prop(Y)"
apply (unfold guar_def)
apply (simp (no_asm_simp) add: ex_prop_equiv)
apply safe
apply (blast intro: elim: equalityE)
apply (simp_all (no_asm_use) add: component_of_def)
apply (force elim: equalityE)+
done

lemma ex_prop_equiv2: "(ex_prop(Y)) \<longleftrightarrow> (Y = program guarantees Y)"
by (blast intro: ex_prop_imp guarantees_imp)

(** Distributive laws.  Re-orient to perform miniscoping **)

lemma guarantees_UN_left:
     "i \<in> I ==>(\<Union>i \<in> I. X(i)) guarantees Y = (\<Inter>i \<in> I. X(i) guarantees Y)"
apply (unfold guar_def)
apply (rule equalityI, safe)
 prefer 2 apply force
apply blast+
done

lemma guarantees_Un_left:
     "(X \<union> Y) guarantees Z = (X guarantees Z) \<inter> (Y guarantees Z)"
apply (unfold guar_def)
apply (rule equalityI, safe, blast+)
done

lemma guarantees_INT_right:
     "i \<in> I ==> X guarantees (\<Inter>i \<in> I. Y(i)) = (\<Inter>i \<in> I. X guarantees Y(i))"
apply (unfold guar_def)
apply (rule equalityI, safe, blast+)
done

lemma guarantees_Int_right:
     "Z guarantees (X \<inter> Y) = (Z guarantees X) \<inter> (Z guarantees Y)"
by (unfold guar_def, blast)

lemma guarantees_Int_right_I:
     "[| F \<in> Z guarantees X;  F \<in> Z guarantees Y |]
     ==> F \<in> Z guarantees (X \<inter> Y)"
by (simp (no_asm_simp) add: guarantees_Int_right)

lemma guarantees_INT_right_iff:
     "i \<in> I==> (F \<in> X guarantees (\<Inter>i \<in> I. Y(i))) \<longleftrightarrow>
      (\<forall>i \<in> I. F \<in> X guarantees Y(i))"
by (simp add: guarantees_INT_right INT_iff, blast)

lemma shunting: "(X guarantees Y) = (program guarantees ((program-X) \<union> Y))"
by (unfold guar_def, auto)

lemma contrapositive:
     "(X guarantees Y) = (program - Y) guarantees (program -X)"
by (unfold guar_def, blast)

(** The following two can be expressed using intersection and subset, which
    is more faithful to the text but looks cryptic.
**)

lemma combining1:
    "[| F \<in> V guarantees X;  F \<in> (X \<inter> Y) guarantees Z |]
     ==> F \<in> (V \<inter> Y) guarantees Z"
by (unfold guar_def, blast)

lemma combining2:
    "[| F \<in> V guarantees (X \<union> Y);  F \<in> Y guarantees Z |]
     ==> F \<in> V guarantees (X \<union> Z)"
by (unfold guar_def, blast)

(** The following two follow Chandy-Sanders, but the use of object-quantifiers
    does not suit Isabelle... **)

(*Premise should be (!!i. i \<in> I ==> F \<in> X guarantees Y i) *)
lemma all_guarantees:
     "[| \<forall>i \<in> I. F \<in> X guarantees Y(i); i \<in> I |]
    ==> F \<in> X guarantees (\<Inter>i \<in> I. Y(i))"
by (unfold guar_def, blast)

(*Premises should be [| F \<in> X guarantees Y i; i \<in> I |] *)
lemma ex_guarantees:
     "\<exists>i \<in> I. F \<in> X guarantees Y(i) ==> F \<in> X guarantees (\<Union>i \<in> I. Y(i))"
by (unfold guar_def, blast)

(*** Additional guarantees laws, by lcp ***)

lemma guarantees_Join_Int:
    "[| F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G |]
     ==> F \<squnion> G: (U \<inter> X) guarantees (V \<inter> Y)"

apply (unfold guar_def)
apply (simp (no_asm))
apply safe
apply (simp add: Join_assoc)
apply (subgoal_tac "F \<squnion> G \<squnion> Ga = G \<squnion> (F \<squnion> Ga) ")
apply (simp add: ok_commute)
apply (simp (no_asm_simp) add: Join_ac)
done

lemma guarantees_Join_Un:
    "[| F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G |]
     ==> F \<squnion> G: (U \<union> X) guarantees (V \<union> Y)"
apply (unfold guar_def)
apply (simp (no_asm))
apply safe
apply (simp add: Join_assoc)
apply (subgoal_tac "F \<squnion> G \<squnion> Ga = G \<squnion> (F \<squnion> Ga) ")
apply (rotate_tac 4)
apply (drule_tac x = "F \<squnion> Ga" in bspec)
apply (simp (no_asm))
apply (force simp add: ok_commute)
apply (simp (no_asm_simp) add: Join_ac)
done

lemma guarantees_JOIN_INT:
     "[| \<forall>i \<in> I. F(i) \<in> X(i) guarantees Y(i);  OK(I,F); i \<in> I |]
      ==> (\<Squnion>i \<in> I. F(i)) \<in> (\<Inter>i \<in> I. X(i)) guarantees (\<Inter>i \<in> I. Y(i))"
apply (unfold guar_def, safe)
 prefer 2 apply blast
apply (drule_tac x = xa in bspec)
apply (simp_all add: INT_iff, safe)
apply (drule_tac x = "(\<Squnion>x \<in> (I-{xa}) . F (x)) \<squnion> G" and A=program in bspec)
apply (auto intro: OK_imp_ok simp add: Join_assoc [symmetric] JOIN_Join_diff JOIN_absorb)
done

lemma guarantees_JOIN_UN:
    "[| \<forall>i \<in> I. F(i) \<in> X(i) guarantees Y(i);  OK(I,F) |]
     ==> JOIN(I,F) \<in> (\<Union>i \<in> I. X(i)) guarantees (\<Union>i \<in> I. Y(i))"
apply (unfold guar_def, auto)
apply (drule_tac x = y in bspec, simp_all, safe)
apply (rename_tac G y)
apply (drule_tac x = "JOIN (I-{y}, F) \<squnion> G" and A=program in bspec)
apply (auto intro: OK_imp_ok simp add: Join_assoc [symmetric] JOIN_Join_diff JOIN_absorb)
done

(*** guarantees laws for breaking down the program, by lcp ***)

lemma guarantees_Join_I1:
     "[| F \<in> X guarantees Y;  F ok G |] ==> F \<squnion> G \<in> X guarantees Y"
apply (simp add: guar_def, safe)
apply (simp add: Join_assoc)
done

lemma guarantees_Join_I2:
     "[| G \<in> X guarantees Y;  F ok G |] ==> F \<squnion> G \<in> X guarantees Y"
apply (simp add: Join_commute [of _ G] ok_commute [of _ G])
apply (blast intro: guarantees_Join_I1)
done

lemma guarantees_JOIN_I:
     "[| i \<in> I; F(i) \<in>  X guarantees Y;  OK(I,F) |]
      ==> (\<Squnion>i \<in> I. F(i)) \<in> X guarantees Y"
apply (unfold guar_def, safe)
apply (drule_tac x = "JOIN (I-{i},F) \<squnion> G" in bspec)
apply (simp (no_asm))
apply (auto intro: OK_imp_ok simp add: JOIN_Join_diff Join_assoc [symmetric])
done

(*** well-definedness ***)

lemma Join_welldef_D1: "F \<squnion> G \<in> welldef ==> programify(F) \<in>  welldef"
by (unfold welldef_def, auto)

lemma Join_welldef_D2: "F \<squnion> G \<in> welldef ==> programify(G) \<in>  welldef"
by (unfold welldef_def, auto)

(*** refinement ***)

lemma refines_refl: "F refines F wrt X"
by (unfold refines_def, blast)

(* More results on guarantees, added by Sidi Ehmety from Chandy & Sander, section 6 *)

lemma wg_type: "wg(F, X) \<subseteq> program"
by (unfold wg_def, auto)

lemma guarantees_type: "X guarantees Y \<subseteq> program"
by (unfold guar_def, auto)

lemma wgD2: "G \<in> wg(F, X) ==> G \<in> program & F \<in> program"
apply (unfold wg_def, auto)
apply (blast dest: guarantees_type [THEN subsetD])
done

lemma guarantees_equiv:
"(F \<in> X guarantees Y) \<longleftrightarrow>
   F \<in> program & (\<forall>H \<in> program. H \<in> X \<longrightarrow> (F component_of H \<longrightarrow> H \<in> Y))"
by (unfold guar_def component_of_def, force)

lemma wg_weakest:
     "!!X. [| F \<in> (X guarantees Y); X \<subseteq> program |] ==> X \<subseteq> wg(F,Y)"
by (unfold wg_def, auto)

lemma wg_guarantees: "F \<in> program ==> F \<in> wg(F,Y) guarantees Y"
by (unfold wg_def guar_def, blast)

lemma wg_equiv:
     "H \<in> wg(F,X) \<longleftrightarrow>
      ((F component_of H \<longrightarrow> H \<in> X) & F \<in> program & H \<in> program)"
apply (simp add: wg_def guarantees_equiv)
apply (rule iffI, safe)
apply (rule_tac [4] x = "{H}" in bexI)
apply (rule_tac [3] x = "{H}" in bexI, blast+)
done

lemma component_of_wg:
    "F component_of H ==> H \<in> wg(F,X) \<longleftrightarrow> (H \<in> X & F \<in> program & H \<in> program)"
by (simp (no_asm_simp) add: wg_equiv)

lemma wg_finite [rule_format]:
"\<forall>FF \<in> Fin(program). FF \<inter> X \<noteq> 0 \<longrightarrow> OK(FF, %F. F)
   \<longrightarrow> (\<forall>F \<in> FF. ((\<Squnion>F \<in> FF. F) \<in>  wg(F,X)) \<longleftrightarrow> ((\<Squnion>F \<in> FF. F) \<in> X))"
apply clarify
apply (subgoal_tac "F component_of (\<Squnion>F \<in> FF. F) ")
apply (drule_tac X = X in component_of_wg)
apply (force dest!: Fin.dom_subset [THEN subsetD, THEN PowD])
apply (simp_all add: component_of_def)
apply (rule_tac x = "\<Squnion>F \<in> (FF-{F}) . F" in exI)
apply (auto intro: JOIN_Join_diff dest: ok_sym simp add: OK_iff_ok)
done

lemma wg_ex_prop:
     "ex_prop(X) ==> (F \<in> X) \<longleftrightarrow> (\<forall>H \<in> program. H \<in> wg(F,X) & F \<in> program)"
apply (simp (no_asm_use) add: ex_prop_equiv wg_equiv)
apply blast
done

(** From Charpentier and Chandy "Theorems About Composition" **)
(* Proposition 2 *)
lemma wx_subset: "wx(X)\<subseteq>X"
by (unfold wx_def, auto)

lemma wx_ex_prop: "ex_prop(wx(X))"
apply (simp (no_asm_use) add: ex_prop_def wx_def)
apply safe
apply blast
apply (rule_tac x=x in bexI, force, simp)+
done

lemma wx_weakest: "\<forall>Z. Z\<subseteq>program \<longrightarrow> Z\<subseteq> X \<longrightarrow> ex_prop(Z) \<longrightarrow> Z \<subseteq> wx(X)"
by (unfold wx_def, auto)

(* Proposition 6 *)
lemma wx'_ex_prop:
 "ex_prop({F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<squnion> G \<in> X})"
apply (unfold ex_prop_def, safe)
 apply (drule_tac x = "G \<squnion> Ga" in bspec)
  apply (simp (no_asm))
 apply (force simp add: Join_assoc)
apply (drule_tac x = "F \<squnion> Ga" in bspec)
 apply (simp (no_asm))
apply (simp (no_asm_use))
apply safe
 apply (simp (no_asm_simp) add: ok_commute)
apply (subgoal_tac "F \<squnion> G = G \<squnion> F")
 apply (simp (no_asm_simp) add: Join_assoc)
apply (simp (no_asm) add: Join_commute)
done

(* Equivalence with the other definition of wx *)

lemma wx_equiv:
     "wx(X) = {F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> (F \<squnion> G) \<in> X}"
apply (unfold wx_def)
apply (rule equalityI, safe, blast)
 apply (simp (no_asm_use) add: ex_prop_def)
apply blast
apply (rule_tac B = "{F \<in> program. \<forall>G \<in> program. F ok G \<longrightarrow> F \<squnion> G \<in> X}"
         in UnionI,
       safe)
apply (rule_tac [2] wx'_ex_prop)
apply (drule_tac x=SKIP in bspec, simp)+
apply auto
done

(* Propositions 7 to 11 are all about this second definition of wx. And
   by equivalence between the two definition, they are the same as the ones proved *)

(* Proposition 12 *)
(* Main result of the paper *)
lemma guarantees_wx_eq: "(X guarantees Y) = wx((program-X) \<union> Y)"
by (auto simp add: guar_def wx_equiv)

(*
{* Corollary, but this result has already been proved elsewhere *}
 "ex_prop(X guarantees Y)"
*)

(* Rules given in section 7 of Chandy and Sander's
    Reasoning About Program composition paper *)

lemma stable_guarantees_Always:
     "[| Init(F) \<subseteq> A; F \<in> program |] ==> F \<in> stable(A) guarantees Always(A)"
apply (rule guaranteesI)
 prefer 2 apply assumption
apply (simp (no_asm) add: Join_commute)
apply (rule stable_Join_Always1)
apply (simp_all add: invariant_def)
apply (auto simp add: programify_def initially_def)
done

lemma constrains_guarantees_leadsTo:
     "[| F \<in> transient(A); st_set(B) |]
      ==> F: (A co A \<union> B) guarantees (A \<longmapsto> (B-A))"
apply (rule guaranteesI)
 prefer 2 apply (blast dest: transient_type [THEN subsetD])
apply (rule leadsTo_Basis')
  apply (blast intro: constrains_weaken_R)
 apply (blast intro!: Join_transient_I1, blast)
done

end


theory CFGExit imports CFG begin

subsection \<open>Adds an exit node to the abstract CFG\<close>

locale CFGExit = CFG sourcenode targetnode kind valid_edge Entry
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") +
  fixes Exit::"'node"  ("'('_Exit'_')")
  assumes Exit_source [dest]: "\<lbrakk>valid_edge a; sourcenode a = (_Exit_)\<rbrakk> \<Longrightarrow> False"
  and Entry_Exit_edge: "\<exists>a. valid_edge a \<and> sourcenode a = (_Entry_) \<and>
    targetnode a = (_Exit_) \<and> kind a = (\<lambda>s. False)\<^sub>\<surd>"

begin

lemma Entry_noteq_Exit [dest]:
  assumes eq:"(_Entry_) = (_Exit_)" shows "False"
proof -
  from Entry_Exit_edge obtain a where "sourcenode a = (_Entry_)"
    and "valid_edge a" by blast
  with eq show False by simp(erule Exit_source)
qed

lemma Exit_noteq_Entry [dest]:"(_Exit_) = (_Entry_) \<Longrightarrow> False"
  by(rule Entry_noteq_Exit[OF sym],simp)

lemma [simp]: "valid_node (_Exit_)"
proof -
  from Entry_Exit_edge obtain a where "targetnode a = (_Exit_)"
    and "valid_edge a" by blast
  thus ?thesis by(fastforce simp:valid_node_def)
qed

definition inner_node :: "'node \<Rightarrow> bool"
  where inner_node_def:
  "inner_node n \<equiv> valid_node n \<and> n \<noteq> (_Entry_) \<and> n \<noteq> (_Exit_)"

lemma inner_is_valid:
  "inner_node n \<Longrightarrow> valid_node n"
by(simp add:inner_node_def valid_node_def)

lemma [dest]:
  "inner_node (_Entry_) \<Longrightarrow> False"
by(simp add:inner_node_def)

lemma [dest]:
  "inner_node (_Exit_) \<Longrightarrow> False"
by(simp add:inner_node_def)

lemma [simp]:"\<lbrakk>valid_edge a; targetnode a \<noteq> (_Exit_)\<rbrakk>
  \<Longrightarrow> inner_node (targetnode a)"
  by(simp add:inner_node_def,rule ccontr,simp,erule Entry_target)

lemma [simp]:"\<lbrakk>valid_edge a; sourcenode a \<noteq> (_Entry_)\<rbrakk>
  \<Longrightarrow> inner_node (sourcenode a)"
  by(simp add:inner_node_def,rule ccontr,simp,erule Exit_source)

lemma valid_node_cases [consumes 1, case_names "Entry" "Exit" "inner"]:
  "\<lbrakk>valid_node n; n = (_Entry_) \<Longrightarrow> Q; n = (_Exit_) \<Longrightarrow> Q;
    inner_node n \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
apply(auto simp:valid_node_def)
 apply(case_tac "sourcenode a = (_Entry_)") apply auto
apply(case_tac "targetnode a = (_Exit_)") apply auto
done

lemma path_Exit_source [dest]:
  assumes "(_Exit_) -as\<rightarrow>* n'" shows "n' = (_Exit_)" and "as = []"
  using \<open>(_Exit_) -as\<rightarrow>* n'\<close>
proof(induct n\<equiv>"(_Exit_)" as n' rule:path.induct)
  case (Cons_path n'' as n' a)
  from \<open>sourcenode a = (_Exit_)\<close> \<open>valid_edge a\<close> have False
    by -(rule Exit_source,simp_all)
  { case 1 with \<open>False\<close> show ?case ..
  next
    case 2 with \<open>False\<close> show ?case ..
  }
qed simp_all

lemma Exit_no_sourcenode[dest]:
  assumes isin:"(_Exit_) \<in> set (sourcenodes as)" and path:"n -as\<rightarrow>* n'"
  shows False
proof -
  from isin obtain ns' ns'' where "sourcenodes as = ns'@(_Exit_)#ns''"
    by(auto dest:split_list simp:sourcenodes_def)
  then obtain as' as'' a where "as = as'@a#as''"
    and source:"sourcenode a = (_Exit_)"
    by(fastforce elim:map_append_append_maps simp:sourcenodes_def)
  with path have "valid_edge a" by(fastforce dest:path_split)
  with source show ?thesis by -(erule Exit_source)
qed

end

end


(*  Title:      ZF/Constructible/WF_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness of Well-Founded Recursion\<close>

theory WF_absolute imports WFrec begin

subsection\<open>Transitive closure without fixedpoints\<close>

definition
  rtrancl_alt :: "[i,i]\<Rightarrow>i" where
    "rtrancl_alt(A,r) \<equiv>
       {p \<in> A*A. \<exists>n\<in>nat. \<exists>f \<in> succ(n) -> A.
                 (\<exists>x y. p = \<langle>x,y\<rangle> \<and>  f`0 = x \<and> f`n = y) \<and>
                       (\<forall>i\<in>n. <f`i, f`succ(i)> \<in> r)}"

lemma alt_rtrancl_lemma1 [rule_format]:
    "n \<in> nat
     \<Longrightarrow> \<forall>f \<in> succ(n) -> field(r).
         (\<forall>i\<in>n. \<langle>f`i, f ` succ(i)\<rangle> \<in> r) \<longrightarrow> \<langle>f`0, f`n\<rangle> \<in> r^*"
apply (induct_tac n)
apply (simp_all add: apply_funtype rtrancl_refl, clarify)
apply (rename_tac n f)
apply (rule rtrancl_into_rtrancl)
 prefer 2 apply assumption
apply (drule_tac x="restrict(f,succ(n))" in bspec)
 apply (blast intro: restrict_type2)
apply (simp add: Ord_succ_mem_iff nat_0_le [THEN ltD] leI [THEN ltD] ltI)
done

lemma rtrancl_alt_subset_rtrancl: "rtrancl_alt(field(r),r) \<subseteq> r^*"
apply (simp add: rtrancl_alt_def)
apply (blast intro: alt_rtrancl_lemma1)
done

lemma rtrancl_subset_rtrancl_alt: "r^* \<subseteq> rtrancl_alt(field(r),r)"
apply (simp add: rtrancl_alt_def, clarify)
apply (frule rtrancl_type [THEN subsetD], clarify, simp)
apply (erule rtrancl_induct)
 txt\<open>Base case, trivial\<close>
 apply (rule_tac x=0 in bexI)
  apply (rule_tac x="\<lambda>x\<in>1. xa" in bexI)
   apply simp_all
txt\<open>Inductive step\<close>
apply clarify
apply (rename_tac n f)
apply (rule_tac x="succ(n)" in bexI)
 apply (rule_tac x="\<lambda>i\<in>succ(succ(n)). if i=succ(n) then z else f`i" in bexI)
  apply (simp add: Ord_succ_mem_iff nat_0_le [THEN ltD] leI [THEN ltD] ltI)
  apply (blast intro: mem_asym)
 apply typecheck
 apply auto
done

lemma rtrancl_alt_eq_rtrancl: "rtrancl_alt(field(r),r) = r^*"
by (blast del: subsetI
          intro: rtrancl_alt_subset_rtrancl rtrancl_subset_rtrancl_alt)

definition
  rtran_closure_mem :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
    \<comment> \<open>The property of belonging to \<open>rtran_closure(r)\<close>\<close>
    "rtran_closure_mem(M,A,r,p) \<equiv>
              \<exists>nnat[M]. \<exists>n[M]. \<exists>n'[M].
               omega(M,nnat) \<and> n\<in>nnat \<and> successor(M,n,n') \<and>
               (\<exists>f[M]. typed_function(M,n',A,f) \<and>
                (\<exists>x[M]. \<exists>y[M]. \<exists>zero[M]. pair(M,x,y,p) \<and> empty(M,zero) \<and>
                  fun_apply(M,f,zero,x) \<and> fun_apply(M,f,n,y)) \<and>
                  (\<forall>j[M]. j\<in>n \<longrightarrow>
                    (\<exists>fj[M]. \<exists>sj[M]. \<exists>fsj[M]. \<exists>ffp[M].
                      fun_apply(M,f,j,fj) \<and> successor(M,j,sj) \<and>
                      fun_apply(M,f,sj,fsj) \<and> pair(M,fj,fsj,ffp) \<and> ffp \<in> r)))"

definition
  rtran_closure :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
    "rtran_closure(M,r,s) \<equiv>
        \<forall>A[M]. is_field(M,r,A) \<longrightarrow>
         (\<forall>p[M]. p \<in> s \<longleftrightarrow> rtran_closure_mem(M,A,r,p))"

definition
  tran_closure :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
    "tran_closure(M,r,t) \<equiv>
         \<exists>s[M]. rtran_closure(M,r,s) \<and> composition(M,r,s,t)"

locale M_trancl = M_basic +
  assumes rtrancl_separation:
         "\<lbrakk>M(r); M(A)\<rbrakk> \<Longrightarrow> separation (M, rtran_closure_mem(M,A,r))"
      and wellfounded_trancl_separation:
         "\<lbrakk>M(r); M(Z)\<rbrakk> \<Longrightarrow>
          separation (M, \<lambda>x.
              \<exists>w[M]. \<exists>wx[M]. \<exists>rp[M].
               w \<in> Z \<and> pair(M,w,x,wx) \<and> tran_closure(M,r,rp) \<and> wx \<in> rp)"
      and M_nat [iff] : "M(nat)"

lemma (in M_trancl) rtran_closure_mem_iff:
     "\<lbrakk>M(A); M(r); M(p)\<rbrakk>
      \<Longrightarrow> rtran_closure_mem(M,A,r,p) \<longleftrightarrow>
          (\<exists>n[M]. n\<in>nat \<and>
           (\<exists>f[M]. f \<in> succ(n) -> A \<and>
            (\<exists>x[M]. \<exists>y[M]. p = \<langle>x,y\<rangle> \<and> f`0 = x \<and> f`n = y) \<and>
                           (\<forall>i\<in>n. <f`i, f`succ(i)> \<in> r)))"
  apply (simp add: rtran_closure_mem_def Ord_succ_mem_iff nat_0_le [THEN ltD])
done

lemma (in M_trancl) rtran_closure_rtrancl:
     "M(r) \<Longrightarrow> rtran_closure(M,r,rtrancl(r))"
apply (simp add: rtran_closure_def rtran_closure_mem_iff
                 rtrancl_alt_eq_rtrancl [symmetric] rtrancl_alt_def)
apply (auto simp add: nat_0_le [THEN ltD] apply_funtype)
done

lemma (in M_trancl) rtrancl_closed [intro,simp]:
     "M(r) \<Longrightarrow> M(rtrancl(r))"
apply (insert rtrancl_separation [of r "field(r)"])
apply (simp add: rtrancl_alt_eq_rtrancl [symmetric]
                 rtrancl_alt_def rtran_closure_mem_iff)
done

lemma (in M_trancl) rtrancl_abs [simp]:
     "\<lbrakk>M(r); M(z)\<rbrakk> \<Longrightarrow> rtran_closure(M,r,z) \<longleftrightarrow> z = rtrancl(r)"
apply (rule iffI)
 txt\<open>Proving the right-to-left implication\<close>
 prefer 2 apply (blast intro: rtran_closure_rtrancl)
apply (rule M_equalityI)
apply (simp add: rtran_closure_def rtrancl_alt_eq_rtrancl [symmetric]
                 rtrancl_alt_def rtran_closure_mem_iff)
apply (auto simp add: nat_0_le [THEN ltD] apply_funtype)
done

lemma (in M_trancl) trancl_closed [intro,simp]:
     "M(r) \<Longrightarrow> M(trancl(r))"
by (simp add: trancl_def)

lemma (in M_trancl) trancl_abs [simp]:
     "\<lbrakk>M(r); M(z)\<rbrakk> \<Longrightarrow> tran_closure(M,r,z) \<longleftrightarrow> z = trancl(r)"
by (simp add: tran_closure_def trancl_def)

lemma (in M_trancl) wellfounded_trancl_separation':
     "\<lbrakk>M(r); M(Z)\<rbrakk> \<Longrightarrow> separation (M, \<lambda>x. \<exists>w[M]. w \<in> Z \<and> \<langle>w,x\<rangle> \<in> r^+)"
by (insert wellfounded_trancl_separation [of r Z], simp)

text\<open>Alternative proof of \<open>wf_on_trancl\<close>; inspiration for the
      relativized version.  Original version is on theory WF.\<close>
lemma "\<lbrakk>wf[A](r);  r-``A \<subseteq> A\<rbrakk> \<Longrightarrow> wf[A](r^+)"
apply (simp add: wf_on_def wf_def)
apply (safe)
apply (drule_tac x = "{x\<in>A. \<exists>w. \<langle>w,x\<rangle> \<in> r^+ \<and> w \<in> Z}" in spec)
apply (blast elim: tranclE)
done

lemma (in M_trancl) wellfounded_on_trancl:
     "\<lbrakk>wellfounded_on(M,A,r);  r-``A \<subseteq> A; M(r); M(A)\<rbrakk>
      \<Longrightarrow> wellfounded_on(M,A,r^+)"
apply (simp add: wellfounded_on_def)
apply (safe intro!: equalityI)
apply (rename_tac Z x)
apply (subgoal_tac "M({x\<in>A. \<exists>w[M]. w \<in> Z \<and> \<langle>w,x\<rangle> \<in> r^+})")
 prefer 2
 apply (blast intro: wellfounded_trancl_separation')
apply (drule_tac x = "{x\<in>A. \<exists>w[M]. w \<in> Z \<and> \<langle>w,x\<rangle> \<in> r^+}" in rspec, safe)
apply (blast dest: transM, simp)
apply (rename_tac y w)
apply (drule_tac x=w in bspec, assumption, clarify)
apply (erule tranclE)
  apply (blast dest: transM)   (*transM is needed to prove M(xa)*)
 apply blast
done

lemma (in M_trancl) wellfounded_trancl:
     "\<lbrakk>wellfounded(M,r); M(r)\<rbrakk> \<Longrightarrow> wellfounded(M,r^+)"
apply (simp add: wellfounded_iff_wellfounded_on_field)
apply (rule wellfounded_on_subset_A, erule wellfounded_on_trancl)
   apply blast
  apply (simp_all add: trancl_type [THEN field_rel_subset])
done

text\<open>Absoluteness for wfrec-defined functions.\<close>

(*first use is_recfun, then M_is_recfun*)

lemma (in M_trancl) wfrec_relativize:
  "\<lbrakk>wf(r); M(a); M(r);
     strong_replacement(M, \<lambda>x z. \<exists>y[M]. \<exists>g[M].
          pair(M,x,y,z) \<and>
          is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), g) \<and>
          y = H(x, restrict(g, r -`` {x})));
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
   \<Longrightarrow> wfrec(r,a,H) = z \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r^+, a, \<lambda>x f. H(x, restrict(f, r -`` {x})), f) \<and>
            z = H(a,restrict(f,r-``{a})))"
apply (frule wf_trancl)
apply (simp add: wftrec_def wfrec_def, safe)
 apply (frule wf_exists_is_recfun
              [of concl: "r^+" a "\<lambda>x f. H(x, restrict(f, r -`` {x}))"])
      apply (simp_all add: trans_trancl function_restrictI trancl_subset_times)
 apply (clarify, rule_tac x=x in rexI)
 apply (simp_all add: the_recfun_eq trans_trancl trancl_subset_times)
done

text\<open>Assuming \<^term>\<open>r\<close> is transitive simplifies the occurrences of \<open>H\<close>.
      The premise \<^term>\<open>relation(r)\<close> is necessary
      before we can replace \<^term>\<open>r^+\<close> by \<^term>\<open>r\<close>.\<close>
theorem (in M_trancl) trans_wfrec_relativize:
  "\<lbrakk>wf(r);  trans(r);  relation(r);  M(r);  M(a);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
   \<Longrightarrow> wfrec(r,a,H) = z \<longleftrightarrow> (\<exists>f[M]. is_recfun(r,a,H,f) \<and> z = H(a,f))"
apply (frule wfrec_replacement', assumption+)
apply (simp cong: is_recfun_cong
           add: wfrec_relativize trancl_eq_r
                is_recfun_restrict_idem domain_restrict_idem)
done

theorem (in M_trancl) trans_wfrec_abs:
  "\<lbrakk>wf(r);  trans(r);  relation(r);  M(r);  M(a);  M(z);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
   \<Longrightarrow> is_wfrec(M,MH,r,a,z) \<longleftrightarrow> z=wfrec(r,a,H)"
by (simp add: trans_wfrec_relativize [THEN iff_sym] is_wfrec_abs, blast)

lemma (in M_trancl) trans_eq_pair_wfrec_iff:
  "\<lbrakk>wf(r);  trans(r); relation(r); M(r);  M(y);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
   \<Longrightarrow> y = <x, wfrec(r, x, H)> \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r,x,H,f) \<and> y = <x, H(x,f)>)"
apply safe
 apply (simp add: trans_wfrec_relativize [THEN iff_sym, of concl: _ x])
txt\<open>converse direction\<close>
apply (rule sym)
apply (simp add: trans_wfrec_relativize, blast)
done

subsection\<open>M is closed under well-founded recursion\<close>

text\<open>Lemma with the awkward premise mentioning \<open>wfrec\<close>.\<close>
lemma (in M_trancl) wfrec_closed_lemma [rule_format]:
     "\<lbrakk>wf(r); M(r);
        strong_replacement(M, \<lambda>x y. y = \<langle>x, wfrec(r, x, H)\<rangle>);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
      \<Longrightarrow> M(a) \<longrightarrow> M(wfrec(r,a,H))"
apply (rule_tac a=a in wf_induct, assumption+)
apply (subst wfrec, assumption, clarify)
apply (drule_tac x1=x and x="\<lambda>x\<in>r -`` {x}. wfrec(r, x, H)"
       in rspec [THEN rspec])
apply (simp_all add: function_lam)
apply (blast intro: lam_closed dest: pair_components_in_M)
done

text\<open>Eliminates one instance of replacement.\<close>
lemma (in M_trancl) wfrec_replacement_iff:
     "strong_replacement(M, \<lambda>x z.
          \<exists>y[M]. pair(M,x,y,z) \<and> (\<exists>g[M]. is_recfun(r,x,H,g) \<and> y = H(x,g))) \<longleftrightarrow>
      strong_replacement(M,
           \<lambda>x y. \<exists>f[M]. is_recfun(r,x,H,f) \<and> y = <x, H(x,f)>)"
apply simp
apply (rule strong_replacement_cong, blast)
done

text\<open>Useful version for transitive relations\<close>
theorem (in M_trancl) trans_wfrec_closed:
     "\<lbrakk>wf(r); trans(r); relation(r); M(r); M(a);
       wfrec_replacement(M,MH,r);  relation2(M,MH,H);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
      \<Longrightarrow> M(wfrec(r,a,H))"
apply (frule wfrec_replacement', assumption+)
apply (frule wfrec_replacement_iff [THEN iffD1])
apply (rule wfrec_closed_lemma, assumption+)
apply (simp_all add: wfrec_replacement_iff trans_eq_pair_wfrec_iff)
done

subsection\<open>Absoluteness without assuming transitivity\<close>
lemma (in M_trancl) eq_pair_wfrec_iff:
  "\<lbrakk>wf(r);  M(r);  M(y);
     strong_replacement(M, \<lambda>x z. \<exists>y[M]. \<exists>g[M].
          pair(M,x,y,z) \<and>
          is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), g) \<and>
          y = H(x, restrict(g, r -`` {x})));
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
   \<Longrightarrow> y = <x, wfrec(r, x, H)> \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), f) \<and>
            y = <x, H(x,restrict(f,r-``{x}))>)"
apply safe
 apply (simp add: wfrec_relativize [THEN iff_sym, of concl: _ x])
txt\<open>converse direction\<close>
apply (rule sym)
apply (simp add: wfrec_relativize, blast)
done

text\<open>Full version not assuming transitivity, but maybe not very useful.\<close>
theorem (in M_trancl) wfrec_closed:
     "\<lbrakk>wf(r); M(r); M(a);
        wfrec_replacement(M,MH,r^+);
        relation2(M,MH, \<lambda>x f. H(x, restrict(f, r -`` {x})));
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
      \<Longrightarrow> M(wfrec(r,a,H))"
apply (frule wfrec_replacement'
               [of MH "r^+" "\<lambda>x f. H(x, restrict(f, r -`` {x}))"])
   prefer 4
   apply (frule wfrec_replacement_iff [THEN iffD1])
   apply (rule wfrec_closed_lemma, assumption+)
     apply (simp_all add: eq_pair_wfrec_iff func.function_restrictI)
done

end


theory WTMiscEnv
  imports TypeEnv LiftEnv
begin

fun fun_ty where
  "fun_ty (FunTy t1 t2 r a) = True"
| "fun_ty tau = False"

fun max_aff where
  "max_aff Aff a = Aff"
| "max_aff a Aff = Aff"
| "max_aff Prim Prim = Prim"
| "max_aff a1 a2 = Ref"

fun as_aff where
  "as_aff OwnPerm = Aff"
| "as_aff UsePerm = Ref"
| "as_aff NoPerm = Prim"

fun req_type where
  "req_type (FunTy t1 t2 r a) = a"
| "req_type (ArrayTy tau) = Ref"
| "req_type (PairTy t1 t2 r) = as_aff r(*(if r = OwnPerm then Aff else max_aff (req_type t1) (req_type t2))*)"
  (*if req_type t1 = Aff \<or> req_type t2 = Aff then Aff else Ref*)
| "req_type (ChanTy tau c) = Ref"
| "req_type tau = Prim"

definition unlim where
  "unlim tau = (req_type tau \<noteq> Aff)"

definition non_prim_entry where
  "non_prim_entry env x = (\<exists> tau. env x = Some tau \<and> req_type tau \<noteq> Prim)"

  (*
definition prim_use_env where
  "prim_use_env env r_s = (\<forall> x. r_s x \<noteq> NoPerm \<longrightarrow> (case env x of
    None \<Rightarrow> False | Some tau \<Rightarrow> req_type tau = Prim))"
  *)

definition np_use_env where
  "np_use_env env r_s = (\<lambda> x. if non_prim_entry env x then r_s x else NoPerm)"

definition null_use_env where
  "null_use_env r_s = (\<forall> x. r_s x = NoPerm)"

definition aff_use_env where
  "aff_use_env r_s a = (case a of
    Aff \<Rightarrow> True
    | Ref \<Rightarrow> weak_use_env r_s
    | Prim \<Rightarrow> null_use_env r_s
  )"

  (*
definition aff_fun_ty where
  "aff_fun_ty tau = (\<not> unlim tau \<and> fun_ty tau)"   *)

definition start_req_perm where
  "start_req_perm tau = (case req_type tau of
    Aff \<Rightarrow> OwnPerm
  | other \<Rightarrow> UsePerm)"

definition end_req_perm where
  "end_req_perm tau = (case req_type tau of
    Aff \<Rightarrow> OwnPerm
  | Ref \<Rightarrow> UsePerm
  | other \<Rightarrow> NoPerm)"

definition req_use_env where
  "req_use_env x tau = one_use_env x (start_req_perm tau)"

definition ereq_use_env where
  "ereq_use_env x tau = one_use_env x (end_req_perm tau)"

    (*
      ####################################
        P1. specialized perm-env lemmas
      ####################################
    *)

    (* - basic perm lemmas *)

lemma req_use_none: "req_use_env x tau x \<noteq> NoPerm"
  apply (simp add: req_use_env_def)
  apply (simp add: start_req_perm_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "req_type tau")
    apply (auto)
  done

lemma req_use_none_alt: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> req_use_env x tau y = NoPerm"
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  done

lemma ereq_use_none: "\<lbrakk> req_type tau \<noteq> Prim \<rbrakk> \<Longrightarrow> ereq_use_env x tau x \<noteq> NoPerm"
  apply (simp add: ereq_use_env_def)
  apply (simp add: end_req_perm_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "req_type tau")
    apply (auto)
  done

lemma ereq_use_none_alt: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> ereq_use_env x tau y = NoPerm"
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  done

    (* - ordering lemmas *)

lemma req_leq_use_env: "\<lbrakk> leq_use_env (req_use_env x tau) r_s; r_s x = r_x x \<rbrakk> \<Longrightarrow> leq_use_env (req_use_env x tau) r_x"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (case_tac "x = xa")
   apply (auto)
  done

lemma req_leq_use_envx: "\<lbrakk> leq_perm (start_req_perm tau) (r_s x) \<rbrakk> \<Longrightarrow> leq_use_env (req_use_env x tau) r_s"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (auto)
  done

    (* - disjointness lemmas *)

lemma disj_req_use_env1: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> disj_use_env (req_use_env x tau) r_s"
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  done

lemma disj_req_use_env2: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> disj_use_env r_s (req_use_env x tau)"
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  done

    (* - affine env lemmas *)

lemma leq_null_use_env: "\<lbrakk> null_use_env r_s; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> null_use_env r_x"
  apply (simp add: null_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma dist_np_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (np_use_env env r_x) (np_use_env env r_s)"
  apply (simp add: leq_use_env_def)
  apply (simp add: np_use_env_def)
  done

lemma aff_leq_use_env: "\<lbrakk> aff_use_env r_s a; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> aff_use_env r_x a"
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
    apply (auto)
   apply (rule_tac r_s="r_s" in leq_weak_use_env)
    apply (simp_all)
  apply (rule_tac r_s="r_s" in leq_null_use_env)
   apply (simp_all)
  done

lemma aff_diff_use_env: "\<lbrakk> aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (diff_use_env r_s r_x) a"
  apply (rule_tac r_s="r_s" in aff_leq_use_env)
   apply (auto)
  apply (rule_tac self_diff_leq_use_env)
  done

lemma aff_rem_use_env: "\<lbrakk> aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (rem_use_env r_s x) a"
  apply (rule_tac r_s="r_s" in aff_leq_use_env)
   apply (auto)
  apply (rule_tac self_rem_leq_use_env)
  done

lemma aff_comp_use_env: "\<lbrakk> aff_use_env r_x a; aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (comp_use_env r_x r_s) a"
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
    apply (auto)
   apply (simp add: comp_use_env_def)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (erule_tac x="x" in allE)
   apply (erule_tac x="x" in allE)
   apply (case_tac "r_x x")
     apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: null_use_env_def)
  done

lemma aff_empty_use_env: "aff_use_env empty_use_env a"
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
    apply (auto)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (simp add: empty_use_env_def)
  apply (simp add: null_use_env_def)
  apply (auto)
  apply (simp add: empty_use_env_def)
  done

(*
lemma aff_comp_use_env: "\<lbrakk> aff_use_env r_x a; aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (comp_use_env r_x r_s) a"
  apply (simp add: comp_use_env_def)
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
   apply (auto)
  apply (simp add: weak_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma aff_empty_use_env: "aff_use_env empty_use_env a"
  apply (simp add: aff_use_env_def)
  apply (auto)
  apply (simp add: weak_use_env_def)
  apply (simp add: empty_use_env_def)
  done    *)

    (* ################# UNSORTED *)

lemma weak_ereq_use_env: "\<lbrakk> unlim tau \<rbrakk> \<Longrightarrow> weak_use_env (ereq_use_env x tau)"
  apply (simp add: weak_use_env_def)
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: end_req_perm_def)
  apply (case_tac "req_type tau")
    apply (auto)
  apply (simp add: unlim_def)
  done

(*
lemma weak_req_use_env: "\<lbrakk> unlim tau \<rbrakk> \<Longrightarrow> weak_use_env (req_use_env x tau)"
  apply (simp add: weak_use_env_def)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: start_req_perm_def)
  apply (simp add: aff_fun_ty_def)
  done    *)

lemma self_ereq_leq_use_env: "leq_use_env (ereq_use_env x tau) (req_use_env x tau)"
  apply (simp add: leq_use_env_def)
  apply (simp add: ereq_use_env_def)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: end_req_perm_def)
  apply (simp add: start_req_perm_def)
  apply (case_tac "req_type tau")
    apply (auto)
  done

lemma ereq_leq_use_env: "\<lbrakk> leq_use_env (req_use_env x tau) r_s \<rbrakk> \<Longrightarrow> leq_use_env (ereq_use_env x tau) r_s"
  apply (rule_tac r_sb="req_use_env x tau" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac self_ereq_leq_use_env)
  done

lemma ereq_leq_use_envx: "\<lbrakk> leq_perm (end_req_perm tau) (r_s x) \<rbrakk> \<Longrightarrow> leq_use_env (ereq_use_env x tau) r_s"
  apply (simp add: leq_use_env_def)
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  done

lemma one_mini_disj_use_env1: "\<lbrakk> r_x x \<noteq> OwnPerm \<or> r = NoPerm \<or> r_ex x = OwnPerm \<rbrakk> \<Longrightarrow> mini_disj_use_env r_x (diff_use_env (one_use_env x r) r_ex)"
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma one_mini_disj_use_env2: "\<lbrakk> r \<noteq> OwnPerm \<or> r_ex x = OwnPerm \<or> r_x x = NoPerm \<rbrakk> \<Longrightarrow> mini_disj_use_env (diff_use_env (one_use_env x r) r_ex) r_x"
apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
   apply (case_tac r)
     apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma diff_one_leq_use_env: "leq_use_env (diff_use_env (one_use_env x r) (one_use_env x OwnPerm)) r_s"
  apply (simp add: diff_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: one_use_env_def)
  apply (case_tac r)
    apply (auto)
  done

end


section \<open>Prisms\<close>

theory Prisms
  imports Main
begin

text \<open>Prisms are like lenses, but they act on sum types rather than product types. For now
  we do not support many properties about them. See \url{https://hackage.haskell.org/package/lens-4.15.2/docs/Control-Lens-Prism.html}
  for more information.\<close>

record ('v, 's) prism =
  prism_match :: "'s \<Rightarrow> 'v option" ("match\<index>")
  prism_build :: "'v \<Rightarrow> 's" ("build\<index>")

locale wb_prism =
  fixes x :: "('v, 's) prism" (structure)
  assumes match_build: "match (build v) = Some v"
  and build_match: "match s = Some v \<Longrightarrow> s = build v"
begin

  lemma build_match_iff: "match s = Some v \<longleftrightarrow> s = build v"
    using build_match match_build by blast

  lemma range_build: "range build = dom match"
    using build_match match_build by fastforce
end

definition prism_suml :: "('a, 'a + 'b) prism" where
"prism_suml = \<lparr> prism_match = (\<lambda> v. case v of Inl x \<Rightarrow> Some x | _ \<Rightarrow> None), prism_build = Inl \<rparr>"

lemma wb_prim_suml: "wb_prism prism_suml"
  apply (unfold_locales)
   apply (simp_all add: prism_suml_def sum.case_eq_if)
  apply (metis option.inject option.simps(3) sum.collapse(1))
done

definition prism_diff :: "('a, 's) prism \<Rightarrow> ('b, 's) prism \<Rightarrow> bool" (infix "\<nabla>" 50) where
"prism_diff X Y = (range build\<^bsub>X\<^esub> \<inter> range build\<^bsub>Y\<^esub> = {})"

lemma prism_diff_build: "X \<nabla> Y \<Longrightarrow> build\<^bsub>X\<^esub> u \<noteq> build\<^bsub>Y\<^esub> v"
  by (simp add: disjoint_iff_not_equal prism_diff_def)

definition prism_plus :: "('a, 's) prism \<Rightarrow> ('b, 's) prism \<Rightarrow> ('a + 'b, 's) prism" (infixl "+\<^sub>P" 85) where
"X +\<^sub>P Y = \<lparr> prism_match = (\<lambda> s. case (match\<^bsub>X\<^esub> s, match\<^bsub>Y\<^esub> s) of
                                 (Some u, _) \<Rightarrow> Some (Inl u) |
                                 (None, Some v) \<Rightarrow> Some (Inr v) |
                                 (None, None) \<Rightarrow> None),
           prism_build = (\<lambda> v. case v of Inl x \<Rightarrow> build\<^bsub>X\<^esub> x | Inr y \<Rightarrow> build\<^bsub>Y\<^esub> y) \<rparr>"
end


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

    Copyright (C) 2005 - 2019  Slawomir Kolodynski

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

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

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

*)

section \<open>Natural numbers in IsarMathLib\<close>

theory Nat_ZF_IML imports ZF.Arith

begin

text\<open>The  ZF set theory constructs natural numbers from the empty set
  and the notion of a one-element set. Namely, zero of natural numbers
  is defined as the empty set. For each natural number $n$ the next natural
  number is defined as $n\cup \{n\}$. With this definition for every
  non-zero natural number we get the identity $n = \{0,1,2,..,n-1\}$.
  It is good to remember that when we see an expression like
  $f: n \rightarrow X$. Also, with this definition
  the relation "less or equal than" becomes "$\subseteq$" and
  the relation "less than" becomes "$\in$".
\<close>

subsection\<open>Induction\<close>

text\<open>The induction lemmas in the standard Isabelle's Nat.thy file like
  for example \<open>nat_induct\<close> require the induction step to
  be a higher order
  statement (the one that uses the $\Longrightarrow$ sign). I found it
  difficult to apply from Isar, which is perhaps more of an indication of
  my Isar skills than anything else. Anyway, here we provide a first order
  version that is easier to reference in Isar declarative style proofs.\<close>

text\<open>The next theorem is a version of induction on natural numbers
  that I was thought in school.\<close>

theorem ind_on_nat:
  assumes A1: "n\<in>nat" and A2: "P(0)" and A3: "\<forall>k\<in>nat. P(k)\<longrightarrow>P(succ(k))"
  shows "P(n)"
proof -
  note A1 A2
  moreover
  { fix x
    assume "x\<in>nat"  "P(x)"
    with A3 have "P(succ(x))" by simp }
  ultimately show  "P(n)" by (rule nat_induct)
qed

text\<open>A nonzero natural number has a predecessor.\<close>

lemma Nat_ZF_1_L3: assumes A1: "n \<in> nat" and A2: "n\<noteq>0"
  shows "\<exists>k\<in>nat. n = succ(k)"
proof -
  from A1 have "n \<in> {0} \<union> {succ(k). k\<in>nat}"
    using nat_unfold by simp
  with A2 show ?thesis by simp
qed

text\<open>What is \<open>succ\<close>, anyway? It's a union with the singleton of the set.\<close>

lemma succ_explained: shows "succ(n) = n \<union> {n}"
  using succ_iff by auto

text\<open>If $k$ is a member of $succ(n)$ but is not $n$, then it must be the member of $n$.\<close>

lemma mem_succ_not_eq: assumes "k\<in>succ(n)" "k\<noteq>n"
  shows "k\<in>n" using assms succ_explained by simp

text\<open>Empty set is an element of every natural number which is not zero.\<close>

lemma empty_in_every_succ: assumes A1: "n \<in> nat"
  shows "0 \<in> succ(n)"
proof -
  note A1
  moreover have "0 \<in> succ(0)" by simp
  moreover
  { fix k assume "k \<in> nat" and A2: "0 \<in> succ(k)"
    then have "succ(k) \<subseteq> succ(succ(k))" by auto
    with A2 have "0 \<in> succ(succ(k))" by auto
  } then have "\<forall>k \<in> nat. 0 \<in> succ(k) \<longrightarrow> 0 \<in> succ(succ(k))"
    by simp
  ultimately show "0 \<in> succ(n)" by (rule ind_on_nat)
qed

text\<open>A more direct way of stating that empty set is an element of every non-zero natural number:\<close>

lemma empty_in_non_empty: assumes "n\<in>nat" "n\<noteq>0"
  shows "0\<in>n"
  using assms Nat_ZF_1_L3 empty_in_every_succ by auto

text\<open>If one natural number is less than another then their successors
  are in the same relation.\<close>

lemma succ_ineq: assumes A1: "n \<in> nat"
  shows "\<forall>i \<in> n. succ(i) \<in> succ(n)"
proof -
  note A1
  moreover have "\<forall>k \<in> 0. succ(k) \<in> succ(0)" by simp
  moreover
  { fix k assume A2: "\<forall>i\<in>k. succ(i) \<in> succ(k)"
    { fix i assume "i \<in> succ(k)"
      then have "i \<in> k \<or> i = k" by auto
      moreover
      { assume "i\<in>k"
	with A2 have "succ(i) \<in> succ(k)" by simp
	hence "succ(i) \<in> succ(succ(k))" by auto }
      moreover
      { assume "i = k"
	then have "succ(i) \<in> succ(succ(k))" by auto }
      ultimately have "succ(i) \<in> succ(succ(k))" by auto
    } then have "\<forall>i \<in> succ(k). succ(i) \<in> succ(succ(k))"
      by simp
  } then have "\<forall>k \<in> nat.
      ( (\<forall>i\<in>k. succ(i) \<in> succ(k)) \<longrightarrow> (\<forall>i \<in> succ(k). succ(i) \<in> succ(succ(k))) )"
    by simp
  ultimately show "\<forall>i \<in> n. succ(i) \<in> succ(n)" by (rule ind_on_nat)
qed

text\<open>For natural numbers if $k\subseteq n$ the similar holds for
  their successors.\<close>

lemma succ_subset: assumes A1: "k \<in> nat"  "n \<in> nat" and A2: "k\<subseteq>n"
  shows "succ(k) \<subseteq> succ(n)"
proof -
  from A1 have T: "Ord(k)" and "Ord(n)"
    using nat_into_Ord by auto
  with A2 have "succ(k) \<le> succ(n)"
    using subset_imp_le by simp
  then show "succ(k) \<subseteq> succ(n)" using le_imp_subset
    by simp
qed

text\<open>For any two natural numbers one of them is contained in the other.\<close>

lemma nat_incl_total: assumes A1: "i \<in> nat"  "j \<in> nat"
  shows "i \<subseteq> j \<or> j \<subseteq> i"
proof -
  from A1 have T: "Ord(i)"   "Ord(j)"
    using nat_into_Ord by auto
  then have "i\<in>j \<or> i=j \<or> j\<in>i" using Ord_linear
    by simp
  moreover
  { assume "i\<in>j"
    with T have "i\<subseteq>j \<or> j\<subseteq>i"
      using lt_def leI le_imp_subset by simp }
  moreover
  { assume "i=j"
    then have "i\<subseteq>j \<or> j\<subseteq>i" by simp }
  moreover
  { assume "j\<in>i"
    with T have "i\<subseteq>j \<or> j\<subseteq>i"
      using lt_def leI  le_imp_subset by simp }
  ultimately show "i \<subseteq> j \<or> j \<subseteq> i" by auto
qed

text\<open>The set of natural numbers is the union of all successors of natural
  numbers.\<close>

lemma nat_union_succ: shows "nat = (\<Union>n \<in> nat. succ(n))"
proof
  show "nat \<subseteq> (\<Union>n \<in> nat. succ(n))" by auto
next
  { fix k assume A2: "k \<in> (\<Union>n \<in> nat. succ(n))"
    then obtain n where T: "n \<in> nat" and I: "k \<in> succ(n)"
      by auto
    then have "k \<le> n" using nat_into_Ord lt_def
      by simp
    with T have "k \<in> nat" using le_in_nat by simp
  } then show  "(\<Union>n \<in> nat. succ(n)) \<subseteq> nat" by auto
qed

text\<open>Successors of natural numbers are subsets of the
  set of natural numbers.\<close>

lemma succnat_subset_nat: assumes A1: "n \<in> nat" shows "succ(n) \<subseteq> nat"
proof -
  from A1 have "succ(n) \<subseteq> (\<Union>n \<in> nat. succ(n))" by auto
  then show "succ(n) \<subseteq> nat" using nat_union_succ by simp
qed

text\<open>Element of a natural number is a natural number.\<close>

lemma elem_nat_is_nat: assumes A1: "n \<in> nat"  and A2: "k\<in>n"
  shows "k < n"  "k \<in> nat"  "k \<le> n"  "\<langle>k,n\<rangle> \<in> Le"
proof -
  from A1 A2 show "k < n" using nat_into_Ord lt_def by simp
  with A1 show "k \<in> nat" using lt_nat_in_nat by simp
  from \<open>k < n\<close> show "k \<le> n" using leI by simp
  with A1 \<open>k \<in> nat\<close> show "\<langle>k,n\<rangle> \<in> Le" using Le_def
    by simp
qed

text\<open>For natural numbers membership and inequality are the same
  and $k \leq n$ is the same as $k \in \textrm{succ}(n)$.
  The proof relies on lemmas in the standard Isabelle's \<open>Nat\<close> and \<open>Ordinal\<close> theories. \<close>

lemma nat_mem_lt: assumes "n\<in>nat"
  shows "k<n \<longleftrightarrow> k\<in>n" and "k\<le>n \<longleftrightarrow> k \<in> succ(n)"
  using assms nat_into_Ord Ord_mem_iff_lt by auto

text\<open>The term $k \leq n$ is the same as $k < \textrm{succ}(n)$.  \<close>

lemma leq_mem_succ: shows "k\<le>n \<longleftrightarrow> k < succ(n)" by simp

text\<open>If the successor of a natural number $k$ is an element of the successor
  of $n$ then a similar relations holds for the numbers themselves.\<close>

lemma succ_mem:
  assumes "n \<in> nat" "succ(k) \<in> succ(n)"
  shows "k\<in>n"
  using assms elem_nat_is_nat(1) succ_leE nat_into_Ord
    unfolding lt_def by blast

text\<open>The set of natural numbers is the union of its elements.\<close>

lemma nat_union_nat: shows "nat = \<Union> nat"
  using elem_nat_is_nat by blast

text\<open>A natural number is a subset of the set of natural numbers.\<close>

lemma nat_subset_nat: assumes A1: "n \<in> nat" shows "n \<subseteq> nat"
proof -
  from A1 have "n \<subseteq> \<Union> nat" by auto
  then show "n \<subseteq> nat" using nat_union_nat by simp
qed

text\<open>Adding natural numbers does not decrease what we add to.\<close>

lemma add_nat_le: assumes A1: "n \<in> nat"  and A2: "k \<in> nat"
  shows
  "n \<le> n #+ k"
  "n \<subseteq> n #+ k"
  "n \<subseteq> k #+ n"
proof -
  from A1 A2 have "n \<le> n"  "0 \<le> k"  "n \<in> nat"  "k \<in> nat"
    using nat_le_refl nat_0_le by auto
  then have "n #+ 0 \<le> n #+ k" by (rule add_le_mono)
  with A1 show "n \<le> n #+ k" using add_0_right by simp
  then show "n \<subseteq> n #+ k" using le_imp_subset by simp
  then show "n \<subseteq> k #+ n" using add_commute by simp
qed

text\<open>Result of adding an element of $k$ is smaller than of adding $k$.\<close>

lemma add_lt_mono:
  assumes "k \<in> nat" and "j\<in>k"
  shows
  "(n #+ j) < (n #+ k)"
  "(n #+ j) \<in> (n #+ k)"
proof -
  from assms have "j < k" using elem_nat_is_nat by blast
  moreover note \<open>k \<in> nat\<close>
  ultimately show "(n #+ j) < (n #+ k)"   "(n #+ j) \<in> (n #+ k)"
    using add_lt_mono2 ltD by auto
qed

text\<open>A technical lemma about a decomposition of a sum of two natural
  numbers: if a number $i$ is from $m + n$ then it is either from $m$
  or can be written as a sum of $m$ and a number from $n$.
  The proof by induction w.r.t. to $m$ seems to be a bit heavy-handed, but I could
  not figure out how to do this directly from results from standard Isabelle/ZF.\<close>

lemma nat_sum_decomp: assumes A1: "n \<in> nat"  and A2: "m \<in> nat"
  shows "\<forall>i \<in> m #+ n. i \<in> m \<or> (\<exists>j \<in> n. i = m #+ j)"
proof -
  note A1
  moreover from A2 have "\<forall>i \<in> m #+ 0. i \<in> m \<or> (\<exists>j \<in> 0. i = m #+ j)"
    using add_0_right by simp
  moreover have "\<forall>k\<in>nat.
    (\<forall>i \<in> m #+ k. i \<in> m \<or> (\<exists>j \<in> k. i = m #+ j)) \<longrightarrow>
    (\<forall>i \<in> m #+ succ(k). i \<in> m \<or> (\<exists>j \<in> succ(k). i = m #+ j))"
  proof -
    { fix k assume A3: "k \<in> nat"
      { assume A4: "\<forall>i \<in> m #+ k. i \<in> m \<or> (\<exists>j \<in> k. i = m #+ j)"
	  { fix i assume "i \<in>  m #+ succ(k)"
	    then have "i \<in> m #+ k \<or> i = m #+ k" using add_succ_right
	      by auto
	    moreover from A4 A3 have
	      "i \<in> m #+ k \<longrightarrow> i \<in> m \<or> (\<exists>j \<in> succ(k). i = m #+ j)"
	      by auto
	    ultimately have "i \<in> m \<or> (\<exists>j \<in> succ(k). i = m #+ j)"
	      by auto
	  } then have "\<forall>i \<in> m #+ succ(k). i \<in> m \<or> (\<exists>j \<in> succ(k). i = m #+ j)"
	    by simp
      } then have "(\<forall>i \<in> m #+ k. i \<in> m \<or> (\<exists>j \<in> k. i = m #+ j)) \<longrightarrow>
	  (\<forall>i \<in> m #+ succ(k). i \<in> m \<or> (\<exists>j \<in> succ(k). i = m #+ j))"
	by simp
    } then show ?thesis by simp
  qed
  ultimately show "\<forall>i \<in> m #+ n. i \<in> m \<or> (\<exists>j \<in> n. i = m #+ j)"
    by (rule ind_on_nat)
qed

text\<open>A variant of induction useful for finite sequences.\<close>

lemma fin_nat_ind: assumes A1: "n \<in> nat" and A2: "k \<in> succ(n)"
  and A3: "P(0)" and A4: "\<forall>j\<in>n. P(j)  \<longrightarrow> P(succ(j))"
  shows "P(k)"
proof -
  from A2 have "k \<in> n \<or> k=n" by auto
  with A1 have "k \<in> nat" using elem_nat_is_nat by blast
  moreover from A3 have "0 \<in> succ(n) \<longrightarrow> P(0)" by simp
  moreover from A1 A4 have
    "\<forall>k \<in> nat. (k \<in> succ(n) \<longrightarrow> P(k)) \<longrightarrow> (succ(k) \<in> succ(n) \<longrightarrow> P(succ(k)))"
    using nat_into_Ord Ord_succ_mem_iff by auto
  ultimately have "k \<in> succ(n) \<longrightarrow> P(k)"
    by (rule ind_on_nat)
  with A2 show "P(k)" by simp
qed

text\<open>Some properties of positive natural numbers.\<close>

lemma succ_plus: assumes "n \<in> nat"  "k \<in> nat"
  shows
  "succ(n #+ j) \<in> nat"
  "succ(n) #+ succ(j) = succ(succ(n #+ j))"
  using assms by auto

text\<open>If $k$ is in the successor of $n$, then the predecessor of $k$ is in $n$.\<close>

lemma pred_succ_mem: assumes "n\<in>nat" "n\<noteq>0" "k\<in>succ(n)" shows "pred(k)\<in>n"
proof -
  from assms(1,3) have "k\<in>nat" using succnat_subset_nat by blast
  { assume "k\<noteq>0"
    with \<open>k\<in>nat\<close> obtain j where "j\<in>nat" and "k=succ(j)"
      using Nat_ZF_1_L3 by auto
    with assms(1,3) have "pred(k)\<in>n" using succ_mem pred_succ_eq
      by simp
  }
  moreover
  { assume "k=0"
    with assms(1,2) have "pred(k)\<in>n"
      using pred_0 empty_in_non_empty by simp
  } ultimately show ?thesis by blast
qed

text\<open>For non-zero natural numbers $\textrm{pred}(n) = n-1$.\<close>

lemma pred_minus_one: assumes "n\<in>nat" "n\<noteq>0"
  shows "n #- 1 = pred(n)"
proof -
  from assms obtain k where "n=succ(k)"
    using Nat_ZF_1_L3 by blast
  with assms show ?thesis
    using pred_succ_eq eq_succ_imp_eq_m1 by simp
qed

text\<open>For natural numbers taking the successor is the same as adding one. \<close>

lemma succ_add_one: assumes "n\<in>nat"
  shows "n #+ 1 = succ(n)" and "n #+ 1 \<in> nat"
  using assms by auto

text\<open>Adding and subtracting a natural number cancel each other.\<close>

lemma add_subctract: assumes "m\<in>nat" shows "(m #+ n) #- n = m"
  using assms diff_add_inverse2 by simp

text\<open>A version of induction on natural numbers that uses the $n+1$ notation
  instead of $succ(n)$.\<close>

lemma ind_on_nat1:
  assumes "n\<in>nat" and "P(0)" and "\<forall>k\<in>nat. P(k)\<longrightarrow>P(k #+ 1)"
  shows "P(n)" using assms succ_add_one(1) ind_on_nat by simp

subsection\<open>Intervals\<close>

text\<open>In this section we consider intervals of natural numbers i.e. sets
  of the form $\{n+j : j \in 0..k-1\}$.\<close>

text\<open>The interval is determined by two parameters: starting point and length.\<close>

definition

  "NatInterval(n,k) \<equiv> {n #+ j. j\<in>k}"

text\<open>Subtracting the beginning af the interval results in a number from
  the length of the interval. It may sound weird, but note that the length of
  such interval is a natural number, hence a set.\<close>

lemma inter_diff_in_len:
  assumes A1: "k \<in> nat" and A2: "i \<in> NatInterval(n,k)"
  shows "i #- n \<in> k"
proof -
  from A2 obtain j where I: "i = n #+ j" and II: "j \<in> k"
    using NatInterval_def by auto
  from A1 II have "j \<in> nat" using elem_nat_is_nat by blast
  moreover from I have "i #- n = natify(j)" using diff_add_inverse
    by simp
  ultimately have "i #- n = j" by simp
  with II show ?thesis by simp
qed

text\<open>Intervals don't overlap with their starting point and
  the union of an interval with its starting point is the sum of the starting
  point and the length of the interval.\<close>

lemma length_start_decomp: assumes  A1: "n \<in> nat"  "k \<in> nat"
  shows
  "n \<inter> NatInterval(n,k) = 0"
  "n \<union> NatInterval(n,k) = n #+ k"
proof -
  { fix i assume A2: "i \<in> n" and "i \<in> NatInterval(n,k)"
    then obtain j where I: "i = n #+ j" and II: "j \<in> k"
      using NatInterval_def by auto
    from A1 have "k \<in> nat" using elem_nat_is_nat by blast
    with II have "j \<in> nat" using elem_nat_is_nat by blast
    with A1 I have "n \<le> i" using add_nat_le by simp
    moreover from A1 A2 have "i < n" using elem_nat_is_nat by blast
    ultimately have False using le_imp_not_lt by blast
  } thus "n \<inter> NatInterval(n,k) = 0" by auto
  from A1 have "n \<subseteq> n #+ k" using add_nat_le by simp
  moreover
  { fix i assume "i \<in> NatInterval(n,k)"
    then obtain j where III: "i = n #+ j" and IV: "j \<in> k"
      using NatInterval_def by auto
    with A1 have "j < k" using elem_nat_is_nat by blast
    with A1 III have "i \<in> n #+ k" using add_lt_mono2 ltD
      by simp }
  ultimately have "n \<union> NatInterval(n,k) \<subseteq> n #+ k" by auto
  moreover from A1 have "n #+ k \<subseteq> n \<union> NatInterval(n,k)"
    using nat_sum_decomp NatInterval_def by auto
  ultimately show "n \<union> NatInterval(n,k) = n #+ k" by auto
qed

text\<open>Some properties of three adjacent intervals.\<close>

lemma adjacent_intervals3: assumes "n \<in> nat"  "k \<in> nat"  "m \<in> nat"
  shows
  "n #+ k #+ m = (n #+ k) \<union> NatInterval(n #+ k,m)"
  "n #+ k #+ m = n \<union> NatInterval(n,k #+  m)"
  "n #+ k #+ m = n \<union> NatInterval(n,k) \<union> NatInterval(n #+ k,m)"
  using assms add_assoc length_start_decomp by auto

end