theory PreferenceLogicTestsApp1     (*** Benzmüller & Fuenmayor, 2020 ***)
   imports PreferenceLogicBasics
begin (*****Application-specific tests for the value ontology****)
(* EE variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>E\<^sub>E (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*ctg*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(* EE variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>E\<^sub>E (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast
(* total EE variant (\<and>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<prec>\<^sub>E\<^sub>E (A\<^bold>\<and>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>E A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>E (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>E\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>E B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast
(* total EE variant (\<or>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<prec>\<^sub>E\<^sub>E (A\<^bold>\<or>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<or>B) \<prec>\<^sub>E\<^sub>E A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>E\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>E B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<or>B) \<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast

(* AE variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>E (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast
(* AE variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>E (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(* total AE variant (\<and>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<prec>\<^sub>A\<^sub>E (A\<^bold>\<and>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>E A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>E (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>E B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast
(* total AE variant (\<or>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<prec>\<^sub>A\<^sub>E (A\<^bold>\<or>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>E A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>E B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast

(* AA variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
(*--------------------------------------------------*)
lemma "\<lfloor>A \<prec>\<^sub>A\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
(* AA variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(*---------------------------------------------------*)
lemma "\<lfloor>A \<prec>\<^sub>A\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(* total AA variant (\<and>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<prec>\<^sub>A\<^sub>A (A\<^bold>\<and>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
(* total AA variant (\<or>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<prec>\<^sub>A\<^sub>A (A\<^bold>\<or>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast

(* EA variant (\<and>)*)
lemma "\<not>\<lfloor>(A\<^bold>\<and>B) \<^bold>\<succ>\<^sub>E\<^sub>A A\<rfloor>" using rBR by blast
lemma "\<lfloor>A \<^bold>\<succ>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<succ>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<succ>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<succ>\<^sub>E\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<succ>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<succ>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
(*--------------------------------------------*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<succ>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>A \<succ>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<succ>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<succ>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
(* EA variant (\<or>)*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<succ>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<not>\<lfloor>A \<^bold>\<succ>\<^sub>E\<^sub>A (A\<^bold>\<or>B)\<rfloor>" using rBR by blast
lemma "\<lfloor>(B \<^bold>\<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<succ>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<succ>\<^sub>E\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<succ>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<succ>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<succ>\<^sub>E\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(*------------------------------------------------*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<succ>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>A \<succ>\<^sub>E\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<succ>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>(A \<succ>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(* total EA variant (\<and>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<and>B) \<succ>\<^sub>E\<^sub>A A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<succ>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<and>B) \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<succ>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
(* total EA variant (\<or>)*)
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A\<^bold>\<or>B) \<succ>\<^sub>E\<^sub>A A\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>A \<succ>\<^sub>E\<^sub>A (A\<^bold>\<or>B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(B \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>((C\<^bold>\<or>B) \<succ>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<succ>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "is_total SBR \<Longrightarrow> \<lfloor>(A \<succ>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<succ>\<^sub>E\<^sub>A (C\<^bold>\<or>B))\<rfloor>" by blast
end


(* Author: Florian Haftmann, TU Muenchen
   Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Lists with elements distinct as canonical example for datatype invariants\<close>

theory Dlist
imports Main
begin

subsection \<open>The type of distinct lists\<close>

typedef 'a dlist = "{xs::'a list. distinct xs}"
  morphisms list_of_dlist Abs_dlist
proof
  show "[] \<in> {xs. distinct xs}" by simp
qed

setup_lifting type_definition_dlist

lemma dlist_eq_iff:
  "dxs = dys \<longleftrightarrow> list_of_dlist dxs = list_of_dlist dys"
  by (simp add: list_of_dlist_inject)

lemma dlist_eqI:
  "list_of_dlist dxs = list_of_dlist dys \<Longrightarrow> dxs = dys"
  by (simp add: dlist_eq_iff)

text \<open>Formal, totalized constructor for @{typ "'a dlist"}:\<close>

definition Dlist :: "'a list \<Rightarrow> 'a dlist" where
  "Dlist xs = Abs_dlist (remdups xs)"

lemma distinct_list_of_dlist [simp, intro]:
  "distinct (list_of_dlist dxs)"
  using list_of_dlist [of dxs] by simp

lemma list_of_dlist_Dlist [simp]:
  "list_of_dlist (Dlist xs) = remdups xs"
  by (simp add: Dlist_def Abs_dlist_inverse)

lemma remdups_list_of_dlist [simp]:
  "remdups (list_of_dlist dxs) = list_of_dlist dxs"
  by simp

lemma Dlist_list_of_dlist [simp, code abstype]:
  "Dlist (list_of_dlist dxs) = dxs"
  by (simp add: Dlist_def list_of_dlist_inverse distinct_remdups_id)

text \<open>Fundamental operations:\<close>

context
begin

qualified definition empty :: "'a dlist" where
  "empty = Dlist []"

qualified definition insert :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "insert x dxs = Dlist (List.insert x (list_of_dlist dxs))"

qualified definition remove :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "remove x dxs = Dlist (remove1 x (list_of_dlist dxs))"

qualified definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist" where
  "map f dxs = Dlist (remdups (List.map f (list_of_dlist dxs)))"

qualified definition filter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "filter P dxs = Dlist (List.filter P (list_of_dlist dxs))"

qualified definition rotate :: "nat \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "rotate n dxs = Dlist (List.rotate n (list_of_dlist dxs))"

end

text \<open>Derived operations:\<close>

context
begin

qualified definition null :: "'a dlist \<Rightarrow> bool" where
  "null dxs = List.null (list_of_dlist dxs)"

qualified definition member :: "'a dlist \<Rightarrow> 'a \<Rightarrow> bool" where
  "member dxs = List.member (list_of_dlist dxs)"

qualified definition length :: "'a dlist \<Rightarrow> nat" where
  "length dxs = List.length (list_of_dlist dxs)"

qualified definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "fold f dxs = List.fold f (list_of_dlist dxs)"

qualified definition foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "foldr f dxs = List.foldr f (list_of_dlist dxs)"

end

subsection \<open>Executable version obeying invariant\<close>

lemma list_of_dlist_empty [simp, code abstract]:
  "list_of_dlist Dlist.empty = []"
  by (simp add: Dlist.empty_def)

lemma list_of_dlist_insert [simp, code abstract]:
  "list_of_dlist (Dlist.insert x dxs) = List.insert x (list_of_dlist dxs)"
  by (simp add: Dlist.insert_def)

lemma list_of_dlist_remove [simp, code abstract]:
  "list_of_dlist (Dlist.remove x dxs) = remove1 x (list_of_dlist dxs)"
  by (simp add: Dlist.remove_def)

lemma list_of_dlist_map [simp, code abstract]:
  "list_of_dlist (Dlist.map f dxs) = remdups (List.map f (list_of_dlist dxs))"
  by (simp add: Dlist.map_def)

lemma list_of_dlist_filter [simp, code abstract]:
  "list_of_dlist (Dlist.filter P dxs) = List.filter P (list_of_dlist dxs)"
  by (simp add: Dlist.filter_def)

lemma list_of_dlist_rotate [simp, code abstract]:
  "list_of_dlist (Dlist.rotate n dxs) = List.rotate n (list_of_dlist dxs)"
  by (simp add: Dlist.rotate_def)

text \<open>Explicit executable conversion\<close>

definition dlist_of_list [simp]:
  "dlist_of_list = Dlist"

lemma [code abstract]:
  "list_of_dlist (dlist_of_list xs) = remdups xs"
  by simp

text \<open>Equality\<close>

instantiation dlist :: (equal) equal
begin

definition "HOL.equal dxs dys \<longleftrightarrow> HOL.equal (list_of_dlist dxs) (list_of_dlist dys)"

instance
  by standard (simp add: equal_dlist_def equal list_of_dlist_inject)

end

declare equal_dlist_def [code]

lemma [code nbe]: "HOL.equal (dxs :: 'a::equal dlist) dxs \<longleftrightarrow> True"
  by (fact equal_refl)

subsection \<open>Induction principle and case distinction\<close>

lemma dlist_induct [case_names empty insert, induct type: dlist]:
  assumes empty: "P Dlist.empty"
  assumes insrt: "\<And>x dxs. \<not> Dlist.member dxs x \<Longrightarrow> P dxs \<Longrightarrow> P (Dlist.insert x dxs)"
  shows "P dxs"
proof (cases dxs)
  case (Abs_dlist xs)
  then have "distinct xs" and dxs: "dxs = Dlist xs"
    by (simp_all add: Dlist_def distinct_remdups_id)
  from \<open>distinct xs\<close> have "P (Dlist xs)"
  proof (induct xs)
    case Nil from empty show ?case by (simp add: Dlist.empty_def)
  next
    case (Cons x xs)
    then have "\<not> Dlist.member (Dlist xs) x" and "P (Dlist xs)"
      by (simp_all add: Dlist.member_def List.member_def)
    with insrt have "P (Dlist.insert x (Dlist xs))" .
    with Cons show ?case by (simp add: Dlist.insert_def distinct_remdups_id)
  qed
  with dxs show "P dxs" by simp
qed

lemma dlist_case [cases type: dlist]:
  obtains (empty) "dxs = Dlist.empty"
    | (insert) x dys where "\<not> Dlist.member dys x" and "dxs = Dlist.insert x dys"
proof (cases dxs)
  case (Abs_dlist xs)
  then have dxs: "dxs = Dlist xs" and distinct: "distinct xs"
    by (simp_all add: Dlist_def distinct_remdups_id)
  show thesis
  proof (cases xs)
    case Nil with dxs
    have "dxs = Dlist.empty" by (simp add: Dlist.empty_def)
    with empty show ?thesis .
  next
    case (Cons x xs)
    with dxs distinct have "\<not> Dlist.member (Dlist xs) x"
      and "dxs = Dlist.insert x (Dlist xs)"
      by (simp_all add: Dlist.member_def List.member_def Dlist.insert_def distinct_remdups_id)
    with insert show ?thesis .
  qed
qed

subsection \<open>Functorial structure\<close>

functor map: map
  by (simp_all add: remdups_map_remdups fun_eq_iff dlist_eq_iff)

subsection \<open>Quickcheck generators\<close>

quickcheck_generator dlist predicate: distinct constructors: Dlist.empty, Dlist.insert

subsection \<open>BNF instance\<close>

context begin

qualified fun wpull :: "('a \<times> 'b) list \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> ('a \<times> 'c) list"
where
  "wpull [] ys = []"
| "wpull xs [] = []"
| "wpull ((a, b) # xs) ((b', c) # ys) =
  (if b \<in> snd ` set xs then
     (a, the (map_of (rev ((b', c) # ys)) b)) # wpull xs ((b', c) # ys)
   else if b' \<in> fst ` set ys then
     (the (map_of (map prod.swap (rev ((a, b) # xs))) b'), c) # wpull ((a, b) # xs) ys
   else (a, c) # wpull xs ys)"

qualified lemma wpull_eq_Nil_iff [simp]: "wpull xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
by(cases "(xs, ys)" rule: wpull.cases) simp_all

qualified lemma wpull_induct
  [consumes 1,
   case_names Nil left[xs eq in_set IH] right[xs ys eq in_set IH] step[xs ys eq IH] ]:
  assumes eq: "remdups (map snd xs) = remdups (map fst ys)"
  and Nil: "P [] []"
  and left: "\<And>a b xs b' c ys.
    \<lbrakk> b \<in> snd ` set xs; remdups (map snd xs) = remdups (map fst ((b', c) # ys));
      (b, the (map_of (rev ((b', c) # ys)) b)) \<in> set ((b', c) # ys); P xs ((b', c) # ys) \<rbrakk>
    \<Longrightarrow> P ((a, b) # xs) ((b', c) # ys)"
  and right: "\<And>a b xs b' c ys.
    \<lbrakk> b \<notin> snd ` set xs; b' \<in> fst ` set ys;
      remdups (map snd ((a, b) # xs)) = remdups (map fst ys);
      (the (map_of (map prod.swap (rev ((a, b) #xs))) b'), b') \<in> set ((a, b) # xs);
      P ((a, b) # xs) ys \<rbrakk>
    \<Longrightarrow> P ((a, b) # xs) ((b', c) # ys)"
  and step: "\<And>a b xs c ys.
    \<lbrakk> b \<notin> snd ` set xs; b \<notin> fst ` set ys; remdups (map snd xs) = remdups (map fst ys);
      P xs ys \<rbrakk>
    \<Longrightarrow> P ((a, b) # xs) ((b, c) # ys)"
  shows "P xs ys"
using eq
proof(induction xs ys rule: wpull.induct)
  case 1 thus ?case by(simp add: Nil)
next
  case 2 thus ?case by(simp split: if_split_asm)
next
  case Cons: (3 a b xs b' c ys)
  let ?xs = "(a, b) # xs" and ?ys = "(b', c) # ys"
  consider (xs) "b \<in> snd ` set xs" | (ys) "b \<notin> snd ` set xs" "b' \<in> fst ` set ys"
    | (step) "b \<notin> snd ` set xs" "b' \<notin> fst ` set ys" by auto
  thus ?case
  proof cases
    case xs
    with Cons.prems have eq: "remdups (map snd xs) = remdups (map fst ?ys)" by auto
    from xs eq have "b \<in> fst ` set ?ys" by (metis list.set_map set_remdups)
    hence "map_of (rev ?ys) b \<noteq> None" unfolding map_of_eq_None_iff by auto
    then obtain c' where "map_of (rev ?ys) b = Some c'" by blast
    then have "(b, the (map_of (rev ?ys) b)) \<in> set ?ys" by(auto dest: map_of_SomeD split: if_split_asm)
    from xs eq this Cons.IH(1)[OF xs eq] show ?thesis by(rule left)
  next
    case ys
    from ys Cons.prems have eq: "remdups (map snd ?xs) = remdups (map fst ys)" by auto
    from ys eq have "b' \<in> snd ` set ?xs" by (metis list.set_map set_remdups)
    hence "map_of (map prod.swap (rev ?xs)) b' \<noteq> None"
      unfolding map_of_eq_None_iff by(auto simp add: image_image)
    then obtain a' where "map_of (map prod.swap (rev ?xs)) b' = Some a'" by blast
    then have "(the (map_of (map prod.swap (rev ?xs)) b'), b') \<in> set ?xs"
      by(auto dest: map_of_SomeD split: if_split_asm)
    from ys eq this Cons.IH(2)[OF ys eq] show ?thesis by(rule right)
  next
    case *: step
    hence "remdups (map snd xs) = remdups (map fst ys)" "b = b'" using Cons.prems by auto
    from * this(1) Cons.IH(3)[OF * this(1)] show ?thesis unfolding \<open>b = b'\<close> by(rule step)
  qed
qed

qualified lemma set_wpull_subset:
  assumes "remdups (map snd xs) = remdups (map fst ys)"
  shows "set (wpull xs ys) \<subseteq> set xs O set ys"
using assms by(induction xs ys rule: wpull_induct) auto

qualified lemma set_fst_wpull:
  assumes "remdups (map snd xs) = remdups (map fst ys)"
  shows "fst ` set (wpull xs ys) = fst ` set xs"
using assms by(induction xs ys rule: wpull_induct)(auto intro: rev_image_eqI)

qualified lemma set_snd_wpull:
  assumes "remdups (map snd xs) = remdups (map fst ys)"
  shows "snd ` set (wpull xs ys) = snd ` set ys"
using assms by(induction xs ys rule: wpull_induct)(auto intro: rev_image_eqI)

qualified lemma wpull:
  assumes "distinct xs"
  and "distinct ys"
  and "set xs \<subseteq> {(x, y). R x y}"
  and "set ys \<subseteq> {(x, y). S x y}"
  and eq: "remdups (map snd xs) = remdups (map fst ys)"
  shows "\<exists>zs. distinct zs \<and> set zs \<subseteq> {(x, y). (R OO S) x y} \<and>
         remdups (map fst zs) = remdups (map fst xs) \<and> remdups (map snd zs) = remdups (map snd ys)"
proof(intro exI conjI)
  let ?zs = "remdups (wpull xs ys)"
  show "distinct ?zs" by simp
  show "set ?zs \<subseteq> {(x, y). (R OO S) x y}" using assms(3-4) set_wpull_subset[OF eq] by fastforce
  show "remdups (map fst ?zs) = remdups (map fst xs)" unfolding remdups_map_remdups using eq
    by(induction xs ys rule: wpull_induct)(auto simp add: set_fst_wpull intro: rev_image_eqI)
  show "remdups (map snd ?zs) = remdups (map snd ys)" unfolding remdups_map_remdups using eq
    by(induction xs ys rule: wpull_induct)(auto simp add: set_snd_wpull intro: rev_image_eqI)
qed

qualified lift_definition set :: "'a dlist \<Rightarrow> 'a set" is List.set .

qualified lemma map_transfer [transfer_rule]:
  "(rel_fun op = (rel_fun (pcr_dlist op =) (pcr_dlist op =))) (\<lambda>f x. remdups (List.map f x)) Dlist.map"
by(simp add: rel_fun_def dlist.pcr_cr_eq cr_dlist_def Dlist.map_def remdups_remdups)

bnf "'a dlist"
  map: Dlist.map
  sets: set
  bd: natLeq
  wits: Dlist.empty
unfolding OO_Grp_alt mem_Collect_eq
subgoal by(rule ext)(simp add: dlist_eq_iff)
subgoal by(rule ext)(simp add: dlist_eq_iff remdups_map_remdups)
subgoal by(simp add: dlist_eq_iff set_def cong: list.map_cong)
subgoal by(simp add: set_def fun_eq_iff)
subgoal by(simp add: natLeq_card_order)
subgoal by(simp add: natLeq_cinfinite)
subgoal by(rule ordLess_imp_ordLeq)(simp add: finite_iff_ordLess_natLeq[symmetric] set_def)
subgoal by(rule predicate2I)(transfer; auto simp add: wpull)
subgoal by(simp add: set_def)
done

lifting_update dlist.lifting
lifting_forget dlist.lifting

end

end


theory Nis imports Main BoolRelations begin

abbreviation \<open>sc X Y i \<equiv> (\<forall>p \<in> set X. nis_semantics i p) \<longrightarrow> (\<exists>q \<in> set Y. nis_semantics i q)\<close>

function mp where
  \<open>mp A B (ProNis n # C) [] = mp (n # A) B C []\<close> |
  \<open>mp A B C (ProNis n # D) = mp A (n # B) C D\<close> |
  \<open>mp A B ((p \<down> q) # C) [] = mp A B C [p, q]\<close> |
  \<open>mp A B C ((p \<down> q) # D) = (mp A B (p # C) D \<and> mp A B (q # C) D)\<close> |
  \<open>mp A B [] [] = common A B\<close>
  by pat_completeness auto
termination by (relation \<open>measure (\<lambda>(_,_,C,D). \<Sum>p \<leftarrow> C @ D. size p)\<close>) auto

theorem main: \<open>(\<forall>i. sc (map ProNis A @ C) (map ProNis B @ D) i) \<longleftrightarrow> mp A B C D\<close>
proof (induct rule: mp.induct)
  case 4
  then show ?case
    by simp meson
qed auto

definition \<open>prover p \<equiv> mp [] [] [] [p]\<close>

corollary \<open>prover p \<longleftrightarrow> (\<forall>i. nis_semantics i p)\<close>
  unfolding prover_def by (simp flip: main)

definition \<open>main \<equiv>
  prover ((ProNis () \<down> (ProNis () \<down> ProNis ())) \<down> (ProNis () \<down> (ProNis () \<down> ProNis ())))\<close>

proposition main by code_simp

export_code main in Haskell

end


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

section{*Weak Safety Properties*}

theory Constrains
imports UNITY
begin

consts traces :: "[i, i] => i"
  (* Initial states and program => (final state, reversed trace to it)...
      the domain may also be state*list(state) *)
inductive
  domains
     "traces(init, acts)" <=
         "(init \<union> (\<Union>act\<in>acts. field(act)))*list(\<Union>act\<in>acts. field(act))"
  intros
         (*Initial trace is empty*)
    Init: "s: init ==> <s,[]> \<in> traces(init,acts)"

    Acts: "[| act:acts;  <s,evs> \<in> traces(init,acts);  <s,s'>: act |]
           ==> <s', Cons(s,evs)> \<in> traces(init, acts)"

  type_intros list.intros UnI1 UnI2 UN_I fieldI2 fieldI1

consts reachable :: "i=>i"
inductive
  domains
  "reachable(F)" \<subseteq> "Init(F) \<union> (\<Union>act\<in>Acts(F). field(act))"
  intros
    Init: "s:Init(F) ==> s:reachable(F)"

    Acts: "[| act: Acts(F);  s:reachable(F);  <s,s'>: act |]
           ==> s':reachable(F)"

  type_intros UnI1 UnI2 fieldI2 UN_I

definition
  Constrains :: "[i,i] => i"  (infixl "Co" 60)  where
  "A Co B == {F:program. F:(reachable(F) \<inter> A) co B}"

definition
  op_Unless  :: "[i, i] => i"  (infixl "Unless" 60)  where
  "A Unless B == (A-B) Co (A \<union> B)"

definition
  Stable     :: "i => i"  where
  "Stable(A) == A Co A"

definition
  (*Always is the weak form of "invariant"*)
  Always :: "i => i"  where
  "Always(A) == initially(A) \<inter> Stable(A)"

(*** traces and reachable ***)

lemma reachable_type: "reachable(F) \<subseteq> state"
apply (cut_tac F = F in Init_type)
apply (cut_tac F = F in Acts_type)
apply (cut_tac F = F in reachable.dom_subset, blast)
done

lemma st_set_reachable: "st_set(reachable(F))"
apply (unfold st_set_def)
apply (rule reachable_type)
done
declare st_set_reachable [iff]

lemma reachable_Int_state: "reachable(F) \<inter> state = reachable(F)"
by (cut_tac reachable_type, auto)
declare reachable_Int_state [iff]

lemma state_Int_reachable: "state \<inter> reachable(F) = reachable(F)"
by (cut_tac reachable_type, auto)
declare state_Int_reachable [iff]

lemma reachable_equiv_traces:
"F \<in> program ==> reachable(F)={s \<in> state. \<exists>evs. <s,evs>:traces(Init(F), Acts(F))}"
apply (rule equalityI, safe)
apply (blast dest: reachable_type [THEN subsetD])
apply (erule_tac [2] traces.induct)
apply (erule reachable.induct)
apply (blast intro: reachable.intros traces.intros)+
done

lemma Init_into_reachable: "Init(F) \<subseteq> reachable(F)"
by (blast intro: reachable.intros)

lemma stable_reachable: "[| F \<in> program; G \<in> program;
    Acts(G) \<subseteq> Acts(F)  |] ==> G \<in> stable(reachable(F))"
apply (blast intro: stableI constrainsI st_setI
             reachable_type [THEN subsetD] reachable.intros)
done

declare stable_reachable [intro!]
declare stable_reachable [simp]

(*The set of all reachable states is an invariant...*)
lemma invariant_reachable:
   "F \<in> program ==> F \<in> invariant(reachable(F))"
apply (unfold invariant_def initially_def)
apply (blast intro: reachable_type [THEN subsetD] reachable.intros)
done

(*...in fact the strongest invariant!*)
lemma invariant_includes_reachable: "F \<in> invariant(A) ==> reachable(F) \<subseteq> A"
apply (cut_tac F = F in Acts_type)
apply (cut_tac F = F in Init_type)
apply (cut_tac F = F in reachable_type)
apply (simp (no_asm_use) add: stable_def constrains_def invariant_def initially_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

(*** Co ***)

lemma constrains_reachable_Int: "F \<in> B co B'==>F:(reachable(F) \<inter> B) co (reachable(F) \<inter> B')"
apply (frule constrains_type [THEN subsetD])
apply (frule stable_reachable [OF _ _ subset_refl])
apply (simp_all add: stable_def constrains_Int)
done

(*Resembles the previous definition of Constrains*)
lemma Constrains_eq_constrains:
"A Co B = {F \<in> program. F:(reachable(F) \<inter> A) co (reachable(F)  \<inter>  B)}"
apply (unfold Constrains_def)
apply (blast dest: constrains_reachable_Int constrains_type [THEN subsetD]
             intro: constrains_weaken)
done

lemmas Constrains_def2 = Constrains_eq_constrains [THEN eq_reflection]

lemma constrains_imp_Constrains: "F \<in> A co A' ==> F \<in> A Co A'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_L dest: constrainsD2)
done

lemma ConstrainsI:
    "[|!!act s s'. [| act \<in> Acts(F); <s,s'>:act; s \<in> A |] ==> s':A';
       F \<in> program|]
     ==> F \<in> A Co A'"
apply (auto simp add: Constrains_def constrains_def st_set_def)
apply (blast dest: reachable_type [THEN subsetD])
done

lemma Constrains_type:
 "A Co B \<subseteq> program"
apply (unfold Constrains_def, blast)
done

lemma Constrains_empty: "F \<in> 0 Co B \<longleftrightarrow> F \<in> program"
by (auto dest: Constrains_type [THEN subsetD]
            intro: constrains_imp_Constrains)
declare Constrains_empty [iff]

lemma Constrains_state: "F \<in> A Co state \<longleftrightarrow> F \<in> program"
apply (unfold Constrains_def)
apply (auto dest: Constrains_type [THEN subsetD] intro: constrains_imp_Constrains)
done
declare Constrains_state [iff]

lemma Constrains_weaken_R:
        "[| F \<in> A Co A'; A'<=B' |] ==> F \<in> A Co B'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken_R)
done

lemma Constrains_weaken_L:
    "[| F \<in> A Co A'; B<=A |] ==> F \<in> B Co A'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken_L st_set_subset)
done

lemma Constrains_weaken:
   "[| F \<in> A Co A'; B<=A; A'<=B' |] ==> F \<in> B Co B'"
apply (unfold Constrains_def2)
apply (blast intro: constrains_weaken st_set_subset)
done

(** Union **)
lemma Constrains_Un:
    "[| F \<in> A Co A'; F \<in> B Co B' |] ==> F \<in> (A \<union> B) Co (A' \<union> B')"
apply (unfold Constrains_def2, auto)
apply (simp add: Int_Un_distrib)
apply (blast intro: constrains_Un)
done

lemma Constrains_UN:
    "[|(!!i. i \<in> I==>F \<in> A(i) Co A'(i)); F \<in> program|]
     ==> F:(\<Union>i \<in> I. A(i)) Co (\<Union>i \<in> I. A'(i))"
by (auto intro: constrains_UN simp del: UN_simps
         simp add: Constrains_def2 Int_UN_distrib)

(** Intersection **)

lemma Constrains_Int:
    "[| F \<in> A Co A'; F \<in> B Co B'|]==> F:(A \<inter> B) Co (A' \<inter> B')"
apply (unfold Constrains_def)
apply (subgoal_tac "reachable (F) \<inter> (A \<inter> B) = (reachable (F) \<inter> A) \<inter> (reachable (F) \<inter> B) ")
apply (auto intro: constrains_Int)
done

lemma Constrains_INT:
    "[| (!!i. i \<in> I ==>F \<in> A(i) Co A'(i)); F \<in> program  |]
     ==> F:(\<Inter>i \<in> I. A(i)) Co (\<Inter>i \<in> I. A'(i))"
apply (simp (no_asm_simp) del: INT_simps add: Constrains_def INT_extend_simps)
apply (rule constrains_INT)
apply (auto simp add: Constrains_def)
done

lemma Constrains_imp_subset: "F \<in> A Co A' ==> reachable(F) \<inter> A \<subseteq> A'"
apply (unfold Constrains_def)
apply (blast dest: constrains_imp_subset)
done

lemma Constrains_trans:
 "[| F \<in> A Co B; F \<in> B Co C |] ==> F \<in> A Co C"
apply (unfold Constrains_def2)
apply (blast intro: constrains_trans constrains_weaken)
done

lemma Constrains_cancel:
"[| F \<in> A Co (A' \<union> B); F \<in> B Co B' |] ==> F \<in> A Co (A' \<union> B')"
apply (unfold Constrains_def2)
apply (simp (no_asm_use) add: Int_Un_distrib)
apply (blast intro: constrains_cancel)
done

(*** Stable ***)
(* Useful because there's no Stable_weaken.  [Tanja Vos] *)

lemma stable_imp_Stable:
"F \<in> stable(A) ==> F \<in> Stable(A)"

apply (unfold stable_def Stable_def)
apply (erule constrains_imp_Constrains)
done

lemma Stable_eq: "[| F \<in> Stable(A); A = B |] ==> F \<in> Stable(B)"
by blast

lemma Stable_eq_stable:
"F \<in> Stable(A) \<longleftrightarrow>  (F \<in> stable(reachable(F) \<inter> A))"
apply (auto dest: constrainsD2 simp add: Stable_def stable_def Constrains_def2)
done

lemma StableI: "F \<in> A Co A ==> F \<in> Stable(A)"
by (unfold Stable_def, assumption)

lemma StableD: "F \<in> Stable(A) ==> F \<in> A Co A"
by (unfold Stable_def, assumption)

lemma Stable_Un:
    "[| F \<in> Stable(A); F \<in> Stable(A') |] ==> F \<in> Stable(A \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un)
done

lemma Stable_Int:
    "[| F \<in> Stable(A); F \<in> Stable(A') |] ==> F \<in> Stable (A \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int)
done

lemma Stable_Constrains_Un:
    "[| F \<in> Stable(C); F \<in> A Co (C \<union> A') |]
     ==> F \<in> (C \<union> A) Co (C \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un [THEN Constrains_weaken_R])
done

lemma Stable_Constrains_Int:
    "[| F \<in> Stable(C); F \<in> (C \<inter> A) Co A' |]
     ==> F \<in> (C \<inter> A) Co (C \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int [THEN Constrains_weaken])
done

lemma Stable_UN:
    "[| (!!i. i \<in> I ==> F \<in> Stable(A(i))); F \<in> program |]
     ==> F \<in> Stable (\<Union>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_UN)
done

lemma Stable_INT:
    "[|(!!i. i \<in> I ==> F \<in> Stable(A(i))); F \<in> program |]
     ==> F \<in> Stable (\<Inter>i \<in> I. A(i))"
apply (simp add: Stable_def)
apply (blast intro: Constrains_INT)
done

lemma Stable_reachable: "F \<in> program ==>F \<in> Stable (reachable(F))"
apply (simp (no_asm_simp) add: Stable_eq_stable Int_absorb)
done

lemma Stable_type: "Stable(A) \<subseteq> program"
apply (unfold Stable_def)
apply (rule Constrains_type)
done

(*** The Elimination Theorem.  The "free" m has become universally quantified!
     Should the premise be !!m instead of \<forall>m ?  Would make it harder to use
     in forward proof. ***)

lemma Elimination:
    "[| \<forall>m \<in> M. F \<in> ({s \<in> A. x(s) = m}) Co (B(m)); F \<in> program |]
     ==> F \<in> ({s \<in> A. x(s):M}) Co (\<Union>m \<in> M. B(m))"
apply (unfold Constrains_def, auto)
apply (rule_tac A1 = "reachable (F) \<inter> A"
        in UNITY.elimination [THEN constrains_weaken_L])
apply (auto intro: constrains_weaken_L)
done

(* As above, but for the special case of A=state *)
lemma Elimination2:
 "[| \<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} Co B(m); F \<in> program |]
     ==> F \<in> {s \<in> state. x(s):M} Co (\<Union>m \<in> M. B(m))"
apply (blast intro: Elimination)
done

(** Unless **)

lemma Unless_type: "A Unless B <=program"
apply (unfold op_Unless_def)
apply (rule Constrains_type)
done

(*** Specialized laws for handling Always ***)

(** Natural deduction rules for "Always A" **)

lemma AlwaysI:
"[| Init(F)<=A;  F \<in> Stable(A) |] ==> F \<in> Always(A)"

apply (unfold Always_def initially_def)
apply (frule Stable_type [THEN subsetD], auto)
done

lemma AlwaysD: "F \<in> Always(A) ==> Init(F)<=A & F \<in> Stable(A)"
by (simp add: Always_def initially_def)

lemmas AlwaysE = AlwaysD [THEN conjE]
lemmas Always_imp_Stable = AlwaysD [THEN conjunct2]

(*The set of all reachable states is Always*)
lemma Always_includes_reachable: "F \<in> Always(A) ==> reachable(F) \<subseteq> A"
apply (simp (no_asm_use) add: Stable_def Constrains_def constrains_def Always_def initially_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

lemma invariant_imp_Always:
     "F \<in> invariant(A) ==> F \<in> Always(A)"
apply (unfold Always_def invariant_def Stable_def stable_def)
apply (blast intro: constrains_imp_Constrains)
done

lemmas Always_reachable = invariant_reachable [THEN invariant_imp_Always]

lemma Always_eq_invariant_reachable: "Always(A) = {F \<in> program. F \<in> invariant(reachable(F) \<inter> A)}"
apply (simp (no_asm) add: Always_def invariant_def Stable_def Constrains_def2 stable_def initially_def)
apply (rule equalityI, auto)
apply (blast intro: reachable.intros reachable_type)
done

(*the RHS is the traditional definition of the "always" operator*)
lemma Always_eq_includes_reachable: "Always(A) = {F \<in> program. reachable(F) \<subseteq> A}"
apply (rule equalityI, safe)
apply (auto dest: invariant_includes_reachable
   simp add: subset_Int_iff invariant_reachable Always_eq_invariant_reachable)
done

lemma Always_type: "Always(A) \<subseteq> program"
by (unfold Always_def initially_def, auto)

lemma Always_state_eq: "Always(state) = program"
apply (rule equalityI)
apply (auto dest: Always_type [THEN subsetD] reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)
done
declare Always_state_eq [simp]

lemma state_AlwaysI: "F \<in> program ==> F \<in> Always(state)"
by (auto dest: reachable_type [THEN subsetD]
            simp add: Always_eq_includes_reachable)

lemma Always_eq_UN_invariant: "st_set(A) ==> Always(A) = (\<Union>I \<in> Pow(A). invariant(I))"
apply (simp (no_asm) add: Always_eq_includes_reachable)
apply (rule equalityI, auto)
apply (blast intro: invariantI rev_subsetD [OF _ Init_into_reachable]
                    rev_subsetD [OF _ invariant_includes_reachable]
             dest: invariant_type [THEN subsetD])+
done

lemma Always_weaken: "[| F \<in> Always(A); A \<subseteq> B |] ==> F \<in> Always(B)"
by (auto simp add: Always_eq_includes_reachable)

(*** "Co" rules involving Always ***)
lemmas Int_absorb2 = subset_Int_iff [unfolded iff_def, THEN conjunct1, THEN mp]

lemma Always_Constrains_pre: "F \<in> Always(I) ==> (F:(I \<inter> A) Co A') \<longleftrightarrow> (F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_def Int_assoc [symmetric])
done

lemma Always_Constrains_post: "F \<in> Always(I) ==> (F \<in> A Co (I \<inter> A')) \<longleftrightarrow>(F \<in> A Co A')"
apply (simp (no_asm_simp) add: Always_includes_reachable [THEN Int_absorb2] Constrains_eq_constrains Int_assoc [symmetric])
done

lemma Always_ConstrainsI: "[| F \<in> Always(I);  F \<in> (I \<inter> A) Co A' |] ==> F \<in> A Co A'"
by (blast intro: Always_Constrains_pre [THEN iffD1])

(* [| F \<in> Always(I);  F \<in> A Co A' |] ==> F \<in> A Co (I \<inter> A') *)
lemmas Always_ConstrainsD = Always_Constrains_post [THEN iffD2]

(*The analogous proof of Always_LeadsTo_weaken doesn't terminate*)
lemma Always_Constrains_weaken:
"[|F \<in> Always(C); F \<in> A Co A'; C \<inter> B<=A; C \<inter> A'<=B'|]==>F \<in> B Co B'"
apply (rule Always_ConstrainsI)
apply (drule_tac [2] Always_ConstrainsD, simp_all)
apply (blast intro: Constrains_weaken)
done

(** Conjoining Always properties **)
lemma Always_Int_distrib: "Always(A \<inter> B) = Always(A) \<inter> Always(B)"
by (auto simp add: Always_eq_includes_reachable)

(* the premise i \<in> I is need since \<Inter>is formally not defined for I=0 *)
lemma Always_INT_distrib: "i \<in> I==>Always(\<Inter>i \<in> I. A(i)) = (\<Inter>i \<in> I. Always(A(i)))"
apply (rule equalityI)
apply (auto simp add: Inter_iff Always_eq_includes_reachable)
done

lemma Always_Int_I: "[| F \<in> Always(A);  F \<in> Always(B) |] ==> F \<in> Always(A \<inter> B)"
apply (simp (no_asm_simp) add: Always_Int_distrib)
done

(*Allows a kind of "implication introduction"*)
lemma Always_Diff_Un_eq: "[| F \<in> Always(A) |] ==> (F \<in> Always(C-A \<union> B)) \<longleftrightarrow> (F \<in> Always(B))"
by (auto simp add: Always_eq_includes_reachable)

(*Delete the nearest invariance assumption (which will be the second one
  used by Always_Int_I) *)
lemmas Always_thin = thin_rl [of "F \<in> Always(A)"]

(*To allow expansion of the program's definition when appropriate*)
named_theorems program "program definitions"

ML
{*
(*Combines two invariance ASSUMPTIONS into one.  USEFUL??*)
fun Always_Int_tac ctxt =
  dtac @{thm Always_Int_I} THEN' assume_tac ctxt THEN' etac @{thm Always_thin};

(*Combines a list of invariance THEOREMS into one.*)
val Always_Int_rule = foldr1 (fn (th1,th2) => [th1,th2] MRS @{thm Always_Int_I});

(*proves "co" properties when the program is specified*)

fun constrains_tac ctxt =
   SELECT_GOAL
      (EVERY [REPEAT (Always_Int_tac ctxt 1),
              REPEAT (etac @{thm Always_ConstrainsI} 1
                      ORELSE
                      resolve_tac [@{thm StableI}, @{thm stableI},
                                   @{thm constrains_imp_Constrains}] 1),
              rtac @{thm constrainsI} 1,
              (* Three subgoals *)
              rewrite_goal_tac ctxt [@{thm st_set_def}] 3,
              REPEAT (force_tac ctxt 2),
              full_simp_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems program})) 1,
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (etac @{thm disjE})),
              ALLGOALS (clarify_tac ctxt),
              REPEAT (FIRSTGOAL (etac @{thm disjE})),
              ALLGOALS (clarify_tac ctxt),
              ALLGOALS (asm_full_simp_tac ctxt),
              ALLGOALS (clarify_tac ctxt)]);

(*For proving invariants*)
fun always_tac ctxt i =
    rtac @{thm AlwaysI} i THEN force_tac ctxt i THEN constrains_tac ctxt i;
*}

method_setup safety = {*
  Scan.succeed (SIMPLE_METHOD' o constrains_tac) *}
  "for proving safety properties"

method_setup always = {*
  Scan.succeed (SIMPLE_METHOD' o always_tac) *}
  "for proving invariants"

end


theory BananasStatics
imports BananasLanguage
begin

record static_environment =
  var\<^sub>e_type :: "name \<rightharpoonup> type \<times> type"
  var\<^sub>t_type :: "name \<rightharpoonup> funct"

definition empty_static :: static_environment where
  "empty_static = \<lparr> var\<^sub>e_type = Map.empty, var\<^sub>t_type = Map.empty \<rparr>"

definition extend\<^sub>e\<^sub>s :: "name \<Rightarrow> type \<times> type \<Rightarrow> static_environment \<Rightarrow> static_environment" where
  "extend\<^sub>e\<^sub>s x t \<Gamma> = \<Gamma>\<lparr> var\<^sub>e_type := var\<^sub>e_type \<Gamma>(x \<mapsto> t) \<rparr>"

definition combine\<^sub>s :: "static_environment \<Rightarrow> static_environment \<Rightarrow> static_environment" where
  "combine\<^sub>s \<Gamma> \<Gamma>' =
    \<lparr> var\<^sub>e_type = var\<^sub>e_type \<Gamma> ++ var\<^sub>e_type \<Gamma>', var\<^sub>t_type = var\<^sub>t_type \<Gamma> ++ var\<^sub>t_type \<Gamma>' \<rparr>"

definition domain\<^sub>s :: "static_environment \<Rightarrow> name set" where
  "domain\<^sub>s \<Gamma> = dom (var\<^sub>e_type \<Gamma>) \<union> dom (var\<^sub>t_type \<Gamma>)"

fun apply_functor_type :: "type \<Rightarrow> funct \<Rightarrow> type" (infixl "\<star>" 75) where
  "t \<star> Id = t"
| "t \<star> K t' = t'"
| "t \<star> f\<^sub>1 \<Otimes> f\<^sub>2 = (t \<star> f\<^sub>1) \<otimes> (t \<star> f\<^sub>2)"
| "t \<star> f\<^sub>1 \<Oplus> f\<^sub>2 = (t \<star> f\<^sub>1) \<oplus> (t \<star> f\<^sub>2)"

inductive typecheck\<^sub>e :: "static_environment \<Rightarrow> expr \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool" (infix "\<turnstile> _ : _ \<rightarrow>" 60)
      and typecheck\<^sub>v :: "static_environment \<Rightarrow> val \<Rightarrow> type \<Rightarrow> bool" (infix "\<turnstile> _ :" 60) where
  tc_id [simp]: "\<Gamma> \<turnstile> \<epsilon> : t \<rightarrow> t"
| tc_con [simp]: "\<Gamma> \<turnstile> v : t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> \<kappa> v : t\<^sub>1 \<rightarrow> t\<^sub>2"
| tc_comp [simp]: "\<Gamma> \<turnstile> f : t\<^sub>2 \<rightarrow> t\<^sub>3 \<Longrightarrow> \<Gamma> \<turnstile> g : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> f \<cdot> g : t\<^sub>1 \<rightarrow> t\<^sub>3"
| tc_fst [simp]: "\<Gamma> \<turnstile> \<pi>\<^sub>1 : t\<^sub>1 \<otimes> t\<^sub>2 \<rightarrow> t\<^sub>1"
| tc_snd [simp]: "\<Gamma> \<turnstile> \<pi>\<^sub>2 : t\<^sub>1 \<otimes> t\<^sub>2 \<rightarrow> t\<^sub>2"
| tc_tup [simp]: "\<Gamma> \<turnstile> \<Theta> : t \<rightarrow> t \<otimes> t"
| tc_pair [simp]: "\<Gamma> \<turnstile> f\<^sub>1 : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> f\<^sub>2 : t\<^sub>3 \<rightarrow> t\<^sub>4 \<Longrightarrow>
    \<Gamma> \<turnstile> f\<^sub>1 \<parallel> f\<^sub>2 : t\<^sub>1 \<otimes> t\<^sub>3 \<rightarrow> t\<^sub>2 \<otimes> t\<^sub>4"
| tc_inl [simp]: "\<Gamma> \<turnstile> \<iota>\<^sub>l : t\<^sub>1 \<rightarrow> t\<^sub>1 \<oplus> t\<^sub>2"
| tc_inr [simp]: "\<Gamma> \<turnstile> \<iota>\<^sub>r : t\<^sub>2 \<rightarrow> t\<^sub>1 \<oplus> t\<^sub>2"
| tc_str [simp]: "\<Gamma> \<turnstile> \<Xi> : t\<^sub>1 \<oplus> t\<^sub>1 \<rightarrow> t\<^sub>1"
| tc_case [simp]: "\<Gamma> \<turnstile> f\<^sub>l : t\<^sub>1 \<rightarrow> t\<^sub>3 \<Longrightarrow> \<Gamma> \<turnstile> f\<^sub>r : t\<^sub>2 \<rightarrow> t\<^sub>4 \<Longrightarrow>
    \<Gamma> \<turnstile> f\<^sub>l \<bar> f\<^sub>r : t\<^sub>1 \<oplus> t\<^sub>2 \<rightarrow> t\<^sub>3 \<oplus> t\<^sub>4"
| tc_dst [simp]: "\<Gamma> \<turnstile> \<rhd> : (t\<^sub>1 \<oplus> t\<^sub>2) \<otimes> t\<^sub>3 \<rightarrow> t\<^sub>1 \<otimes> t\<^sub>3 \<oplus> t\<^sub>2 \<otimes> t\<^sub>3"
| tc_app [simp]: "\<Gamma> \<turnstile> $ : (t\<^sub>1 \<hookrightarrow> t\<^sub>2) \<otimes> t\<^sub>1 \<rightarrow> t\<^sub>2"
| tc_arr [simp]: "\<Gamma> \<turnstile> f : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> g : t\<^sub>3 \<rightarrow> t\<^sub>4 \<Longrightarrow>
    \<Gamma> \<turnstile> g \<leftarrow> f : t\<^sub>2 \<hookrightarrow> t\<^sub>3 \<rightarrow> t\<^sub>1 \<hookrightarrow> t\<^sub>4"
| tc_inj [simp]: "var\<^sub>t_type \<Gamma> n = Some F \<Longrightarrow> \<Gamma> \<turnstile> \<succ>\<^bsub>n\<^esub> : \<mu> F \<star> F \<rightarrow> \<mu> F"
| tc_outj [simp]: "var\<^sub>t_type \<Gamma> n = Some F \<Longrightarrow> \<Gamma> \<turnstile> \<prec>\<^bsub>n\<^esub> : \<mu> F \<rightarrow> \<mu> F \<star> F"
| tc_cata [simp]: "var\<^sub>t_type \<Gamma> n = Some F \<Longrightarrow> \<Gamma> \<turnstile> f : t \<star> F \<rightarrow> t \<Longrightarrow> \<Gamma> \<turnstile> \<lparr> f \<rparr>\<^bsub>n\<^esub> : \<mu> F \<rightarrow> t"
| tc_ana [simp]: "var\<^sub>t_type \<Gamma> n = Some F \<Longrightarrow> \<Gamma> \<turnstile> f : t \<rightarrow> t \<star> F \<Longrightarrow> \<Gamma> \<turnstile> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> : t \<rightarrow> \<mu> F"
| tc_var [simp]: "var\<^sub>e_type \<Gamma> x = Some (t\<^sub>1, t\<^sub>2) \<Longrightarrow> \<Gamma> \<turnstile> Var x : t\<^sub>1 \<rightarrow> t\<^sub>2"

| tcv_unit [simp]: "\<Gamma> \<turnstile> UnitV : \<one>"
| tcv_pair [simp]: "\<Gamma> \<turnstile> v\<^sub>1 : t\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> v\<^sub>2 : t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> PairV v\<^sub>1 v\<^sub>2 : t\<^sub>1 \<otimes> t\<^sub>2"
| tcv_inl [simp]: "\<Gamma> \<turnstile> v : t\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> InlV v : t\<^sub>1 \<oplus> t\<^sub>2"
| tcv_inr [simp]: "\<Gamma> \<turnstile> v : t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> InrV v : t\<^sub>1 \<oplus> t\<^sub>2"
| tcv_fun [simp]: "\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> FunV e : t\<^sub>1 \<hookrightarrow> t\<^sub>2"
| tcv_inj [simp]: "var\<^sub>t_type \<Gamma> n = Some F \<Longrightarrow> \<Gamma> \<turnstile> v : \<mu> F \<star> F \<Longrightarrow> \<Gamma> \<turnstile> InjV n v : \<mu> F"

inductive_cases [elim]: "\<Gamma> \<turnstile> \<epsilon> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<kappa> v : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> f \<cdot> g : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<pi>\<^sub>1 : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<pi>\<^sub>2 : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<Theta> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> f\<^sub>l \<parallel> f\<^sub>r : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<iota>\<^sub>l : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<iota>\<^sub>r : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<Xi> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> f\<^sub>l \<bar> f\<^sub>r : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<rhd> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> $ : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> g \<leftarrow> f : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<prec>\<^bsub>n\<^esub> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<succ>\<^bsub>n\<^esub> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<lparr> f \<rparr>\<^bsub>n\<^esub> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> : t \<rightarrow> t'"
inductive_cases [elim]: "\<Gamma> \<turnstile> Var x : t \<rightarrow> t'"

inductive_cases [elim]: "\<Gamma> \<turnstile> UnitV : t"
inductive_cases [elim]: "\<Gamma> \<turnstile> PairV v\<^sub>1 v\<^sub>2 : t"
inductive_cases [elim]: "\<Gamma> \<turnstile> InrV v : t"
inductive_cases [elim]: "\<Gamma> \<turnstile> InlV v : t"
inductive_cases [elim]: "\<Gamma> \<turnstile> FunV e : t"
inductive_cases [elim]: "\<Gamma> \<turnstile> InjV f v : t"

abbreviation ctor_type :: "type list \<Rightarrow> type" where
  "ctor_type ts \<equiv> foldr (op \<otimes>) ts \<one>"

inductive typecheck\<^sub>c\<^sub>e :: "static_environment \<Rightarrow> funct \<Rightarrow> (name \<times> name list) list \<Rightarrow>
    (name \<rightharpoonup> type \<times> type) \<Rightarrow> bool" where
  tcce_nil [simp]: "typecheck\<^sub>c\<^sub>e \<Gamma> F [] Map.empty"
| tcce_cons [simp]: "typecheck\<^sub>c\<^sub>e \<Gamma> F cts \<Gamma>\<^sub>e \<Longrightarrow>
    those (map (map_option \<mu> o var\<^sub>t_type \<Gamma>) ts) = Some ts' \<Longrightarrow>
      typecheck\<^sub>c\<^sub>e \<Gamma> F ((x, ts) # cts) (\<Gamma>\<^sub>e(x \<mapsto> (ctor_type ts', \<mu> F)))"

inductive_cases [elim]: "typecheck\<^sub>c\<^sub>e \<Gamma> F [] \<Gamma>\<^sub>e"
inductive_cases [elim]: "typecheck\<^sub>c\<^sub>e \<Gamma> F ((x, ts) # cts) \<Gamma>\<^sub>e"

fun typecheck\<^sub>c\<^sub>t_arg :: "static_environment \<Rightarrow> name \<Rightarrow> name \<Rightarrow> funct option" where
  "typecheck\<^sub>c\<^sub>t_arg \<Gamma> tn t = (if t = tn then Some Id else map_option (K o \<mu>) (var\<^sub>t_type \<Gamma> t))"

abbreviation ctor_funct :: "funct list \<Rightarrow> funct" where
  "ctor_funct Fs \<equiv> foldr (op \<Otimes>) Fs (K \<one>)"

primrec typecheck\<^sub>c\<^sub>t :: "static_environment \<Rightarrow> name \<Rightarrow> name \<times> name list \<Rightarrow> funct option" where
  "typecheck\<^sub>c\<^sub>t \<Gamma> tn (x, ts) = map_option ctor_funct (those (map (typecheck\<^sub>c\<^sub>t_arg \<Gamma> tn) ts))"

abbreviation adt_type :: "funct list \<Rightarrow> funct" where
  "adt_type Fs \<equiv> foldr (op \<Oplus>) Fs (K \<zero>)"

definition typecheck\<^sub>c\<^sub>t\<^sub>s :: "static_environment \<Rightarrow> name \<Rightarrow> (name \<times> name list) list \<Rightarrow>
    funct option" where
  "typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x cts = map_option adt_type (those (map (typecheck\<^sub>c\<^sub>t \<Gamma> x) cts))"

inductive typecheck\<^sub>d\<^sub>t :: "static_environment \<Rightarrow> name \<Rightarrow> (name \<times> name list) list \<Rightarrow>
    static_environment \<Rightarrow> bool" where
  tcdt [simp]: "typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> n cts = Some F \<Longrightarrow> typecheck\<^sub>c\<^sub>e \<Gamma> F cts \<Gamma>\<^sub>e \<Longrightarrow>
      typecheck\<^sub>d\<^sub>t \<Gamma> n cts \<lparr> var\<^sub>e_type = \<Gamma>\<^sub>e, var\<^sub>t_type = [n \<mapsto> F] \<rparr>"

inductive typecheck_decl :: "static_environment \<Rightarrow> decl \<Rightarrow> static_environment \<Rightarrow> bool"
    (infix "\<Turnstile> _ :" 60) where
  tcd_type [simp]: "typecheck\<^sub>d\<^sub>t \<Gamma> x cts \<Gamma>' \<Longrightarrow> \<Gamma> \<Turnstile> TypeDecl x cts : combine\<^sub>s \<Gamma> \<Gamma>'"
| tcd_expr [simp]: "\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<Turnstile> ExprDecl x e : extend\<^sub>e\<^sub>s x (t\<^sub>1, t\<^sub>2) \<Gamma>"

inductive_cases [elim]: "\<Gamma> \<Turnstile> TypeDecl x F : \<Gamma>'"
inductive_cases [elim]: "\<Gamma> \<Turnstile> ExprDecl x e : \<Gamma>'"

inductive typecheck_decls :: "static_environment \<Rightarrow> decl list \<Rightarrow> static_environment \<Rightarrow> bool"
    (infix "\<Turnstile> _ ::" 60) where
  tcd_nil [simp]: "\<Gamma> \<Turnstile> [] :: \<Gamma>"
| tcd_cons [simp]: "\<Gamma> \<Turnstile> \<delta> : \<Gamma>' \<Longrightarrow> binders\<^sub>d \<delta> \<inter> domain\<^sub>s \<Gamma> = {} \<Longrightarrow> \<Gamma>' \<Turnstile> \<Delta> :: \<Gamma>'' \<Longrightarrow>
    \<Gamma> \<Turnstile> \<delta> # \<Delta> :: \<Gamma>''"

inductive_cases [elim]: "\<Gamma> \<Turnstile> [] :: \<Gamma>'"
inductive_cases [elim]: "\<Gamma> \<Turnstile> \<delta> # \<Lambda> :: \<Gamma>'"

inductive typecheck_prog :: "prog \<Rightarrow> static_environment \<Rightarrow> type \<Rightarrow> bool" (infix "\<TTurnstile> _ \<rightarrow>" 60) where
  tcp_prog [simp]: "empty_static \<Turnstile> \<Delta> :: \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> v : t\<^sub>1 \<Longrightarrow>
    Prog \<Delta> e v \<TTurnstile> \<Gamma> \<rightarrow> t\<^sub>2"

inductive_cases [elim]: "Prog \<Delta> e v \<TTurnstile> \<Gamma> \<rightarrow> t"

(* useful properties *)

lemma [simp]: "var\<^sub>t_type (extend\<^sub>e\<^sub>s x (t\<^sub>1, t\<^sub>2) \<Gamma>) = var\<^sub>t_type \<Gamma>"
  by (simp add: extend\<^sub>e\<^sub>s_def)

lemma [simp]: "\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> x \<notin> domain\<^sub>s \<Gamma> \<Longrightarrow> extend\<^sub>e\<^sub>s x (t\<^sub>1', t\<^sub>2') \<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2"
  and [simp]: "\<Gamma> \<turnstile> v : t \<Longrightarrow> x \<notin> domain\<^sub>s \<Gamma> \<Longrightarrow> extend\<^sub>e\<^sub>s x (t\<^sub>1', t\<^sub>2') \<Gamma> \<turnstile> v : t"
  proof (induction \<Gamma> e t\<^sub>1 t\<^sub>2 and \<Gamma> v t rule: typecheck\<^sub>e_typecheck\<^sub>v.inducts)
  case (tc_var \<Gamma> y t\<^sub>1 t\<^sub>2)
    moreover hence "x \<noteq> y" by (auto simp add: domain\<^sub>s_def)
    ultimately show ?case by simp
  qed (simp_all add: extend\<^sub>e\<^sub>s_def)

lemma unfold_tc_cts [simp]: "typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x ((y, ts) # cts) = Some F \<Longrightarrow>
  \<exists>ts' Fs. those (map (typecheck\<^sub>c\<^sub>t_arg \<Gamma> x) ts) = Some ts' \<and>
    typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x cts = Some Fs \<and> ctor_funct ts' \<Oplus> Fs = F"
  by (auto simp add: typecheck\<^sub>c\<^sub>t\<^sub>s_def split: option.splits)

(* static uniqueness *)

(* not actually true! fix once we have polymorphism *)
lemma unique_typechecking\<^sub>e [elim]: "\<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> e : t\<^sub>1' \<rightarrow> t\<^sub>2' \<Longrightarrow> t\<^sub>1 = t\<^sub>1' \<and> t\<^sub>2 = t\<^sub>2'"
  and unique_typechecking\<^sub>v [elim]: "\<Gamma> \<turnstile> v : t \<Longrightarrow> \<Gamma> \<turnstile> v : t' \<Longrightarrow> t = t'"
  by (induction \<Gamma> e t\<^sub>1 t\<^sub>2 and \<Gamma> v t rule: typecheck\<^sub>e_typecheck\<^sub>v.inducts) simp_all

lemma unique_typechecking\<^sub>c\<^sub>e [elim]: "typecheck\<^sub>c\<^sub>e \<Gamma> F cts \<Gamma>\<^sub>e \<Longrightarrow> typecheck\<^sub>c\<^sub>e \<Gamma> F cts \<Gamma>\<^sub>e' \<Longrightarrow> \<Gamma>\<^sub>e = \<Gamma>\<^sub>e'"
  proof (induction \<Gamma> F cts \<Gamma>\<^sub>e arbitrary: \<Gamma>\<^sub>e' rule: typecheck\<^sub>c\<^sub>e.induct)
  case (tcce_nil \<Gamma> F)
    thus ?case
      by (induction \<Gamma> F "[]::(name \<times> name list) list" \<Gamma>\<^sub>e' rule: typecheck\<^sub>c\<^sub>e.induct) simp_all
  next case (tcce_cons \<Gamma> F cts \<Gamma>\<^sub>e ts ts' x)
    with tcce_cons(4) show ?case
      by (induction \<Gamma> F "(x, ts) # cts" \<Gamma>\<^sub>e' rule: typecheck\<^sub>c\<^sub>e.induct) simp_all
  qed

lemma unique_typechecking\<^sub>d\<^sub>t [elim]: "typecheck\<^sub>d\<^sub>t \<Gamma> x cts \<Gamma>' \<Longrightarrow> typecheck\<^sub>d\<^sub>t \<Gamma> x cts \<Gamma>'' \<Longrightarrow> \<Gamma>' = \<Gamma>''"
  proof (induction \<Gamma> x cts \<Gamma>' rule: typecheck\<^sub>d\<^sub>t.induct)
  case (tcdt \<Gamma> x cts F \<Gamma>\<^sub>e)
    with tcdt(3) show ?case
      by (induction \<Gamma> x cts \<Gamma>'' rule: typecheck\<^sub>d\<^sub>t.induct) (simp, metis unique_typechecking\<^sub>c\<^sub>e)
  qed

lemma [elim]: "\<Gamma> \<Turnstile> \<delta> : \<Gamma>' \<Longrightarrow> \<Gamma> \<Turnstile> \<delta> : \<Gamma>'' \<Longrightarrow> \<Gamma>' = \<Gamma>''"
  proof (induction \<Gamma> \<delta> \<Gamma>' rule: typecheck_decl.induct)
  case (tcd_expr \<Gamma> e t\<^sub>1 t\<^sub>2 x)
    with tcd_expr(2) show ?case
      by (induction \<Gamma> "ExprDecl x e" \<Gamma>'' rule: typecheck_decl.induct) (metis unique_typechecking\<^sub>e)
  next case (tcd_type \<Gamma> x cts \<Gamma>')
    with tcd_type(2) show ?case
      by (induction \<Gamma> "TypeDecl x cts" \<Gamma>'' rule: typecheck_decl.induct)
         (metis unique_typechecking\<^sub>d\<^sub>t)
  qed

end


theory LiftEnv
  imports PermEnvMisc
begin

fun lift_use_env where
  "lift_use_env env NoPerm = env"
| "lift_use_env env UsePerm = env"
| "lift_use_env env OwnPerm = (\<lambda> x. if env x = NoPerm then NoPerm else OwnPerm)"

  (*
      only value types can be sent with no permission.
      function types may only be sent with ownership if they themselves do not
      require ownership.
      array types may use onwership if they are sent with ownership
   *)

fun safe_use_lift where
  "safe_use_lift env UsePerm = (\<forall> x. env x \<noteq> OwnPerm)"
| "safe_use_lift env NoPerm = (\<forall> x. env x = NoPerm)"
| "safe_use_lift env OwnPerm = True"

lemma lift_use_none: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> lift_use_env r_s r x = NoPerm"
  apply (case_tac r)
    apply (auto)
  done

lemma lift_use_own: "\<lbrakk> r_s x = OwnPerm; safe_use_lift r_s r \<rbrakk> \<Longrightarrow> lift_use_env r_s r x = OwnPerm"
  apply (case_tac r)
    apply (auto)
  done

    (*
      ####################################
        P1. lift equality lemmas
      ####################################
    *)

    (* - simple lift lemmas *)

lemma cancel_lift_use_env_gen: "\<lbrakk> leq_perm r' r \<rbrakk> \<Longrightarrow> lift_use_env (lift_use_env r_s r') r = lift_use_env r_s r"
  apply (case_tac "\<forall> x. lift_use_env (lift_use_env r_s r') r x = lift_use_env r_s r x")
   apply (auto)
  apply (case_tac r')
    apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma cancel_lift_use_env: "lift_use_env (lift_use_env r_s r) r = lift_use_env r_s r"
  apply (rule_tac cancel_lift_use_env_gen)
  apply (case_tac r)
    apply (auto)
  done

lemma ann_lift_use_env: "\<lbrakk> r = OwnPerm \<rbrakk> \<Longrightarrow> diff_use_env (lift_use_env r_s q) (lift_use_env r_s r) = empty_use_env"
  apply (case_tac "\<forall> x. diff_use_env (lift_use_env r_s q) (lift_use_env r_s r) x = empty_use_env x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: empty_use_env_def)
  apply (case_tac q)
    apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma lift_rem_use_env: "lift_use_env (rem_use_env r_s x) r = rem_use_env (lift_use_env r_s r) x"
  apply (case_tac "\<forall> x'. lift_use_env (rem_use_env r_s x) r x' = rem_use_env (lift_use_env r_s r) x x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac r)
    apply (auto)
  done

lemma lift_empty_use_env: "lift_use_env empty_use_env r = empty_use_env"
  apply (case_tac "\<forall> x. lift_use_env empty_use_env r x = empty_use_env x")
   apply (auto)
  apply (case_tac r)
    apply (auto)
  apply (simp add: empty_use_env_def)
  done

    (* - diff / lift lemmas *)

lemma lift_diff_use_env: "diff_use_env (lift_use_env r_s r) r_x = lift_use_env (diff_use_env r_s r_x) r"
  apply (case_tac "\<forall> x. diff_use_env (lift_use_env r_s r) r_x x = lift_use_env (diff_use_env r_s r_x) r x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma cancel_diff_lift_use_env: "\<lbrakk> is_own r \<rbrakk> \<Longrightarrow> diff_use_env (lift_use_env r_x q) (lift_use_env r_x r) = empty_use_env"
  apply (case_tac "\<forall> x. diff_use_env (lift_use_env r_x q) (lift_use_env r_x r) x = empty_use_env x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: empty_use_env_def)
  apply (simp add: is_own_def)
  apply (case_tac q)
    apply (auto)
    apply (case_tac "r_x x")
      apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma lhs_lift_diff_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> diff_use_env r_x (lift_use_env r_s r) = diff_use_env (lift_use_env r_x r) (lift_use_env r_s r)"
  apply (case_tac "\<forall> x. diff_use_env r_x (lift_use_env r_s r) x = diff_use_env (lift_use_env r_x r) (lift_use_env r_s r) x")
   apply (auto)
  apply (simp add: leq_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done
(*
lemma comm_lift_diff_use_env: "diff_use_env (lift_use_env r_s r) r_x = lift_use_env (diff_use_env r_s r_x) r"
  apply (case_tac "\<forall> x. lift_use_env (diff_use_env r_s r_x) r x = diff_use_env (lift_use_env r_s r) r_x x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done*)

lemma outer_lift_diff_use_env: "lift_use_env (diff_use_env r_s r_x) r = diff_use_env (lift_use_env r_s r) r_x"
  apply (case_tac "\<forall> x. lift_use_env (diff_use_env r_s r_x) r x = diff_use_env (lift_use_env r_s r) r_x x")
   apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

        (* - comp / lift lemmas *)

lemma lift_comp_use_env: "lift_use_env (comp_use_env r_s r_x) r = comp_use_env (lift_use_env r_s r) (lift_use_env r_x r)"
  apply (case_tac "\<forall> x. lift_use_env (comp_use_env r_s r_x) r x = comp_use_env (lift_use_env r_s r) (lift_use_env r_x r) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

    (*
      ####################################
        P1. lift ordering lemmas
      ####################################
    *)

lemma self_lift_leq_use_env: "leq_use_env r_s (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (case_tac r)
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma lift_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env r_x (lift_use_env r_s r)"
  apply (rule_tac r_sb="r_s" in trans_leq_use_env)
   apply (rule_tac self_lift_leq_use_env)
  apply (simp)
  done

lemma lift_leq_use_env_rev: "\<lbrakk> leq_use_env (lift_use_env r_x r) r_s \<rbrakk> \<Longrightarrow> leq_use_env r_x r_s"
  apply (rule_tac r_sb="lift_use_env r_x r" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac self_lift_leq_use_env)
  done

lemma dist_lift_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_x r) (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac r)
    apply (auto)
  apply (case_tac "r_x x")
  apply (auto)
  done

lemma dist_lift_leq_use_env_gen: "\<lbrakk> leq_perm q r \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_s q) (lift_use_env r_s r)"
  apply (case_tac q)
    apply (auto)
    apply (rule_tac self_lift_leq_use_env)
   apply (rule_tac self_lift_leq_use_env)
  apply (case_tac r)
    apply (auto)
  apply (simp add: leq_use_env_def)
  done

lemma lhs_lift_leq_use_env: "\<lbrakk> leq_use_env r_x (lift_use_env r_s r); is_own r \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_x q) (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (simp add: is_own_def)
  apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac q)
    apply (auto)
  done

lemma lhs_lift_leq_use_env_gen: "\<lbrakk> leq_use_env r_x (lift_use_env r_s r); leq_perm q r \<rbrakk> \<Longrightarrow> leq_use_env (lift_use_env r_x q) (lift_use_env r_s r)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac r)
    apply (auto)
    apply (case_tac q)
      apply (auto)
   apply (case_tac q)
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  apply (case_tac q)
    apply (auto)
  done

    (* - diff / lift lemmas *)

lemma spec_diff_lift_leq_use_env: "leq_use_env (diff_use_env (lift_use_env r_s r) (lift_use_env r_s r)) (diff_use_env r_s (lift_use_env r_s r))"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac r)
    apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma spec_diff_lift_leq_use_env_gen: "\<lbrakk> leq_perm q r \<rbrakk> \<Longrightarrow>
  leq_use_env (diff_use_env (lift_use_env r_s q) (lift_use_env r_s r)) (diff_use_env r_s (lift_use_env r_s r))"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac q)
    apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
     apply (case_tac r)
       apply (auto)
    apply (case_tac r)
      apply (auto)
   apply (case_tac r)
     apply (auto)
    apply (case_tac "r_s x")
      apply (auto)
   apply (case_tac "r_s x")
     apply (auto)
  apply (case_tac r)
    apply (auto)
  done

    (*
      ####################################
        P1. misc lift lemmas
      ####################################
    *)

lemma disj_lift_use_envr: "\<lbrakk> disj_use_env r_s (lift_use_env r_x r) \<rbrakk> \<Longrightarrow> disj_use_env r_s r_x"
  apply (rule_tac r_s="lift_use_env r_x r" in disj_leq_use_env2)
   apply (auto)
  apply (rule_tac self_lift_leq_use_env)
  done

lemma weak_lift_use_env: "\<lbrakk> weak_use_env r_s; r \<noteq> OwnPerm \<rbrakk> \<Longrightarrow> weak_use_env (lift_use_env r_s r)"
  apply (simp add: weak_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac r)
    apply (auto)
  done

lemma weak_lift_empty_use_env: "weak_use_env (lift_use_env empty_use_env r)"
  apply (simp add: weak_use_env_def)
  apply (auto)
  apply (case_tac r)
    apply (auto)
    apply (simp add: empty_use_env_def)
   apply (simp add: empty_use_env_def)
  apply (simp add: empty_use_env_def)
  done

    (*
      ####################################
        P1. lift safety lemmas
      ####################################
    *)

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

lemma safe_lift_empty_use_env: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift empty_use_env r"
  apply (case_tac r)
    apply (simp_all add: empty_use_env_def)
  done

lemma safe_lift_rem_use_env: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift (rem_use_env r_s x) r"
  apply (simp add: rem_use_env_def)
  apply (case_tac r)
    apply (auto)
  done

lemma safe_lift_leq_perm: "\<lbrakk> safe_use_lift r_s r'; leq_perm r' r \<rbrakk> \<Longrightarrow> safe_use_lift r_s r"
  apply (case_tac r)
    apply (auto)
   apply (case_tac r')
     apply (auto)
  apply (case_tac r')
    apply (auto)
  done

lemma safe_lift_comp_use_env: "\<lbrakk> safe_use_lift r_s r; safe_use_lift r_x r \<rbrakk> \<Longrightarrow> safe_use_lift (comp_use_env r_s r_x) r"
  apply (case_tac r)
    apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (simp add: comp_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
   apply (case_tac "r_x x")
     apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done
(*
lemma safe_lift_perm_use_env: "\<lbrakk> leq_perm q r; safe_use_lift r_s q \<rbrakk> \<Longrightarrow> safe_use_lift r_s r"
  apply (case_tac q)
    apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac r)
    apply (auto)
  done*)

lemma safe_lift_cancel_use_env: "\<lbrakk> safe_use_lift r_x q; r = OwnPerm \<rbrakk> \<Longrightarrow> safe_use_lift (diff_use_env r_s (lift_use_env r_s r)) q"
  apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (case_tac q)
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma safe_lift_diff_use_env: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift (diff_use_env r_s r_x) r"
  apply (case_tac r)
    apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_s x")
    apply (auto)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma safe_lift_twice_use_env: "\<lbrakk> safe_use_lift r_s q; leq_perm q r \<rbrakk> \<Longrightarrow> safe_use_lift (lift_use_env r_s q) r"
  apply (case_tac q)
    apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac r)
    apply (auto)
  apply (case_tac r)
    apply (auto)
  done

end