           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |                January 2006               |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_sf_def
imports CSP_F_Main
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)

declare split_if [split del]

(*****************************************************************

         1. definition of full sequential-formed process
         2.
         3.

 *****************************************************************)

(*==========================================================*
 |                                                          |
 |                    Definition of fsfF                    |
 |                                                          |
 *==========================================================*)

(*
Isabelle 2005

consts
  fsfF_proc :: "('p,'a) proc set"

inductive "fsfF_proc"

intros
fsfF_proc_int:
  "[| sumset C ~= {} ; ALL c: sumset C. Rf c : fsfF_proc |]
   ==> (!! :C .. Rf) : fsfF_proc"

fsfF_proc_ext:
  "[| ALL a:A. Pf a : fsfF_proc ;
      Q = SKIP | Q = DIV | Q = STOP |]
   ==> ((? :A -> Pf) [+] Q) : fsfF_proc"
*)

inductive_set
  fsfF_proc :: "('p,'a) proc set"
where
fsfF_proc_int:
  "[| sumset C ~= {} ; ALL c: sumset C. Rf c : fsfF_proc |]
   ==> (!! :C .. Rf) : fsfF_proc" |

fsfF_proc_ext:
  "[| ALL a:A. Pf a : fsfF_proc ;
      Q = SKIP | Q = DIV | Q = STOP |]
   ==> ((? :A -> Pf) [+] Q) : fsfF_proc"

(*-------------------------------------------*
 |   sequential-formed SSKIP, SDIV, SSTOP    |
 *-------------------------------------------*)

definition
  SSKIP     :: "('p,'a) proc"
  where
  SSKIP_def : "SSKIP == (? y:{} -> DIV) [+] SKIP"

definition
  SDIV      :: "('p,'a) proc"
  where
  SDIV_def  : "SDIV  == (? y:{} -> DIV) [+] DIV"

definition
  SSTOP     :: "('p,'a) proc"
  where
  SSTOP_def : "SSTOP == (? y:{} -> DIV) [+] STOP"

(*** small lemmas ***)

(* in *)

lemma fsfF_SSKIP_in[simp]: "SSKIP : fsfF_proc"
apply (simp add: SSKIP_def)
apply (simp add: fsfF_proc.intros)
done

lemma fsfF_SDIV_in[simp]: "SDIV : fsfF_proc"
apply (simp add: SDIV_def)
apply (simp add: fsfF_proc.intros)
done

lemma fsfF_SSTOP_in[simp]: "SSTOP : fsfF_proc"
apply (simp add: SSTOP_def)
apply (simp add: fsfF_proc.intros)
done

(* eqF *)

lemma cspF_SSKIP_eqF: "SKIP =F SSKIP"
apply (simp add: SSKIP_def)
apply (rule cspF_rw_right)
apply (rule cspF_Ext_choice_rule)
apply (simp)
done

lemma cspF_SDIV_eqF: "DIV =F SDIV"
apply (simp add: SDIV_def)
apply (rule cspF_rw_right)
apply (rule cspF_Ext_choice_rule)
apply (simp)
done

lemma cspF_SSTOP_eqF: "STOP =F SSTOP"
apply (simp add: SSTOP_def)
apply (rule cspF_rw_right)
apply (rule cspF_Ext_choice_rule)
apply (simp)
done

(*----------------------------------------------------------*
 |                          iff                             |
 *----------------------------------------------------------*)

(* proc *)

lemma fsfF_proc_iff:
  "(SP : fsfF_proc) =
    ((EX C Rf.
  sumset C ~= {} & SP = !! :C .. Rf & (ALL c: sumset C. Rf c : fsfF_proc)) |
     (EX A Pf Q.
        SP = (? :A -> Pf) [+] Q & (ALL a:A. Pf a : fsfF_proc) &
        (Q = SKIP | Q = DIV | Q = STOP)))"

apply (rule iffI)

(* => *)
 apply (erule fsfF_proc.cases)
 apply (simp_all)

(* <= *)
 apply (elim conjE exE disjE)
 apply (simp_all add: fsfF_proc.intros)
done

lemma fsfF_procI:
   "((EX C Rf.
  sumset C ~= {} & SP = !! :C .. Rf & (ALL c: sumset C. Rf c : fsfF_proc)) |
     (EX A Pf Q.
        SP = (? :A -> Pf) [+] Q & (ALL a:A. Pf a : fsfF_proc) &
        (Q = SKIP | Q = DIV | Q = STOP)))
    ==> SP : fsfF_proc"
apply (simp add: fsfF_proc_iff[of SP])
done

lemma fsfF_procE:
  "[| SP : fsfF_proc ;
     ((EX C Rf.
  sumset C ~= {} & SP = !! :C .. Rf & (ALL c: sumset C. Rf c : fsfF_proc)) |
     (EX A Pf Q.
        SP = (? :A -> Pf) [+] Q & (ALL a:A. Pf a : fsfF_proc) &
        (Q = SKIP | Q = DIV | Q = STOP)))
      ==> S |]
    ==> S"
apply (simp add: fsfF_proc_iff[of SP])
done

(*----------------------------------------------------------*
 |                    subexpression                         |
 *----------------------------------------------------------*)

(* proc *)

lemma Rf_fsfF_proc:
  "[| !! :C .. Rf : fsfF_proc ; c: sumset C |]
   ==> Rf c : fsfF_proc"
apply (erule fsfF_procE)
apply (elim disjE conjE exE)
apply (simp_all)
done

lemma Pf_fsfF_proc:
  "[| (? :A -> Pf) [+] Q : fsfF_proc ; a:A |]
   ==> Pf a : fsfF_proc"
apply (erule fsfF_procE)
apply (simp)
done

lemma Qf_range:
  "(? :A -> Pf) [+] Q : fsfF_proc
   ==> Q = SKIP | Q = DIV | Q = STOP"
apply (erule fsfF_procE)
apply (simp)
done

(*======================================================*
 |                                                      |
 |    function to decompose : fsfF_decompo_int, ext     |
 |                                                      |
 *======================================================*)

(*
isabelle 2011

consts
  fsfF_C ::
     "('p,'a) proc => 'a sets_nats"
  fsfF_Rf ::
     "('p,'a) proc => ('a aset_anat => ('p,'a) proc)"

  fsfF_A ::
     "('p,'a) proc => 'a set"
  fsfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
  fsfF_Q ::
     "('p,'a) proc => ('p,'a) proc"

(* they are partial functions *)

recdef fsfF_C "{}"
  "fsfF_C (!! :C .. Rf) = C"
recdef fsfF_Rf "{}"
  "fsfF_Rf (!! :C .. Rf) = Rf"
recdef fsfF_A "{}"
  "fsfF_A ((? :A -> Pf) [+] Q) = A"
recdef fsfF_Pf "{}"
  "fsfF_Pf ((? :A -> Pf) [+] Q) = Pf"
recdef fsfF_Q "{}"
  "fsfF_Q ((? :A -> Pf) [+] Q) = Q"
*)

fun
  fsfF_C ::
     "('p,'a) proc => 'a sets_nats"
where
  "fsfF_C (!! :C .. Rf) = C"

fun
  fsfF_Rf ::
     "('p,'a) proc => ('a aset_anat => ('p,'a) proc)"
where
  "fsfF_Rf (!! :C .. Rf) = Rf"

fun
  fsfF_A ::
     "('p,'a) proc => 'a set"
where
  "fsfF_A ((? :A -> Pf) [+] Q) = A"

fun
  fsfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
where
  "fsfF_Pf ((? :A -> Pf) [+] Q) = Pf"

fun
  fsfF_Q ::
     "('p,'a) proc => ('p,'a) proc"
where
  "fsfF_Q ((? :A -> Pf) [+] Q) = Q"

(* they are partial functions *)

(*------------------------*
 |     decomposition      |
 *------------------------*)

lemma cspF_fsfF_proc_decompo:
   "P : fsfF_proc ==>
     ((P = (!! : fsfF_C P .. fsfF_Rf P)) |
      (P = (? : fsfF_A P -> fsfF_Pf P [+] fsfF_Q P)))"
apply (erule fsfF_proc.cases)
apply (simp_all)
done

(****************** to add them again ******************)

declare split_if    [split]
declare disj_not1   [simp]

end


(*
  Author: Mohammad Abdulaziz, Fred Kurz
*)
theory SAT_Solve_SAS_Plus
  imports "SAS_Plus_STRIPS"
    "SAT_Plan_Extensions"
begin
section "SAT-Solving of SAS+ Problems"

lemma sas_plus_problem_has_serial_solution_iff_i:
  assumes "is_valid_problem_sas_plus \<Psi>"
    and "\<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> \<Psi>) t"
  shows "is_serial_solution_for_problem \<Psi> [\<phi>\<^sub>O\<inverse> \<Psi> op. op \<leftarrow> concat (\<Phi>\<inverse> (\<phi> \<Psi>) \<A> t)]"
proof -
  let ?\<Pi> = "\<phi> \<Psi>"
    and ?\<pi>' = "concat (\<Phi>\<inverse> (\<phi> \<Psi>) \<A> t)"
  let ?\<psi> = "[\<phi>\<^sub>O\<inverse> \<Psi> op. op \<leftarrow> ?\<pi>']"
  {
    have "is_valid_problem_strips ?\<Pi>"
      using is_valid_problem_sas_plus_then_strips_transformation_too[OF assms(1)].
    moreover have "STRIPS_Semantics.is_serial_solution_for_problem ?\<Pi> ?\<pi>'"
      using calculation serializable_encoding_decoded_plan_is_serializable[OF
          _ assms(2)]
      unfolding decode_plan_def
      by simp
    ultimately have "SAS_Plus_Semantics.is_serial_solution_for_problem \<Psi> ?\<psi>"
      using assms(1) serial_strips_equivalent_to_serial_sas_plus
      by blast
  }
  thus ?thesis
    using serial_strips_equivalent_to_serial_sas_plus[OF assms(1)]
    by blast
qed

lemma sas_plus_problem_has_serial_solution_iff_ii:
  assumes "is_valid_problem_sas_plus \<Psi>"
    and "is_serial_solution_for_problem \<Psi> \<psi>"
    and "h = length \<psi>"
  shows "\<exists>\<A>. (\<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> \<Psi>) h)"
proof -
  let ?\<Pi> = "\<phi> \<Psi>"
    and ?\<pi> = "\<phi>\<^sub>P \<Psi> (embed \<psi>)"
  let ?\<A> = "valuation_for_plan ?\<Pi> ?\<pi>"
  let ?t = "length \<psi>"
  (* TODO refactor *)
  have nb: "length \<psi> = length ?\<pi>"
    unfolding SAS_Plus_STRIPS.sas_plus_parallel_plan_to_strips_parallel_plan_def
      sasp_op_to_strips_def
      sas_plus_parallel_plan_to_strips_parallel_plan_def
    by (induction \<psi>; auto)
  have "is_valid_problem_strips ?\<Pi>"
    using assms(1) is_valid_problem_sas_plus_then_strips_transformation_too
    by blast
  moreover have "STRIPS_Semantics.is_parallel_solution_for_problem ?\<Pi> ?\<pi>"
    using execute_serial_plan_sas_plus_is_execute_parallel_plan_sas_plus[OF assms(1,2)]
      strips_equivalent_to_sas_plus[OF assms(1)]
    by blast
  moreover {
    fix k
    assume "k < length ?\<pi>"
    moreover obtain ops' where "ops' = ?\<pi> ! k"
      by simp
    moreover have "ops' \<in> set ?\<pi>"
      using calculation nth_mem
      by blast
    moreover have "?\<pi> = [[\<phi>\<^sub>O \<Psi> op. op \<leftarrow> ops]. ops \<leftarrow> embed \<psi>]"
      unfolding SAS_Plus_STRIPS.sas_plus_parallel_plan_to_strips_parallel_plan_def
        sasp_op_to_strips_def
        sas_plus_parallel_plan_to_strips_parallel_plan_def
      ..
    moreover obtain ops
      where "ops' = [\<phi>\<^sub>O \<Psi> op. op \<leftarrow> ops]"
        and "ops \<in> set (embed \<psi>)"
      using calculation(3, 4)
      by auto
    moreover have "ops \<in> { [op] | op. op \<in> set \<psi> }"
      using calculation(6) set_of_embed_is
      by blast
    moreover obtain op
      where "ops = [op]" and "op \<in> set \<psi>"
      using calculation(7)
      by blast
    ultimately have "are_all_operators_non_interfering (?\<pi> ! k)"
      by fastforce
  }
  ultimately show ?thesis
    using encode_problem_serializable_complete nb
    by (auto simp: assms(3))
qed

text \<open> To wrap-up our documentation of the Isabelle formalization, we take a look at the central
theorem which combines all the previous theorem to show that SAS+ problems \<^term>\<open>\<Psi>\<close> can be solved
using the planning as satisfiability framework.

A solution \<^term>\<open>\<psi>\<close> for the SAS+ problem \<^term>\<open>\<Psi>\<close> exists if and only if a model \<^term>\<open>\<A>\<close> and a
hypothesized plan length \<^term>\<open>t\<close> exist s.t.
@{text[display,indent=4] "\<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> \<Psi>) t"}
for the serializable SATPlan encoding of the corresponding STRIPS problem \<^term>\<open>\<Phi>\<^sub>\<forall> (\<phi> \<Psi>) t\<close> exist. \<close>
theorem  sas_plus_problem_has_serial_solution_iff:
  assumes "is_valid_problem_sas_plus \<Psi>"
  shows "(\<exists>\<psi>. is_serial_solution_for_problem \<Psi> \<psi>) \<longleftrightarrow> (\<exists>\<A> t. \<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> \<Psi>) t)"
  using sas_plus_problem_has_serial_solution_iff_i[OF assms]
    sas_plus_problem_has_serial_solution_iff_ii[OF assms]
  by blast

section \<open>Adding Noop actions to the SAS+ problem\<close>

text \<open>Here we add noop actions to the SAS+ problem to enable the SAT formula to be satisfiable if
      there are plans that are shorter than the given horizons.\<close>

definition "empty_sasp_action \<equiv> \<lparr>SAS_Plus_Representation.sas_plus_operator.precondition_of = [],
                                SAS_Plus_Representation.sas_plus_operator.effect_of = []\<rparr>"

lemma sasp_exec_noops: "execute_serial_plan_sas_plus s (replicate n empty_sasp_action) = s"
  by (induction n arbitrary: )
     (auto simp: empty_sasp_action_def STRIPS_Representation.is_operator_applicable_in_def
                 execute_operator_def)

definition
  "prob_with_noop \<Pi> \<equiv>
     \<lparr>SAS_Plus_Representation.sas_plus_problem.variables_of = SAS_Plus_Representation.sas_plus_problem.variables_of \<Pi>,
      SAS_Plus_Representation.sas_plus_problem.operators_of = empty_sasp_action # SAS_Plus_Representation.sas_plus_problem.operators_of \<Pi>,
      SAS_Plus_Representation.sas_plus_problem.initial_of = SAS_Plus_Representation.sas_plus_problem.initial_of \<Pi>,
      SAS_Plus_Representation.sas_plus_problem.goal_of = SAS_Plus_Representation.sas_plus_problem.goal_of \<Pi>,
      SAS_Plus_Representation.sas_plus_problem.range_of = SAS_Plus_Representation.sas_plus_problem.range_of \<Pi>\<rparr>"

lemma sasp_noops_in_noop_problem: "set (replicate n empty_sasp_action) \<subseteq> set (SAS_Plus_Representation.sas_plus_problem.operators_of (prob_with_noop \<Pi>))"
  by (induction n) (auto simp: prob_with_noop_def)

lemma noops_complete:
  "SAS_Plus_Semantics.is_serial_solution_for_problem \<Psi> \<pi> \<Longrightarrow>
     SAS_Plus_Semantics.is_serial_solution_for_problem (prob_with_noop \<Psi>) ((replicate n empty_sasp_action) @ \<pi>)"
  by(induction n)
    (auto simp: SAS_Plus_Semantics.is_serial_solution_for_problem_def insert list.pred_set
                    sasp_exec_noops prob_with_noop_def Let_def empty_sasp_action_def elem)

definition "rem_noops \<equiv> filter (\<lambda>op. op \<noteq> empty_sasp_action)"

lemma sasp_filter_empty_action:
  "execute_serial_plan_sas_plus s (rem_noops \<pi>s) = execute_serial_plan_sas_plus s \<pi>s"
  by (induction \<pi>s arbitrary: s)
     (auto simp: empty_sasp_action_def rem_noops_def)

lemma noops_sound:
  "SAS_Plus_Semantics.is_serial_solution_for_problem (prob_with_noop \<Psi>) \<pi>s \<Longrightarrow>
     SAS_Plus_Semantics.is_serial_solution_for_problem \<Psi> (rem_noops \<pi>s)"
  by(induction \<pi>s)
    (fastforce simp: SAS_Plus_Semantics.is_serial_solution_for_problem_def insert list.pred_set
                     prob_with_noop_def ListMem_iff rem_noops_def
                     sasp_filter_empty_action[unfolded empty_sasp_action_def rem_noops_def]
                     empty_sasp_action_def)+

lemma noops_valid: "is_valid_problem_sas_plus \<Psi> \<Longrightarrow> is_valid_problem_sas_plus (prob_with_noop \<Psi>)"
  by (auto simp: is_valid_problem_sas_plus_def prob_with_noop_def Let_def
                 empty_sasp_action_def is_valid_operator_sas_plus_def list.pred_set)

lemma sas_plus_problem_has_serial_solution_iff_i':
  assumes "is_valid_problem_sas_plus \<Psi>"
    and "\<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> (prob_with_noop \<Psi>)) t"
  shows "SAS_Plus_Semantics.is_serial_solution_for_problem \<Psi>
           (rem_noops
                   (map (\<lambda>op. \<phi>\<^sub>O\<inverse> (prob_with_noop \<Psi>) op)
                        (concat (\<Phi>\<inverse> (\<phi> (prob_with_noop \<Psi>)) \<A> t))))"
  using assms noops_valid
  by(force intro!: noops_sound sas_plus_problem_has_serial_solution_iff_i)

lemma sas_plus_problem_has_serial_solution_iff_ii':
  assumes "is_valid_problem_sas_plus \<Psi>"
    and "SAS_Plus_Semantics.is_serial_solution_for_problem \<Psi> \<psi>"
    and "length \<psi> \<le> h"
  shows "\<exists>\<A>. (\<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> (prob_with_noop \<Psi>)) h)"
  using assms
  by(fastforce
       intro!: assms noops_valid noops_complete
               sas_plus_problem_has_serial_solution_iff_ii
                 [where \<psi> = "(replicate (h - length \<psi>) empty_sasp_action) @ \<psi>"] )
end


(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

section \<open>Algebraic laws for abrupt designs\<close>

theory algebraic_laws_prog
  imports "../impl/utp_prog_des_more"
begin

(* TODO: add laws for assigns when composed with try catch...

sledgehammer_params[(*stop_on_first,*)parallel_subgoals, join_subgoals]*)

named_theorems algebraic_laws_prog

lemma Abs_prog_Rep_prog_ndesign:"\<lbrakk>Abs_prog (\<^bold>N P)\<rbrakk>\<^sub>p = (\<^bold>N P)"
  by (simp add: Abs_prog_inverse H1_H3_idempotent Healthy_def')

lemmas Abs_prog_Rep_prog_Ncarrier=
  Abs_prog_Rep_prog_ndesign[folded Ncarrier_ndesigns]

lemma fun_apply_rep_prog:
  "\<lbrakk>f X\<rbrakk>\<^sub>p = (Rep_prog \<circ> f \<circ> Abs_prog) \<lbrakk>X\<rbrakk>\<^sub>p"
  by (simp add: Rep_prog_inverse)

subsection Skip

text \<open>In this section we introduce the algebraic laws of programming related to the SKIP
      statement.\<close>

lemma skip_prog_left_unit [algebraic_laws_prog]:
  "(SKIP ; P) = P"
  by simp

lemma skip_prog_right_unit[algebraic_laws_prog]:
  "(P ; SKIP) = P"
  by simp

subsection \<open>Assignment Laws\<close>
text \<open>In this section we introduce the algebraic laws of programming related to the assignment
      statement.\<close>

lemma usubst_assign_p_apply:
  "\<sigma> \<dagger> \<langle>\<rho>\<rangle>\<^sub>p = \<langle>\<rho> o \<sigma>\<rangle>\<^sub>p"
  by (simp add: prog_rep_eq usubst)

lemma assigns_prog_id [algebraic_laws_prog]: "\<langle>id\<rangle>\<^sub>p = SKIP"
  by (simp add: prog_rep_eq)

lemma assigns_prog_test[algebraic_laws_prog]:
  assumes 1:"mwb_lens x"
  shows     "(x :== \<guillemotleft>u\<guillemotright> ; x :== \<guillemotleft>v\<guillemotright>) = (x :== \<guillemotleft>v\<guillemotright>)"
  using 1
  by (simp add: prog_rep_eq assign_design_test)

lemma assigns_prog_left_subst: (*we need to re express the algebraic laws for substitution*)
  "(x :== u ; P) = (psubst [x \<mapsto>\<^sub>s u] P)"
  by (simp add: prog_rep_eq  usubst H1_H3_impl_H2 Rep_prog_H1_H3_closed assigns_d_comp_ext )

lemma assigns_prog_twice[algebraic_laws_prog]:
  assumes "mwb_lens x" and  "x \<sharp> f"
  shows "(x :== e ; x :== f) = (x :== f)"
  using assms
  by (simp add: prog_rep_eq assign_d_twice)

lemma assigns_prog_commute:
  assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
  shows "(x :== e ; y :==  f) = (y :== f ; x :==  e)"
  using assms
  by (simp add: prog_rep_eq assigns_d_commute)

lemma assigns_prog_left_cond_cond[algebraic_laws_prog]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(x :== e ; (IF b THEN P ELSE Q FI)) =
         (IF (b\<lbrakk>e/x\<rbrakk>) THEN (x :== e ; P) ELSE (x :== e ; Q) FI)"
  by (simp add: prog_rep_eq closure assigns_d_left_cond_d_ndesigns)

lemma assigns_prog_uop1[algebraic_laws_prog]:
  assumes 1: "mwb_lens v"
  shows "(v :== e1 ; v :== (uop F (&v))) = (v :== (uop F e1))"
  by (simp add: prog_rep_eq assigns_d_uop1 assms)

lemma assign_prog_bop1[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v :== e1 ; v :== (bop bp (&v) e2)) = (v :== (bop bp e1 e2))"
  by (simp add: prog_rep_eq assign_d_bop1 assms)

lemma assign_prog_bop2[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2"
  shows "(v :== e1 ; v :== (bop bp e2 (&v))) = (v :== (bop bp e2 e1))"
  by (simp add: prog_rep_eq assign_d_bop2 assms)

lemma assign_prog_trop1[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v :== e1 ; v :== (trop tp (&v) e2 e3)) =
         (v :== (trop tp e1 e2 e3))"
  by (simp add: prog_rep_eq assign_d_trop1 assms)

lemma assign_prog_trop2[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v :== e1 ; v :== (trop tp e2 (&v) e3)) =
         (v :== (trop tp e2 e1 e3))"
  by (simp add: prog_rep_eq assign_d_trop2 assms)

lemma assign_prog_trop3[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3"
  shows "(v :== e1 ; v :== (trop tp e2 e3 (&v))) =
         (v :== (trop tp e2 e3 e1))"
  by (simp add: prog_rep_eq assign_d_trop3 assms)

lemma assign_prog_qtop1[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ; v :== (qtop tp (&v) e2 e3 e4)) =
         (v :== (qtop tp e1 e2 e3 e4))"
  by (simp add: prog_rep_eq assign_d_qtop1 assms)

lemma assign_prog_qtop2[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ; v :== (qtop tp e2 (&v) e3 e4)) =
         (v :== (qtop tp e2 e1 e3 e4))"
  by (simp add: prog_rep_eq assign_d_qtop2 assms)

lemma assign_prog_qtop3[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ; v :== (qtop tp e2 e3 (&v) e4)) =
         (v :== (qtop tp e2 e3 e1 e4))"
  by (simp add: prog_rep_eq assign_d_qtop3 assms)

lemma assign_prog_qtop4[algebraic_laws_prog]:
  assumes 1: "mwb_lens v" and 2:"v \<sharp> e2" and 3:"v \<sharp> e3" and 4:"v \<sharp> e4"
  shows "(v :== e1 ; v :== (qtop tp e2 e3 e4 (&v))) =
         (v :== (qtop tp e2 e3 e4 e1))"
  by (simp add: prog_rep_eq assign_d_qtop4 assms)

text \<open>In the sequel we define assignment laws proposed by Hoare\<close>

lemma assign_prog_vwb_skip_prog[algebraic_laws_prog]:
  assumes 1: "vwb_lens v"
  shows "(v :== &v) = SKIP"
  by (simp add: assms prog_rep_eq assign_d_vwb_skip_d)

lemma assign_prog_simultaneous:
  assumes  1: "vwb_lens var2"
  and      2: "var1 \<bowtie> var2"
  shows "var1, var2 :== expr, &var2 = var1 :== expr"
  by (simp add: assms assign_d_simultaneous prog_rep_eq)

lemma assign_prog_seq[algebraic_laws_prog]:
  assumes  1: "vwb_lens var2"
  shows"(var1 :== expr) ; (var2 :== &var2) = (var1 :== expr)"
  by (simp add: assms prog_rep_eq assign_d_seq)

lemma assign_prog_cond_prog_uop[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v"
  shows "IF uop F expr THEN (v :== expr ;  C1) ELSE (v :== expr ; C2) FI =
          v :== expr ; IF uop F (&v) THEN  C1 ELSE C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_uop_ndesigns)

lemma assign_prog_cond_bop1[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "IF bop bp expr exp2 THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
          v :== expr ; IF bop bp (&v) exp2 THEN C1 ELSE C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_bop1_ndesigns)

lemma assign_prog_cond_bop2[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2"
  shows "IF bop bp exp2 expr THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
          v :== expr ; IF bop bp  exp2 (&v) THEN  C1 ELSE C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_bop2_ndesigns)

lemma assign_prog_cond_prog_trop1[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "IF trop bp expr exp2 exp3 THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
         v :== expr ; IF trop bp (&v) exp2 exp3 THEN  C1 ELSE  C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_trop1_ndesigns)

lemma assign_prog_cond_prog_trop2[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "IF trop bp exp2 expr exp3 THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
         v :== expr ; IF trop bp exp2 (&v) exp3 THEN C1 ELSE C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_trop2_ndesigns)

lemma assign_prog_cond_prog_trop3[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3"
  shows "IF trop bp exp2 exp3 expr THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
         v :== expr ; IF trop bp exp2 exp3 (&v) THEN  C1 ELSE C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_trop3_ndesigns)

lemma assign_prog_cond_prog_qtop1[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "IF qtop bp expr exp2 exp3 exp4 THEN (v :== expr ; Simpl\<^sub>A\<^sub>B\<^sub>R C1) ELSE (v :== expr ; Simpl\<^sub>A\<^sub>B\<^sub>R C2) FI =
         v :== expr ; IF qtop bp (&v) exp2 exp3 exp4 THEN Simpl\<^sub>A\<^sub>B\<^sub>R C1 ELSE Simpl\<^sub>A\<^sub>B\<^sub>R C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_qtop1_ndesigns)

lemma assign_prog_cond_prog_qtop2[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4:"v \<sharp> exp4"
  shows "IF qtop bp exp2 expr  exp3 exp4 THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
         v :== expr ; IF qtop bp exp2 (&v) exp3 exp4 THEN C1 ELSE C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_qtop2_ndesigns)

lemma assign_prog_cond_prog_qtop3[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "IF qtop bp exp2 exp3 expr exp4 THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
         v :== expr ; IF qtop bp exp2 exp3 (&v) exp4 THEN C1 ELSE  C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_qtop3_ndesigns)

lemma assign_prog_cond_prog_qtop4[algebraic_laws_prog]: (*needs more laws to be automatic*)
  assumes 1: "weak_lens v" and 2: "v \<sharp> exp2" and 3: "v \<sharp> exp3" and 4: "v \<sharp> exp4"
  shows "IF qtop bp exp2 exp3 exp4 expr THEN (v :== expr ; C1) ELSE (v :== expr ; C2) FI =
         v :== expr ; IF qtop bp exp2 exp3 exp4 (&v) THEN C1 ELSE C2 FI"
  by (simp add: assms prog_rep_eq closure assign_d_cond_d_qtop4_ndesigns)

lemma assigns_prog_cond_prog[algebraic_laws_prog]:
  "(IF bexp THEN (v :== exp1) ELSE (v :== exp2) FI) =
   (v :== (exp1 \<triangleleft> bexp \<triangleright> exp2))"
  by (simp add: prog_rep_eq closure assign_d_cond_d_If)

subsection \<open>Conditional laws\<close>

lemma if_prog_pusbst_distr[usubst]:
 "\<sigma> \<dagger>  (IF b THEN P ELSE Q FI) =  IF \<sigma> \<dagger> b THEN \<sigma> \<dagger> P ELSE \<sigma> \<dagger> Q FI"
  by (simp add: prog_rep_eq usubst)

lemma if_prog_idem[urel_cond]:
  "IF B THEN P ELSE P FI = P"
  by (simp add: prog_rep_eq urel_cond)

lemma if_prog_symm:
  "IF b THEN P ELSE Q FI = IF \<not>b THEN Q ELSE P FI"
  by pauto

lemma if_prog_assoc:
  "IF b THEN P ELSE IF b THEN Q ELSE R FI FI =
   IF b THEN IF b THEN P ELSE Q FI ELSE R FI"
  by pauto

lemma if_prog_distr'[urel_cond]:
  "IF b THEN IF b' THEN P ELSE R FI ELSE IF b' THEN Q ELSE R FI FI =
   IF b' THEN IF b THEN P ELSE Q FI ELSE R FI"
  by pauto

lemma if_prog_true:
  "IF true THEN P ELSE Q FI = P"
  by pauto

lemma if_prog_false:
  "IF false THEN P ELSE Q FI = Q"
  by pauto

lemma if_prog_L6[urel_cond]:
  "IF b THEN P ELSE IF b THEN Q ELSE R FI FI =
   IF b THEN P ELSE R FI"
  by pauto

lemma if_prog_conj[urel_cond]:
  "IF b \<and> c THEN P ELSE Q FI = IF b THEN IF c THEN P ELSE Q FI ELSE Q FI"
  by pauto

theorem if_prog_12:
  "IF bexp1 THEN (IF bexp2 THEN C1 ELSE C3 FI) ELSE (IF bexp3 THEN C2 ELSE C3 FI) FI =
   IF (bexp2 \<triangleleft>bexp1\<triangleright>bexp3) THEN  (IF bexp1 THEN C1 ELSE C2 FI) ELSE C3 FI"
  by pauto

lemma comp_prog_if_prog_left_distr:
  "((IF b THEN P ELSE Q FI); R) = (IF b THEN (P ; R) ELSE (Q ; R) FI)"
  by pauto

lemma seq_prog_monoI:
  "P\<^sub>1 \<sqsubseteq> P\<^sub>2 \<Longrightarrow> Q\<^sub>1 \<sqsubseteq> Q\<^sub>2  \<Longrightarrow> (P\<^sub>1 ; Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 ; Q\<^sub>2)"
   by (simp add: prog_rep_eq seqr_mono)

lemma if_prog_monoI:
  "P\<^sub>1 \<sqsubseteq> P\<^sub>2 \<Longrightarrow> Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<Longrightarrow> (IF b THEN P\<^sub>1 ELSE Q\<^sub>1 FI) \<sqsubseteq> (IF b THEN P\<^sub>2 ELSE Q\<^sub>2 FI)"
  by (simp add: prog_rep_eq cond_mono)

lemma if_prog_mono:
  "mono (\<lambda>X. IF b THEN P ; X ELSE Q FI)"
  by (auto intro: monoI seq_prog_monoI if_prog_monoI)

subsection \<open>sequential composition laws\<close>

lemma seq_psubst_prog:
  "\<langle>\<rho>\<rangle>\<^sub>p ; P = (\<rho> \<dagger> P)"
  by (simp add: prog_rep_eq usubst Rep_prog_H1_H3_closed [THEN H1_H2_impl_H1 [OF H1_H3_impl_H2]])

lemma seq_prog_assoc: "P ; (Q ; R) = (P ; Q) ; R"
  by (simp add: prog_rep_eq seqr_assoc)

subsection \<open>Monotonic laws\<close>

lemma Mono_progI:
  "(\<And>x y .x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y) \<Longrightarrow> mono_prog f"
  apply ptransfer
  apply (rule Mono_utp_orderI)
  apply (metis Abs_prog_Rep_prog_Ncarrier Healthy_if comp_apply)
  done

lemma Mono_progD:
  "mono_prog f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
  apply ptransfer
  apply (drule Mono_utp_orderD)
  unfolding fun_apply_rep_prog mono_prog_def
     apply simp_all
   apply (metis Healthy_def' Healthy_if Rep_prog_H1_H3_closed ndes_hcond_def)+
  done

lemma Mono_progE:
  "mono_prog f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> (f x \<sqsubseteq> f y \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  apply ptransfer
  unfolding fun_apply_rep_prog mono_prog_def
  using Mono_utp_orderD Rep_prog_H1_H3_closed is_Ncarrier_is_ndesigns
  by blast

lemma mono_Monotone_prog:
  assumes M:"mono F"
  shows "mono_prog F"
  by (simp add: Mono_progI assms monoD)

subsection \<open>Lattices laws\<close>
lemma least_prog_alt_def:
  "least_prog l A = (l \<in> A \<and> (ALL x : A. l \<sqsubseteq> x))"
  unfolding  prog_rep_eq least_def image_def Ball_def
  by (auto simp add: Rep_prog_inject Rep_prog_H1_H3_closed is_Ncarrier_is_ndesigns)

lemma Upper_prog_alt_def:
  "Upper_prog A = {u. (ALL x. x \<in> A \<longrightarrow> x \<sqsubseteq> u)}"
  unfolding   prog_rep_eq Upper_def image_def Ball_def Upper_prog_def
  apply auto
   apply (metis (mono_tags, lifting) Abs_prog_Rep_prog_Ncarrier Healthy_if
                                     Rep_prog_H1_H3_closed is_Ncarrier_is_ndesigns)
  apply (smt IntE IntI Rep_prog Rep_prog_inverse is_Ncarrier_is_ndesigns mem_Collect_eq)
  done

lemma Lower_prog_alt_def:
  "Lower_prog A = {l. (ALL x. x \<in> A \<longrightarrow> l \<sqsubseteq> x)}"
  unfolding   prog_rep_eq Lower_def image_def Ball_def Lower_prog_def
  apply auto
   apply (metis (mono_tags, lifting) Abs_prog_Rep_prog_Ncarrier Healthy_if Rep_prog_H1_H3_closed is_Ncarrier_is_ndesigns)
  apply (smt IntE IntI Rep_prog Rep_prog_inverse is_Ncarrier_is_ndesigns mem_Collect_eq)
  done

lemma greatest_prog_alt_def:
 "greatest_prog g A =  (g \<in> A \<and> (ALL x : A. x \<sqsubseteq> g))"
  unfolding  prog_rep_eq greatest_def image_def Ball_def
  by (auto simp add: Rep_prog_inject Rep_prog_H1_H3_closed is_Ncarrier_is_ndesigns)

lemma greatest_prog_unique:
 "greatest_prog y A\<Longrightarrow> greatest_prog x A \<Longrightarrow> x = y"
  by (simp add: Rep_prog_eq greatest_prog.rep_eq ndes_utp_theory.greatest_unique)

lemma least_prog_unique:
  "least_prog y A\<Longrightarrow> least_prog x A \<Longrightarrow> x = y"
  by (simp add: Rep_prog_eq least_prog.rep_eq ndes_utp_theory.least_unique)

lemma sup_prog_empty:
  "\<Squnion>\<^sub>p{} = ABORT"
  by (simp add: prog_rep_eq utp_theory_ndes_bot_is_true)

lemma sup_prog_univ:
  "\<Squnion>\<^sub>pUNIV = MAGIC"
  apply (simp add: prog_rep_eq sup_def least_def Upper_def)
  apply (rule someI2_ex)
   apply (rule exI[where x = "(\<not> $ok)"])
   apply auto[]
     apply (metis H1_below_top Healthy_if ndes_hcond_def)
    apply rel_simp
   apply (metis des_top_is_H1_H3 is_Ncarrier_is_ndesigns magic.rep_eq range_eqI)
  apply auto[]
  apply (metis (no_types, hide_lams) H1_below_top Healthy_if antisym_conv des_top_ndes_def
         magic.rep_eq ndes_hcond_def ndesign_is_healthy_NDES range_eqI)
  done

lemma inf_prog_empty:
  "\<Sqinter>\<^sub>p{} = MAGIC"
  by (simp add: prog_rep_eq utp_theory_ndes_top_is_not_ok)

lemma inf_prog_univ:
  "\<Sqinter>\<^sub>pUNIV = ABORT"
  apply (simp add: prog_rep_eq )
  by (metis (no_types, lifting)  Rep_prog UNIV_I image_empty image_subsetI
      image_subset_iff normal_design_theory_continuous.bottom_lower
      normal_design_theory_continuous.inf_closed normal_design_theory_continuous.inf_lower
      normal_design_theory_continuous.weak_sup_empty order_antisym_conv order_refl
      sup_prog.rep_eq utp_theory_ndes_bot_is_true)

lemma sup_prog_least:
  "(\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> z) \<Longrightarrow> \<Squnion>\<^sub>p A \<sqsubseteq> z"
  apply (simp only: prog_rep_eq)
  apply (rule normal_design_theory_continuous.weak.sup_least)
  using  Rep_prog
    apply auto
  done

lemma sup_prog_Upper:
  "x \<in> A \<Longrightarrow> x \<sqsubseteq> \<Squnion>\<^sub>p A "
  apply (simp only: prog_rep_eq)
  apply (metis (mono_tags, lifting) Rep_prog ball_imageD image_subsetI normal_design_theory_continuous.sup_upper)
  done

lemma sup_H1_H3_in_Upper:
  "(\<And>x. x \<in> A \<Longrightarrow> x is \<^bold>N ) \<Longrightarrow> \<^bold>\<Squnion>\<^bsub>NDES\<^esub>A \<in> Upper (uthy_order NDES) A"
  unfolding Upper_def
  apply auto
   apply (rule normal_design_theory_continuous.sup_upper )
    apply (simp_all add: is_Ncarrier_is_ndesigns subsetI)
  done

lemma sup_prog_in_Upper_prog:
  "(\<Squnion>\<^sub>p A) \<in> (Upper_prog A)"
  by (metis (mono_tags, lifting) Rep_prog_H1_H3_closed Upper_prog_def imageE image_eqI map_fun_def
                                 o_def sup_H1_H3_in_Upper sup_prog_def)

lemma sup_H1_H3_is_least_Upper:
  "(\<And>x. x \<in> A \<Longrightarrow> x is \<^bold>N) \<Longrightarrow> least (uthy_order NDES) (\<^bold>\<Squnion>\<^bsub>NDES\<^esub> A) (Upper (uthy_order NDES) A)"
  unfolding least_def
  apply (auto simp add: is_Ncarrier_is_ndesigns)
    apply (metis Upper_closed is_Healthy_subset_member is_Ncarrier_is_ndesigns utp_order_carrier)
  using sup_H1_H3_in_Upper apply auto[1]
  apply (rule normal_design_theory_continuous.weak.sup_least)
    apply (auto simp add: Upper_def is_Ncarrier_is_ndesigns )
  done

lemma sup_prog_is_least_Upper_prog:
  "least_prog (\<Squnion>\<^sub>p A) (Upper_prog A)"
  by (metis (mono_tags, lifting) Rep_prog_H1_H3_closed Upper_prog.rep_eq imageE least_prog.rep_eq
                                 sup_H1_H3_is_least_Upper sup_prog.rep_eq)

lemma sup_prog_alt_def:
  "(\<Squnion>\<^sub>p A) = (SOME x. least_prog x (Upper_prog A))"
  apply (rule someI2_ex)
  using sup_prog_is_least_Upper_prog
   apply blast
  apply (simp only: prog_rep_eq)
  apply (metis Upper_prog.rep_eq least_prog.rep_eq ndes_utp_theory.least_unique sup_prog.rep_eq sup_prog_is_least_Upper_prog)
  done

lemma inf_prog_greatest:
  "(\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x ) \<Longrightarrow> z \<sqsubseteq> \<Sqinter>\<^sub>p A"
  apply (simp only: prog_rep_eq)
  apply (rule normal_design_theory_continuous.weak.inf_greatest)
  using  Rep_prog
    apply auto
  done

lemma inf_prog_lower:
  "x \<in> A \<Longrightarrow> \<Sqinter>\<^sub>p A \<sqsubseteq> x"
  apply (simp only: prog_rep_eq)
  apply (meson Rep_prog image_eqI image_subsetI normal_design_theory_continuous.inf_lower)
  done

lemma inf_prog_lower2:
  "u \<in> A \<Longrightarrow> u \<sqsubseteq> v \<Longrightarrow> (\<Sqinter>\<^sub>p A) \<sqsubseteq> v"
  using inf_prog_lower [of u A] by auto

lemma inf_H1_H3_in_lower:
  "(\<And>x. x \<in> A \<Longrightarrow> x is \<^bold>N ) \<Longrightarrow> \<^bold>\<Sqinter>\<^bsub>NDES\<^esub>A \<in> Lower (uthy_order NDES) A"
  unfolding Lower_def
  apply auto
   apply (rule normal_design_theory_continuous.inf_lower )
    apply (simp_all add: is_Ncarrier_is_ndesigns subsetI)
  done

lemma inf_prog_in_lower_prog:
  "(\<Sqinter>\<^sub>p A) \<in> (Lower_prog A)"
  by (metis (mono_tags, lifting) Rep_prog_H1_H3_closed Lower_prog_def imageE image_eqI map_fun_def
                                 o_def inf_H1_H3_in_lower inf_prog_def)

lemma inf_H1_H3_is_greatest_lower:
  "(\<And>x. x \<in> A \<Longrightarrow> x is \<^bold>N) \<Longrightarrow> greatest (uthy_order NDES) (\<^bold>\<Sqinter>\<^bsub>NDES\<^esub> A) (Lower (uthy_order NDES) A)"
  unfolding greatest_def
  apply (auto simp add: is_Ncarrier_is_ndesigns)
    apply (metis Lower_closed is_Healthy_subset_member is_Ncarrier_is_ndesigns utp_order_carrier)
  using inf_H1_H3_in_lower apply auto[1]
  apply (rule normal_design_theory_continuous.weak.inf_greatest)
    apply (auto simp add: Lower_def is_Ncarrier_is_ndesigns )
  done

lemma inf_prog_is_greatest_lower_prog:
  "greatest_prog (\<Sqinter>\<^sub>p A) (Lower_prog A)"
  by (metis (mono_tags, lifting) Rep_prog_H1_H3_closed Lower_prog.rep_eq imageE greatest_prog.rep_eq
                                 inf_H1_H3_is_greatest_lower inf_prog.rep_eq)

lemma inf_prog_alt_def:
  "(\<Sqinter>\<^sub>p A) = (SOME x. greatest_prog x (Lower_prog A))"
  apply (rule someI2_ex)
  using inf_prog_is_greatest_lower_prog
   apply blast
  apply (simp only: prog_rep_eq)
  apply (metis Lower_prog.rep_eq greatest_prog.rep_eq ndes_utp_theory.greatest_unique inf_prog.rep_eq inf_prog_is_greatest_lower_prog)
  done

lemma meet_prog_alt_def:
  "a \<sqinter>\<^sub>p b = \<Sqinter>\<^sub>p{a, b}"
  by (simp add: prog_rep_eq meet_def)

lemma utp_join_prog_alt_def:
  "a \<squnion>\<^sub>p b = \<Squnion>\<^sub>p{a, b}"
  by (simp add: prog_rep_eq join_def)

subsection \<open>Fixed points laws\<close>

lemma gfp_prog_alt_def:
  "\<nu>\<^sub>p F = \<Squnion>\<^sub>p{x. x \<sqsubseteq> F x}"
  apply (simp only: prog_rep_eq)
  unfolding GFP_def sup_def image_def
  apply auto
  apply (rule someI2_ex)
   apply (rule exI[where x = "\<^bold>\<Squnion>\<^bsub>NDES\<^esub> {y. \<exists>x. \<lbrakk>x\<rbrakk>\<^sub>p \<sqsubseteq> \<lbrakk>F x\<rbrakk>\<^sub>p \<and> y = \<lbrakk>x\<rbrakk>\<^sub>p}"])
    (*Test Timeout bug of sledgehammer para*)
   apply (rule sup_H1_H3_is_least_Upper)
  using Rep_prog
   apply fastforce
  apply (rule someI2_ex)
   apply (rule exI[where x = "\<^bold>\<Squnion>\<^bsub>NDES\<^esub> {u. (u is \<H>\<^bsub>NDES\<^esub>) \<and> u \<sqsubseteq> \<lbrakk>F (Abs_prog u)\<rbrakk>\<^sub>p}"])
   apply (rule sup_H1_H3_is_least_Upper)
   apply (simp add: is_Ncarrier_is_ndesigns)
  apply (rule ndes_utp_theory.least_unique)
   apply auto
  unfolding least_def Upper_def
  apply auto
   apply (simp add: Rep_prog_inverse)
  unfolding Ball_def
  apply auto
  apply (metis Abs_prog_Rep_prog_Ncarrier Healthy_if)
  done

lemma lfp_prog_alt_def:
  "\<mu>\<^sub>p F = \<Sqinter>\<^sub>p{x. F x \<sqsubseteq> x}"
  apply (simp only: prog_rep_eq)
  unfolding LFP_def inf_def image_def
  apply auto
  apply (rule someI2_ex)
   apply (rule exI[where x = "\<^bold>\<Sqinter>\<^bsub>NDES\<^esub>{y. \<exists>x. \<lbrakk>F x\<rbrakk>\<^sub>p \<sqsubseteq> \<lbrakk>x\<rbrakk>\<^sub>p \<and> y = \<lbrakk>x\<rbrakk>\<^sub>p}"])
   apply (rule inf_H1_H3_is_greatest_lower)
  using Rep_prog
   apply fastforce
  apply (rule someI2_ex)
   apply (rule exI[where x="\<^bold>\<Sqinter>\<^bsub>NDES\<^esub>{u. (u is \<H>\<^bsub>NDES\<^esub>) \<and> \<lbrakk>F (Abs_prog u)\<rbrakk>\<^sub>p \<sqsubseteq> u}"])
   apply (rule inf_H1_H3_is_greatest_lower)
   apply (simp add: is_Ncarrier_is_ndesigns)
  apply (rule  ndes_utp_theory.greatest_unique)
   apply auto
  unfolding greatest_def Lower_def Ball_def
  apply auto
   apply (simp add: Rep_prog_inverse)
  apply (metis Abs_prog_Rep_prog_Ncarrier Healthy_if)
  done

lemma lfp_prog_unfold:
  assumes M:"mono_prog F"
  shows "\<mu>\<^sub>p F = F (\<mu>\<^sub>p F)"
proof -
    show ?thesis
    apply (simp only: prog_rep_eq)
    unfolding fun_apply_rep_prog  prec_lfp_prog.rep_eq
    apply (subst (1) normal_design_theory_continuous.LFP_healthy_comp)
    apply (subst (2) normal_design_theory_continuous.LFP_healthy_comp)
    using M
      by (metis (mono_tags, lifting) Pi_I Rep_prog mono_prog.rep_eq normal_design_theory_continuous.LFP_healthy_comp normal_design_theory_continuous.LFP_unfold o_def)
qed

lemma gfp_prog_unfold:
  assumes M : "mono_prog F"
  shows "\<nu>\<^sub>p F = F (\<nu>\<^sub>p F)"
  apply (simp only: prog_rep_eq)
  unfolding fun_apply_rep_prog prec_gfp_prog.rep_eq
      apply (subst (1) normal_design_theory_continuous.GFP_healthy_comp)
  apply (subst (2) normal_design_theory_continuous.GFP_healthy_comp)
  using M
  apply (metis (mono_tags, lifting) Pi_I Rep_prog mono_prog.rep_eq normal_design_theory_continuous.GFP_healthy_comp normal_design_theory_continuous.GFP_unfold o_def)
  done

lemma lfp_prog_const: "\<mu>\<^sub>p (\<lambda>x. t) = t"
  by (simp add: mono_prog.rep_eq lfp_prog_unfold utp_theory.Mono_utp_orderI)

lemma gfp_prog_const:
  "\<nu>\<^sub>p (\<lambda>x. t) = t"
  by (simp add: Mono_progI gfp_prog_unfold)

lemma lfp_prog_idem:
  "mono_prog F \<Longrightarrow> idem_prog F \<Longrightarrow> \<mu>\<^sub>p F = F ABORT"
proof (ptransfer,
       subst normal_design_theory_continuous.weak.LFP_idem[unfolded utp_theory_ndes_bot_is_true],
       goal_cases)
  case 1
  then show ?case using Rep_prog by fastforce
next
  case 2
  then show ?case by simp
next
  case 3
  then show ?case by simp
next
  case 4
  then show ?case unfolding fun_apply_rep_prog by (simp add: abort.rep_eq)
qed

lemma gfp_prog_idem:
  "mono_prog F \<Longrightarrow> idem_prog F \<Longrightarrow> \<nu>\<^sub>p F = F MAGIC"
proof (ptransfer,
       subst normal_design_theory_continuous.weak.GFP_idem[unfolded utp_theory_ndes_top_is_not_ok],
       goal_cases)
  case 1
  then show ?case using Rep_prog by fastforce
next
  case 2
  then show ?case by simp
next
  case 3
  then show ?case by simp
next
  case 4
  then show ?case  unfolding fun_apply_rep_prog by (simp add: magic.rep_eq)
qed

lemma lfp_prog_lowerbound:
  "F x \<sqsubseteq> x \<Longrightarrow> \<mu>\<^sub>p F \<sqsubseteq> x"
  by (simp add: inf_prog_lower lfp_prog_alt_def)

lemma gfp_prog_upperbound:
  "x \<sqsubseteq> F x \<Longrightarrow> x \<sqsubseteq> \<nu>\<^sub>p F"
  by (simp add: gfp_prog_alt_def sup_prog_Upper)

lemma lfp_prog_greatest:
  "(\<And>z. F z \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z) \<Longrightarrow> x \<sqsubseteq> \<mu>\<^sub>p F"
  by (metis (full_types) CollectD inf_prog_greatest lfp_prog_alt_def)

lemma gfp_prog_least:
  "(\<And>z.  z \<sqsubseteq> F z \<Longrightarrow> z \<sqsubseteq> x ) \<Longrightarrow> \<nu>\<^sub>p F \<sqsubseteq> x"
  by (metis (no_types, lifting) CollectD gfp_prog_alt_def sup_prog_least)

lemma lfp_prog_mono:
  "(\<And>x. F x \<sqsubseteq> G x)\<Longrightarrow> \<mu>\<^sub>p F \<sqsubseteq> \<mu>\<^sub>p G"
  apply (rule lfp_prog_lowerbound[THEN lfp_prog_greatest])
  apply (blast intro: order_trans)
  done

lemma gfp_prog_mono:
  "(\<And>x. F x \<sqsubseteq> G x) \<Longrightarrow> \<nu>\<^sub>p F \<sqsubseteq> \<nu>\<^sub>p G"
  apply (rule gfp_prog_upperbound[THEN gfp_prog_least])
    apply (blast intro: order_trans)
  done

lemma lfp_prog_fixed_point:
   "F x = x \<Longrightarrow> \<mu>\<^sub>p F \<sqsubseteq> x"
   by (simp add: lfp_prog_lowerbound)

lemma gfp_prog_ficed_point:
  "x = F x \<Longrightarrow> x \<sqsubseteq> \<nu>\<^sub>p F"
  by (simp add: gfp_prog_upperbound)

subsection \<open>While laws for programs\<close>

text \<open>In this section we introduce the algebraic laws of programming related to the while
      statement.\<close>

lemma while_lfp_prog_mu_prog:
  "WHILE b DO body OD = (\<mu>\<^sub>p X \<bullet> IF b THEN body ; X ELSE SKIP FI)"
  unfolding  while_lfp_prog_def from_until_lfp_prog_def skip_prog_left_unit
  by simp

theorem while_lfp_prog_unfold:
  "WHILE b DO body OD = (IF b THEN (body ; WHILE b DO body OD) ELSE SKIP FI)"
proof -
  have "(WHILE b DO body OD) = (\<mu>\<^sub>p X \<bullet> IF b THEN (body ; X) ELSE SKIP FI)"
    by (simp add: while_lfp_prog_mu_prog)
  also have "... = (IF b THEN (body ; (\<mu>\<^sub>p X \<bullet> IF b THEN (body ; X) ELSE SKIP FI)) ELSE SKIP FI)"
    proof (rule lfp_prog_unfold[OF Mono_progI ], goal_cases)
      case (1 x y)
      then show ?case by (simp add: if_prog_monoI seq_prog_monoI)
    qed
  also have "... = (IF b THEN (body ; WHILE b DO body OD) ELSE SKIP FI)"
    by (simp add: while_lfp_prog_mu_prog)
  finally show ?thesis .
qed

theorem while_lfp_prog_true:
  "WHILE true DO body OD = (\<mu>\<^sub>p X \<bullet>  body ; X)"
  unfolding while_lfp_prog_mu_prog  if_prog_true ..

lemma while_lfp_prog_false:
  "(WHILE false DO body OD) = SKIP"
  unfolding while_lfp_prog_mu_prog if_prog_false
  by (simp add: lfp_prog_const)

lemma while_lfp_prog_non_termination:
  "WHILE true DO SKIP OD = ABORT"
  unfolding while_lfp_prog_mu_prog if_prog_true
  by (auto simp add: lfp_prog_idem Mono_progI Rep_prog_inverse idem_prog.rep_eq idempotent_def)

subsection \<open>Iteration laws\<close>

lemma from_until_lfp_prog_def_alt:
  "FROM init UNTIL b DO body OD = init ; WHILE \<not>b DO body OD"
  unfolding from_until_lfp_prog_def while_lfp_prog_mu_prog ..

lemma from_until_lfp_prog_unfold:
  "FROM init UNTIL b DO body OD = init ; IF \<not>b THEN body ; WHILE \<not>b DO body OD ELSE SKIP FI"
  unfolding from_until_lfp_prog_def_alt
  using while_lfp_prog_unfold[of "\<not>b" body]
  by simp

lemma from_until_lfp_prog_true:
  "FROM init UNTIL true DO body OD = init"
  unfolding from_until_lfp_prog_def_alt
  by (simp add: while_lfp_prog_false)

lemma from_until_lfp_prog_non_termination: (*should equal abort situation*)
  "FROM init UNTIL false DO SKIP OD = init ; ABORT"
  unfolding from_until_lfp_prog_def_alt
  by (simp add: while_lfp_prog_non_termination)

lemma do_while_lfp_prog_def_alt:
  "DO body WHILE b OD = body ; WHILE b DO body OD"
  unfolding do_while_lfp_prog_def from_until_lfp_prog_def_alt
  by simp

lemma do_while_lfp_prog_unfold:
  "DO body WHILE b OD = body ; IF b THEN body; WHILE b DO body OD ELSE SKIP FI"
  unfolding do_while_lfp_prog_def_alt
  using while_lfp_prog_unfold[of b body]
  by simp

lemma do_while_lfp_prog_false:
  "DO body WHILE false OD = body"
  unfolding do_while_lfp_prog_def_alt
  by (simp add: while_lfp_prog_false)

lemma do_while_lfp_prog_non_termination:(*should equal abort situation*)
  "DO SKIP WHILE true OD = ABORT"
  unfolding do_while_lfp_prog_def_alt
  by (simp add: while_lfp_prog_non_termination)

lemma for_lfp_prog_def_alt:
  "FOR (init, b, incr) DO body OD =
   init ; WHILE b DO body ; incr OD"
  unfolding for_lfp_prog_def from_until_lfp_prog_def_alt
  by simp

lemma for_lfp_prog_unfold:
  "FOR (init, b, incr) DO body OD =
   init; IF b THEN body; incr; WHILE b DO body; incr OD ELSE SKIP FI"
  unfolding for_lfp_prog_def_alt
  using while_lfp_prog_unfold [of b "body;incr"] seq_prog_assoc[THEN HOL.sym]
  by metis

lemma for_lfp_prog_false:
  "FOR (init, false, incr) DO body OD = init"
  unfolding for_lfp_prog_def_alt
  by (simp add: while_lfp_prog_false)

lemma for_lfp_prog_non_termination:
  "FOR (init, true, incr) DO SKIP OD = init; WHILE true DO incr OD"
  unfolding for_lfp_prog_def_alt
  by (simp add: while_lfp_prog_non_termination)

subsection \<open>assume laws\<close>

lemma assume_twice[algebraic_laws_prog]: "((b\<^sup>\<top>\<^sup>P) ; (c\<^sup>\<top>\<^sup>P)) = (b \<and> c)\<^sup>\<top>\<^sup>P"
  by (simp add: prog_rep_eq) (metis assume_d_twice assume_des_def)

lemma assert_twice[algebraic_laws_prog]: "(b\<^sub>\<bottom>\<^sub>P ; (c\<^sub>\<bottom>\<^sub>P)) = (b \<and> c)\<^sub>\<bottom>\<^sub>P"
  by (simp add: prog_rep_eq) (metis assert_d_twice assert_des_def)

end


section \<open>Commutativity in Executions\<close>
theory commutativity
  imports repliss_sem prefix
    "HOL-Eisbach.Eisbach"
    execution_invariants
    invContext_simps
begin

text \<open>This theory proves commutativity between certain actions in executions.\<close>

definition canSwap :: "'ls itself \<Rightarrow> ('proc::valueType, 'op, 'any::valueType)  action \<Rightarrow> ('proc, 'op, 'any) action \<Rightarrow> bool" where
  "canSwap t a b \<equiv> (\<forall>(C1::('proc, 'ls, 'op, 'any) state) C2 i1 i2.
      i1\<noteq>i2 \<and> (C1 ~~ [(i1,a),(i2,b)] \<leadsto>* C2) \<and> state_wellFormed C1 \<longrightarrow> (C1 ~~ [(i2,b),(i1,a)] \<leadsto>* C2))"

text \<open>\DefineSnippet{canSwap_def}{
  @{thm [display] canSwap_def[unfolded imp_conjL[symmetric]]}
}%EndSnippet\<close>

text \<open>We can swap one action over a list of actions with canSwap\<close>
text_raw \<open>\DefineSnippet{swapMany}{\<close>
lemma swapMany:
  fixes C1 :: "('proc::valueType, 'ls, 'op, 'any::valueType) state"
    and t :: "'ls itself"
  assumes steps: "C1 ~~ tr @ [(i,a)] \<leadsto>* C2"
    and tr_different_session: "\<And>x. x\<in>set tr \<Longrightarrow> get_invoc x \<noteq> i"
    and tr_canSwap: "\<And>x. x\<in>set tr \<Longrightarrow> canSwap t (get_action x) a"
    and wf: "state_wellFormed C1"
    and noFail: "\<And>i. (i, ACrash) \<notin> set tr"
shows "C1 ~~ [(i,a)] @ tr \<leadsto>* C2"
text_raw \<open>}%EndSnippet\<close>
  using steps tr_different_session tr_canSwap noFail
proof (induct tr arbitrary: C2 rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc a' tr')
  then have IH: "\<And>C2. \<lbrakk>C1 ~~ tr' @ [(i, a)] \<leadsto>* C2; \<And>x. x \<in> set tr' \<Longrightarrow> get_invoc x \<noteq> i; \<And>x. x \<in> set tr' \<Longrightarrow> canSwap t (get_action x) a\<rbrakk> \<Longrightarrow> C1 ~~ [(i, a)] @ tr' \<leadsto>* C2"
    and steps: "C1 ~~ (tr' @ [a']) @ [(i, a)] \<leadsto>* C2"
    and tr_different_session: "\<And>x. x \<in> set (tr' @ [a']) \<Longrightarrow> get_invoc x \<noteq> i"
    and tr_canSwap: "\<And>x. x \<in> set (tr' @ [a']) \<Longrightarrow> canSwap t (get_action x) a"
    and noFail2a: "\<And>i. (i, ACrash) \<notin> set (tr' @ [a'])"
    by auto

  from steps
  obtain C'
    where steps1: "C1 ~~ tr' \<leadsto>* C'"
      and steps2: "C' ~~ [a', (i, a)] \<leadsto>* C2"
    by (auto simp add: steps_append)

  have wf': "state_wellFormed C'"
    using local.wf state_wellFormed_combine steps1 noFail2a by auto

  from steps2
  have steps2': "C' ~~ [(i, a), a'] \<leadsto>* C2"
    using tr_canSwap by (metis canSwap_def list.set_intros(1) prod.collapse rotate1.simps(2) set_rotate1 tr_different_session wf')

  from steps1 steps2'
  have "C1 ~~ tr' @  [(i, a), a'] \<leadsto>* C2"
    using steps_append2 by blast

  from this
  obtain C''
    where steps1': "C1 ~~ tr' @  [(i, a)] \<leadsto>* C''" and steps2'': "C'' ~~ [a'] \<leadsto>* C2"
    by (metis (no_types, hide_lams) append.assoc append_Cons append_Nil steps_append)

  from steps1' IH
  have steps1'': "C1 ~~ [(i, a)] @ tr' \<leadsto>* C''"
    by (simp add: snoc.prems(2) snoc.prems(3))

  with steps2''
  show ?case
    using steps_append2 by fastforce
qed

lemma swapMany_middle:
  fixes C1 :: "('proc::valueType, 'ls, 'op, 'any::valueType) state"
  assumes steps: "C1 ~~ tr_start @ tr @ [(s,a)] @ tr_end \<leadsto>* C2"
    and tr_different_session: "\<And>x. x\<in>set tr \<Longrightarrow> get_invoc x \<noteq> s"
    and tr_canSwap: "\<And>x. x\<in>set tr \<Longrightarrow> canSwap (t::'ls itself) (get_action x) a"
    and wf: "state_wellFormed C1"
    and nofail1: "\<And>i. (i,ACrash)\<notin> set tr_start"
    and nofail2: "\<And>i. (i,ACrash)\<notin> set tr"
  shows "C1 ~~ tr_start @ [(s,a)] @ tr @ tr_end \<leadsto>* C2"
proof -
  from steps
  obtain C1' C2'
    where "C1 ~~ tr_start \<leadsto>* C1'" and "C1' ~~ tr @ [(s,a)] \<leadsto>* C2'" and "C2' ~~ tr_end \<leadsto>* C2"
    by (meson steps_append)

  then have "C1' ~~ [(s,a)] @ tr  \<leadsto>* C2'"
    using local.wf state_wellFormed_combine swapMany tr_canSwap tr_different_session nofail1 nofail2  by blast

  then show "C1 ~~ tr_start @ [(s,a)] @ tr @ tr_end \<leadsto>* C2"
    using \<open>C1 ~~ tr_start \<leadsto>* C1'\<close> \<open>C2' ~~ tr_end \<leadsto>* C2\<close>
    using steps_append by blast
qed

lemma swapMany_middle':
  fixes C1 :: "('proc::valueType, 'ls, 'op, 'any::valueType) state"
  assumes steps: "C1 ~~ tr_start @ tr @ [a] @ tr_end \<leadsto>* C2"
    and tr_different_session: "\<And>x. x\<in>set tr \<Longrightarrow> get_invoc x \<noteq> (get_invoc a)"
    and tr_canSwap: "\<And>x. x\<in>set tr \<Longrightarrow> canSwap (t::'ls itself) (get_action x) (get_action a)"
    and wf: "state_wellFormed C1"
    and nofail1: "\<And>i. (i,ACrash)\<notin> set tr_start"
    and nofail2: "\<And>i. (i,ACrash)\<notin> set tr"
  shows "C1 ~~ tr_start @ [a] @ tr @ tr_end \<leadsto>* C2"
  by (insert assms, cases a, rule ssubst, assumption, rule swapMany_middle, auto)

lemma show_canSwap:
  assumes "\<And>(C1::('proc::valueType, 'ls, 'op, 'any::valueType) state) C2 C3 s1 s2. \<lbrakk>s1 \<noteq> s2; C1 ~~ (s1,a) \<leadsto> C2; C2 ~~ (s2,b) \<leadsto> C3; state_wellFormed C1\<rbrakk> \<Longrightarrow> \<exists>C. (C1 ~~ (s2,b) \<leadsto> C) \<and> (C ~~ (s1,a) \<leadsto> C3)"
  shows "canSwap (t::'ls itself) a b"
proof (auto simp add: canSwap_def)
  fix C1 C3 :: "('proc, 'ls, 'op, 'any) state"
  fix s1 s2
  assume a0: "s1 \<noteq> s2"
    and a1: "C1 ~~ [(s1, a), (s2, b)] \<leadsto>* C3"
    and a2: "state_wellFormed C1"

  from a1 obtain C2
    where a1': "C1 ~~ (s1,a) \<leadsto> C2" and a1'': "C2 ~~ (s2,b) \<leadsto> C3"
    using steps_appendFront steps_single by blast

  show "C1 ~~ [(s2, b), (s1, a)] \<leadsto>* C3"
  proof (subst steps.simps, clarsimp simp add: steps_empty steps_single, rule assms)
    show "s1 \<noteq> s2" using a0.
    show "C1 ~~ (s1, a) \<leadsto> C2" using a1'.
    show "C2 ~~ (s2,b) \<leadsto> C3" using a1''.
    show "state_wellFormed C1" using a2.
  qed
qed

lemma show_canSwap':
  assumes "x = a"
    and"\<And>(C1::('proc::valueType, 'ls, 'op, 'any::valueType) state) C2 C3 s1 s2. \<lbrakk>s1 \<noteq> s2; C1 ~~ (s1,a) \<leadsto> C2; C2 ~~ (s2,b) \<leadsto> C3; state_wellFormed C1\<rbrakk> \<Longrightarrow> \<exists>C. (C1 ~~ (s2,b) \<leadsto> C) \<and> (C ~~ (s1,a) \<leadsto> C3)"
  shows "canSwap (t::'ls itself) x b"
  by (simp add: assms show_canSwap)

method prove_canSwap'' uses simp elim  = (
    rule show_canSwap',
    auto del: ext  simp add: simp step_simps fun_upd_twist intro!: show_state_calls_eq ext split: if_splits elim!: elim)

lemma not_is_AInvcheck: "\<not>is_AInvcheck a \<Longrightarrow> a \<noteq> AInvcheck i"
  by (simp add: is_AInvcheck_def)

text "The following are all the relevant cases where canSwap is true:"
text_raw \<open>\DefineSnippet{canSwap_cases}{\<close>
lemma canSwap_cases:
  assumes no_begin_atomic: "\<And>txId txns. b \<noteq> ABeginAtomic txId txns"
    and no_invoc: "\<And>p. b \<noteq> AInvoc p"
    and no_invcheck_a: "\<not>is_AInvcheck a"
    and no_invcheck_b: "\<not>is_AInvcheck b"
    and no_fail_a: "a \<noteq> ACrash"
    and no_fail_b: "b \<noteq> ACrash"
shows "canSwap t a b"
text_raw \<open>}%EndSnippet\<close>
proof (cases a; cases b)
  fix tx txns
  assume [simp]: "a = ABeginAtomic tx txns"
    and [simp]: "b = AEndAtomic"
  show "canSwap t a b"
    by (prove_canSwap'' simp:   wellFormed_currentTxUncommitted elim: chooseSnapshot_unchanged_precise )
next
  fix tx txns c op r
  assume [simp]: "a = ABeginAtomic tx txns"
    and [simp]: "b = ADbOp c op r"
  show "canSwap t a b"
    by (prove_canSwap'' simp: wellFormed_callOrigin_dom2  wellFormed_currentTxUncommitted  elim: chooseSnapshot_unchanged_precise )
next
  fix c1 op1 r1 c2 op2 r2
  assume [simp]: "a = ADbOp c1 op1 r1"
    and [simp]: "b = ADbOp c2 op2 r2"
  show "canSwap t a b"
    by (prove_canSwap'' simp:  getContextH_callsUpdate getContextH_visUpdate wellFormed_visibleCallsSubsetCalls2)
next
qed (auto simp add: assms not_is_AInvcheck, (prove_canSwap'' simp: in_mono)+) \<comment> \<open>Big case analysis, takes around 40 seconds\<close>

end


subsection \<open>The Bellman-Ford Algorithm\<close>

theory Bellman_Ford
  imports
    "HOL-Library.Extended"
    "HOL-Library.IArray"
    "HOL-Library.Code_Target_Numeral"
    "HOL-Library.Product_Lexorder"
    "HOL-Library.RBT_Mapping"
    "../state_monad/State_Main"
    "../heap_monad/Heap_Main"
    Example_Misc
    "../util/Tracing"
    "../util/Ground_Function"
begin

subsubsection \<open>Misc\<close>

instance extended :: (countable) countable
proof standard
  obtain to_nat :: "'a \<Rightarrow> nat" where "inj to_nat"
    by auto
  let ?f = "\<lambda> x. case x of Fin n \<Rightarrow> to_nat n + 2 | Pinf \<Rightarrow> 0 | Minf \<Rightarrow> 1"
  from \<open>inj _ \<close> have "inj ?f"
    by (auto simp: inj_def split: extended.split)
  then show "\<exists>to_nat :: 'a extended \<Rightarrow> nat. inj to_nat"
    by auto
qed

instance extended :: (heap) heap ..

lemma fold_acc_preserv:
  assumes "\<And> x acc. P acc \<Longrightarrow> P (f x acc)" "P acc"
  shows "P (fold f xs acc)"
  using assms(2) by (induction xs arbitrary: acc) (auto intro: assms(1))

lemma get_return:
  "run_state (State_Monad.bind State_Monad.get (\<lambda> m. State_Monad.return (f m))) m = (f m, m)"
  by (simp add: State_Monad.bind_def State_Monad.get_def)

subsubsection \<open>Single-Sink Shortest Path Problem\<close>

datatype bf_result = Path "nat list" int | No_Path | Computation_Error

context
  fixes n :: nat and W :: "nat \<Rightarrow> nat \<Rightarrow> int extended"
begin

context
  fixes t :: nat \<comment> \<open>Final node\<close>
begin

text \<open>
  The correctness proof closely follows Kleinberg \<open>&\<close> Tardos: "Algorithm Design",
  chapter "Dynamic Programming" @{cite "Kleinberg-Tardos"}
\<close>

definition weight :: "nat list \<Rightarrow> int extended" where
  "weight xs = snd (fold (\<lambda> i (j, x). (i, W i j + x)) (rev xs) (t, 0))"

definition
  "OPT i v = (
    Min (
      {weight (v # xs) | xs. length xs + 1 \<le> i \<and> set xs \<subseteq> {0..n}} \<union>
      {if t = v then 0 else \<infinity>}
    )
  )"

lemma weight_Cons [simp]:
  "weight (v # w # xs) = W v w + weight (w # xs)"
  by (simp add: case_prod_beta' weight_def)

lemma weight_single [simp]:
  "weight [v] = W v t"
  by (simp add: weight_def)

(* XXX Generalize to the right type class *)
lemma Min_add_right:
  "Min S + (x :: int extended) = Min ((\<lambda> y. y + x) ` S)" (is "?A = ?B") if "finite S" "S \<noteq> {}"
proof -
  have "?A \<le> ?B"
    using that by (force intro: Min.boundedI add_right_mono)
  moreover have "?B \<le> ?A"
    using that by (force intro: Min.boundedI)
  ultimately show ?thesis
    by simp
qed

lemma OPT_0:
  "OPT 0 v = (if t = v then 0 else \<infinity>)"
  unfolding OPT_def by simp

(* TODO: Move to distribution! *)
lemma Pinf_add_right[simp]:
  "\<infinity> + x = \<infinity>"
  by (cases x; simp)

subsubsection \<open>Functional Correctness\<close>

lemma OPT_Suc:
  "OPT (Suc i) v = min (OPT i v) (Min {OPT i w + W v w | w. w \<le> n})" (is "?lhs = ?rhs")
  if "t \<le> n"
proof -
  have fin': "finite {xs. length xs \<le> i \<and> set xs \<subseteq> {0..n}}" for i
    by (auto intro: finite_subset[OF _ finite_lists_length_le[OF finite_atLeastAtMost]])
  have fin: "finite {weight (v # xs) |xs. length xs \<le> i \<and> set xs \<subseteq> {0..n}}"
    for v i using [[simproc add: finite_Collect]] by (auto intro: finite_subset[OF _ fin'])
  have OPT_in: "OPT i v \<in>
    {weight (v # xs) | xs. length xs + 1 \<le> i \<and> set xs \<subseteq> {0..n}} \<union>
    {if t = v then 0 else \<infinity>}"
    if "i > 0" for i v
    using that unfolding OPT_def
    by - (rule Min_in, auto 4 3 intro: finite_subset[OF _ fin, of _ v "Suc i"])

  have "OPT i v \<ge> OPT (Suc i) v"
    unfolding OPT_def using fin by (auto 4 3 intro: Min_antimono)
  have subs:
    "(\<lambda>y. y + W v w) ` {weight (w # xs) |xs. length xs + 1 \<le> i \<and> set xs \<subseteq> {0..n}}
    \<subseteq> {weight (v # xs) |xs. length xs + 1 \<le> Suc i \<and> set xs \<subseteq> {0..n}}" if \<open>w \<le> n\<close> for v w
    using \<open>w \<le> n\<close> apply clarify
    subgoal for _ _ xs
      by (rule exI[where x = "w # xs"]) (auto simp: algebra_simps)
    done
  have "OPT i t + W v t \<ge> OPT (Suc i) v"
    unfolding OPT_def using subs[OF \<open>t \<le> n\<close>, of v] that
    by (subst Min_add_right)
       (auto 4 3
         simp: Bellman_Ford.weight_single
         intro: exI[where x = "[]"] finite_subset[OF _ fin[of _ "Suc i"]] intro!: Min_antimono
       )
  moreover have "OPT i w + W v w \<ge> OPT (Suc i) v" if "w \<le> n" \<open>w \<noteq> t\<close> \<open>t \<noteq> v\<close> for w
    unfolding OPT_def using subs[OF \<open>w \<le> n\<close>, of v] that
    by (subst Min_add_right)
       (auto 4 3 intro: finite_subset[OF _ fin[of _ "Suc i"]] intro!: Min_antimono)
  moreover have "OPT i w + W t w \<ge> OPT (Suc i) t" if "w \<le> n" \<open>w \<noteq> t\<close> for w
    unfolding OPT_def
    apply (subst Min_add_right)
      prefer 3
    using \<open>w \<noteq> t\<close>
      apply simp
      apply (cases "i = 0")
       apply (simp; fail)
    using subs[OF \<open>w \<le> n\<close>, of t]
    by (subst (2) Min_insert)
       (auto 4 4
         intro: finite_subset[OF _ fin[of _ "Suc i"]] exI[where x = "[]"] intro!: Min_antimono
       )
  ultimately have "Min {local.OPT i w + W v w |w. w \<le> n} \<ge> OPT (Suc i) v"
    by (auto intro!: Min.boundedI)
  with \<open>OPT i v \<ge> _\<close> have "?lhs \<le> ?rhs"
    by simp

  from OPT_in[of "Suc i" v] consider
    "OPT (Suc i) v = \<infinity>" | "t = v" "OPT (Suc i) v = 0" |
    xs where "OPT (Suc i) v = weight (v # xs)" "length xs \<le> i" "set xs \<subseteq> {0..n}"
    by (auto split: if_split_asm)
  then have "?lhs \<ge> ?rhs"
  proof cases
    case 1
    then show ?thesis
      by simp
  next
    case 2
    then have "OPT i v \<le> OPT (Suc i) v"
      unfolding OPT_def using [[simproc add: finite_Collect]]
      by (auto 4 4 intro: finite_subset[OF _ fin', of _ "Suc i"] intro!: Min_le)
    then show ?thesis
      by (rule min.coboundedI1)
  next
    case xs: 3
    note [simp] = xs(1)
    show ?thesis
    proof (cases "length xs = i")
      case True
      show ?thesis
      proof (cases "i = 0")
        case True
        with xs have "OPT (Suc i) v = W v t"
          by simp
        also have "W v t = OPT i t + W v t"
          unfolding OPT_def using \<open>i = 0\<close> by auto
        also have "\<dots> \<ge> Min {OPT i w + W v w |w. w \<le> n}"
          using \<open>t \<le> n\<close> by (auto intro: Min_le)
        finally show ?thesis
          by (rule min.coboundedI2)
      next
        case False
        with \<open>_ = i\<close> have "xs \<noteq> []"
          by auto
        with xs have "weight xs \<ge> OPT i (hd xs)"
          unfolding OPT_def
          by (intro Min_le[rotated] UnI1 CollectI exI[where x = "tl xs"])
             (auto 4 3 intro: finite_subset[OF _ fin, of _ "hd xs" "Suc i"] dest: list.set_sel(2))
        have "Min {OPT i w + W v w |w. w \<le> n} \<le> W v (hd xs) + OPT i (hd xs)"
          using \<open>set xs \<subseteq> _\<close> \<open>xs \<noteq> []\<close> by (force simp: add.commute intro: Min_le)
        also have "\<dots> \<le> W v (hd xs) + weight xs"
          using \<open>_ \<ge> OPT i (hd xs)\<close> by (metis add_left_mono)
        also from \<open>xs \<noteq> []\<close> have "\<dots> = OPT (Suc i) v"
          by (cases xs) auto
        finally show ?thesis
          by (rule min.coboundedI2)
      qed
    next
      case False
      with xs have "OPT i v \<le> OPT (Suc i) v"
        by (auto 4 4 intro: Min_le finite_subset[OF _ fin, of _ v "Suc i"] simp: OPT_def)
      then show ?thesis
        by (rule min.coboundedI1)
    qed
  qed
  with \<open>?lhs \<le> ?rhs\<close> show ?thesis
    by (rule order.antisym)
qed

fun bf :: "nat \<Rightarrow> nat \<Rightarrow> int extended" where
  "bf 0 j = (if t = j then 0 else \<infinity>)"
| "bf (Suc k) j = min_list
      (bf k j # [W j i + bf k i . i \<leftarrow> [0 ..< Suc n]])"

lemmas [simp del] = bf.simps
lemmas [simp] = bf.simps[unfolded min_list_fold]
thm bf.simps
thm bf.induct

lemma bf_correct:
  "OPT i j = bf i j" if \<open>t \<le> n\<close>
proof (induction i arbitrary: j)
  case 0
  then show ?case
    by (simp add: OPT_0)
next
  case (Suc i)
  have *:
    "{bf i w + W j w |w. w \<le> n} = set (map (\<lambda>w. W j w + bf i w) [0..<Suc n])"
    by (fastforce simp: add.commute image_def)
  from Suc \<open>t \<le> n\<close> show ?case
    by (simp add: OPT_Suc del: upt_Suc, subst Min.set_eq_fold[symmetric], auto simp: *)
qed

subsubsection \<open>Functional Memoization\<close>

memoize_fun bf\<^sub>m: bf with_memory dp_consistency_mapping monadifies (state) bf.simps

text \<open>Generated Definitions\<close>
context includes state_monad_syntax begin
thm bf\<^sub>m'.simps bf\<^sub>m_def
end

text \<open>Correspondence Proof\<close>
memoize_correct
  by memoize_prover
print_theorems
lemmas [code] = bf\<^sub>m.memoized_correct

interpretation iterator
  "\<lambda> (x, y). x \<le> n \<and> y \<le> n"
  "\<lambda> (x, y). if y < n then (x, y + 1) else (x + 1, 0)"
  "\<lambda> (x, y). x * (n + 1) + y"
  by (rule table_iterator_up)

interpretation bottom_up: dp_consistency_iterator_empty
  "\<lambda> (_::(nat \<times> nat, int extended) mapping). True"
  "\<lambda> (x, y). bf x y"
  "\<lambda> k. do {m \<leftarrow> State_Monad.get; State_Monad.return (Mapping.lookup m k :: int extended option)}"
  "\<lambda> k v. do {m \<leftarrow> State_Monad.get; State_Monad.set (Mapping.update k v m)}"
  "\<lambda> (x, y). x \<le> n \<and> y \<le> n"
  "\<lambda> (x, y). if y < n then (x, y + 1) else (x + 1, 0)"
  "\<lambda> (x, y). x * (n + 1) + y"
  Mapping.empty ..

definition
  "iter_bf = iter_state (\<lambda> (x, y). bf\<^sub>m' x y)"

lemma iter_bf_unfold[code]:
  "iter_bf = (\<lambda> (i, j).
    (if i \<le> n \<and> j \<le> n
     then do {
            bf\<^sub>m' i j;
            iter_bf (if j < n then (i, j + 1) else (i + 1, 0))
          }
     else State_Monad.return ()))"
  unfolding iter_bf_def by (rule ext) (safe, clarsimp simp: iter_state_unfold)

lemmas bf_memoized = bf\<^sub>m.memoized[OF bf\<^sub>m.crel]
lemmas bf_bottom_up = bottom_up.memoized[OF bf\<^sub>m.crel, folded iter_bf_def]

thm bf\<^sub>m'.simps bf_memoized

subsubsection \<open>Imperative Memoization\<close>

context
  fixes mem :: "nat ref \<times> nat ref \<times> int extended option array ref \<times> int extended option array ref"
  assumes mem_is_init: "mem = result_of (init_state (n + 1) 1 0) Heap.empty"
begin

lemma [intro]:
  "dp_consistency_heap_array_pair' (n + 1) fst snd id 1 0 mem"
  by (standard; simp add: mem_is_init injective_def)

interpretation iterator
  "\<lambda> (x, y). x \<le> n \<and> y \<le> n"
  "\<lambda> (x, y). if y < n then (x, y + 1) else (x + 1, 0)"
  "\<lambda> (x, y). x * (n + 1) + y"
  by (rule table_iterator_up)

lemma [intro]:
  "dp_consistency_heap_array_pair_iterator (n + 1) fst snd id 1 0 mem
  (\<lambda> (x, y). if y < n then (x, y + 1) else (x + 1, 0))
  (\<lambda> (x, y). x * (n + 1) + y)
  (\<lambda> (x, y). x \<le> n \<and> y \<le> n)"
  by (standard; simp add: mem_is_init injective_def)

memoize_fun bf\<^sub>h: bf
  with_memory (default_proof) dp_consistency_heap_array_pair_iterator
  where size = "n + 1"
    and key1="fst :: nat \<times> nat \<Rightarrow> nat" and key2="snd :: nat \<times> nat \<Rightarrow> nat"
    and k1="1 :: nat" and k2="0 :: nat"
    and to_index = "id :: nat \<Rightarrow> nat"
    and mem = mem
    and cnt = "\<lambda> (x, y). x \<le> n \<and> y \<le> n"
    and nxt = "\<lambda> (x :: nat, y). if y < n then (x, y + 1) else (x + 1, 0)"
    and sizef = "\<lambda> (x, y). x * (n + 1) + y"
monadifies (heap) bf.simps

memoize_correct
  by memoize_prover

lemmas memoized_empty = bf\<^sub>h.memoized_empty[OF bf\<^sub>h.consistent_DP_iter_and_compute[OF bf\<^sub>h.crel]]
lemmas iter_heap_unfold = iter_heap_unfold

end (* Fixed Memory *)

end (* Final Node *)

end (* Bellman Ford *)

subsubsection \<open>Extracting an Executable Constant for the Imperative Implementation\<close>

ground_function (prove_termination) bf\<^sub>h'_impl: bf\<^sub>h'.simps

lemma bf\<^sub>h'_impl_def:
  fixes n :: nat
  fixes mem :: "nat ref \<times> nat ref \<times> int extended option array ref \<times> int extended option array ref"
  assumes mem_is_init: "mem = result_of (init_state (n + 1) 1 0) Heap.empty"
  shows "bf\<^sub>h'_impl n w t mem = bf\<^sub>h' n w t mem"
proof -
  have "bf\<^sub>h'_impl n w t mem i j = bf\<^sub>h' n w t mem i j" for i j
    by (induction rule: bf\<^sub>h'.induct[OF mem_is_init];
        simp add: bf\<^sub>h'.simps[OF mem_is_init]; solve_cong simp
       )
  then show ?thesis
    by auto
qed

definition
  "iter_bf_heap n w t mem = iterator_defs.iter_heap
      (\<lambda>(x, y). x \<le> n \<and> y \<le> n)
      (\<lambda>(x, y). if y < n then (x, y + 1) else (x + 1, 0))
      (\<lambda>(x, y). bf\<^sub>h'_impl n w t mem x y)"

lemma iter_bf_heap_unfold[code]:
  "iter_bf_heap n w t mem = (\<lambda> (i, j).
    (if i \<le> n \<and> j \<le> n
     then do {
            bf\<^sub>h'_impl n w t mem i j;
            iter_bf_heap n w t mem (if j < n then (i, j + 1) else (i + 1, 0))
          }
     else Heap_Monad.return ()))"
  unfolding iter_bf_heap_def by (rule ext) (safe, simp add: iter_heap_unfold)

definition
  "bf_impl n w t i j = do {
    mem \<leftarrow> (init_state (n + 1) (1::nat) (0::nat) ::
      (nat ref \<times> nat ref \<times> int extended option array ref \<times> int extended option array ref) Heap);
    iter_bf_heap n w t mem (0, 0);
    bf\<^sub>h'_impl n w t mem i j
  }"

lemma bf_impl_correct:
  "bf n w t i j = result_of (bf_impl n w t i j) Heap.empty"
  using memoized_empty[OF HOL.refl, of n w t "(i, j)"]
  by (simp add:
        execute_bind_success[OF succes_init_state] bf_impl_def bf\<^sub>h'_impl_def iter_bf_heap_def
      )

subsubsection \<open>Test Cases\<close>

definition
  "G\<^sub>1_list = [[(1 :: nat,-6 :: int), (2,4), (3,5)], [(3,10)], [(3,2)], []]"

definition
  "graph_of a i j = case_option \<infinity> (Fin o snd) (List.find (\<lambda> p. fst p = j) (a !! i))"

definition "test_bf = bf_impl 3 (graph_of (IArray G\<^sub>1_list)) 3 3 0"

code_reflect Test functions test_bf

text \<open>One can see a trace of the calls to the memory in the output\<close>
ML \<open>Test.test_bf ()\<close>

lemma bottom_up_alt[code]:
  "bf n W t i j =
     fst (run_state
      (iter_bf n W t (0, 0) \<bind> (\<lambda>_. bf\<^sub>m' n W t i j))
      Mapping.empty)"
  using bf_bottom_up by auto

definition
  "bf_ia n W t i j = (let W' = graph_of (IArray W) in
    fst (run_state
      (iter_bf n W' t (i, j) \<bind> (\<lambda>_. bf\<^sub>m' n W' t i j))
      Mapping.empty)
  )"

value "fst (run_state (bf\<^sub>m' 3 (graph_of (IArray G\<^sub>1_list)) 3 3 0) Mapping.empty)"

value "bf 3 (graph_of (IArray G\<^sub>1_list)) 3 3 0"

end (* Theory *)


(*  Title:      HOL/MicroJava/BV/JType.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>The Java Type System as Semilattice\<close>

theory JType
imports "../DFA/Semilattices" "../J/WellForm"
begin

definition super :: "'a prog \<Rightarrow> cname \<Rightarrow> cname" where
  "super G C == fst (the (class G C))"

lemma superI:
  "G \<turnstile> C \<prec>C1 D \<Longrightarrow> super G C = D"
  by (unfold super_def) (auto dest: subcls1D)

definition is_ref :: "ty \<Rightarrow> bool" where
  "is_ref T == case T of PrimT t \<Rightarrow> False | RefT r \<Rightarrow> True"

definition sup :: "'c prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty err" where
  "sup G T1 T2 ==
  case T1 of PrimT P1 \<Rightarrow> (case T2 of PrimT P2 \<Rightarrow>
                         (if P1 = P2 then OK (PrimT P1) else Err) | RefT R \<Rightarrow> Err)
           | RefT R1 \<Rightarrow> (case T2 of PrimT P \<Rightarrow> Err | RefT R2 \<Rightarrow>
  (case R1 of NullT \<Rightarrow> (case R2 of NullT \<Rightarrow> OK NT | ClassT C \<Rightarrow> OK (Class C))
            | ClassT C \<Rightarrow> (case R2 of NullT \<Rightarrow> OK (Class C)
                           | ClassT D \<Rightarrow> OK (Class (exec_lub (subcls1 G) (super G) C D)))))"

definition subtype :: "'c prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" where
  "subtype G T1 T2 == G \<turnstile> T1 \<preceq> T2"

definition is_ty :: "'c prog \<Rightarrow> ty \<Rightarrow> bool" where
  "is_ty G T == case T of PrimT P \<Rightarrow> True | RefT R \<Rightarrow>
               (case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (C, Object) \<in> (subcls1 G)\<^sup>*)"

abbreviation "types G == Collect (is_type G)"

definition esl :: "'c prog \<Rightarrow> ty esl" where
  "esl G == (types G, subtype G, sup G)"

lemma PrimT_PrimT: "(G \<turnstile> xb \<preceq> PrimT p) = (xb = PrimT p)"
  by (auto elim: widen.cases)

lemma PrimT_PrimT2: "(G \<turnstile> PrimT p \<preceq> xb) = (xb = PrimT p)"
  by (auto elim: widen.cases)

lemma is_tyI:
  "\<lbrakk> is_type G T; ws_prog G \<rbrakk> \<Longrightarrow> is_ty G T"
  by (auto simp add: is_ty_def intro: subcls_C_Object
           split: ty.splits ref_ty.splits)

lemma is_type_conv:
  "ws_prog G \<Longrightarrow> is_type G T = is_ty G T"
proof
  assume "is_type G T" "ws_prog G"
  thus "is_ty G T"
    by (rule is_tyI)
next
  assume wf: "ws_prog G" and
         ty: "is_ty G T"

  show "is_type G T"
  proof (cases T)
    case PrimT
    thus ?thesis by simp
  next
    fix R assume R: "T = RefT R"
    with wf
    have "R = ClassT Object \<Longrightarrow> ?thesis" by simp
    moreover
    from R wf ty
    have "R \<noteq> ClassT Object \<Longrightarrow> ?thesis"
     by (auto simp add: is_ty_def is_class_def split_tupled_all
               elim!: subcls1.cases
               elim: converse_rtranclE
               split: ref_ty.splits)
    ultimately
    show ?thesis by blast
  qed
qed

lemma order_widen:
  "acyclic (subcls1 G) \<Longrightarrow> order (subtype G)"
  apply (unfold Semilat.order_def lesub_def subtype_def)
  apply (auto intro: widen_trans)
  apply (case_tac x)
   apply (case_tac y)
    apply (auto simp add: PrimT_PrimT)
   apply (case_tac y)
    apply simp
  apply simp
  apply (rename_tac ref_ty ref_tya, case_tac ref_ty)
   apply (case_tac ref_tya)
    apply simp
   apply simp
  apply (case_tac ref_tya)
   apply simp
  apply simp
  apply (auto dest: acyclic_impl_antisym_rtrancl antisymD)
  done

lemma wf_converse_subcls1_impl_acc_subtype:
  "wf ((subcls1 G)\<inverse>) \<Longrightarrow> acc (subtype G)"
apply (unfold Semilat.acc_def lesssub_def)
apply (drule_tac p = "((subcls1 G)\<inverse>) - Id" in wf_subset)
 apply auto
apply (drule wf_trancl)
apply (simp add: wf_eq_minimal)
apply clarify
apply (unfold lesub_def subtype_def)
apply (rename_tac M T)
apply (case_tac "\<exists>C. Class C \<in> M")
 prefer 2
 apply (case_tac T)
  apply (fastforce simp add: PrimT_PrimT2)
 apply simp
 apply (rename_tac ref_ty)
 apply (subgoal_tac "ref_ty = NullT")
  apply simp
  apply (rule_tac x = NT in bexI)
   apply (rule allI)
   apply (rule impI, erule conjE)
   apply (drule widen_RefT)
   apply clarsimp
   apply (case_tac t)
    apply simp
   apply simp
  apply simp
 apply (case_tac ref_ty)
  apply simp
 apply simp
apply (erule_tac x = "{C. Class C \<in> M}" in allE)
apply auto
apply (rename_tac D)
apply (rule_tac x = "Class D" in bexI)
 prefer 2
 apply assumption
apply clarify
apply (frule widen_RefT)
apply (erule exE)
apply (case_tac t)
 apply simp
apply simp
apply (insert rtrancl_r_diff_Id [symmetric, of "subcls1 G"])
apply simp
apply (erule rtrancl.cases)
 apply blast
apply (drule rtrancl_converseI)
apply (subgoal_tac "(subcls1 G - Id)\<inverse> = (subcls1 G)\<inverse> - Id")
 prefer 2
 apply (simp add: converse_Int) apply safe[1]
apply simp
apply (blast intro: rtrancl_into_trancl2)
done

lemma closed_err_types:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk>
  \<Longrightarrow> closed (err (types G)) (lift2 (sup G))"
  apply (unfold closed_def plussub_def lift2_def sup_def)
  apply (auto split: err.split)
  apply (drule is_tyI, assumption)
  apply (auto simp add: is_ty_def is_type_conv simp del: is_type.simps
              split: ty.split ref_ty.split)
  apply (blast dest!: is_lub_exec_lub is_lubD is_ubD intro!: is_ubI superI)
  done

lemma sup_subtype_greater:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
      is_type G t1; is_type G t2; sup G t1 t2 = OK s \<rbrakk>
  \<Longrightarrow> subtype G t1 s \<and> subtype G t2 s"
proof -
  assume ws_prog:       "ws_prog G"
  assume single_valued: "single_valued (subcls1 G)"
  assume acyclic:       "acyclic (subcls1 G)"

  { fix c1 c2
    assume is_class: "is_class G c1" "is_class G c2"
    with ws_prog
    obtain
      "G \<turnstile> c1 \<preceq>C Object"
      "G \<turnstile> c2 \<preceq>C Object"
      by (blast intro: subcls_C_Object)
    with ws_prog single_valued
    obtain u where
      "is_lub ((subcls1 G)\<^sup>*) c1 c2 u"
      by (blast dest: single_valued_has_lubs)
    moreover
    note acyclic
    moreover
    have "\<forall>x y. G \<turnstile> x \<prec>C1 y \<longrightarrow> super G x = y"
      by (blast intro: superI)
    ultimately
    have "G \<turnstile> c1 \<preceq>C exec_lub (subcls1 G) (super G) c1 c2 \<and>
          G \<turnstile> c2 \<preceq>C exec_lub (subcls1 G) (super G) c1 c2"
      by (simp add: exec_lub_conv) (blast dest: is_lubD is_ubD)
  } note this [simp]

  assume "is_type G t1" "is_type G t2" "sup G t1 t2 = OK s"
  thus ?thesis
    apply (unfold sup_def subtype_def)
    apply (cases s)
    apply (auto split: ty.split_asm ref_ty.split_asm if_split_asm)
    done
qed

lemma sup_subtype_smallest:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
      is_type G a; is_type G b; is_type G c;
      subtype G a c; subtype G b c; sup G a b = OK d \<rbrakk>
  \<Longrightarrow> subtype G d c"
proof -
  assume ws_prog:       "ws_prog G"
  assume single_valued: "single_valued (subcls1 G)"
  assume acyclic:       "acyclic (subcls1 G)"

  { fix c1 c2 D
    assume is_class: "is_class G c1" "is_class G c2"
    assume le: "G \<turnstile> c1 \<preceq>C D" "G \<turnstile> c2 \<preceq>C D"
    from ws_prog is_class
    obtain
      "G \<turnstile> c1 \<preceq>C Object"
      "G \<turnstile> c2 \<preceq>C Object"
      by (blast intro: subcls_C_Object)
    with ws_prog single_valued
    obtain u where
      lub: "is_lub ((subcls1 G)\<^sup>*) c1 c2 u"
      by (blast dest: single_valued_has_lubs)
    with acyclic
    have "exec_lub (subcls1 G) (super G) c1 c2 = u"
      by (blast intro: superI exec_lub_conv)
    moreover
    from lub le
    have "G \<turnstile> u \<preceq>C D"
      by (simp add: is_lub_def is_ub_def)
    ultimately
    have "G \<turnstile> exec_lub (subcls1 G) (super G) c1 c2 \<preceq>C D"
      by blast
  } note this [intro]

  have [dest!]:
    "\<And>C T. G \<turnstile> Class C \<preceq> T \<Longrightarrow> \<exists>D. T=Class D \<and> G \<turnstile> C \<preceq>C D"
    by (frule widen_Class, auto)

  assume "is_type G a" "is_type G b" "is_type G c"
         "subtype G a c" "subtype G b c" "sup G a b = OK d"
  thus ?thesis
    by (auto simp add: subtype_def sup_def
             split: ty.split_asm ref_ty.split_asm if_split_asm)
qed

lemma sup_exists:
  "\<lbrakk> subtype G a c; subtype G b c; sup G a b = Err \<rbrakk> \<Longrightarrow> False"
  by (auto simp add: PrimT_PrimT PrimT_PrimT2 sup_def subtype_def
           split: ty.splits ref_ty.splits)

lemma err_semilat_JType_esl_lemma:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk>
  \<Longrightarrow> err_semilat (esl G)"
proof -
  assume ws_prog:   "ws_prog G"
  assume single_valued: "single_valued (subcls1 G)"
  assume acyclic:   "acyclic (subcls1 G)"

  hence "order (subtype G)"
    by (rule order_widen)
  moreover
  from ws_prog single_valued acyclic
  have "closed (err (types G)) (lift2 (sup G))"
    by (rule closed_err_types)
  moreover

  from ws_prog single_valued acyclic
  have
    "(\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). x <=_(Err.le (subtype G)) x +_(lift2 (sup G)) y) \<and>
     (\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). y <=_(Err.le (subtype G)) x +_(lift2 (sup G)) y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_subtype_greater split: err.split)

  moreover

  from ws_prog single_valued acyclic
  have
    "\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). \<forall>z\<in>err (types G).
    x <=_(Err.le (subtype G)) z \<and> y <=_(Err.le (subtype G)) z \<longrightarrow> x +_(lift2 (sup G)) y <=_(Err.le (subtype G)) z"
    by (unfold lift2_def plussub_def lesub_def Err.le_def)
       (auto intro: sup_subtype_smallest sup_exists split: err.split)

  ultimately

  show ?thesis
    by (unfold esl_def semilat_def Err.sl_def) auto
qed

lemma single_valued_subcls1:
  "ws_prog G \<Longrightarrow> single_valued (subcls1 G)"
  by (auto simp add: ws_prog_def unique_def single_valued_def
    intro: subcls1I elim!: subcls1.cases)

theorem err_semilat_JType_esl:
  "ws_prog G \<Longrightarrow> err_semilat (esl G)"
  by (frule acyclic_subcls1, frule single_valued_subcls1, rule err_semilat_JType_esl_lemma)

end