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

Theory ported from HOL.
*)

section\<open>Weak LeadsTo relation (restricted to the set of reachable states)\<close>

theory SubstAx
imports WFair Constrains
begin

definition
  (* The definitions below are not `conventional', but yield simpler rules *)
  Ensures :: "[i,i] => i"            (infixl "Ensures" 60)  where
  "A Ensures B == {F \<in> program. F \<in> (reachable(F) \<inter> A) ensures (reachable(F) \<inter> B) }"

definition
  LeadsTo :: "[i, i] => i"            (infixl "\<longmapsto>w" 60)  where
  "A \<longmapsto>w B == {F \<in> program. F:(reachable(F) \<inter> A) \<longmapsto> (reachable(F) \<inter> B)}"

(*Resembles the previous definition of LeadsTo*)

(* Equivalence with the HOL-like definition *)
lemma LeadsTo_eq:
"st_set(B)==> A \<longmapsto>w B = {F \<in> program. F:(reachable(F) \<inter> A) \<longmapsto> B}"
apply (unfold LeadsTo_def)
apply (blast dest: psp_stable2 leadsToD2 constrainsD2 intro: leadsTo_weaken)
done

lemma LeadsTo_type: "A \<longmapsto>w B <=program"
by (unfold LeadsTo_def, auto)

(*** Specialized laws for handling invariants ***)

(** Conjoining an Always property **)
lemma Always_LeadsTo_pre: "F \<in> Always(I) ==> (F:(I \<inter> A) \<longmapsto>w A') \<longleftrightarrow> (F \<in> A \<longmapsto>w A')"
by (simp add: LeadsTo_def Always_eq_includes_reachable Int_absorb2 Int_assoc [symmetric] leadsToD2)

lemma Always_LeadsTo_post: "F \<in> Always(I) ==> (F \<in> A \<longmapsto>w (I \<inter> A')) \<longleftrightarrow> (F \<in> A \<longmapsto>w A')"
apply (unfold LeadsTo_def)
apply (simp add: Always_eq_includes_reachable Int_absorb2 Int_assoc [symmetric] leadsToD2)
done

(* Like 'Always_LeadsTo_pre RS iffD1', but with premises in the good order *)
lemma Always_LeadsToI: "[| F \<in> Always(C); F \<in> (C \<inter> A) \<longmapsto>w A' |] ==> F \<in> A \<longmapsto>w A'"
by (blast intro: Always_LeadsTo_pre [THEN iffD1])

(* Like 'Always_LeadsTo_post RS iffD2', but with premises in the good order *)
lemma Always_LeadsToD: "[| F \<in> Always(C);  F \<in> A \<longmapsto>w A' |] ==> F \<in> A \<longmapsto>w (C \<inter> A')"
by (blast intro: Always_LeadsTo_post [THEN iffD2])

(*** Introduction rules \<in> Basis, Trans, Union ***)

lemma LeadsTo_Basis: "F \<in> A Ensures B ==> F \<in> A \<longmapsto>w B"
by (auto simp add: Ensures_def LeadsTo_def)

lemma LeadsTo_Trans:
     "[| F \<in> A \<longmapsto>w B;  F \<in> B \<longmapsto>w C |] ==> F \<in> A \<longmapsto>w C"
apply (simp (no_asm_use) add: LeadsTo_def)
apply (blast intro: leadsTo_Trans)
done

lemma LeadsTo_Union:
"[|(!!A. A \<in> S ==> F \<in> A \<longmapsto>w B); F \<in> program|]==>F \<in> \<Union>(S) \<longmapsto>w B"
apply (simp add: LeadsTo_def)
apply (subst Int_Union_Union2)
apply (rule leadsTo_UN, auto)
done

(*** Derived rules ***)

lemma leadsTo_imp_LeadsTo: "F \<in> A \<longmapsto> B ==> F \<in> A \<longmapsto>w B"
apply (frule leadsToD2, clarify)
apply (simp (no_asm_simp) add: LeadsTo_eq)
apply (blast intro: leadsTo_weaken_L)
done

(*Useful with cancellation, disjunction*)
lemma LeadsTo_Un_duplicate: "F \<in> A \<longmapsto>w (A' \<union> A') ==> F \<in> A \<longmapsto>w A'"
by (simp add: Un_ac)

lemma LeadsTo_Un_duplicate2:
     "F \<in> A \<longmapsto>w (A' \<union> C \<union> C) ==> F \<in> A \<longmapsto>w (A' \<union> C)"
by (simp add: Un_ac)

lemma LeadsTo_UN:
    "[|(!!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w B); F \<in> program|]
     ==>F:(\<Union>i \<in> I. A(i)) \<longmapsto>w B"
apply (simp add: LeadsTo_def)
apply (simp (no_asm_simp) del: UN_simps add: Int_UN_distrib)
apply (rule leadsTo_UN, auto)
done

(*Binary union introduction rule*)
lemma LeadsTo_Un:
     "[| F \<in> A \<longmapsto>w C; F \<in> B \<longmapsto>w C |] ==> F \<in> (A \<union> B) \<longmapsto>w C"
apply (subst Un_eq_Union)
apply (rule LeadsTo_Union)
apply (auto dest: LeadsTo_type [THEN subsetD])
done

(*Lets us look at the starting state*)
lemma single_LeadsTo_I:
    "[|(!!s. s \<in> A ==> F:{s} \<longmapsto>w B); F \<in> program|]==>F \<in> A \<longmapsto>w B"
apply (subst UN_singleton [symmetric], rule LeadsTo_UN, auto)
done

lemma subset_imp_LeadsTo: "[| A \<subseteq> B; F \<in> program |] ==> F \<in> A \<longmapsto>w B"
apply (simp (no_asm_simp) add: LeadsTo_def)
apply (blast intro: subset_imp_leadsTo)
done

lemma empty_LeadsTo: "F \<in> 0 \<longmapsto>w A \<longleftrightarrow> F \<in> program"
by (auto dest: LeadsTo_type [THEN subsetD]
            intro: empty_subsetI [THEN subset_imp_LeadsTo])
declare empty_LeadsTo [iff]

lemma LeadsTo_state: "F \<in> A \<longmapsto>w state \<longleftrightarrow> F \<in> program"
by (auto dest: LeadsTo_type [THEN subsetD] simp add: LeadsTo_eq)
declare LeadsTo_state [iff]

lemma LeadsTo_weaken_R: "[| F \<in> A \<longmapsto>w A';  A'<=B'|] ==> F \<in> A \<longmapsto>w B'"
apply (unfold LeadsTo_def)
apply (auto intro: leadsTo_weaken_R)
done

lemma LeadsTo_weaken_L: "[| F \<in> A \<longmapsto>w A'; B \<subseteq> A |] ==> F \<in> B \<longmapsto>w A'"
apply (unfold LeadsTo_def)
apply (auto intro: leadsTo_weaken_L)
done

lemma LeadsTo_weaken: "[| F \<in> A \<longmapsto>w A'; B<=A; A'<=B' |] ==> F \<in> B \<longmapsto>w B'"
by (blast intro: LeadsTo_weaken_R LeadsTo_weaken_L LeadsTo_Trans)

lemma Always_LeadsTo_weaken:
"[| F \<in> Always(C);  F \<in> A \<longmapsto>w A'; C \<inter> B \<subseteq> A;   C \<inter> A' \<subseteq> B' |]
      ==> F \<in> B \<longmapsto>w B'"
apply (blast dest: Always_LeadsToI intro: LeadsTo_weaken Always_LeadsToD)
done

(** Two theorems for "proof lattices" **)

lemma LeadsTo_Un_post: "F \<in> A \<longmapsto>w B ==> F:(A \<union> B) \<longmapsto>w B"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_Un subset_imp_LeadsTo)

lemma LeadsTo_Trans_Un: "[| F \<in> A \<longmapsto>w B;  F \<in> B \<longmapsto>w C |]
      ==> F \<in> (A \<union> B) \<longmapsto>w C"
apply (blast intro: LeadsTo_Un subset_imp_LeadsTo LeadsTo_weaken_L LeadsTo_Trans dest: LeadsTo_type [THEN subsetD])
done

(** Distributive laws **)
lemma LeadsTo_Un_distrib: "(F \<in> (A \<union> B) \<longmapsto>w C)  \<longleftrightarrow> (F \<in> A \<longmapsto>w C & F \<in> B \<longmapsto>w C)"
by (blast intro: LeadsTo_Un LeadsTo_weaken_L)

lemma LeadsTo_UN_distrib: "(F \<in> (\<Union>i \<in> I. A(i)) \<longmapsto>w B) \<longleftrightarrow>  (\<forall>i \<in> I. F \<in> A(i) \<longmapsto>w B) & F \<in> program"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_UN LeadsTo_weaken_L)

lemma LeadsTo_Union_distrib: "(F \<in> \<Union>(S) \<longmapsto>w B)  \<longleftrightarrow>  (\<forall>A \<in> S. F \<in> A \<longmapsto>w B) & F \<in> program"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_Union LeadsTo_weaken_L)

(** More rules using the premise "Always(I)" **)

lemma EnsuresI: "[| F:(A-B) Co (A \<union> B);  F \<in> transient (A-B) |] ==> F \<in> A Ensures B"
apply (simp add: Ensures_def Constrains_eq_constrains)
apply (blast intro: ensuresI constrains_weaken transient_strengthen dest: constrainsD2)
done

lemma Always_LeadsTo_Basis: "[| F \<in> Always(I); F \<in> (I \<inter> (A-A')) Co (A \<union> A');
         F \<in> transient (I \<inter> (A-A')) |]
  ==> F \<in> A \<longmapsto>w A'"
apply (rule Always_LeadsToI, assumption)
apply (blast intro: EnsuresI LeadsTo_Basis Always_ConstrainsD [THEN Constrains_weaken] transient_strengthen)
done

(*Set difference: maybe combine with leadsTo_weaken_L??
  This is the most useful form of the "disjunction" rule*)
lemma LeadsTo_Diff:
     "[| F \<in> (A-B) \<longmapsto>w C;  F \<in> (A \<inter> B) \<longmapsto>w C |] ==> F \<in> A \<longmapsto>w C"
by (blast intro: LeadsTo_Un LeadsTo_weaken)

lemma LeadsTo_UN_UN:
     "[|(!!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w A'(i)); F \<in> program |]
      ==> F \<in> (\<Union>i \<in> I. A(i)) \<longmapsto>w (\<Union>i \<in> I. A'(i))"
apply (rule LeadsTo_Union, auto)
apply (blast intro: LeadsTo_weaken_R)
done

(*Binary union version*)
lemma LeadsTo_Un_Un:
  "[| F \<in> A \<longmapsto>w A'; F \<in> B \<longmapsto>w B' |] ==> F:(A \<union> B) \<longmapsto>w (A' \<union> B')"
by (blast intro: LeadsTo_Un LeadsTo_weaken_R)

(** The cancellation law **)

lemma LeadsTo_cancel2: "[| F \<in> A \<longmapsto>w(A' \<union> B); F \<in> B \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (A' \<union> B')"
by (blast intro: LeadsTo_Un_Un subset_imp_LeadsTo LeadsTo_Trans dest: LeadsTo_type [THEN subsetD])

lemma Un_Diff: "A \<union> (B - A) = A \<union> B"
by auto

lemma LeadsTo_cancel_Diff2: "[| F \<in> A \<longmapsto>w (A' \<union> B); F \<in> (B-A') \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (A' \<union> B')"
apply (rule LeadsTo_cancel2)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: Un_Diff)
done

lemma LeadsTo_cancel1: "[| F \<in> A \<longmapsto>w (B \<union> A'); F \<in> B \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (B' \<union> A')"
apply (simp add: Un_commute)
apply (blast intro!: LeadsTo_cancel2)
done

lemma Diff_Un2: "(B - A) \<union> A = B \<union> A"
by auto

lemma LeadsTo_cancel_Diff1: "[| F \<in> A \<longmapsto>w (B \<union> A'); F \<in> (B-A') \<longmapsto>w B' |] ==> F \<in> A \<longmapsto>w (B' \<union> A')"
apply (rule LeadsTo_cancel1)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: Diff_Un2)
done

(** The impossibility law **)

(*The set "A" may be non-empty, but it contains no reachable states*)
lemma LeadsTo_empty: "F \<in> A \<longmapsto>w 0 ==> F \<in> Always (state -A)"
apply (simp (no_asm_use) add: LeadsTo_def Always_eq_includes_reachable)
apply (cut_tac reachable_type)
apply (auto dest!: leadsTo_empty)
done

(** PSP \<in> Progress-Safety-Progress **)

(*Special case of PSP \<in> Misra's "stable conjunction"*)
lemma PSP_Stable: "[| F \<in> A \<longmapsto>w A';  F \<in> Stable(B) |]==> F:(A \<inter> B) \<longmapsto>w (A' \<inter> B)"
apply (simp add: LeadsTo_def Stable_eq_stable, clarify)
apply (drule psp_stable, assumption)
apply (simp add: Int_ac)
done

lemma PSP_Stable2: "[| F \<in> A \<longmapsto>w A'; F \<in> Stable(B) |] ==> F \<in> (B \<inter> A) \<longmapsto>w (B \<inter> A')"
apply (simp (no_asm_simp) add: PSP_Stable Int_ac)
done

lemma PSP: "[| F \<in> A \<longmapsto>w A'; F \<in> B Co B'|]==> F \<in> (A \<inter> B') \<longmapsto>w ((A' \<inter> B) \<union> (B' - B))"
apply (simp (no_asm_use) add: LeadsTo_def Constrains_eq_constrains)
apply (blast dest: psp intro: leadsTo_weaken)
done

lemma PSP2: "[| F \<in> A \<longmapsto>w A'; F \<in> B Co B' |]==> F:(B' \<inter> A) \<longmapsto>w ((B \<inter> A') \<union> (B' - B))"
by (simp (no_asm_simp) add: PSP Int_ac)

lemma PSP_Unless:
"[| F \<in> A \<longmapsto>w A'; F \<in> B Unless B'|]==> F:(A \<inter> B) \<longmapsto>w ((A' \<inter> B) \<union> B')"
apply (unfold op_Unless_def)
apply (drule PSP, assumption)
apply (blast intro: LeadsTo_Diff LeadsTo_weaken subset_imp_LeadsTo)
done

(*** Induction rules ***)

(** Meta or object quantifier ????? **)
lemma LeadsTo_wf_induct: "[| wf(r);
         \<forall>m \<in> I. F \<in> (A \<inter> f-``{m}) \<longmapsto>w
                            ((A \<inter> f-``(converse(r) `` {m})) \<union> B);
         field(r)<=I; A<=f-``I; F \<in> program |]
      ==> F \<in> A \<longmapsto>w B"
apply (simp (no_asm_use) add: LeadsTo_def)
apply auto
apply (erule_tac I = I and f = f in leadsTo_wf_induct, safe)
apply (drule_tac [2] x = m in bspec, safe)
apply (rule_tac [2] A' = "reachable (F) \<inter> (A \<inter> f -`` (converse (r) ``{m}) \<union> B) " in leadsTo_weaken_R)
apply (auto simp add: Int_assoc)
done

lemma LessThan_induct: "[| \<forall>m \<in> nat. F:(A \<inter> f-``{m}) \<longmapsto>w ((A \<inter> f-``m) \<union> B);
      A<=f-``nat; F \<in> program |] ==> F \<in> A \<longmapsto>w B"
apply (rule_tac A1 = nat and f1 = "%x. x" in wf_measure [THEN LeadsTo_wf_induct])
apply (simp_all add: nat_measure_field)
apply (simp add: ltI Image_inverse_lessThan vimage_def [symmetric])
done

(******
 To be ported ??? I am not sure.

  integ_0_le_induct
  LessThan_bounded_induct
  GreaterThan_bounded_induct

*****)

(*** Completion \<in> Binary and General Finite versions ***)

lemma Completion: "[| F \<in> A \<longmapsto>w (A' \<union> C);  F \<in> A' Co (A' \<union> C);
         F \<in> B \<longmapsto>w (B' \<union> C);  F \<in> B' Co (B' \<union> C) |]
      ==> F \<in> (A \<inter> B) \<longmapsto>w ((A' \<inter> B') \<union> C)"
apply (simp (no_asm_use) add: LeadsTo_def Constrains_eq_constrains Int_Un_distrib)
apply (blast intro: completion leadsTo_weaken)
done

lemma Finite_completion_aux:
     "[| I \<in> Fin(X);F \<in> program |]
      ==> (\<forall>i \<in> I. F \<in> (A(i)) \<longmapsto>w (A'(i) \<union> C)) \<longrightarrow>
          (\<forall>i \<in> I. F \<in> (A'(i)) Co (A'(i) \<union> C)) \<longrightarrow>
          F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto>w ((\<Inter>i \<in> I. A'(i)) \<union> C)"
apply (erule Fin_induct)
apply (auto simp del: INT_simps simp add: Inter_0)
apply (rule Completion, auto)
apply (simp del: INT_simps add: INT_extend_simps)
apply (blast intro: Constrains_INT)
done

lemma Finite_completion:
     "[| I \<in> Fin(X); !!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w (A'(i) \<union> C);
         !!i. i \<in> I ==> F \<in> A'(i) Co (A'(i) \<union> C);
         F \<in> program |]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto>w ((\<Inter>i \<in> I. A'(i)) \<union> C)"
by (blast intro: Finite_completion_aux [THEN mp, THEN mp])

lemma Stable_completion:
     "[| F \<in> A \<longmapsto>w A';  F \<in> Stable(A');
         F \<in> B \<longmapsto>w B';  F \<in> Stable(B') |]
    ==> F \<in> (A \<inter> B) \<longmapsto>w (A' \<inter> B')"
apply (unfold Stable_def)
apply (rule_tac C1 = 0 in Completion [THEN LeadsTo_weaken_R])
    prefer 5
    apply blast
apply auto
done

lemma Finite_stable_completion:
     "[| I \<in> Fin(X);
         (!!i. i \<in> I ==> F \<in> A(i) \<longmapsto>w A'(i));
         (!!i. i \<in> I ==>F \<in> Stable(A'(i)));   F \<in> program  |]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto>w (\<Inter>i \<in> I. A'(i))"
apply (unfold Stable_def)
apply (rule_tac C1 = 0 in Finite_completion [THEN LeadsTo_weaken_R], simp_all)
apply (rule_tac [3] subset_refl, auto)
done

ML \<open>
(*proves "ensures/leadsTo" properties when the program is specified*)
fun ensures_tac ctxt sact =
  SELECT_GOAL
    (EVERY [REPEAT (Always_Int_tac ctxt 1),
            eresolve_tac ctxt @{thms Always_LeadsTo_Basis} 1
                ORELSE   (*subgoal may involve LeadsTo, leadsTo or ensures*)
                REPEAT (ares_tac ctxt [@{thm LeadsTo_Basis}, @{thm leadsTo_Basis},
                                  @{thm EnsuresI}, @{thm ensuresI}] 1),
            (*now there are two subgoals: co & transient*)
            simp_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems program})) 2,
            Rule_Insts.res_inst_tac ctxt
              [((("act", 0), Position.none), sact)] [] @{thm transientI} 2,
               (*simplify the command's domain*)
            simp_tac (ctxt addsimps [@{thm domain_def}]) 3,
            (* proving the domain part *)
           clarify_tac ctxt 3,
           dresolve_tac ctxt @{thms swap} 3, force_tac ctxt 4,
           resolve_tac ctxt @{thms ReplaceI} 3, force_tac ctxt 3, force_tac ctxt 4,
           asm_full_simp_tac ctxt 3, resolve_tac ctxt @{thms conjI} 3, simp_tac ctxt 4,
           REPEAT (resolve_tac ctxt @{thms state_update_type} 3),
           constrains_tac ctxt 1,
           ALLGOALS (clarify_tac ctxt),
           ALLGOALS (asm_full_simp_tac (ctxt addsimps [@{thm st_set_def}])),
                      ALLGOALS (clarify_tac ctxt),
          ALLGOALS (asm_lr_simp_tac ctxt)]);
\<close>

method_setup ensures = \<open>
    Args.goal_spec -- Scan.lift Args.embedded_inner_syntax >>
    (fn (quant, s) => fn ctxt => SIMPLE_METHOD'' quant (ensures_tac ctxt s))
\<close> "for proving progress properties"

end


(*  Title:      Imperative_Loops
    Author:     Christian Sternagel
*)

section \<open>Looping Constructs for Imperative HOL\<close>

theory Imperative_Loops
imports "HOL-Imperative_HOL.Imperative_HOL"
begin

subsection \<open>While Loops\<close>

text \<open>
  We would have liked to restrict to read-only loop conditions using a condition of
  type @{typ "heap \<Rightarrow> bool"} together with @{const tap}. However, this does not allow
  for code generation due to breaking the heap-abstraction.
\<close>
partial_function (heap) while :: "bool Heap \<Rightarrow> 'b Heap \<Rightarrow> unit Heap"
where
  [code]: "while p f = do {
    b \<leftarrow> p;
    if b then f \<then> while p f
    else return ()
  }"

definition "cond p h \<longleftrightarrow> fst (the (execute p h))"

text \<open>A locale that restricts to read-only loop conditions.\<close>
locale ro_cond =
  fixes p :: "bool Heap"
  assumes read_only: "success p h \<Longrightarrow> snd (the (execute p h)) = h"
begin

lemma ro_cond: "ro_cond p"
  using read_only by (simp add: ro_cond_def)

lemma cond_cases [execute_simps]:
  "success p h \<Longrightarrow> cond p h \<Longrightarrow> execute p h = Some (True, h)"
  "success p h \<Longrightarrow> \<not> cond p h \<Longrightarrow> execute p h = Some (False, h)"
  using read_only [of h] by (auto simp: cond_def success_def)

lemma execute_while_unfolds [execute_simps]:
  "success p h \<Longrightarrow> cond p h \<Longrightarrow> execute (while p f) h = execute (f \<then> while p f) h"
  "success p h \<Longrightarrow> \<not> cond p h \<Longrightarrow> execute (while p f) h = execute (return ()) h"
  by (auto simp: while.simps execute_simps)

lemma
  success_while_cond: "success p h \<Longrightarrow> cond p h \<Longrightarrow> effect f h h' r \<Longrightarrow> success (while p f) h' \<Longrightarrow>
    success (while p f) h" and
  success_while_not_cond: "success p h \<Longrightarrow> \<not> cond p h \<Longrightarrow> success (while p f) h"
  by (auto simp: while.simps effect_def execute_simps intro!: success_intros)

lemma success_cond_effect:
  "success p h \<Longrightarrow> cond p h \<Longrightarrow> effect p h h True"
  using read_only [of h] by (auto simp: effect_def execute_simps)

lemma success_not_cond_effect:
  "success p h \<Longrightarrow> \<not> cond p h \<Longrightarrow> effect p h h False"
  using read_only [of h] by (auto simp: effect_def execute_simps)

end

text \<open>The loop-condition does no longer hold after the loop is finished.\<close>
lemma ro_cond_effect_while_post:
  assumes "ro_cond p"
    and "effect (while p f) h h' r"
  shows "success p h' \<and> \<not> cond p h'"
  using assms(1)
  apply (induct rule: while.raw_induct [OF _ assms(2)])
  apply (auto elim!: effect_elims effect_ifE simp: cond_def)
  apply (metis effectE ro_cond.read_only)+
done

text \<open>A rule for proving partial correctness of while loops.\<close>
lemma ro_cond_effect_while_induct:
  assumes "ro_cond p"
  assumes "effect (while p f) h h' u"
    and "I h"
    and "\<And>h h' u. I h \<Longrightarrow> success p h \<Longrightarrow> cond p h \<Longrightarrow> effect f h h' u \<Longrightarrow> I h'"
  shows "I h'"
using assms(1, 3-)
proof (induction p f h h' u rule: while.raw_induct)
  case (1 w p f h h' u)
  obtain b
    where "effect p h h b"
    and *: "effect (if b then f \<then> w p f else return ()) h h' u"
    using "1.hyps" and \<open>ro_cond p\<close>
    by (auto elim!: effect_elims intro: effect_intros) (metis effectE ro_cond.read_only)
  then have cond: "success p h" "cond p h = b" by (auto simp: cond_def elim!: effect_elims effectE)
  show ?case
  proof (cases "b")
    assume "\<not> b"
    then show ?thesis using * and \<open>I h\<close> by (auto elim: effect_elims)
  next
    assume "b"
    moreover
    with * obtain h'' and r
      where "effect f h h'' r" and "effect (w p f) h'' h' u" by (auto elim: effect_elims)
    moreover
    ultimately
    show ?thesis using 1 and cond by blast
  qed
qed fact

lemma effect_success_conv:
  "(\<exists>h'. effect c h h' () \<and> I h') \<longleftrightarrow> success c h \<and> I (snd (the (execute c h)))"
  by (auto simp: success_def effect_def)

context ro_cond
begin

lemmas
  effect_while_post = ro_cond_effect_while_post [OF ro_cond] and
  effect_while_induct [consumes 1, case_names base step] = ro_cond_effect_while_induct [OF ro_cond]

text \<open>A rule for proving total correctness of while loops.\<close>
lemma wf_while_induct [consumes 1, case_names success_cond success_body base step]:
  assumes "wf R" \<comment> \<open>a well-founded relation on heaps proving termination of the loop\<close>
    and success_p: "\<And>h. I h \<Longrightarrow> success p h" \<comment> \<open>the loop-condition terminates\<close>
    and success_f: "\<And>h. I h \<Longrightarrow> success p h \<Longrightarrow> cond p h \<Longrightarrow> success f h" \<comment> \<open>the loop-body terminates\<close>
    and "I h" \<comment> \<open>the invariant holds before the loop is entered\<close>
    and step: "\<And>h h' r. I h \<Longrightarrow> success p h \<Longrightarrow> cond p h \<Longrightarrow> effect f h h' r \<Longrightarrow> (h', h) \<in> R \<and> I h'"
       \<comment> \<open>the invariant is preserved by iterating the loop\<close>
  shows "\<exists>h'. effect (while p f) h h' () \<and> I h'"
using \<open>wf R\<close> and \<open>I h\<close>
proof (induction h)
  case (less h)
  show ?case
  proof (cases "cond p h")
    assume "\<not> cond p h" then show ?thesis
      using \<open>I h\<close> and success_p [of h] by (simp add: effect_def execute_simps)
  next
    assume "cond p h"
    with \<open>I h\<close> and success_f [of h] and step [of h] and success_p [of h]
      obtain h' and r where "effect f h h' r" and "(h', h) \<in> R" and "I h'" and "success p h"
      by (auto simp: success_def effect_def)
    with less.IH [of h'] show ?thesis
      using \<open>cond p h\<close> by (auto simp: execute_simps effect_def)
  qed
qed

text \<open>A rule for proving termination of while loops.\<close>
lemmas
  success_while_induct [consumes 1, case_names success_cond success_body base step] =
    wf_while_induct [unfolded effect_success_conv, THEN conjunct1]

end

subsection \<open>For Loops\<close>

fun "for" :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b Heap) \<Rightarrow> unit Heap"
where
  "for [] f = return ()" |
  "for (x # xs) f = f x \<then> for xs f"

text \<open>A rule for proving partial correctness of for loops.\<close>
lemma effect_for_induct [consumes 2, case_names base step]:
  assumes "i \<le> j"
    and "effect (for [i ..< j] f) h h' u"
    and "I i h"
    and "\<And>k h h' r. i \<le> k \<Longrightarrow> k < j \<Longrightarrow> I k h \<Longrightarrow> effect (f k) h h' r \<Longrightarrow> I (Suc k) h'"
  shows "I j h'"
using assms
proof (induction "j - i" arbitrary: i h)
  case 0
  then show ?case by (auto elim: effect_elims)
next
  case (Suc k)
  show ?case
  proof (cases "j = i")
    case True
    with Suc show ?thesis by auto
  next
    case False
    with \<open>i \<le> j\<close> and \<open>Suc k = j - i\<close>
      have "i < j" and "k = j - Suc i" and "Suc i \<le> j" by auto
    then have "[i ..< j] = i # [Suc i ..< j]" by (metis upt_rec)
    with \<open>effect (for [i ..< j] f) h h' u\<close> obtain h'' r
      where *: "effect (f i) h h'' r" and **: "effect (for [Suc i ..< j] f) h'' h' u"
      by (auto elim: effect_elims)
    from Suc(6) [OF _ _ \<open>I i h\<close> *] and \<open>i < j\<close>
      have "I (Suc i) h''" by auto
    show ?thesis
      by (rule Suc(1) [OF \<open>k = j - Suc i\<close> \<open>Suc i \<le> j\<close> ** \<open>I (Suc i) h''\<close> Suc(6)]) auto
  qed
qed

text \<open>A rule for proving total correctness of for loops.\<close>
lemma for_induct [consumes 1, case_names succeed base step]:
  assumes "i \<le> j"
    and "\<And>k h. I k h \<Longrightarrow> i \<le> k \<Longrightarrow> k < j \<Longrightarrow> success (f k) h"
    and "I i h"
    and "\<And>k h h' r. I k h \<Longrightarrow> i \<le> k \<Longrightarrow> k < j \<Longrightarrow> effect (f k) h h' r \<Longrightarrow> I (Suc k) h'"
  shows "\<exists>h'. effect (for [i ..< j] f) h h' () \<and> I j h'" (is "?P i h")
using assms
proof (induction "j - i" arbitrary: i h)
  case 0
  then show ?case by (auto simp: effect_def execute_simps)
next
  case (Suc k)
  show ?case
  proof (cases "j = i")
    assume "j = i"
    with Suc show ?thesis by auto
  next
    assume "j \<noteq> i"
    with \<open>i \<le> j\<close> and \<open>Suc k = j - i\<close>
      have "i < j" and "k = j - Suc i" and "Suc i \<le> j" by auto
    then have [simp]: "[i ..< j] = i # [Suc i ..< j]" by (metis upt_rec)
    obtain h' r where *: "effect (f i) h h' r"
      using Suc(4) [OF \<open>I i h\<close> le_refl \<open>i < j\<close>] by (auto elim!: success_effectE)
    moreover
    then have "I (Suc i) h'" using Suc by auto
    moreover
    have "?P (Suc i) h'"
      by (rule Suc(1) [OF \<open>k = j - Suc i\<close> \<open>Suc i \<le> j\<close> Suc(4) \<open>I (Suc i) h'\<close> Suc(6)]) auto
    ultimately
    show ?case by (auto simp: effect_def execute_simps)
  qed
qed

text \<open>A rule for proving termination of for loops.\<close>
lemmas
  success_for_induct [consumes 1, case_names succeed base step] =
    for_induct [unfolded effect_success_conv, THEN conjunct1]

end


section \<open>Verification Condition Generator for Total Correctness\<close>

theory VCG_total
  imports utp_hoare_total
begin

method rules =
  rule seq_hoare_r_t|
  rule skip_hoare_r_t|
  rule cond_hoare_r_t|
  rule assigns_hoare_r'_t| (* merges two subgoals? *)
(*   rule assigns_hoare_r_t|  (* not useful for splitting/merging goals, but necessary for pred_* *) *)
  rule assert_hoare_r_t|
  rule assume_hoare_r_t|
  rule while_hoare_r_t|
  rule while_hoare_r'_t|
  rule while_invr_hoare_r_t

(* once proof done, remove any unnecessary bits from invariants/assumptions *)
lemma bubble_sort_manual:
  assumes "mwb_lens xs" and "mwb_lens n" and "mwb_lens newn" and "mwb_lens i"
      and "xs \<bowtie> n" and "xs \<bowtie> newn" and "xs \<bowtie> i"
      and "n \<bowtie> newn" and "n \<bowtie> i"
      and "newn \<bowtie> i"
  shows
  "\<lbrace>true\<rbrace>
  n \<Midarrow> #\<^sub>u(&xs);;
  (&n =\<^sub>u #\<^sub>u(&xs))\<^sup>\<top>\<^sup>C;;
  while &n >\<^sub>u 0
  invr &n \<le>\<^sub>u #\<^sub>u(&xs) \<and> &n \<ge>\<^sub>u 0 \<and> sorted\<^sub>u(drop\<^sub>u(&n, &xs))
  do
    newn \<Midarrow> 0;;
    i \<Midarrow> 1;;
    (* If the outer loop is executing then we know the list isn't empty. *)
    (#\<^sub>u(&xs) >\<^sub>u 0 \<and> &newn =\<^sub>u 0 \<and> &i =\<^sub>u 1 \<and> &n \<le>\<^sub>u #\<^sub>u(&xs) \<and> &n >\<^sub>u 0 \<and> sorted\<^sub>u(drop\<^sub>u(&n, &xs)))\<^sup>\<top>\<^sup>C;;
    while &i <\<^sub>u &n
    (* If the inner loop ever executes then we know the list has more than one element (#\<^sub>u(&xs) >\<^sub>u 1)
       ...but where do we put that info? Is it even necessary? *)
    invr &i \<ge>\<^sub>u 1 \<and> &i \<le>\<^sub>u &n \<and> &newn \<le>\<^sub>u &i \<and> &newn <\<^sub>u &n \<and> &n \<le>\<^sub>u #\<^sub>u(&xs) \<and> &n >\<^sub>u 0 \<and> sorted\<^sub>u(drop\<^sub>u(&n, &xs))
    do
      bif &xs\<lparr>&i-1\<rparr>\<^sub>u >\<^sub>u &xs\<lparr>&i\<rparr>\<^sub>u then
        xs \<Midarrow> take\<^sub>u(&i-1, &xs) ^\<^sub>u \<langle>&xs\<lparr>&i\<rparr>\<^sub>u, &xs\<lparr>&i-1\<rparr>\<^sub>u\<rangle> ^\<^sub>u drop\<^sub>u(&i+1, &xs);;
        newn \<Midarrow> &i
      else
        SKIP
      eif;;
      i \<Midarrow> &i + 1
    od;;
    n \<Midarrow> &newn
  od
  \<lbrace>sorted\<^sub>u(&xs)\<rbrace>\<^sub>D"
  apply (insert assms)
  apply (rule seq_hoare_r_t[of _ _ true])
   defer
   apply (rule seq_hoare_r_t)
    apply (rule assume_hoare_r_t)
     apply (rule skip_hoare_r_t)
    apply rel_auto
   apply (rule while_invr_hoare_r_t)
     apply (rule seq_hoare_r_t)
      defer
      apply (rule seq_hoare_r_t[of _ _ true])
       defer
       apply (rule seq_hoare_r_t)
        apply (rule assume_hoare_r_t)
         apply (rule skip_hoare_r_t)
        apply rel_auto
       apply (rule seq_hoare_r_t)
        apply (rule while_invr_hoare_r_t)
          apply (rule seq_hoare_r_t)
           apply (rule cond_hoare_r_t)
            defer
            apply (rule skip_hoare_r_t)
           prefer 4
           apply (rule assigns_hoare_r'_t) (* use to instantiate schematic variable precondition *)
          prefer 9
          apply (rule seq_hoare_r_t)
           prefer 2
           apply (rule assigns_hoare_r'_t)
          prefer 9
          apply (rule assigns_hoare_r'_t)
         apply (rule assigns_hoare_r_t)
         prefer 2
         apply (rule assigns_hoare_r_t)
         prefer 8
         apply (rule assigns_hoare_r_t)
         prefer 8
         apply rel_auto
        apply rel_auto
       apply rel_auto
      unfolding lens_indep_def
      apply pred_auto
       prefer 3
       apply pred_auto
      prefer 4
      apply pred_auto
     prefer 4
     apply pred_auto
    prefer 3
    apply pred_simp
    defer
    apply (smt diff_diff_cancel diff_le_self length_take less_imp_le min.absorb2 not_le nth_Cons_0 nth_Cons_Suc nth_append nth_append_length order_trans)
   apply (smt Suc_diff_Suc Suc_le_lessD Suc_pred drop_Suc_Cons drop_append id_take_nth_drop leD length_take less_imp_le min_def min_less_iff_conj sorted_append)
(*       apply (case_tac "get\<^bsub>xs\<^esub> A")
       apply auto *)

end


section\<open>Pseudo-Hoops\<close>

theory PseudoHoops
imports RightComplementedMonoid
begin

lemma drop_assumption:
  "p \<Longrightarrow> True"
  by simp

class pseudo_hoop_algebra = left_complemented_monoid_algebra + right_complemented_monoid_nole_algebra +
  assumes left_right_impl_times: "(a l\<rightarrow> b) * a = a * (a r\<rightarrow> b)"
begin
  definition
    "inf_rr a b  = a * (a r\<rightarrow> b)"

  definition
    "lesseq_r a b = (a r\<rightarrow> b = 1)"

  definition
    "less_r a b = (lesseq_r a b \<and> \<not> lesseq_r b a)"
end

(*
sublocale pseudo_hoop_algebra < right: right_complemented_monoid_algebra lesseq_r less_r 1 "( * )" inf_rr "(r\<rightarrow>)";
  apply unfold_locales;
  apply simp_all;
  apply (simp add: less_r_def);
  apply (simp add: inf_rr_def);
  apply (rule right_impl_times, rule right_impl_ded);
  by (simp add: lesseq_r_def);
*)

context pseudo_hoop_algebra begin

  lemma inf_rr_inf [simp]: "inf_rr = (\<sqinter>)"
    by (unfold fun_eq_iff, simp add: inf_rr_def inf_l_def left_right_impl_times)

  lemma lesseq_lesseq_r: "lesseq_r a b = (a \<le> b)"
  proof -
    interpret A: right_complemented_monoid_algebra lesseq_r less_r 1 "(*)" inf_rr "(r\<rightarrow>)"
      by (rule right_complemented_monoid_algebra)
    show "lesseq_r a b = (a \<le> b)"
      apply (subst  le_iff_inf)
      apply (subst A.dual_algebra.inf.absorb_iff1 [of a b])
      apply (unfold inf_rr_inf [THEN sym])
      by simp
  qed

  lemma [simp]: "less_r = (<)"
    by (unfold fun_eq_iff, simp add: less_r_def less_le_not_le)

  subclass right_complemented_monoid_algebra
    apply (cut_tac right_complemented_monoid_algebra)
    by simp
  end

sublocale pseudo_hoop_algebra <
     pseudo_hoop_dual: pseudo_hoop_algebra "\<lambda> a b . b * a" "(\<sqinter>)" "(r\<rightarrow>)" "(\<le>)" "(<)" 1 "(l\<rightarrow>)"
  apply unfold_locales
  apply (simp add: inf_l_def)
  apply simp
  apply (simp add: left_impl_times)
  apply (simp add: left_impl_ded)
  by (simp add: left_right_impl_times)

context pseudo_hoop_algebra begin
lemma commutative_ps: "(\<forall> a b . a * b = b * a) = ((l\<rightarrow>) = (r\<rightarrow>))"
  apply (simp add: fun_eq_iff)
  apply safe
  apply (rule antisym)
  apply (simp add: right_residual [THEN sym])
  apply (subgoal_tac "x * (x l\<rightarrow> xa) =  (x l\<rightarrow> xa) * x")
  apply (drule drop_assumption)
  apply simp
  apply (simp add: left_residual)
  apply simp
  apply (simp add: left_residual [THEN sym])
  apply (simp add: right_residual)
  apply (rule antisym)
  apply (simp add: left_residual)
  apply (simp add: right_residual [THEN sym])
  apply (simp add: left_residual)
  by (simp add: right_residual [THEN sym])

lemma lemma_2_4_5: "a l\<rightarrow> b \<le> (c l\<rightarrow> a) l\<rightarrow> (c l\<rightarrow> b)"
  apply (simp add: left_residual [THEN sym] mult.assoc)
  apply (rule_tac y = "(a l\<rightarrow> b) * a" in order_trans)
  apply (rule mult_left_mono)
  by (simp_all add: left_residual)

end

context pseudo_hoop_algebra begin

lemma lemma_2_4_6: "a r\<rightarrow> b \<le> (c r\<rightarrow> a) r\<rightarrow> (c r\<rightarrow> b)"
  by (rule pseudo_hoop_dual.lemma_2_4_5)

primrec
  imp_power_l:: "'a => nat \<Rightarrow> 'a \<Rightarrow> 'a" ("(_) l-(_)\<rightarrow> (_)" [65,0,65] 65) where
   "a l-0\<rightarrow> b = b" |
   "a l-(Suc n)\<rightarrow> b = (a l\<rightarrow> (a l-n\<rightarrow> b))"

primrec
  imp_power_r:: "'a => nat \<Rightarrow> 'a \<Rightarrow> 'a" ("(_) r-(_)\<rightarrow> (_)" [65,0,65] 65) where
   "a r-0\<rightarrow> b = b" |
   "a r-(Suc n)\<rightarrow> b = (a r\<rightarrow> (a r-n\<rightarrow> b))"

lemma lemma_2_4_7_a: "a l-n\<rightarrow> b = a ^ n l\<rightarrow> b"
  apply (induct_tac n)
  by (simp_all add: left_impl_ded)

lemma lemma_2_4_7_b: "a r-n\<rightarrow> b = a ^ n r\<rightarrow> b"
  apply (induct_tac n)
  by (simp_all add: right_impl_ded [THEN sym] power_commutes)

lemma lemma_2_5_8_a [simp]: "a * b \<le> a"
  by (rule dual_algebra.H)

lemma lemma_2_5_8_b [simp]: "a * b \<le> b"
  by (rule H)

lemma lemma_2_5_9_a: "a \<le> b l\<rightarrow> a"
  by (simp add: left_residual [THEN sym] dual_algebra.H)

lemma lemma_2_5_9_b: "a \<le> b r\<rightarrow> a"
  by (simp add: right_residual [THEN sym] H)

lemma lemma_2_5_11: "a * b \<le> a \<sqinter> b"
  by simp

lemma lemma_2_5_12_a: "a \<le> b \<Longrightarrow>  c l\<rightarrow> a \<le> c l\<rightarrow> b"
  apply (subst left_residual [THEN sym])
  apply (subst left_impl_times)
  apply (rule_tac y = "(a l\<rightarrow> c) * b" in order_trans)
  apply (simp add: mult_left_mono)
  by (rule H)

lemma lemma_2_5_13_a: "a \<le> b \<Longrightarrow>  b l\<rightarrow> c \<le> a l\<rightarrow> c"
  apply (simp add: left_residual [THEN sym])
  apply (rule_tac y = "(b l\<rightarrow> c) * b" in order_trans)
  apply (simp add: mult_left_mono)
  by (simp add: left_residual)

lemma lemma_2_5_14: "(b l\<rightarrow> c) * (a l\<rightarrow> b) \<le> a l\<rightarrow> c"
  apply (simp add: left_residual [THEN sym])
  apply (simp add: mult.assoc)
  apply (subst left_impl_times)
  apply (subst mult.assoc [THEN sym])
  apply (subst left_residual)
  by (rule dual_algebra.H)

lemma lemma_2_5_16: "(a l\<rightarrow> b) \<le>  (b l\<rightarrow> c) r\<rightarrow> (a l\<rightarrow> c)"
  apply (simp add: right_residual [THEN sym])
  by (rule lemma_2_5_14)

lemma lemma_2_5_18: "(a l\<rightarrow> b) \<le>  a * c l\<rightarrow> b * c"
  apply (simp add: left_residual  [THEN sym])
  apply (subst mult.assoc  [THEN sym])
  apply (rule mult_right_mono)
  apply (subst left_impl_times)
  by (rule H)

end

context pseudo_hoop_algebra begin

lemma lemma_2_5_12_b: "a \<le> b \<Longrightarrow>  c r\<rightarrow> a \<le> c r\<rightarrow> b"
  by (rule pseudo_hoop_dual.lemma_2_5_12_a)

lemma lemma_2_5_13_b: "a \<le> b \<Longrightarrow>  b r\<rightarrow> c \<le> a r\<rightarrow> c"
  by (rule pseudo_hoop_dual.lemma_2_5_13_a)

lemma lemma_2_5_15: "(a r\<rightarrow> b) * (b r\<rightarrow> c) \<le> a r\<rightarrow> c"
  by (rule pseudo_hoop_dual.lemma_2_5_14)

lemma lemma_2_5_17: "(a r\<rightarrow> b) \<le>  (b r\<rightarrow> c) l\<rightarrow> (a r\<rightarrow> c)"
  by (rule pseudo_hoop_dual.lemma_2_5_16)

lemma lemma_2_5_19: "(a r\<rightarrow> b) \<le>  c * a r\<rightarrow> c * b"
  by (rule pseudo_hoop_dual.lemma_2_5_18)

definition
  "lower_bound A = {a . \<forall> x \<in> A . a \<le> x}"

definition
  "infimum A = {a \<in> lower_bound A . (\<forall> x \<in> lower_bound A . x \<le> a)}"

lemma infimum_unique: "(infimum A = {x}) = (x \<in> infimum A)"
  apply safe
  apply simp
  apply (rule antisym)
  by (simp_all add: infimum_def)

lemma lemma_2_6_20:
  "a \<in> infimum A \<Longrightarrow> b l\<rightarrow> a \<in> infimum (((l\<rightarrow>) b)`A)"
  apply (subst infimum_def)
  apply safe
  apply (simp add: infimum_def lower_bound_def lemma_2_5_12_a)
  by (simp add: infimum_def lower_bound_def left_residual  [THEN sym])

end

context pseudo_hoop_algebra begin

lemma lemma_2_6_21:
  "a \<in> infimum A \<Longrightarrow> b r\<rightarrow> a \<in> infimum (((r\<rightarrow>) b)`A)"
  by (rule pseudo_hoop_dual.lemma_2_6_20)

lemma infimum_pair: "a \<in> infimum {x . x = b \<or> x = c} = (a = b \<sqinter> c)"
  apply (simp add: infimum_def lower_bound_def)
  apply safe
  apply (rule antisym)
  by simp_all

lemma lemma_2_6_20_a:
  "a l\<rightarrow> (b \<sqinter> c) = (a l\<rightarrow> b) \<sqinter> (a l\<rightarrow> c)"
  apply (subgoal_tac "b \<sqinter> c \<in> infimum {x . x = b \<or> x = c}")
  apply (drule_tac b = a in lemma_2_6_20)
  apply (case_tac "((l\<rightarrow>) a) ` {x . ((x = b) \<or> (x = c))} = {x . x = a l\<rightarrow> b \<or> x = a l\<rightarrow> c}")
  apply (simp_all add: infimum_pair)
  by auto
end

context pseudo_hoop_algebra begin

lemma lemma_2_6_21_a:
  "a r\<rightarrow> (b \<sqinter> c) = (a r\<rightarrow> b) \<sqinter> (a r\<rightarrow> c)"
  by (rule pseudo_hoop_dual.lemma_2_6_20_a)

lemma mult_mono: "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a * c \<le> b * d"
  apply (rule_tac y = "a * d" in order_trans)
  by (simp_all add: mult_right_mono mult_left_mono)

lemma lemma_2_7_22: "(a l\<rightarrow> b) * (c l\<rightarrow> d) \<le> (a \<sqinter> c) l\<rightarrow> (b \<sqinter> d)"
  apply (rule_tac y = "(a \<sqinter> c l\<rightarrow> b) * (a \<sqinter> c l\<rightarrow> d)" in order_trans)
  apply (rule mult_mono)
  apply (simp_all add: lemma_2_5_13_a)
  apply (rule_tac y = "(a \<sqinter> c l\<rightarrow> b) \<sqinter> (a \<sqinter> c l\<rightarrow> d)" in order_trans)
  apply (rule lemma_2_5_11)
  by (simp add: lemma_2_6_20_a)

end

context pseudo_hoop_algebra begin
lemma lemma_2_7_23: "(a r\<rightarrow> b) * (c r\<rightarrow> d) \<le> (a \<sqinter> c) r\<rightarrow> (b \<sqinter> d)"
  apply (rule_tac y = "(c \<sqinter> a) r\<rightarrow> (d \<sqinter> b)" in order_trans)
  apply (rule pseudo_hoop_dual.lemma_2_7_22)
  by (simp add: inf_commute)

definition
  "upper_bound A = {a . \<forall> x \<in> A . x \<le> a}"

definition
  "supremum A = {a \<in> upper_bound A . (\<forall> x \<in> upper_bound A . a \<le> x)}"

lemma supremum_unique:
  "a \<in> supremum A \<Longrightarrow> b \<in> supremum A \<Longrightarrow> a = b"
  apply (simp add: supremum_def upper_bound_def)
  apply (rule antisym)
  by auto

lemma lemma_2_8_i:
  "a \<in> supremum A \<Longrightarrow> a l\<rightarrow> b \<in> infimum ((\<lambda> x . x l\<rightarrow> b)`A)"
  apply (subst infimum_def)
  apply safe
  apply (simp add: supremum_def upper_bound_def lower_bound_def lemma_2_5_13_a)
  apply (simp add: supremum_def upper_bound_def lower_bound_def left_residual  [THEN sym])
  by (simp add: right_residual)

end

context pseudo_hoop_algebra begin

lemma lemma_2_8_i1:
  "a \<in> supremum A \<Longrightarrow> a r\<rightarrow> b \<in> infimum ((\<lambda> x . x r\<rightarrow> b)`A)"
  by (rule pseudo_hoop_dual.lemma_2_8_i, simp)

definition
  times_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "**" 70) where
  "(A ** B) = {a . \<exists> x \<in> A . \<exists> y \<in> B . a = x * y}"

lemma times_set_assoc: "A ** (B ** C) = (A ** B) ** C"
  apply (simp add: times_set_def)
  apply safe
  apply (rule_tac x = "xa * xb" in exI)
  apply safe
  apply (rule_tac x = xa in bexI)
  apply (rule_tac x = xb in bexI)
  apply simp_all
  apply (subst mult.assoc)
  apply (rule_tac x = ya in bexI)
  apply simp_all
  apply (rule_tac x = xb in bexI)
  apply simp_all
  apply (rule_tac x = "ya * y" in exI)
  apply (subst mult.assoc)
  apply simp
  by auto

primrec power_set :: "'a set \<Rightarrow> nat \<Rightarrow> 'a set" (infixr "*^" 80) where
    power_set_0: "(A *^ 0) = {1}"
  | power_set_Suc: "(A *^ (Suc n)) = (A ** (A *^ n))"

lemma infimum_singleton [simp]: "infimum {a} = {a}"
  apply (simp add: infimum_def lower_bound_def)
  by auto

lemma lemma_2_8_ii:
  "a \<in> supremum A \<Longrightarrow> (a ^ n) l\<rightarrow> b \<in> infimum ((\<lambda> x . x l\<rightarrow> b)`(A *^ n))"
  apply (induct_tac n)
  apply simp
  apply (simp add: left_impl_ded)
  apply (drule_tac a = "a ^ n l\<rightarrow> b" and b = a in lemma_2_6_20)
  apply (simp add: infimum_def lower_bound_def times_set_def)
  apply safe
  apply (drule_tac b = "y l\<rightarrow> b" in lemma_2_8_i)
  apply (simp add: infimum_def lower_bound_def times_set_def left_impl_ded)
  apply (rule_tac y = "a l\<rightarrow> y l\<rightarrow> b" in order_trans)
  apply simp_all
  apply (subgoal_tac "(\<forall>xa \<in> A *^ n. x \<le> a l\<rightarrow> xa l\<rightarrow> b)")
  apply simp
  apply safe
  apply (drule_tac b = "xa l\<rightarrow> b" in lemma_2_8_i)
  apply (simp add: infimum_def lower_bound_def)
  apply safe
  apply (subgoal_tac "(\<forall>xb \<in> A. x \<le> xb l\<rightarrow> xa l\<rightarrow> b)")
  apply simp
  apply safe
  apply (subgoal_tac "x \<le> xb * xa l\<rightarrow> b")
  apply (simp add: left_impl_ded)
  apply (subgoal_tac "(\<exists>x \<in> A. \<exists>y \<in> A *^ n. xb * xa = x * y)")
  by auto

lemma power_set_Suc2:
  "A *^ (Suc n) = A *^ n ** A"
  apply (induct_tac n)
  apply (simp add: times_set_def)
  apply simp
  apply (subst times_set_assoc)
  by simp

lemma power_set_add:
  "A *^ (n + m) = (A *^ n) ** (A *^ m)"
  apply (induct_tac m)
  apply simp
  apply (simp add: times_set_def)
  apply simp
  apply (subst times_set_assoc)
  apply (subst times_set_assoc)
  apply (subst power_set_Suc2 [THEN sym])
  by simp
end

context pseudo_hoop_algebra begin

lemma lemma_2_8_ii1:
  "a \<in> supremum A \<Longrightarrow> (a ^ n) r\<rightarrow> b \<in> infimum ((\<lambda> x . x r\<rightarrow> b)`(A *^ n))"
  apply (induct_tac n)
  apply simp
  apply (subst power_Suc2)
  apply (subst power_set_Suc2)
  apply (simp add: right_impl_ded)
  apply (drule_tac a = "a ^ n r\<rightarrow> b" and b = a in lemma_2_6_21)
  apply (simp add: infimum_def lower_bound_def times_set_def)
  apply safe
  apply (drule_tac b = "xa r\<rightarrow> b" in lemma_2_8_i1)
  apply (simp add: infimum_def lower_bound_def times_set_def right_impl_ded)
  apply (rule_tac y = "a r\<rightarrow> xa r\<rightarrow> b" in order_trans)
  apply simp_all
  apply (subgoal_tac "(\<forall>xa \<in> A *^ n. x \<le> a r\<rightarrow> xa r\<rightarrow> b)")
  apply simp
  apply safe
  apply (drule_tac b = "xa r\<rightarrow> b" in lemma_2_8_i1)
  apply (simp add: infimum_def lower_bound_def)
  apply safe
  apply (subgoal_tac "(\<forall>xb \<in> A. x \<le> xb r\<rightarrow> xa r\<rightarrow> b)")
  apply simp
  apply safe
  apply (subgoal_tac "x \<le> xa * xb r\<rightarrow> b")
  apply (simp add: right_impl_ded)
  apply (subgoal_tac "(\<exists>x \<in> A *^ n. \<exists>y \<in> A . xa * xb = x * y)")
  by auto

lemma lemma_2_9_i:
  "b \<in> supremum A \<Longrightarrow> a * b \<in> supremum ((*) a ` A)"
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply (simp add: mult_left_mono)
  by (simp add: right_residual)

lemma lemma_2_9_i1:
  "b \<in> supremum A \<Longrightarrow> b * a \<in> supremum ((\<lambda> x . x * a) ` A)"
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply (simp add: mult_right_mono)
  by (simp add: left_residual)

lemma lemma_2_9_ii:
  "b \<in> supremum A \<Longrightarrow> a \<sqinter> b \<in> supremum ((\<sqinter>) a ` A)"
  apply (subst supremum_def)
  apply safe
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply (rule_tac y = x in order_trans)
  apply simp_all
  apply (subst inf_commute)
  apply (subst inf_l_def)
  apply (subst left_right_impl_times)
  apply (frule_tac a = "(b r\<rightarrow> a)" in lemma_2_9_i1)
  apply (simp add: right_residual)
  apply (simp add: supremum_def upper_bound_def)
  apply (simp add: right_residual)
  apply safe
  apply (subgoal_tac "(\<forall>xa \<in> A. b r\<rightarrow> a \<le> xa r\<rightarrow> x)")
  apply simp
  apply safe
  apply (simp add: inf_l_def)
  apply (simp add: left_right_impl_times)
  apply (rule_tac y = "xa r\<rightarrow>  b * (b r\<rightarrow> a)" in order_trans)
  apply simp
  apply (rule lemma_2_5_12_b)
  apply (subst left_residual)
  apply (subgoal_tac "(\<forall>xa\<in>A. xa \<le> (b r\<rightarrow> a) l\<rightarrow> x)")
  apply simp
  apply safe
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "xaa * (xaa r\<rightarrow> a)" in order_trans)
  apply (rule mult_left_mono)
  apply (rule lemma_2_5_13_b)
  apply simp
  apply (subst right_impl_times)
  by simp

lemma lemma_2_10_24:
  "a \<le> (a l\<rightarrow> b) r\<rightarrow> b"
  by (simp add: right_residual [THEN sym] inf_l_def [THEN sym])

lemma lemma_2_10_25:
  "a \<le> (a l\<rightarrow> b) r\<rightarrow> a"
  by (rule lemma_2_5_9_b)
end

context pseudo_hoop_algebra begin
lemma lemma_2_10_26:
  "a \<le> (a r\<rightarrow> b) l\<rightarrow> b"
  by (rule pseudo_hoop_dual.lemma_2_10_24)

lemma lemma_2_10_27:
  "a \<le> (a r\<rightarrow> b) l\<rightarrow> a"
  by (rule lemma_2_5_9_a)

lemma lemma_2_10_28:
  "b l\<rightarrow> ((a l\<rightarrow> b) r\<rightarrow> a) = b l\<rightarrow> a"
  apply (rule antisym)
  apply (subst left_residual [THEN sym])
  apply (rule_tac y = "((a l\<rightarrow> b) r\<rightarrow> a) \<sqinter> a" in order_trans)
  apply (subst inf_l_def)
  apply (rule_tac y = "(((a l\<rightarrow> b) r\<rightarrow> a) l\<rightarrow> b) * ((a l\<rightarrow> b) r\<rightarrow> a)" in order_trans)
  apply (subst left_impl_times)
  apply simp_all
  apply (rule mult_right_mono)
  apply (rule_tac y = "a l\<rightarrow> b" in order_trans)
  apply (rule lemma_2_5_13_a)
  apply (fact lemma_2_10_25)
  apply (fact lemma_2_10_26)
  apply (rule lemma_2_5_12_a)
  by (fact lemma_2_10_25)

end

context pseudo_hoop_algebra begin

lemma lemma_2_10_29:
  "b r\<rightarrow> ((a r\<rightarrow> b) l\<rightarrow> a) = b r\<rightarrow> a"
  by (rule pseudo_hoop_dual.lemma_2_10_28)

lemma lemma_2_10_30:
  "((b l\<rightarrow> a) r\<rightarrow> a) l\<rightarrow> a = b l\<rightarrow> a"
  apply (rule antisym)
  apply (simp_all add: lemma_2_10_26)
  apply (rule lemma_2_5_13_a)
  by (rule lemma_2_10_24)

end

context pseudo_hoop_algebra begin

lemma lemma_2_10_31:
  "((b r\<rightarrow> a) l\<rightarrow> a) r\<rightarrow> a = b r\<rightarrow> a"
  by (rule pseudo_hoop_dual.lemma_2_10_30)

lemma lemma_2_10_32:
  "(((b l\<rightarrow> a) r\<rightarrow> a) l\<rightarrow> b) l\<rightarrow> (b l\<rightarrow> a) = b l\<rightarrow> a"
  proof -
    have "((((b l\<rightarrow> a) r\<rightarrow> a) l\<rightarrow> b) l\<rightarrow> (b l\<rightarrow> a) = (((b l\<rightarrow> a) r\<rightarrow> a) l\<rightarrow> b) l\<rightarrow> (((b l\<rightarrow> a) r\<rightarrow> a) l\<rightarrow> a))"
      by (simp add: lemma_2_10_30)
    also have "\<dots> = ((((b l\<rightarrow> a) r\<rightarrow> a) l\<rightarrow> b) * ((b l\<rightarrow> a) r\<rightarrow> a) l\<rightarrow> a)"
      by (simp add: left_impl_ded)
    also have "\<dots> = (((b l\<rightarrow> a) r\<rightarrow> a) \<sqinter> b) l\<rightarrow> a"
      by (simp add: inf_l_def)
    also have "\<dots> = b l\<rightarrow> a" apply (subgoal_tac "((b l\<rightarrow> a) r\<rightarrow> a) \<sqinter> b = b", simp, rule antisym)
      by (simp_all add: lemma_2_10_24)
    finally show ?thesis .
  qed

end

context pseudo_hoop_algebra begin

lemma lemma_2_10_33:
  "(((b r\<rightarrow> a) l\<rightarrow> a) r\<rightarrow> b) r\<rightarrow> (b r\<rightarrow> a) = b r\<rightarrow> a"
  by (rule pseudo_hoop_dual.lemma_2_10_32)
end

class pseudo_hoop_sup_algebra = pseudo_hoop_algebra + sup +
  assumes
    sup_comute: "a \<squnion> b = b \<squnion> a"
    and sup_le [simp]: "a \<le> a \<squnion> b"
    and le_sup_equiv: "(a \<le> b) = (a \<squnion> b = b)"
begin
  lemma sup_le_2 [simp]:
    "b \<le> a \<squnion> b"
    by (subst sup_comute, simp)

  lemma le_sup_equiv_r:
    "(a \<squnion> b = b) = (a \<le> b)"
    by (simp add: le_sup_equiv)

  lemma sup_idemp [simp]:
    "a \<squnion> a = a"
    by (simp add: le_sup_equiv_r)
end

class pseudo_hoop_sup1_algebra = pseudo_hoop_algebra + sup +
  assumes
  sup_def: "a \<squnion> b = ((a l\<rightarrow> b) r\<rightarrow> b) \<sqinter> ((b l\<rightarrow> a) r\<rightarrow> a)"
begin

lemma sup_comute1: "a \<squnion> b = b \<squnion> a"
  apply (simp add: sup_def)
  apply (rule antisym)
  by simp_all

lemma sup_le1 [simp]: "a \<le> a \<squnion> b"
  by (simp add: sup_def lemma_2_10_24 lemma_2_5_9_b)

lemma le_sup_equiv1: "(a \<le> b) = (a \<squnion> b = b)"
  apply safe
  apply (simp add: left_lesseq)
  apply (rule antisym)
  apply (simp add: sup_def)
  apply (simp add: sup_def)
  apply (simp_all add: lemma_2_10_24)
  apply (simp add:  le_iff_inf)
  apply (subgoal_tac "(a \<sqinter> b = a \<sqinter> (a \<squnion> b)) \<and> (a \<sqinter> (a \<squnion> b) = a)")
  apply simp
  apply safe
  apply simp
  apply (rule antisym)
  apply simp
  apply (drule drop_assumption)
  by (simp add: sup_comute1)

subclass pseudo_hoop_sup_algebra
  apply unfold_locales
  apply (simp add: sup_comute1)
  apply simp
  by (simp add: le_sup_equiv1)
end

class pseudo_hoop_sup2_algebra = pseudo_hoop_algebra + sup +
  assumes
  sup_2_def: "a \<squnion> b = ((a r\<rightarrow> b) l\<rightarrow> b) \<sqinter> ((b r\<rightarrow> a) l\<rightarrow> a)"

context pseudo_hoop_sup1_algebra begin end

sublocale pseudo_hoop_sup2_algebra < sup1_dual: pseudo_hoop_sup1_algebra "(\<squnion>)" "\<lambda> a b . b * a" "(\<sqinter>)" "(r\<rightarrow>)" "(\<le>)" "(<)" 1 "(l\<rightarrow>)"
  apply unfold_locales
  by (simp add: sup_2_def)

context pseudo_hoop_sup2_algebra begin

lemma sup_comute_2: "a \<squnion> b = b \<squnion> a"
  by (rule  sup1_dual.sup_comute)

lemma sup_le2 [simp]: "a \<le> a \<squnion> b"
  by (rule sup1_dual.sup_le)

lemma le_sup_equiv2: "(a \<le> b) = (a \<squnion> b = b)"
  by (rule sup1_dual.le_sup_equiv)

subclass pseudo_hoop_sup_algebra
  apply unfold_locales
  apply (simp add: sup_comute_2)
  apply simp
  by (simp add: le_sup_equiv2)

end

class pseudo_hoop_lattice_a = pseudo_hoop_sup_algebra +
  assumes sup_inf_le_distr: "a \<squnion> (b \<sqinter> c) \<le> (a \<squnion> b) \<sqinter> (a \<squnion> c)"
begin
  lemma sup_lower_upper_bound [simp]:
    "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> a \<squnion> b \<le> c"
    apply (subst le_iff_inf)
    apply (subgoal_tac "(a \<squnion> b) \<sqinter> c = (a \<squnion> b) \<sqinter> (a \<squnion> c) \<and> a \<squnion> (b \<sqinter> c) \<le> (a \<squnion> b) \<sqinter> (a \<squnion> c) \<and> a \<squnion> (b \<sqinter> c) = a \<squnion> b")
    apply (rule antisym)
    apply simp
    apply safe
    apply auto[1]
    apply (simp add:  le_sup_equiv)
    apply (rule sup_inf_le_distr)
    by (simp add: le_iff_inf)
end

sublocale pseudo_hoop_lattice_a <  lattice "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>)"
  by (unfold_locales, simp_all)

class pseudo_hoop_lattice_b = pseudo_hoop_sup_algebra +
  assumes le_sup_cong: "a \<le> b \<Longrightarrow> a \<squnion> c \<le> b \<squnion> c"

begin
  lemma sup_lower_upper_bound_b [simp]:
    "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> a \<squnion> b \<le> c"
    proof -
      assume A: "a \<le> c"
      assume B: "b \<le> c"
      have "a \<squnion> b \<le> c \<squnion> b" by (cut_tac A, simp add: le_sup_cong)
      also have "\<dots> = b \<squnion> c" by (simp add: sup_comute)
      also have "\<dots> \<le> c \<squnion> c" by (cut_tac B, rule le_sup_cong, simp)
      also have "\<dots> = c"  by simp
      finally show ?thesis .
    qed

  lemma  sup_inf_le_distr_b:
    "a \<squnion> (b \<sqinter> c) \<le> (a \<squnion> b) \<sqinter> (a \<squnion> c)"
    apply (rule sup_lower_upper_bound_b)
    apply simp
    apply simp
    apply safe
    apply (subst sup_comute)
    apply (rule_tac y = "b" in order_trans)
    apply simp_all
    apply (rule_tac y = "c" in order_trans)
    by simp_all
end

context pseudo_hoop_lattice_a begin end

sublocale pseudo_hoop_lattice_b <  pseudo_hoop_lattice_a "(\<squnion>)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  by (unfold_locales, rule sup_inf_le_distr_b)

class pseudo_hoop_lattice = pseudo_hoop_sup_algebra +
  assumes sup_assoc_1: "a \<squnion> (b \<squnion> c) = (a \<squnion> b) \<squnion> c"
begin
  lemma le_sup_cong_c:
    "a \<le> b \<Longrightarrow> a \<squnion> c \<le> b \<squnion> c"
    proof -
      assume A: "a \<le> b"
      have "a \<squnion> c \<squnion> (b \<squnion> c) = a \<squnion> (c \<squnion> (b \<squnion> c))" by (simp add: sup_assoc_1)
      also have "\<dots> = a \<squnion> ((b \<squnion> c) \<squnion> c)" by (simp add: sup_comute)
      also have "\<dots> = a \<squnion> (b \<squnion> (c \<squnion> c))" by (simp add: sup_assoc_1 [THEN sym])
      also have "\<dots> = (a \<squnion> b) \<squnion> c" by (simp add: sup_assoc_1)
      also have "\<dots> = b \<squnion> c" by (cut_tac A, simp add: le_sup_equiv)
      finally show ?thesis by (simp add: le_sup_equiv)
    qed
end

sublocale pseudo_hoop_lattice <  pseudo_hoop_lattice_b "(\<squnion>)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  by (unfold_locales, rule le_sup_cong_c)

sublocale pseudo_hoop_lattice <  semilattice_sup "(\<squnion>)" "(\<le>)" "(<)"
  by (unfold_locales, simp_all)

sublocale pseudo_hoop_lattice <  lattice "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>)"
  by unfold_locales

lemma (in pseudo_hoop_lattice_a) supremum_pair [simp]:
  "supremum {a, b} = {a \<squnion> b}"
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply simp_all
  apply (rule antisym)
  by simp_all

sublocale pseudo_hoop_lattice <  distrib_lattice "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>)"
  apply unfold_locales
  apply (rule distrib_imp1)
  apply (case_tac "xa \<sqinter> (ya \<squnion> za) \<in> supremum ((\<sqinter>) xa ` {ya, za})")
  apply (simp add: supremum_pair)
  apply (erule notE)
  apply (rule lemma_2_9_ii)
  by (simp add: supremum_pair)

class bounded_semilattice_inf_top = semilattice_inf + order_top
begin
lemma inf_eq_top_iff [simp]:
  "(inf x y = top) = (x = top \<and> y = top)"
  by (simp add: eq_iff)
end

sublocale pseudo_hoop_algebra < bounded_semilattice_inf_top "(\<sqinter>)" "(\<le>)" "(<)" "1"
  by unfold_locales simp

definition (in pseudo_hoop_algebra)
  sup1::"'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>1" 70) where
  "a \<squnion>1 b = ((a l\<rightarrow> b) r\<rightarrow> b) \<sqinter> ((b l\<rightarrow> a) r\<rightarrow> a)"

sublocale pseudo_hoop_algebra < sup1: pseudo_hoop_sup1_algebra "(\<squnion>1)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  by (simp add: sup1_def)

definition (in pseudo_hoop_algebra)
  sup2::"'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>2" 70) where
  "a \<squnion>2 b = ((a r\<rightarrow> b) l\<rightarrow> b) \<sqinter> ((b r\<rightarrow> a) l\<rightarrow> a)"

sublocale pseudo_hoop_algebra < sup2: pseudo_hoop_sup2_algebra "(\<squnion>2)" "(*)" "(\<sqinter>)" "(l\<rightarrow>)" "(\<le>)" "(<)" 1 "(r\<rightarrow>)"
  apply unfold_locales
  by (simp add: sup2_def)

context pseudo_hoop_algebra
begin
  lemma lemma_2_15_i:
    "1 \<in> supremum {a, b} \<Longrightarrow> a * b = a \<sqinter> b"
    apply (rule antisym)
    apply (rule lemma_2_5_11)
    apply (simp add: inf_l_def)
    apply (subst left_impl_times)
    apply (rule mult_right_mono)
    apply (subst right_lesseq)
    apply (subgoal_tac "a \<squnion>1 b = 1")
    apply (simp add: sup1_def)
    apply (rule antisym)
    apply simp
    by (simp add: supremum_def upper_bound_def)

  lemma lemma_2_15_ii:
    "1 \<in> supremum {a, b} \<Longrightarrow> a \<le> c \<Longrightarrow> b \<le> d \<Longrightarrow> 1 \<in> supremum {c, d}"
    apply (simp add: supremum_def upper_bound_def)
    apply safe
    apply (drule_tac x = x in spec)
    apply safe
    by simp_all

lemma sup_union:
  "a \<in> supremum A \<Longrightarrow> b \<in> supremum B \<Longrightarrow> supremum {a, b} = supremum (A \<union> B)"
  apply safe
  apply (simp_all add: supremum_def upper_bound_def)
  apply safe
  apply auto
  apply (subgoal_tac "(\<forall>x \<in> A \<union> B. x \<le> xa)")
  by auto

lemma sup_singleton [simp]: "a \<in> supremum {a}"
  by (simp add: supremum_def upper_bound_def)

lemma sup_union_singleton: "a \<in> supremum X \<Longrightarrow> supremum {a, b} = supremum (X \<union> {b})"
  apply (rule_tac B = "{b}" in  sup_union)
  by simp_all

lemma sup_le_union [simp]: "a \<le> b \<Longrightarrow> supremum (A \<union> {a, b}) = supremum (A \<union> {b})"
  apply (simp add: supremum_def upper_bound_def)
  by auto

lemma sup_sup_union: "a \<in> supremum A \<Longrightarrow> b \<in> supremum (B \<union> {a}) \<Longrightarrow> b \<in> supremum (A \<union> B)"
  apply (simp add: supremum_def upper_bound_def)
  by auto

end

(*
context monoid_mult
begin
lemma "a ^ 2 = a * a"
  by (simp add: power2_eq_square)
end
*)

lemma [simp]:
  "n \<le> 2 ^ n"
  apply (induct_tac n)
  apply auto
  apply (rule_tac y = "1 + 2 ^ n" in order_trans)
  by auto

context pseudo_hoop_algebra
begin

lemma sup_le_union_2:
  "a \<le> b \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> supremum A = supremum ((A - {a}) \<union> {b})"
  apply (case_tac "supremum ((A - {a , b}) \<union> {a, b}) = supremum ((A - {a, b}) \<union> {b})")
  apply (case_tac "((A - {a, b}) \<union> {a, b} = A) \<and> ((A - {a, b}) \<union> {b} = (A - {a}) \<union> {b})")
  apply safe[1]
  apply simp
  apply simp
  apply (erule notE)
  apply safe [1]
  apply (erule notE)
  apply (rule sup_le_union)
  by simp

  lemma lemma_2_15_iii_0:
    "1 \<in> supremum {a, b} \<Longrightarrow> 1 \<in> supremum {a ^ 2, b ^ 2}"
    apply (frule_tac a = a in lemma_2_9_i)
    apply simp
    apply (frule_tac a = a and b = b in sup_union_singleton)
    apply (subgoal_tac "supremum ({a * a, a * b} \<union> {b}) = supremum ({a * a, b})")
    apply simp_all
    apply (frule_tac a = b in lemma_2_9_i)
    apply simp
    apply (drule_tac a = b and A = "{b * (a * a), b * b}" and b = 1 and B = "{a * a}" in sup_sup_union)
    apply simp
    apply (case_tac "{a * a, b} = {b, a * a}")
    apply simp
    apply auto [1]
    apply simp
    apply (subgoal_tac "supremum {a * a, b * (a * a), b * b} = supremum {a * a, b * b}")
    apply(simp add: power2_eq_square)
    apply (case_tac "b * (a * a) = b * b")
    apply auto[1]
    apply (cut_tac  A = "{a * a, b * (a * a), b * b}" and a = "b * (a * a)" and b = "a * a" in  sup_le_union_2)
    apply simp
    apply simp
    apply simp
    apply (subgoal_tac "({a * a, b * (a * a), b * b} - {b * (a * a)} \<union> {a * a}) = {a * a, b * b}")
    apply simp
    apply auto[1]
    apply (case_tac "a * a = a * b")
    apply (subgoal_tac "{b, a * a, a * b} = {a * a, b}")
    apply simp
    apply auto[1]
    apply (cut_tac  A = "{b, a * a, a * b}" and a = "a * b" and b = "b" in  sup_le_union_2)
    apply simp
    apply simp
    apply simp
    apply (subgoal_tac "{b, a * a, a * b} - {a * b} \<union> {b} = {a * a, b}")
    apply simp
    by auto

lemma [simp]: "m \<le> n \<Longrightarrow> a ^ n \<le> a ^ m"
  apply (subgoal_tac "a ^ n = (a ^ m) * (a ^ (n-m))")
  apply simp
  apply (cut_tac a = a and m = "m" and n = "n - m" in power_add)
  by simp

lemma [simp]: "a ^ (2 ^ n) \<le> a ^ n"
  by simp

lemma lemma_2_15_iii_1: "1 \<in> supremum {a, b} \<Longrightarrow> 1 \<in> supremum {a ^ (2 ^ n), b ^ (2 ^ n)}"
  apply (induct_tac n)
  apply auto[1]
  apply (drule drop_assumption)
  apply (drule lemma_2_15_iii_0)
  apply (subgoal_tac "\<forall>a . (a ^ (2::nat) ^ n)\<^sup>2 = a ^ (2::nat) ^ Suc n")
  apply simp
  apply safe
  apply (cut_tac a = aa and m = "2 ^ n" and n = 2 in  power_mult)
  apply auto
  apply (subgoal_tac "((2::nat) ^ n * (2::nat)) = ((2::nat) * (2::nat) ^ n)")
  by simp_all

  lemma lemma_2_15_iii:
    "1 \<in> supremum {a, b} \<Longrightarrow> 1 \<in> supremum {a ^ n, b ^ n}"
    apply (drule_tac n = n in lemma_2_15_iii_1)
    apply (simp add: supremum_def upper_bound_def)
    apply safe
    apply (drule_tac x = x in spec)
    apply safe
    apply (rule_tac y = "a ^ n" in order_trans)
    apply simp_all
    apply (rule_tac y = "b ^ n" in order_trans)
    by simp_all
end

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section \<open>\isaheader{Array-based hash maps without explicit invariants}\<close>
theory ArrayHashMap
  imports ArrayHashMap_Impl
begin

(*@impl Map
  @type ('k,'v) ahm
  @abbrv ahm,a
  Array based hash maps without explicit invariant.
*)

subsection \<open>Abstract type definition\<close>

typedef (overloaded) ('key :: hashable, 'val) hashmap =
  "{hm :: ('key, 'val) ArrayHashMap_Impl.hashmap. ArrayHashMap_Impl.ahm_invar hm}"
  morphisms impl_of HashMap
proof
  interpret map_empty ArrayHashMap_Impl.ahm_\<alpha> ArrayHashMap_Impl.ahm_invar ArrayHashMap_Impl.ahm_empty
    by(rule ahm_empty_impl)
  show "ArrayHashMap_Impl.ahm_empty () \<in> ?hashmap"
    by(simp add: empty_correct)
qed

type_synonym ('k,'v) ahm = "('k,'v) hashmap"

lemma ahm_invar_impl_of [simp, intro]: "ArrayHashMap_Impl.ahm_invar (impl_of hm)"
using impl_of[of hm] by simp

lemma HashMap_impl_of [code abstype]: "HashMap (impl_of t) = t"
by(rule impl_of_inverse)

subsection \<open>Primitive operations\<close>

definition ahm_empty_const :: "('key :: hashable, 'val) hashmap"
where "ahm_empty_const \<equiv> (HashMap (ArrayHashMap_Impl.ahm_empty ()))"

definition ahm_empty :: "unit \<Rightarrow> ('key :: hashable, 'val) hashmap"
where "ahm_empty \<equiv> \<lambda>_. ahm_empty_const"

definition ahm_\<alpha> :: "('key :: hashable, 'val) hashmap \<Rightarrow> 'key \<Rightarrow> 'val option"
where "ahm_\<alpha> hm = ArrayHashMap_Impl.ahm_\<alpha> (impl_of hm)"

definition ahm_lookup :: "'key \<Rightarrow> ('key :: hashable, 'val) hashmap \<Rightarrow> 'val option"
where "ahm_lookup k hm = ArrayHashMap_Impl.ahm_lookup k (impl_of hm)"

definition ahm_iteratei :: "('key :: hashable, 'val) hashmap \<Rightarrow> ('key \<times> 'val, '\<sigma>) set_iterator"
where "ahm_iteratei hm = ArrayHashMap_Impl.ahm_iteratei (impl_of hm)"

definition ahm_update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key :: hashable, 'val) hashmap \<Rightarrow> ('key, 'val) hashmap"
where
  "ahm_update k v hm = HashMap (ArrayHashMap_Impl.ahm_update k v (impl_of hm))"

definition ahm_delete :: "'key \<Rightarrow> ('key :: hashable, 'val) hashmap \<Rightarrow> ('key, 'val) hashmap"
where
  "ahm_delete k hm = HashMap (ArrayHashMap_Impl.ahm_delete k (impl_of hm))"

lemma impl_of_ahm_empty [code abstract]:
  "impl_of ahm_empty_const = ArrayHashMap_Impl.ahm_empty ()"
by(simp add: ahm_empty_const_def HashMap_inverse)

lemma impl_of_ahm_update [code abstract]:
  "impl_of (ahm_update k v hm) = ArrayHashMap_Impl.ahm_update k v (impl_of hm)"
by(simp add: ahm_update_def HashMap_inverse ahm_update_correct)

lemma impl_of_ahm_delete [code abstract]:
  "impl_of (ahm_delete k hm) = ArrayHashMap_Impl.ahm_delete k (impl_of hm)"
by(simp add: ahm_delete_def HashMap_inverse ahm_delete_correct)

lemma finite_dom_ahm_\<alpha>[simp]: "finite (dom (ahm_\<alpha> hm))"
  by (simp add: ahm_\<alpha>_def finite_dom_ahm_\<alpha>)

lemma ahm_empty_correct[simp]: "ahm_\<alpha> (ahm_empty ()) = Map.empty"
  by(simp add: ahm_\<alpha>_def ahm_empty_def ahm_empty_const_def HashMap_inverse)

lemma ahm_lookup_correct[simp]: "ahm_lookup k m = ahm_\<alpha> m k"
  by (simp add: ahm_lookup_def ArrayHashMap_Impl.ahm_lookup_def ahm_\<alpha>_def)

lemma ahm_update_correct[simp]: "ahm_\<alpha> (ahm_update k v hm) = (ahm_\<alpha> hm)(k \<mapsto> v)"
  by (simp add: ahm_\<alpha>_def ahm_update_def ahm_update_correct HashMap_inverse)

lemma ahm_delete_correct[simp]:
  "ahm_\<alpha> (ahm_delete k hm) = (ahm_\<alpha> hm) |` (- {k})"
  by (simp add: ahm_\<alpha>_def ahm_delete_def HashMap_inverse ahm_delete_correct)

lemma ahm_iteratei_impl[simp]: "map_iterator (ahm_iteratei m) (ahm_\<alpha> m)"
  unfolding ahm_iteratei_def ahm_\<alpha>_def
  apply (rule ahm_iteratei_correct)
  by simp

subsection \<open>ICF Integration\<close>

definition [icf_rec_def]: "ahm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = ahm_\<alpha>,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = ahm_empty,
  bmap_op_lookup = ahm_lookup,
  bmap_op_update = ahm_update,
  bmap_op_update_dj = ahm_update, \<comment> \<open>TODO: We could use a more efficient bucket update here\<close>
  bmap_op_delete = ahm_delete,
  bmap_op_list_it = ahm_iteratei
\<rparr>"

setup Locale_Code.open_block
interpretation ahm_basic: StdBasicMap ahm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "ahm_ops \<equiv> ahm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation ahm: StdMap ahm_ops
  unfolding ahm_ops_def
  by (rule ahm_basic.dflt_ops_impl)
interpretation ahm: StdMap_no_invar ahm_ops
  apply unfold_locales
  unfolding icf_rec_unf ..
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "ahm"\<close>

lemma pi_ahm[proper_it]:
  "proper_it' ahm_iteratei ahm_iteratei"
  unfolding ahm_iteratei_def[abs_def]
    ArrayHashMap_Impl.ahm_iteratei_def ArrayHashMap_Impl.ahm_iteratei_aux_def
  apply (rule proper_it'I)
  apply (case_tac "impl_of s")
  apply simp
  apply (rename_tac array nat)
  apply (case_tac array)
  apply simp
  by (intro icf_proper_iteratorI)

interpretation pi_ahm: proper_it_loc ahm_iteratei ahm_iteratei
  apply unfold_locales
  apply (rule pi_ahm)
  done

text \<open>Code generator test\<close>
definition test_codegen where "test_codegen \<equiv> (
  ahm.add ,
  ahm.add_dj ,
  ahm.ball ,
  ahm.bex ,
  ahm.delete ,
  ahm.empty ,
  ahm.isEmpty ,
  ahm.isSng ,
  ahm.iterate ,
  ahm.iteratei ,
  ahm.list_it ,
  ahm.lookup ,
  ahm.restrict ,
  ahm.sel ,
  ahm.size ,
  ahm.size_abort ,
  ahm.sng ,
  ahm.to_list ,
  ahm.to_map ,
  ahm.update ,
  ahm.update_dj)"

export_code test_codegen checking SML

end