theory ShortestPath
imports
  Complex
  "../Graph_Theory/Graph_Theory"
  "~~/src/HOL/Library/Extended_Nat"
begin

section {*Shortest Path (with non-negative edge costs)*}
text{* The following theory is used in the verification of a certifying algorithm's checker for shortest path. For more information see \cite{FrameworkVerificationofCertifyingComputations}. *}

locale basic_sp =
  fin_digraph +
  fixes dist :: "'a \<Rightarrow> ereal"
  fixes c :: "'b \<Rightarrow> real"
  fixes s :: "'a"
  assumes general_source_val: "dist s \<le> 0"
  assumes trian:
    "\<And>e. e \<in> arcs G \<Longrightarrow>
      dist (head G e) \<le> dist (tail G e) + c e"

locale basic_just_sp =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G. v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

locale shortest_path_pos_cost =
  basic_just_sp +
  assumes s_in_G: "s \<in> verts G"
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

locale basic_just_sp_pred =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        e = the (pred v) \<and>
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

sublocale basic_just_sp_pred \<subseteq> basic_just_sp
using basic_just_sp_pred_axioms
unfolding basic_just_sp_pred_def
   basic_just_sp_pred_axioms_def
by unfold_locales (blast)

locale shortest_path_pos_cost_pred =
  basic_just_sp_pred +
  assumes s_in_G: "s \<in> verts G"
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

sublocale shortest_path_pos_cost_pred \<subseteq> shortest_path_pos_cost
using shortest_path_pos_cost_pred_axioms
by unfold_locales
   (auto simp: shortest_path_pos_cost_pred_def
   shortest_path_pos_cost_pred_axioms_def)

lemma tail_value_helper:
  assumes "hd p = last p"
  assumes "distinct p"
  assumes "p \<noteq> []"
  shows "p = [hd p]"
  by (metis assms distinct.simps(2) list.sel(1) neq_Nil_conv last_ConsR last_in_set)

lemma (in basic_sp) dist_le_cost:
  fixes v :: 'a
  fixes p :: "'b list"
  assumes "awalk s p v"
  shows "dist v \<le> awalk_cost c p"
  using assms
  proof (induct "length p" arbitrary: p v)
  case 0
    hence "s = v" by auto
    thus ?case using 0(1) general_source_val
      by (metis awalk_cost_Nil length_0_conv zero_ereal_def)
  next
  case (Suc n)
    then obtain p' e where p'e: "p = p' @ [e]"
      by (cases p rule: rev_cases) auto
    then obtain u where ewu: "awalk s p' u \<and> awalk u [e] v"
      using awalk_append_iff Suc(3) by simp
    then have du: "dist u \<le> ereal (awalk_cost c p')"
      using Suc p'e by simp
    from ewu have ust: "u = tail G e" and vta: "v = head G e"
      by auto
    then have "dist v \<le> dist u + c e"
      using ewu du ust trian[where e=e] by force
    with du have "dist v \<le> ereal (awalk_cost c p') + c e"
      by (metis add_right_mono order_trans)
    thus "dist v \<le> awalk_cost c p"
      using awalk_cost_append p'e by simp
  qed

lemma (in fin_digraph) witness_path:
  assumes "\<mu> c s v = ereal r"
  shows "\<exists> p. apath s p v \<and> \<mu> c s v = awalk_cost c p"
proof -
  have sv: "s \<rightarrow>\<^sup>* v"
    using shortest_path_inf[of s v c] assms by fastforce
  {
    fix p assume "awalk s p v"
    then have no_neg_cyc:
    "\<not> (\<exists>w q. awalk w q w \<and> w \<in> set (awalk_verts s p) \<and> awalk_cost c q < 0)"
      using neg_cycle_imp_inf_\<mu> assms by force
  }
  thus ?thesis using no_neg_cyc_reach_imp_path[OF sv] by presburger
qed

lemma (in basic_sp)  dist_le_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<le> \<mu> c s v"
proof (rule ccontr)
  assume nt: "\<not> ?thesis"
  show False
  proof (cases "\<mu> c s v")
    show "\<And>r. \<mu> c s v = ereal r \<Longrightarrow> False"
    proof -
      fix r assume r_asm: "\<mu> c s v = ereal r"
      hence sv: "s \<rightarrow>\<^sup>* v"
        using shortest_path_inf[where u=s and v=v and f=c] by auto
      obtain p where
        "awalk s p v"
        "\<mu> c s v = awalk_cost c p"
        using witness_path[OF r_asm] unfolding apath_def by force
      thus False using nt dist_le_cost by simp
    qed
  next
    show "\<mu> c s v = \<infinity> \<Longrightarrow> False" using nt by simp
  next
    show "\<mu> c s v = - \<infinity> \<Longrightarrow> False" using dist_le_cost
    proof -
      assume asm: "\<mu> c s v = - \<infinity>"
      let ?C = "(\<lambda>x. ereal (awalk_cost c x)) ` {p. awalk s p v}"
      have "\<exists>x\<in> ?C. x < dist v"
        using Inf_ereal_iff [where y ="dist v"and X="?C" and z= "-\<infinity>"]
        nt asm unfolding \<mu>_def INF_def by simp
      then obtain p where
        "awalk s p v"
        "awalk_cost c p < dist v"
        by force
      thus False using dist_le_cost by force
    qed
  qed
qed

lemma (in basic_just_sp) dist_ge_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "num v \<noteq> \<infinity>"
  assumes "dist v \<noteq> -\<infinity>"
  assumes "\<mu> c s s = ereal 0"
  assumes "dist s = 0"
  assumes "\<And>u. u\<in>verts G \<Longrightarrow> u\<noteq>s \<Longrightarrow>
            num u \<noteq> \<infinity> \<Longrightarrow> num u \<noteq> enat 0"
  shows "dist v \<ge> \<mu> c s v"
proof -
  obtain n where "enat n = num v" using assms(2) by force
  thus ?thesis using assms
  proof(induct n arbitrary: v)
  case 0 thus ?case by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "v = head G e"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(4) Suc(2) by force
      have  ds: "dist (tail G e) = \<mu> c s (tail G e)"
        using Suc(1)[OF ns tail_in_verts[OF e_assms(1)] nsinf]
        Suc(5-8) e_assms(3) dist_le_\<mu>[OF tail_in_verts[OF e_assms(1)]]
        by simp
      have dmuc:"dist v \<ge> \<mu> c s (tail G e) + ereal (c e)"
        using e_assms(3) ds  by auto
      thus ?thesis
      proof (cases "dist v = \<infinity>")
      case False
        have "arc_to_ends G e = (tail G e, v)"
          unfolding arc_to_ends_def
          by (simp add: e_assms(2))
        obtain r where  \<mu>r: "\<mu> c s (tail G e) = ereal r"
           using e_assms(3) Suc(5) ds False
           by (cases "\<mu> c s (tail G e)", auto)
        obtain p where
          "awalk s p (tail G e)" and
          \<mu>s: "\<mu> c s (tail G e) = ereal (awalk_cost c p)"
          using witness_path[OF \<mu>r] unfolding apath_def
          by blast
        then have pe: "awalk s (p @ [e]) v"
          using e_assms(1,2) by (auto simp: awalk_simps)
        hence muc:"\<mu> c s v \<le> \<mu> c s (tail G e) + ereal (c e)"
        using \<mu>s min_cost_le_walk_cost[OF pe] by simp
        thus  "dist v \<ge> \<mu> c s v"  using dmuc by simp
      qed simp
    qed (simp add: Suc(6,7))
  qed
qed

lemma (in shortest_path_pos_cost) num_not0:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "num v \<noteq> \<infinity>"
  shows "num v \<noteq> enat 0"
proof -
  obtain ku where "num v = ku + enat 1"
    using assms just by blast
  thus ?thesis  by (induct ku) auto
qed

lemma (in shortest_path_pos_cost) dist_ne_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<noteq> -\<infinity>"
proof (cases "num v = \<infinity>")
case False
  obtain n where "enat n = num v"
    using False by force
  thus ?thesis using assms False
  proof(induct n arbitrary: v)
  case 0 thus ?case
    using num_not0 tail_val by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case True
      thus ?thesis using tail_val by simp
    next
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(3) Suc(2) by force
      have "dist (tail G e ) \<noteq> - \<infinity>"
        by (rule Suc(1) [OF ns tail_in_verts[OF e_assms(1)] nsinf])
      thus ?thesis using e_assms(2) by simp
    qed
  qed
next
case True
  thus ?thesis using no_path[OF assms] by simp
qed

theorem (in shortest_path_pos_cost) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using no_path[OF assms(1)] dist_le_\<mu>[OF assms(1)]
    dist_ge_\<mu>[OF assms(1) _ dist_ne_ninf[OF assms(1)]
    tail_value_check[OF s_in_G] tail_val num_not0]
    by fastforce

corollary (in shortest_path_pos_cost_pred) correct_shortest_path_pred:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using correct_shortest_path assms by simp

end


(* Title:      Coloring
   Author:     Insa Stucke (ist@informatik.uni-kiel.de)
*)

theory Relation_Algebra_Coloring imports  "~~/src/HOL/Hoare/Hoare_Logic"
                                          "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Orders"
                                          "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Cardinal"
begin

text{* This theory contains the relational program for approximating
a vertex coloring of an undirected graph. The correctness proof is done by using
Hoare logic. *}

declare [[show_sorts,show_types]]

text{* minpoint is a function selecting a point contained in a nonempty vector. It is defined by
the following properties. *}

class minpoint =
  fixes minpoint :: "'a \<Rightarrow> 'a"

class relation_algebra_minpoint = relation_algebra_card + minpoint +
  assumes minpoint_sub:  "is_vector x \<and> x \<noteq> bot \<longrightarrow> minpoint x \<le> x"
  and     minpoint_point:"is_vector x \<and> x \<noteq> bot \<longrightarrow> is_point (minpoint x)"
  and     minpoint_empty:"x = bot \<longrightarrow> minpoint x = bot"

context relation_algebra_minpoint
  begin

text{* ";" is a symbol used in Hoare_Logic, thus we have to change the notation here.*}

no_notation
  composition (infixl ";" 75)
notation
  composition (infixl "\<bullet>" 75)

(*
(* We omit the proof of the coloring property here since it has already been done in [2]. *)
definition has_color_prop  :: "'a \<Rightarrow> 'a  \<Rightarrow> bool"
  where "has_color_prop e c \<equiv> c\<bullet>c\<^sup>\<smile> \<sqsubseteq> ~e"
*)

text{* Below we define the maximum degree and prove some properties about it. *}

definition max_deg  :: "'a \<Rightarrow> nat"
  where "max_deg x \<equiv> Max { |x\<bullet>y \<sqinter> 1'| |y . is_point y}"

definition max_degv  :: "'a \<Rightarrow> 'a \<Rightarrow> nat"
  where "max_degv x v \<equiv> Max { |x\<bullet>y \<sqinter> 1'| |y . is_point y \<and> y \<sqsubseteq> v}"

lemma maxdegtop: "max_degv x top = max_deg x"
using max_deg_def max_degv_def by auto

lemma maxdegin:
  assumes "is_vector v"
  and "v \<noteq> bot"
  shows "{ |x\<bullet>y \<sqinter> 1'| |y . is_point y \<and> y \<sqsubseteq> v} \<noteq> {}"
using assms vectorcontpoint by blast

lemma mon_max_degv:
  assumes "x \<sqsubseteq> y"
  and "is_vector x \<and> is_vector y"
  and "x \<noteq>bot"
  and "y \<noteq>bot"
  shows "max_degv e x \<le> max_degv e y"
unfolding max_degv_def
proof -
  have aux: "Max {|e\<bullet>z \<sqinter> 1'| |z. is_point z \<and> z \<sqsubseteq> x} \<in> { |e\<bullet>z\<sqinter> 1'| |z . is_point z \<and> z \<sqsubseteq> x}"
    proof (rule Max_in)
      show "finite {|e\<bullet>z \<sqinter> 1'| |z. is_point z \<and> z \<sqsubseteq> x}"
        by (simp add: finite_point_p_fun)
      next
      show "{|e\<bullet>y \<sqinter> 1'| |y. is_point y\<and> y \<sqsubseteq> x} \<noteq> {}"
        using assms maxdegin by auto
    qed
  obtain p where h1: "Max {|e\<bullet>y\<sqinter> 1'| |y. is_point y \<and> y \<sqsubseteq> x} = |e\<bullet>p\<sqinter> 1'| \<and> is_point p"
    using aux by blast
  have pleq: "|e\<bullet>p\<sqinter> 1'| \<le> Max { |e\<bullet>z\<sqinter> 1'| |z . is_point z\<and> z \<sqsubseteq> y}"
    proof (rule Max_ge)
      show "finite {|e\<bullet>z \<sqinter> 1'| |z. is_point z \<and> z \<sqsubseteq> y}"
        by (simp add: local.finite_point_p_fun)
      next
      show "|e\<bullet>p \<sqinter> 1'| \<in> {|e\<bullet>z \<sqinter> 1'| |z. is_point z \<and> z \<sqsubseteq> y}"
        using assms(1) h1 aux by auto
      qed
  show "Max {|e\<bullet>y \<sqinter> 1'| |y. is_point y \<and> y \<sqsubseteq> x} \<sqsubseteq> Max {|e\<bullet>ya \<sqinter> 1'| |ya. is_point ya \<and> ya \<sqsubseteq> y}"
    by (simp add: h1 pleq)
qed

text{* The following lemma correspond to Lemma 3.3 in the paper. *}
lemma linorderaux:
  assumes "is_linear m \<and> is_order m"
  shows "m\<^sup>\<smile> = 1' \<squnion> m\<^sup>c"
proof (rule antisym)
  show "m\<^sup>\<smile> \<sqsubseteq> 1' \<squnion> m\<^sup>c"
    using assms aux_refl_anti_lin is_lin_def is_linear_def is_order_def by auto
  next
  show "1' \<squnion> m\<^sup>c \<sqsubseteq> m\<^sup>\<smile>"
    by (metis assms aux_card_lin_ord galois_aux3 is_linear_def is_order_def is_refl_def le_inf_iff reflone sup_least)
qed

definition is_symm :: "'a \<Rightarrow> bool"
  where "is_symm x \<longleftrightarrow> x = x\<^sup>\<smile>"

text{* The pre-, postcondition and invariant is defined below. *}

definition pre :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
where "pre e m \<longleftrightarrow> is_irrefl e \<and> is_symm e \<and> is_order m \<and> is_linear m"

definition post where "post e c \<longleftrightarrow> |c\<^sup>\<smile>\<bullet>top\<sqinter> 1'| \<le> max_deg e +1"

definition inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a  \<Rightarrow> bool"
where "inv e m c \<longleftrightarrow> pre e m \<and> is_p_fun c \<and> (c\<^sup>\<smile>\<bullet>top) \<sqsubseteq> (m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top)\<^sup>c)\<^sup>c \<and> |c\<^sup>\<smile>\<bullet>top \<sqinter> 1'| \<le> max_degv e (c\<bullet>top) +1"

text{* In the following we prove the programs correctness. *}

theorem correctness: "VARS e m c p q
  { pre e m }
  c := bot;
  WHILE c\<bullet>top \<noteq> top
    INV { inv e m c }
     DO p := minpoint ((c\<bullet>top)\<^sup>c);
        q := minpoint ((c\<^sup>\<smile>\<bullet>e\<bullet>p)\<^sup>c \<sqinter> (m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>e\<bullet>p)\<^sup>c)\<^sup>c);
        c := c \<squnion> p\<bullet>q\<^sup>\<smile>
     OD
  { post e c}"
proof (vcg_simp)
  (* Proof of (PO1) *)
  fix e and m
  assume hpre: "pre e m"
  show "inv e m bot" by (simp add: hpre inv_def is_p_fun_def)
next
  (* Proof of (PO2) *)
  fix e m c :: 'a
  assume hinv: "inv e m c \<and> c\<bullet>top = top"
  show "post e c" unfolding post_def
    using hinv local.inv_def maxdegtop by auto
next
  (* Proof of (PO3) *)
  fix e m c :: 'a
  let ?p = "minpoint ((c\<bullet>top)\<^sup>c)"
  let ?q = "minpoint ((c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c \<sqinter> (m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c)\<^sup>c)"
  assume hinv: "inv e m c \<and> c\<bullet>top \<noteq> top"
    have auxvec1: "is_vector ((c\<bullet>top)\<^sup>c)"
      by (simp add: is_vector_def one_compl)
    have ppoint: "is_point ?p"
      by (metis auxvec1 hinv compl_bot_eq double_compl minpoint_point)
    have auxvec2: "is_vector ((c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c)"
      by (simp add: compvecpoi local.vector_compl ppoint)
    have auxvec3: "is_vector ((c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c \<sqinter> (m\<^sup>c\<bullet>((c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c))\<^sup>c)"
      using auxvec2 is_vector_def mult_assoc vector_compl vector_mult by auto
    have aux_q: "is_point (?q) \<or> ?q = bot"
      using auxvec3 minpoint_empty minpoint_point by blast
  show "inv e m (c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)" unfolding inv_def
  proof (intro conjI)
    show "|(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top \<sqinter> 1'| \<le> max_degv e ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top) +1"
      proof -
        have "is_point (?q) \<or> ?q = bot"
          using aux_q by blast
        then show "|(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top\<sqinter> 1'| \<le> max_degv e ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top) +1"
          proof
            assume qbot: "?q = bot"
            show "|(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top\<sqinter> 1'| \<le> max_degv e ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top) +1"
              using hinv inv_def qbot by auto
            next
            assume qbot: "is_point (?q)"
            have qincl: "?q \<sqsubseteq> c\<^sup>\<smile>\<bullet>top \<or> ?q \<sqsubseteq> (c\<^sup>\<smile>\<bullet>top)\<^sup>c"
              using comp_assoc is_vector_def leq_point_vect'' qbot by auto
            then show "|(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top \<sqinter> 1'| \<le> max_degv e ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top) +1"
              proof
                assume case1: "?q \<sqsubseteq> c\<^sup>\<smile>\<bullet>top"
                have "|(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top \<sqinter> 1'| = |c\<^sup>\<smile>\<bullet>top \<sqinter> 1'|"
                  by (simp add: comp_points_top sup.absorb1 ppoint qbot case1)
                also have "\<dots> \<le> max_degv e (c\<bullet>top) +1"
                  using hinv inv_def by blast
                also have "\<dots> \<le> max_degv e ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top) +1"
                  proof -
                    have a: "max_degv e (c\<bullet>top) \<le> max_degv e ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top)"
                      proof (rule mon_max_degv)
                      show "is_vector (c\<bullet>top) \<and> is_vector ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top)"
                        by (simp add: is_vector_def mult_assoc)
                      next
                      show "c\<bullet>top \<noteq>bot"
                        using is_point_def le_bot ss_p18 qbot case1 by auto
                      next
                      show "(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top \<noteq>bot"
                        by (simp add: comp_points ss_p18 ppoint qbot)
                      next
                      show "c\<bullet>top \<sqsubseteq> (c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<bullet>top"
                        by simp
                      qed
                    thus ?thesis
                      using add_le_cancel_right by blast
                  qed
                finally show ?thesis
                  by blast
                next
                assume case2: "?q \<sqsubseteq> (c\<^sup>\<smile>\<bullet>top)\<^sup>c"
                have aux: "?q \<squnion> m\<^sup>c\<bullet>?q \<sqsubseteq> (c\<^sup>\<smile>\<bullet>top)\<^sup>c"
                  proof -
                    have "?q \<squnion> m\<^sup>c\<bullet>?q \<sqsubseteq> (c\<^sup>\<smile>\<bullet>top)\<^sup>c \<squnion> m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top)\<^sup>c"
                      using mult_isol sup.mono case2 by blast
                    also have "\<dots> \<sqsubseteq> (c\<^sup>\<smile>\<bullet>top)\<^sup>c"
                      by (metis hinv inv_def aux6_var galois_aux)
                    finally show ?thesis
                      by blast
                  qed
                have aux1: "c\<^sup>\<smile>\<bullet>top \<sqsubseteq> ?q\<^sup>c \<sqinter> (m\<^sup>c\<bullet>?q)\<^sup>c"
                  using aux comp_anti by fastforce
                have aux2: "?q\<^sup>c \<sqinter> (m\<^sup>c\<bullet>?q)\<^sup>c \<sqsubseteq> c\<^sup>\<smile>\<bullet>e\<bullet>?p"
                  proof -
                    have 1: "?q \<sqsubseteq> (m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c)\<^sup>c"
                      using auxvec3 minpoint_empty minpoint_sub by fastforce
                    have 2: "(m\<^sup>\<smile>)\<^sup>c\<bullet> ?q \<sqsubseteq> c\<^sup>\<smile>\<bullet>e\<bullet>?p"
                      by (simp add: "1" conv_compl conv_galois_1)
                    have 3: "(1' \<squnion> m\<^sup>c)\<^sup>c\<bullet> ?q \<sqsubseteq> c\<^sup>\<smile>\<bullet>e\<bullet>?p"
                      using "2" linorderaux hinv inv_def pre_def by auto
                    have 4: "((1' \<squnion> m\<^sup>c)\<bullet> ?q)\<^sup>c \<sqsubseteq> c\<^sup>\<smile>\<bullet>e\<bullet>?p"
                      by (metis "3" pointscompleq qbot)
                    thus ?thesis
                      by (simp add: compl_sup distrib_right mult_onel)
                  qed
                have aux: "|c\<^sup>\<smile>\<bullet>top\<sqinter> 1'| \<le> |e\<bullet>?p\<sqinter> 1'|"
                  proof -
                    have "|c\<^sup>\<smile>\<bullet>top\<sqinter> 1'| \<le> |?q\<^sup>c \<sqinter> (m\<^sup>c\<bullet>?q)\<^sup>c\<sqinter> 1'|"
                      using aux1 cardmono meet_iso by blast
                    also have "\<dots> \<le> |c\<^sup>\<smile>\<bullet>e\<bullet>?p\<sqinter> 1'|"
                      using aux2 cardmono meet_iso by blast
                    also have "\<dots> \<le> |e\<bullet>?p\<sqinter> 1'|"
                      proof (rule cardvecpar)
                      show "is_vector (c\<^sup>\<smile>\<bullet>e\<bullet>?p)"
                        using auxvec2 vector_compl by force
                      next
                      show "is_vector (e \<bullet>?p)"
                        by (metis comp_assoc comp_points_top is_vector_def one_idem_mult ppoint)
                      show  "|c\<^sup>\<smile>\<bullet>e\<bullet>?p|\<le> |e\<bullet>?p|"
                        using hinv inv_def card_pfun comp_assoc by auto
                      qed
                  finally show ?thesis
                    by blast
                  qed
                have "|(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top \<sqinter> 1'| = |c\<^sup>\<smile>\<bullet>top\<sqinter> 1'| + 1 "
                  proof -
                    have "|(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top \<sqinter> 1'| = |(c\<^sup>\<smile>\<bullet>top \<squnion> ?q) \<sqinter> 1'|"
                      by (simp add: comp_points_top ppoint qbot)
                    also have "\<dots> = |(c\<^sup>\<smile>\<bullet>top\<sqinter> 1') \<squnion> (?q \<sqinter> 1')|"
                      by (simp add: inf_sup_distrib2)
                    also have "\<dots> = |c\<^sup>\<smile>\<bullet>top\<sqinter> 1'| + |?q\<sqinter> 1'| - |(c\<^sup>\<smile>\<bullet>top\<sqinter> 1') \<sqinter> (?q \<sqinter> 1')|"
                      using cardcup by blast
                    also have "\<dots> = |c\<^sup>\<smile>\<bullet>top\<sqinter> 1'| + |?q\<sqinter> 1'| - |c\<^sup>\<smile>\<bullet>top \<sqinter> ?q\<sqinter> 1'|"
                    proof -
                      have aux: "(c\<^sup>\<smile>\<bullet>top\<sqinter> 1') \<sqinter> (?q \<sqinter> 1') = c\<^sup>\<smile>\<bullet>top \<sqinter> ?q\<sqinter> 1'"
                        by (simp add: inf.absorb2 inf.assoc)
                      then show ?thesis
                        by simp
                    qed
                    also have "\<dots> = |c\<^sup>\<smile>\<bullet>top\<sqinter> 1'| + |?q\<sqinter> 1'|"
                      proof -
                        have a: "c\<^sup>\<smile>\<bullet>top \<sqinter> ?q\<sqinter> 1' = bot"
                          by (metis aux6_var inf.assoc inf_compl_bot_left1 sup.absorb1 case2)
                        thus ?thesis
                          using a card0 by auto
                      qed
                    finally show ?thesis
                      using card_partial_point pointcap_ppoint qbot by auto
                  qed
                also have "\<dots> \<le> |e\<bullet>?p\<sqinter> 1'| + |?q\<sqinter> 1'|"
                  by (simp add: aux card_partial_point pointcap_ppoint qbot)
                also have "\<dots> = |e\<bullet>?p\<sqinter> 1'| + 1"
                  by (simp add: card_partial_point pointcap_ppoint qbot)
                also have "\<dots> \<le> max_degv e (c\<bullet>top \<squnion> ?p) +1"
                  proof -
                    have aux: "|e\<bullet>?p\<sqinter> 1'| \<le> Max {|e\<bullet>y \<sqinter> 1'| |y. is_point y \<and> y \<sqsubseteq> (c\<bullet>top \<squnion> ?p)}"
                      proof (rule Max_ge)
                      show "finite {|e\<bullet>y \<sqinter> 1'| |y. is_point y \<and> y \<sqsubseteq> c\<bullet>top \<squnion> ?p}"
                        by (simp add: finite_point_p_fun)
                      next
                      show "|e\<bullet>?p \<sqinter> 1'| \<in> {|e\<bullet>y \<sqinter> 1'| |y. is_point y \<and> y \<sqsubseteq> c\<bullet>top \<squnion> ?p}"
                        using ppoint by auto
                      qed
                    thus ?thesis
                      by (simp add: add_le_cancel_right max_degv_def)
                  qed
                finally show ?thesis
                  by (simp add: comp_points_top ppoint qbot)
              qed
            qed
          qed
    next
    show "pre e m"
      using hinv inv_def by blast
    next
    have hp: "c\<^sup>\<smile>\<bullet>?p \<sqsubseteq>  bot"
      by (metis is_vector_def one_compl hinv compl_bot_eq compl_eq_compl_iff compl_top_eq conv_galois_1 conv_invol minpoint_sub)
    show "is_p_fun (c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)" unfolding is_p_fun_def
      apply (simp add: distrib_left)
      proof (intro conjI)
        show "c\<^sup>\<smile>\<bullet>c \<sqsubseteq> 1'"
          using hinv inv_def is_p_fun_def by blast
        next
        show "?q\<bullet>?p\<^sup>\<smile>\<bullet>c \<sqsubseteq> 1'"
          by (metis hp annir bot_least comp_assoc conv_contrav conv_invol conv_zero le_bot)
        next
        show "c\<^sup>\<smile>\<bullet>(?p\<bullet>(?q)\<^sup>\<smile>) \<sqsubseteq> 1'"
          by (metis hp annil bot_least le_bot mult.semigroup_axioms semigroup.assoc)
        show "(?q\<bullet>?p\<^sup>\<smile>)\<bullet>(?p\<bullet>?q\<^sup>\<smile>) \<sqsubseteq> 1'"
          proof -
            have "(?q\<bullet>?p\<^sup>\<smile>)\<bullet>(?p\<bullet>?q\<^sup>\<smile>) \<sqsubseteq> ?q\<bullet>top\<bullet>?q\<^sup>\<smile>"
              by (metis mult_assoc mult_double_iso top_greatest)
            also have "\<dots> \<sqsubseteq> ?q\<bullet>?q\<^sup>\<smile>"
              proof -
                have qp: "is_point ?q \<or> ?q = bot"
                  using aux_q by blast
                    then show ?thesis
                      proof
                        assume qpoint: "is_point ?q"
                        show ?thesis
                          by (metis local.comp_assoc local.comp_points_top local.eq_refl local.one_idem_mult qpoint)
                        next
                        assume qbot: "?q = bot"
                        show ?thesis
                          by (simp add: qbot)
                      qed
              qed
            also have "\<dots> \<sqsubseteq> 1'"
              using aux_q annir bot_least conv_invol conv_zero eq_refl mult_onel point_cnv_map ss423 by presburger
            finally show ?thesis
              by blast
          qed
       qed
    next
    show "(c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top \<sqsubseteq> (m\<^sup>c\<bullet>((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top)\<^sup>c)\<^sup>c"
      proof -
        have aux1: "?q\<bullet>?p\<^sup>\<smile>\<bullet>top \<sqsubseteq> ?q"
          using aux_q annil comp_points_top eq_refl ppoint by presburger
        have aux2: "m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top)\<^sup>c \<sqsubseteq> (c\<^sup>\<smile>\<bullet>top)\<^sup>c"
          using hinv inv_def compl_le_swap1 by blast
        have aux3: "m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top)\<^sup>c \<sqsubseteq> ?q\<^sup>c"
          proof -
            have 1: "c\<^sup>\<smile>\<bullet>e\<bullet>?p \<sqsubseteq> c\<^sup>\<smile>\<bullet>top"
              by (simp add: mult_assoc mult_isol_var)
            have 2: "(m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c)\<^sup>c \<sqsubseteq> (m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top)\<^sup>c)\<^sup>c"
              using "1" compl_mono mult_isol by blast
            have 3: "m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top)\<^sup>c \<sqsubseteq> ?q\<^sup>c"
              proof -
                have a: "?q \<sqsubseteq> (c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c \<sqinter> (m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>e\<bullet>?p)\<^sup>c)\<^sup>c"
                  using auxvec3 local.bot_unique local.minpoint_empty local.minpoint_sub by blast
                then show ?thesis
                  by (meson "2" local.compl_le_swap1 local.dual_order.trans local.inf.boundedE)
              qed
            thus ?thesis
              by blast
          qed
        have "m\<^sup>c\<bullet>((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top)\<^sup>c = m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top \<squnion> ?q\<bullet>?p\<^sup>\<smile>\<bullet>top)\<^sup>c"
          by simp
        also have "\<dots> \<sqsubseteq> m\<^sup>c\<bullet>(c\<^sup>\<smile>\<bullet>top \<squnion> ?q)\<^sup>c"
          by (metis aux1 aux_q comp_points_top eq_iff le_bot ppoint)
        also have "\<dots> \<sqsubseteq> m\<^sup>c\<bullet>((c\<^sup>\<smile>\<bullet>top)\<^sup>c \<sqinter> ?q\<^sup>c)"
          by simp
        also have "\<dots> \<sqsubseteq> (c\<^sup>\<smile>\<bullet>top)\<^sup>c \<sqinter> ?q\<^sup>c"
          using aux2 aux3 local.dual_order.trans local.inf.boundedI local.mult_subdistl by blast
        also have "\<dots> \<sqsubseteq> ((c\<^sup>\<smile> \<squnion> ?q\<bullet>?p\<^sup>\<smile>)\<bullet>top)\<^sup>c"
          by (metis aux1 aux_q local.comp_points_top local.compl_sup local.distrib_right' local.eq_iff local.le_bot ppoint)
        also have "\<dots> \<sqsubseteq> ((c \<squnion> ?p\<bullet>?q\<^sup>\<smile>)\<^sup>\<smile>\<bullet>top)\<^sup>c"
          by simp
        finally show ?thesis
          using local.compl_le_swap1 by blast
      qed
    qed
qed
end


section \<open>Iteration for conjunctive models \label{S:conjunctive-iteration}\<close>

theory Conjunctive_Iteration
imports
  Conjunctive_Sequential
  Iteration
  Infimum_Nat
begin

text \<open>
  Sequential left-distributivity is only supported by conjunctive models
  but does not apply in general. The relational model is one such example.
\<close>

locale iteration_finite_conjunctive = seq_finite_conjunctive + iteration

begin

lemma isolation: "c\<^sup>\<omega> = c\<^sup>\<star> \<sqinter> c\<^sup>\<infinity>"
proof -
  define F where "F = (\<lambda> x. c\<^sup>\<star> \<sqinter> x)"
  define G where "G = (\<lambda> x. c;x)"
  define H where "H = (\<lambda> x. nil \<sqinter> c;x)"

  have FG: "F \<circ> G = (\<lambda> x. c\<^sup>\<star> \<sqinter> c;x)" using F_def G_def by auto
  have HF: "H \<circ> F = (\<lambda> x. nil \<sqinter> c;(c\<^sup>\<star> \<sqinter> x))" using F_def H_def by auto

  have adjoint: "dist_over_sup F" by (simp add: F_def inf_Sup)
  have monoH: "mono H" by (metis H_def inf_mono monoI order_refl seq_mono_right)
  have monoG: "mono G" by (metis G_def inf.absorb_iff2 monoI seq_inf_distrib)

  have "\<forall> x. ((F \<circ> G) x = (H \<circ> F) x)" using FG HF
    by (metis fiter_unfold inf_sup_aci(2) seq_inf_distrib)
  then have "F (lfp G) = lfp H" using adjoint monoH monoG fusion_lfp_eq by blast
  then have "c\<^sup>\<star> \<sqinter> lfp (\<lambda> x. c;x) = lfp (\<lambda> x. nil \<sqinter> c;x)"
     using F_def G_def H_def by blast
  thus ?thesis by (simp add: infiter_def iter_def)
qed

lemma iter_induct_isolate: "c\<^sup>\<star>;d \<sqinter> c\<^sup>\<infinity> = lfp (\<lambda> x. d \<sqinter> c;x)"
proof -
  define F where "F = (\<lambda> x. c\<^sup>\<star>;d \<sqinter> x)"
  define G where "G = (\<lambda> x. c;x)"
  define H where "H = (\<lambda> x. d \<sqinter> c;x)"

  have FG: "F \<circ> G = (\<lambda> x. c\<^sup>\<star>;d \<sqinter> c;x)" using F_def G_def by auto
  have HF: "H \<circ> F = (\<lambda> x. d \<sqinter> c;c\<^sup>\<star>;d \<sqinter> c;x)" using F_def H_def weak_seq_inf_distrib
    by (metis comp_apply inf.commute inf.left_commute seq_assoc seq_inf_distrib)
  have unroll: "c\<^sup>\<star>;d = (nil \<sqinter> c;c\<^sup>\<star>);d" using fiter_unfold by auto
  have distribute: "c\<^sup>\<star>;d = d \<sqinter> c;c\<^sup>\<star>;d" by (simp add: unroll inf_seq_distrib)
  have FGx: "(F \<circ> G) x = d \<sqinter> c;c\<^sup>\<star>;d \<sqinter> c;x" using FG distribute by simp

  have adjoint: "dist_over_sup F" by (simp add: F_def inf_Sup)
  have monoH: "mono H" by (metis H_def inf_mono monoI order_refl seq_mono_right)
  have monoG: "mono G" by (metis G_def inf.absorb_iff2 monoI seq_inf_distrib)

  have "\<forall> x. ((F \<circ> G) x = (H \<circ> F) x)" using FGx HF by (simp add: FG distribute)
  then have "F (lfp G) = lfp H" using adjoint monoH monoG fusion_lfp_eq by blast
  then have "c\<^sup>\<star>;d \<sqinter> lfp (\<lambda> x. c;x) = lfp (\<lambda> x. d \<sqinter> c;x)"
     using F_def G_def H_def by blast
  thus ?thesis by (simp add: infiter_def)
qed

lemma iter_induct_eq: "c\<^sup>\<omega>;d = lfp (\<lambda> x. d \<sqinter> c;x)"
proof -
  have "c\<^sup>\<omega>;d = c\<^sup>\<star>;d \<sqinter> c\<^sup>\<infinity>;d" by (simp add: isolation inf_seq_distrib)
  then have "c\<^sup>\<star>;d \<sqinter> c\<^sup>\<infinity>;d = c\<^sup>\<star>;d \<sqinter> c\<^sup>\<infinity>" by (simp add: infiter_annil)
  then have "c\<^sup>\<star>;d \<sqinter> c\<^sup>\<infinity> = lfp (\<lambda> x. d \<sqinter> c;x)" by (simp add: iter_induct_isolate)
  thus ?thesis
    by (simp add: \<open>c\<^sup>\<omega> ; d = c\<^sup>\<star> ; d \<sqinter> c\<^sup>\<infinity> ; d\<close> \<open>c\<^sup>\<star> ; d \<sqinter> c\<^sup>\<infinity> ; d = c\<^sup>\<star> ; d \<sqinter> c\<^sup>\<infinity>\<close>)
qed

lemma iter_induct: "d \<sqinter> c;x \<sqsubseteq> x \<Longrightarrow> c\<^sup>\<omega>;d \<sqsubseteq> x"
  by (simp add: iter_induct_eq lfp_lowerbound)

lemma iter_isolate: "c\<^sup>\<star>;d \<sqinter> c\<^sup>\<infinity> = c\<^sup>\<omega>;d"
  by (simp add: iter_induct_eq iter_induct_isolate)

lemma iter_isolate2: "c;c\<^sup>\<star>;d \<sqinter> c\<^sup>\<infinity> = c;c\<^sup>\<omega>;d"
  by (metis infiter_unfold iter_isolate seq_assoc seq_inf_distrib)

lemma iter_decomp: "(c \<sqinter> d)\<^sup>\<omega> = c\<^sup>\<omega>;(d;c\<^sup>\<omega>)\<^sup>\<omega>"
proof (rule antisym)
  have      "c;c\<^sup>\<omega>;(d;c\<^sup>\<omega>)\<^sup>\<omega> \<sqinter> (d;c\<^sup>\<omega>)\<^sup>\<omega> \<sqsubseteq> c\<^sup>\<omega>;(d;c\<^sup>\<omega>)\<^sup>\<omega>" by (metis inf_commute order.refl inf_seq_distrib seq_nil_left iter_unfold)
  thus "(c \<sqinter> d)\<^sup>\<omega> \<sqsubseteq> c\<^sup>\<omega>;(d;c\<^sup>\<omega>)\<^sup>\<omega>" by (metis inf.left_commute iter_induct_nil iter_unfold seq_assoc inf_seq_distrib)
next
  have "(c;(c \<sqinter> d)\<^sup>\<omega> \<sqinter> d;(c \<sqinter> d)\<^sup>\<omega>) \<sqinter> nil \<sqsubseteq> (c \<sqinter> d)\<^sup>\<omega>" by (metis inf_commute order.refl inf_seq_distrib iter_unfold)
  then have a: "c\<^sup>\<omega>;(d;(c \<sqinter> d)\<^sup>\<omega> \<sqinter> nil) \<sqsubseteq> (c \<sqinter> d)\<^sup>\<omega>"
  proof -
    have "nil \<sqinter> d;(c \<sqinter> d)\<^sup>\<omega> \<sqinter> c;(c \<sqinter> d)\<^sup>\<omega> \<sqsubseteq> (c \<sqinter> d)\<^sup>\<omega>"
      by (metis eq_iff inf.semigroup_axioms inf_commute inf_seq_distrib iter_unfold semigroup.assoc)
    thus ?thesis using iter_induct_eq by (metis inf_sup_aci(1) iter_induct)
  qed
  then have "d;c\<^sup>\<omega>;(d;(c \<sqinter> d)\<^sup>\<omega> \<sqinter> nil) \<sqinter> nil \<sqsubseteq> d;(c \<sqinter> d)\<^sup>\<omega> \<sqinter> nil" by (metis inf_mono order.refl seq_assoc seq_mono)
  then have "(d;c\<^sup>\<omega>)\<^sup>\<omega> \<sqsubseteq> d;(c \<sqinter> d)\<^sup>\<omega> \<sqinter> nil" by (metis inf_commute iter_induct_nil)
  then have "c\<^sup>\<omega>;(d;c\<^sup>\<omega>)\<^sup>\<omega> \<sqsubseteq> c\<^sup>\<omega>;(d;(c \<sqinter> d)\<^sup>\<omega> \<sqinter> nil)" by (metis order.refl seq_mono)
  thus "c\<^sup>\<omega>;(d;c\<^sup>\<omega>)\<^sup>\<omega> \<sqsubseteq> (c \<sqinter> d)\<^sup>\<omega>" using a refine_trans by blast
qed

lemma iter_leapfrog_var: "(c;d)\<^sup>\<omega>;c \<sqsubseteq> c;(d;c)\<^sup>\<omega>"
proof -
  have "c \<sqinter> c;d;c;(d;c)\<^sup>\<omega> \<sqsubseteq> c;(d;c)\<^sup>\<omega>"
    by (metis iter_unfold order_refl seq_assoc seq_inf_distrib seq_nil_right)
  thus ?thesis using iter_induct_eq by (metis iter_induct seq_assoc)
qed

lemma fiter_leapfrog: "c;(d;c)\<^sup>\<star> = (c;d)\<^sup>\<star>;c"
proof -
  have lr: "c;(d;c)\<^sup>\<star> \<sqsubseteq> (c;d)\<^sup>\<star>;c"
  proof -
    have "(d ; c)\<^sup>\<star> = nil \<sqinter> d ; c ; (d ; c)\<^sup>\<star>"
      by (meson finite_iteration.fiter_unfold finite_iteration_axioms)
    then show ?thesis
      by (metis fiter_induct seq_assoc seq_distrib_left.weak_seq_inf_distrib
          seq_distrib_left_axioms seq_nil_right)
  qed
  have rl: "(c;d)\<^sup>\<star>;c \<sqsubseteq> c;(d;c)\<^sup>\<star>"
  proof -
    have a1: "(c;d)\<^sup>\<star>;c = c \<sqinter> c;d;(c;d)\<^sup>\<star>;c"
       by (metis finite_iteration.fiter_unfold finite_iteration_axioms
           inf_seq_distrib seq_nil_left)
    have a2: "(c;d)\<^sup>\<star>;c \<sqsubseteq> c;(d;c)\<^sup>\<star> \<longleftrightarrow> c \<sqinter> c;d;(c;d)\<^sup>\<star>;c \<sqsubseteq> c;(d;c)\<^sup>\<star>" by (simp add: a1)
    then have a3: "... \<longleftrightarrow> c;( nil \<sqinter> d;(c;d)\<^sup>\<star>;c) \<sqsubseteq> c;(d;c)\<^sup>\<star>"
       by (metis a1 eq_iff fiter_unfold lr seq_assoc seq_inf_distrib seq_nil_right)
    have a4: "(nil \<sqinter> d;(c;d)\<^sup>\<star>;c) \<sqsubseteq> (d;c)\<^sup>\<star> \<Longrightarrow> c;( nil \<sqinter> d;(c;d)\<^sup>\<star>;c) \<sqsubseteq> c;(d;c)\<^sup>\<star>"
       using seq_mono_right by blast
    have a5: "(nil \<sqinter> d;(c;d)\<^sup>\<star>;c) \<sqsubseteq> (d;c)\<^sup>\<star>"
      proof -
        have f1: "d ; (c ; d)\<^sup>\<star> ; c \<sqinter> nil = d ; ((c ; d)\<^sup>\<star> ; c) \<sqinter> nil \<sqinter> nil"
           by (simp add: seq_assoc)
        have "d ; c ; (d ; (c ; d)\<^sup>\<star> ; c \<sqinter> nil) = d ; ((c ; d)\<^sup>\<star> ; c)"
           by (metis (no_types) a1 inf_sup_aci(1) seq_assoc
                seq_finite_conjunctive.seq_inf_distrib seq_finite_conjunctive_axioms
                seq_nil_right)
        then show ?thesis
           using f1 by (metis (no_types) finite_iteration.fiter_induct finite_iteration_axioms
                           inf.cobounded1 inf_sup_aci(1) seq_nil_right)
     qed
   thus ?thesis using a2 a3 a4 by blast
  qed
  thus ?thesis by (simp add: eq_iff lr)
qed

end

locale iteration_infinite_conjunctive = seq_infinite_conjunctive + iteration + infimum_nat

begin

lemma fiter_seq_choice: "c\<^sup>\<star> = (\<Sqinter>i::nat. c \<^sup>;^ i)"
proof (rule antisym)
  show "c\<^sup>\<star> \<sqsubseteq> (\<Sqinter>i. c \<^sup>;^ i)"
  proof (rule INF_greatest)
    fix i
    show "c\<^sup>\<star> \<sqsubseteq> c \<^sup>;^ i"
      proof (induct i type: nat)
        case 0
        show "c\<^sup>\<star> \<sqsubseteq> c \<^sup>;^ 0" by (simp add: fiter0)
      next
        case (Suc n)
        have "c\<^sup>\<star> \<sqsubseteq> c ; c\<^sup>\<star>" by (metis fiter_unfold inf_le2)
        also have "... \<sqsubseteq> c ; (c \<^sup>;^ n)" using Suc.hyps by (simp only: seq_mono_right)
        also have "... = c \<^sup>;^ Suc n" by simp
        finally show "c\<^sup>\<star> \<sqsubseteq> c \<^sup>;^ Suc n" .
      qed
  qed
next
  have "(\<Sqinter>i. c \<^sup>;^ i) \<sqsubseteq> (c \<^sup>;^ 0) \<sqinter> (\<Sqinter>i. c \<^sup>;^ Suc i)"
    by (meson INF_greatest INF_lower UNIV_I le_inf_iff)
  also have "... = nil \<sqinter> (\<Sqinter>i. c ; (c \<^sup>;^ i))" by simp
  also have "... = nil \<sqinter> c ; (\<Sqinter>i. c \<^sup>;^ i)" by (simp add: seq_INF_distrib)
  finally show "(\<Sqinter>i. c \<^sup>;^ i) \<sqsubseteq> c\<^sup>\<star>" using fiter_induct by fastforce
qed

lemma fiter_seq_choice_nonempty: "c ; c\<^sup>\<star> = (\<Sqinter>i\<in>{i. 0 < i}. c \<^sup>;^ i)"
proof -
  have "(\<Sqinter>i\<in>{i. 0 < i}. c \<^sup>;^ i) = (\<Sqinter>i. c \<^sup>;^ (Suc i))" by (simp add: INF_nat_shift)
  also have "... = (\<Sqinter>i. c ; (c \<^sup>;^ i))" by simp
  also have "... = c ; (\<Sqinter>i. c \<^sup>;^ i)" by (simp add: seq_INF_distrib_UNIV)
  also have "... = c ; c\<^sup>\<star>" by (simp add: fiter_seq_choice)
  finally show ?thesis by simp
qed

end

locale conj_iteration = cra + iteration_infinite_conjunctive

begin

lemma conj_distrib4: "c\<^sup>\<star> \<iinter> d\<^sup>\<star> \<sqsubseteq> (c \<iinter> d)\<^sup>\<star>"
proof -
  have "c\<^sup>\<star> \<iinter> d\<^sup>\<star> = (nil \<sqinter> (c;c\<^sup>\<star>)) \<iinter> d\<^sup>\<star>" by (metis fiter_unfold)
  then have "c\<^sup>\<star> \<iinter> d\<^sup>\<star> = (nil \<iinter> d\<^sup>\<star>) \<sqinter> ((c;c\<^sup>\<star>) \<iinter> d\<^sup>\<star>)" by (simp add: inf_conj_distrib)
  then have "c\<^sup>\<star> \<iinter> d\<^sup>\<star> \<sqsubseteq> nil \<sqinter> ((c;c\<^sup>\<star>) \<iinter> (d;d\<^sup>\<star>))" by (metis conj_idem fiter0 fiter_unfold inf.bounded_iff inf_le2 local.conj_mono)
  then have "c\<^sup>\<star> \<iinter> d\<^sup>\<star> \<sqsubseteq> nil \<sqinter> ((c \<iinter> d);(c\<^sup>\<star> \<iinter> d\<^sup>\<star>))" by (meson inf_mono_right order.trans sequential_interchange)
  thus ?thesis by (metis seq_nil_right fiter_induct)
qed

end

end


(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)
theory Folds
imports "../Regular-Sets/Regular_Exp"
begin

section {* ``Summation'' for regular expressions *}

text {*
  To obtain equational system out of finite set of equivalence classes, a fold operation
  on finite sets @{text "folds"} is defined. The use of @{text "SOME"} makes @{text "folds"}
  more robust than the @{text "fold"} in the Isabelle library. The expression @{text "folds f"}
  makes sense when @{text "f"} is not @{text "associative"} and @{text "commutitive"},
  while @{text "fold f"} does not.
*}

definition
  folds :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b"
where
  "folds f z S \<equiv> SOME x. fold_graph f z S x"

text {* Plus-combination for a set of regular expressions *}

abbreviation
  Setalt :: "'a rexp set \<Rightarrow> 'a rexp" ("\<Uplus>_" [1000] 999)
where
  "\<Uplus>A \<equiv> folds Plus Zero A"

text {*
  For finite sets, @{term Setalt} is preserved under @{term lang}.
*}

lemma folds_plus_simp [simp]:
  fixes rs::"('a rexp) set"
  assumes a: "finite rs"
  shows "lang (\<Uplus>rs) = \<Union> (lang ` rs)"
unfolding folds_def
apply(rule set_eqI)
apply(rule someI2_ex)
apply(rule_tac finite_imp_fold_graph[OF a])
apply(erule fold_graph.induct)
apply(auto)
done

end


(*  Title:      HOL/Nunchaku_Examples/Datatype_Nuns.thy
    Author:     Jasmin Blanchette, Inria Nancy, LORIA, MPII
    Copyright   2009-2015

Examples featuring Nunchaku applied to datatypes.
*)

section {* Examples Featuring Nunchaku Applied to Datatypes *}

theory Datatype_Nuns
imports "../Nunchaku"
begin

nunchaku_params [verbose, max_potential = 0, timeout = 240]

primrec rot where
  "rot Nibble0 = Nibble1"
| "rot Nibble1 = Nibble2"
| "rot Nibble2 = Nibble3"
| "rot Nibble3 = Nibble4"
| "rot Nibble4 = Nibble5"
| "rot Nibble5 = Nibble6"
| "rot Nibble6 = Nibble7"
| "rot Nibble7 = Nibble8"
| "rot Nibble8 = Nibble9"
| "rot Nibble9 = NibbleA"
| "rot NibbleA = NibbleB"
| "rot NibbleB = NibbleC"
| "rot NibbleC = NibbleD"
| "rot NibbleD = NibbleE"
| "rot NibbleE = NibbleF"
| "rot NibbleF = Nibble0"

lemma "rot n \<noteq> n"
nunchaku [expect = none]
sorry

lemma "(rot ^^ 15) n \<noteq> n"
nunchaku [expect = none]
sorry

lemma "(rot ^^ 15) n = n"
nunchaku [expect = genuine]
oops

lemma "(rot ^^ 16) n = n"
nunchaku [expect = none]
sorry

datatype ('a, 'b) pd = Pd "'a \<times> 'b"

fun fs where
  "fs (Pd (a, _)) = a"

fun sn where
  "sn (Pd (_, b)) = b"

lemma "fs (Pd p) = fst p"
nunchaku [expect = none]
sorry

lemma "fs (Pd p) = snd p"
nunchaku [expect = genuine]
oops

lemma "sn (Pd p) = snd p"
nunchaku [expect = none]
sorry

lemma "sn (Pd p) = fst p"
nunchaku [expect = genuine]
oops

lemma "fs (Pd ((a, b), (c, d))) = (a, b)"
nunchaku [expect = none]
by simp

lemma "fs (Pd ((a, b), (c, d))) = (c, d)"
nunchaku [expect = genuine]
oops

datatype ('a, 'b) fn = Fn "'a \<Rightarrow> 'b"

fun app where
  "app (Fn f) x = f x"

lemma "app (Fn g) y = g y"
nunchaku [expect = none]
sorry

lemma "app (Fn g) y = g' y"
nunchaku [expect = genuine]
oops

lemma "app (Fn g) y = g y'"
nunchaku [expect = genuine]
oops

end


theory "Denotational-Props"
  imports "Denotational"
begin

subsubsection {* Continuity of the semantics *}

lemma ESem_cont':"Y0 = Y 0 \<Longrightarrow> chain Y \<Longrightarrow> range (\<lambda>i. \<lbrakk> e \<rbrakk>\<^bsub>Y i\<^esub>) <<| \<lbrakk> e \<rbrakk>\<^bsub>(\<Squnion> i. Y i)\<^esub> " and
  "\<And>e. e \<in> snd ` set (asToHeap as) \<Longrightarrow> cont (ESem e)"
proof(nominal_induct e and as avoiding: Y0  arbitrary: Y rule:exp_assn.strong_induct)
case (Lam x e Y0 Y)
  have [simp]: "\<And> i. fdom (Y i) = fdom (Lub Y)"
    by (metis chain_fdom `chain Y`)
  have [simp]:"\<And> i. atom x \<sharp> Y i" and [simp]:"atom x \<sharp> Lub Y"  using Lam.hyps(1) Lam.prems(1)
    unfolding sharp_Env by auto
  have "cont (ESem e)" using Lam.hyps(2) by (rule contI, auto)
  have  "cont (\<lambda> \<rho>. Fn\<cdot>(\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x f\<mapsto> v)\<^esub>))"
    by (intro cont2cont cont_compose[OF `cont (ESem e)`])
  from contE[OF this, OF Lam.prems(2)]
  show ?case
    by simp
next
case (App e v Y0 Y)
  have "cont (ESem e)" using App.hyps(1) by (rule contI, auto)
  thus ?case
    by (auto intro:contE[OF _ App.prems(2)])
next
case (Var v Y0 Y)
  have "cont (\<lambda> \<rho>. ESem (Var v) \<rho>)" by auto
  thus ?case
    by (rule contE[OF _ Var.prems(2)])
next
case (Let as e Y0 Y)
  have fdoms[simp]: "\<And> i. fdom (Y i) = fdom (Lub Y)"
    by (metis chain_fdom `chain Y`)
  have [simp]:"\<And> i. set (bn as) \<sharp>* Y i" and [simp]: "set (bn as) \<sharp>* Lub Y"  using Let.hyps(1) Let.prems(1)
    unfolding sharp_star_Env by auto
  have unset: "\<And>i. fdom (Y i) \<inter> (heapVars (asToHeap as)) = {}"
    using Let by (metis fdoms disjoint_iff_not_equal sharp_star_Env)
  have conts: "\<forall>e\<in>snd ` set (asToHeap as). cont (ESem e)" using Let.hyps(2) by metis
  have cont: "cont (ESem e)" using Let.hyps(3) by (rule contI, auto)
  have cond: "HSem_cond'' (asToHeap as) (\<Squnion> i. Y i)" by (rule disjoint_is_HSem_cond'[OF unset[unfolded fdoms] conts])
  have conds: "\<And>i. HSem_cond'' (asToHeap as) (Y i)" by (rule disjoint_is_HSem_cond'[OF unset conts])

  have chain: "chain (\<lambda>i. HSem (asToHeap as) (Y i))"
    apply (rule chainI)
    apply (rule HSem_monofun''[OF Let.hyps(2) conds conds chainE[OF `chain Y`]])
    by assumption

  have "(\<Squnion> i. HSem (asToHeap as) (Y i)) = HSem (asToHeap as) (Lub Y)"
    apply (rule HSem_cont''[OF Let.hyps(2) cond conds `chain Y`, symmetric])
    by assumption
  thus ?case
    apply simp
    by (metis Let(3) chain)
next
case ANil thus ?case by auto
next
case (ACons v e as Y0 Y)
  have "cont (ESem e)" using ACons.hyps(1) by (rule contI, auto)
  with ACons
  show ?case by auto
qed

interpretation has_cont_ESem ESem
  apply default
  using ESem_cont'[OF refl]
  by (rule contI)

lemmas ESem_cont2cont[simp,cont2cont] = cont_compose[OF ESem_cont]

abbreviation HSem_syn ("\<lbrace>_\<rbrace>_"  [60,60] 60) where "\<lbrace>\<Gamma>\<rbrace>\<rho> \<equiv> HSem \<Gamma> \<rho>"

abbreviation HSem_fempty  ("\<lbrace>_\<rbrace>"  [60] 60) where "\<lbrace>\<Gamma>\<rbrace> \<equiv> \<lbrace>\<Gamma>\<rbrace>fempty"

(* TODO: Where to put this *)

lemma fresh_fmap_upd_lookup[simp]: "S \<sharp>* (\<rho>::Env) \<Longrightarrow> S \<sharp>* x \<Longrightarrow> S \<sharp>* \<rho>(x f\<mapsto> \<rho> f! y)"
  by (auto simp add: fresh_append fresh_star_fmap_upd_eq intro: eqvt_fresh_star_cong2[where f = fmap_delete, OF fmap_delete_eqvt])

lemma compatible_insert:
  assumes [simp]: "S = insert x (fdom \<rho>1)"
  and "x \<notin> fdom \<rho>1"
  and "x \<notin> fdom \<rho>2"
  and compat: "compatible \<rho>1 (\<rho>2\<^bsub>[fdom \<rho>1]\<^esub>)"
  shows "compatible (\<rho>1(x f\<mapsto> y)) (\<rho>2\<^bsub>[S]\<^esub>)"
proof(rule compatible_fmapI)
case (goal1 z)
  show ?case
  apply(cases "z = x")
  using `x \<notin> fdom \<rho>2` apply simp
  using goal1(1) the_lookup_compatible[OF compat, of z]
  apply (cases "z \<in> fdom \<rho>2")
  by auto
next
case goal2 with assms(1) show ?case by simp
qed

subsubsection {* Denotation of Substitution *}

lemma ESem_subst: "x \<noteq> y \<Longrightarrow> atom x \<sharp> \<rho> \<Longrightarrow>  \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x f\<mapsto> \<lbrakk>Var y\<rbrakk>\<^bsub>\<rho>\<^esub>)\<^esub> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<rho>\<^esub>"
  and
  "x \<noteq> y \<Longrightarrow> atom x \<sharp> \<rho> \<Longrightarrow>  heapToEnv (asToHeap as) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x f\<mapsto> \<rho> f! y)\<^esub>)
                    = heapToEnv (asToHeap as[x::a=y]) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>) "
proof (nominal_induct e and as  avoiding: \<rho> x y rule:exp_assn.strong_induct)
case (Var var \<rho> x y) thus ?case by auto
next
case (App exp var \<rho> x y) thus ?case by auto
next
case (Let as exp \<rho> x y)
  from `set (bn as) \<sharp>* x` `set (bn as) \<sharp>* y`
  have "x \<notin> heapVars (asToHeap as)" "y \<notin> heapVars (asToHeap as) "
    by (induct as rule: exp_assn.bn_inducts, auto simp add: exp_assn.bn_defs fresh_star_insert)
  hence [simp]:"heapVars (asToHeap (as[x::a=y])) = heapVars (asToHeap as)"
     by (induct as rule: exp_assn.bn_inducts, auto)

  have cond1: "HSem_cond' (asToHeap as) (\<rho>(x f\<mapsto> \<rho> f! y))"
      (is "fix_join_cond ?\<rho>1 ?F1")
    apply (rule disjoint_is_HSem_cond)
    apply (auto simp add:  `x \<notin> heapVars (asToHeap as)`)
    by (metis Let(1) sharp_star_Env)
  have cond2: "HSem_cond' (asToHeap as[x::a=y]) \<rho>"
      (is "fix_join_cond ?\<rho>2 ?F2")
    apply (rule disjoint_is_HSem_cond)
    apply (auto simp add:  `x \<notin> heapVars (asToHeap as)`)
    by (metis Let(1) sharp_star_Env)

  have lookup_other: "\<And> \<rho> . \<lbrace>asToHeap as[x::a=y]\<rbrace>\<rho> f! y = \<rho> f! y"
    using `y \<notin> heapVars (asToHeap as)`
    by (auto simp add: the_lookup_HSem_other)

  have [simp]:"fdom \<rho> \<union> heapVars (asToHeap as) - {x} = fdom \<rho> \<union> heapVars (asToHeap as)"
    using `x \<notin> heapVars (asToHeap as)` `atom x \<sharp> \<rho>` by (auto simp add: sharp_Env)

  have *: "\<rho>(x f\<mapsto> \<rho> f! y)\<^bsub>[fdom (\<rho>(x f\<mapsto> \<rho> f! y)) \<union> heapVars (asToHeap as)]\<^esub>
        = (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars (asToHeap as)]\<^esub>)(x f\<mapsto> \<rho> f! y)" (is "_ = ?\<rho>1'(x f\<mapsto> _)")
    apply (subst fmap_upd_expand)
    apply auto[3]
    done

  have "fix_on (fix_join_compat ?\<rho>1 ?F1) (\<lambda> \<rho>'. ?\<rho>1 \<squnion> ?F1 \<rho>') \<sqsubseteq>
       (fix_on (fix_join_compat ?\<rho>2 ?F2) (\<lambda> \<rho>'. ?\<rho>2 \<squnion> ?F2 \<rho>')) ( x f\<mapsto> (fix_on (fix_join_compat ?\<rho>2 ?F2) (\<lambda> \<rho>'. ?\<rho>2 \<squnion> ?F2 \<rho>') f! y))"
    (is "?L \<sqsubseteq> ?R( x f\<mapsto> ?R f! y)")
  proof (rule fix_on_ind[OF fix_on_cond_fjc[OF cond1]])
  case goal1 show ?case by (auto intro: adm_is_adm_on)
  case goal2
    show ?case
      apply (subst bottom_of_fjc)
      apply (subst to_bot_fmap_def)
      apply (rule fmap_bottom_below)
      apply (subst (2) fmap_upd_fdom)
      apply (subst fdom_fix_on[OF fix_on_cond_fjc[OF cond2]])
      apply (simp add: bottom_of_fjc to_bot_fmap_def)
      done
  case (goal3 \<rho>')
    let "?F1' \<rho>'" = "heapToEnv (asToHeap as) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>'\<^esub>)\<^bsub>[fdom \<rho> \<union> heapVars (asToHeap as)]\<^esub>"

    have "?\<rho>1 \<squnion> ?F1 \<rho>' = ?\<rho>1'(x f\<mapsto> \<rho> f! y) \<squnion> ?F1 \<rho>'"
      by (subst *, rule)
    also
    have "\<dots> = (?\<rho>1' \<squnion> ?F1' \<rho>')(x f\<mapsto> \<rho> f! y)"
      apply (subst fmap_upd_join)
      using `atom x \<sharp> \<rho>` `x \<notin> heapVars (asToHeap as)` apply (auto simp add: sharp_Env)[3]
      using rho_F_compat_fjc[OF cond1 goal3(1)] apply (metis *)
      by auto
    also
    { have "?F1' \<rho>' \<sqsubseteq> ?F1' (?R( x f\<mapsto> ?R f! y))"
        by (rule cont2monofunE[OF cont_compose[OF fmap_expand_cont cont2cont_heapToEnv[OF ESem_cont]] goal3(2)])
      also
      have "... = ?F2 ?R"
        apply (subst `_ \<Longrightarrow> _ \<Longrightarrow> heapToEnv _ _ = _`[OF `x \<noteq> y` ])
          using `atom x \<sharp> \<rho>` `x \<notin> heapVars (asToHeap as)` fdom_fix_on[OF fix_on_cond_fjc[OF cond2]]
          apply (simp add: sharp_Env bottom_of_fjc)
        by simp
      also note calculation
    }
    hence "... \<sqsubseteq> (?\<rho>2 \<squnion> ?F2 ?R)( x f\<mapsto> \<rho> f! y)"
      apply (rule cont2monofunE[OF
              fmap_upd_cont[OF cont_id cont_const]
              join_mono'[OF rho_F_compat_fjc[OF cond2 fix_on_there[OF fix_on_cond_fjc[OF cond2]]]]
              , rotated])
      apply simp
    done
    also have "... = ?R( x f\<mapsto> \<rho> f! y)"
      by (rule arg_cong[OF fix_on_eq[OF fix_on_cond_fjc[OF cond2], symmetric]])
    also have "... = ?R( x f\<mapsto> ?R f! y)"
      by (subst lookup_other[of \<rho>, unfolded HSem_def'[OF cond2]], rule)
    finally show "?\<rho>1 \<squnion> ?F1 \<rho>' \<sqsubseteq> ?R( x f\<mapsto> ?R f! y)".
  qed
  also
  have "?R (x f\<mapsto> ?R f! y) \<sqsubseteq> ?L"
  proof (rule fix_on_ind[OF fix_on_cond_fjc[OF cond2]])
  case goal1 show ?case by (auto intro: adm_is_adm_on)
  case goal2
    show ?case
      apply (subst fix_on_eq[OF fix_on_cond_fjc[OF cond1]])
      apply (subst bottom_of_fjc)
      apply (subst to_bot_fmap_def)
      apply (subst fdom_fmap_expand)
        apply simp

      apply (rule fmap_upd_belowI)
        apply (subst fdom_join[OF rho_F_compat_fjc[OF cond1 fix_on_there[OF fix_on_cond_fjc[OF cond1]]]])
        apply simp

      apply simp
      apply (subst the_lookup_join[OF rho_F_compat_fjc[OF cond1 fix_on_there[OF fix_on_cond_fjc[OF cond1]]]])
      apply (rule rev_below_trans[OF join_above1[OF the_lookup_compatible[OF rho_F_compat_fjc[OF cond1 fix_on_there[OF fix_on_cond_fjc[OF cond1]]]]]])
      apply (cases "y \<in> fdom \<rho>")
      using  `y \<notin> heapVars (asToHeap as)` apply (auto simp add: bottom_of_fjc to_bot_fmap_def lookup_not_fdom)
      done
  case (goal3 \<rho>')
    let "?F1' \<rho>'" = "heapToEnv (asToHeap as) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>'\<^esub>)\<^bsub>[fdom \<rho> \<union> heapVars (asToHeap as)]\<^esub>"
    let "?F2' \<rho>'" = "heapToEnv (asToHeap as[x::a=y]) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>'\<^esub>)\<^bsub>[insert x (fdom \<rho> \<union> heapVars (asToHeap as))]\<^esub>"
    have "fdom \<rho>' = fdom \<rho> \<union> heapVars (asToHeap as)"
      using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond2] goal3(1)] by simp

    have "(?\<rho>2 \<squnion> ?F2 \<rho>') (x f\<mapsto> (?\<rho>2 \<squnion> ?F2 \<rho>') f! y) = (?\<rho>2 \<squnion> ?F2 \<rho>')(x f\<mapsto> \<rho> f! y)"
      apply (rule arg_cong) back
      apply (subst the_lookup_join[OF rho_F_compat_fjc[OF cond2 goal3(1)]])
      apply (case_tac "y \<in> fdom \<rho>")
      using `y \<notin> heapVars (asToHeap as)`
      by (auto simp add: sharp_Env lookup_not_fdom)
    also
    have "... = (?\<rho>1'(x f\<mapsto> \<rho> f! y) \<squnion> ?F2' \<rho>')"
      apply (subst fmap_upd_join)
      using `atom x \<sharp> \<rho>` `x \<notin> heapVars (asToHeap as)` apply (auto simp add: sharp_Env)[3]
      apply (rule compatible_insert)
        using `atom x \<sharp> \<rho>` `x \<notin> heapVars (asToHeap as)` apply (auto simp add: sharp_Env)[3]
      apply simp
      apply (rule rho_F_compat_fjc[OF cond2 goal3(1), simplified])
      apply simp
      done
    also
    have "... = ?\<rho>1 \<squnion> ?F2' \<rho>'"
      by (subst *, rule)
    also
    have "... = ?\<rho>1 \<squnion> ?F1 (\<rho>'(x f\<mapsto> \<rho>' f! y))"
      apply (subst `_ \<Longrightarrow> _ \<Longrightarrow> heapToEnv _ _ = _`[OF `x \<noteq> y` ])
        using `atom x \<sharp> \<rho>` `fdom \<rho>' = _` `x \<notin> heapVars (asToHeap as)` fdom_fix_on[OF fix_on_cond_fjc[OF cond2]]
        apply (simp add: sharp_Env bottom_of_fjc)
      by simp
    also
    from `\<rho>'(x f\<mapsto> \<rho>' f! y) \<sqsubseteq> ?L`
    have  "... \<sqsubseteq> ?L"
      unfolding bottom_of_fjc
      by (rule join_fjc[OF rho_fjc[OF cond1] F_pres_compat''[OF cond1], unfolded fjc_iff])
    finally
    show "(?\<rho>2 \<squnion> ?F2 \<rho>') (x f\<mapsto> (?\<rho>2 \<squnion> ?F2 \<rho>') f! y) \<sqsubseteq> ?L".
  qed
  finally
  have "\<lbrace>asToHeap as\<rbrace>(\<rho>(x f\<mapsto> \<rho> f! y)) = (\<lbrace>asToHeap (as[x ::a= y])\<rbrace>\<rho>)(x f\<mapsto> \<lbrace>asToHeap (as[x ::a= y])\<rbrace>\<rho> f! y)"
    unfolding  HSem_def'[OF cond1] subst HSem_def'[OF cond2] .
  with Let
  show ?case
  by (auto simp add: fresh_star_Pair fresh_at_base)
next
case (Lam var exp \<rho> x' y) thus ?case
  apply (auto simp add: fresh_star_Pair pure_fresh)
  apply (subst fmap_upd_twist)
  apply (auto)[1]
  apply (rule cfun_eqI)
  apply (erule_tac x = "x'" in meta_allE)
  apply (erule_tac x = "y" in meta_allE)
  apply (erule_tac x = "\<rho>(var f\<mapsto> x)" in meta_allE)
  apply (auto simp add: pure_fresh fresh_at_base)[1]
  done
next
case (ANil \<rho> x y) thus ?case by auto
next
case(ACons var exp as \<rho> x y)  thus ?case by auto
qed

(* TODO move where? *)

lemma fmap_expand_compatible:
  assumes [simp]: "finite S"
  assumes compat:"compatible \<rho>1 \<rho>2"
  shows "compatible (\<rho>1\<^bsub>[S]\<^esub>) (\<rho>2\<^bsub>[S]\<^esub>)"
  apply (rule compatible_fmapI)
  apply (case_tac "x \<in> fdom \<rho>1")
  apply (auto simp add: fdom_compatible[OF compat] intro: the_lookup_compatible[OF compat])
  done

lemma fmap_expand_join:
  assumes [simp]: "finite S"
  assumes compat:"compatible \<rho>1 \<rho>2"
  shows "(\<rho>1 \<squnion> \<rho>2)\<^bsub>[S]\<^esub> = \<rho>1\<^bsub>[S]\<^esub> \<squnion> \<rho>2\<^bsub>[S]\<^esub>"
proof-
  have [simp]: "fdom \<rho>2 = fdom \<rho>1" by (metis fdom_compatible[OF compat])
  have [simp]: "fdom (\<rho>1 \<squnion> \<rho>2) = fdom \<rho>1" by (rule fdom_join[OF compat])
  have compat2: "compatible (\<rho>1\<^bsub>[S]\<^esub>) (\<rho>2\<^bsub>[S]\<^esub>)"
    by (rule fmap_expand_compatible[OF assms])
  show ?thesis
    apply (rule fmap_eqI)
    apply (simp add: fdom_join[OF compat2])
    apply (case_tac "x \<in> fdom \<rho>1")
    by (auto simp add: the_lookup_join[OF compat2] the_lookup_join[OF compat])
qed

subsubsection {* The semantics ignores fresh variables *}

lemma ESem_ignores_fresh:
  "\<rho>1 \<le> \<rho>2 \<Longrightarrow> atom ` (fdom \<rho>2 - fdom \<rho>1) \<sharp>* e \<Longrightarrow> \<lbrakk>e\<rbrakk>\<^bsub>\<rho>1\<^esub> = \<lbrakk>e\<rbrakk>\<^bsub>\<rho>2\<^esub>"
  and
  "\<rho>1 \<le> \<rho>2 \<Longrightarrow> atom ` (fdom \<rho>2 - fdom \<rho>1) \<sharp>* as \<Longrightarrow> heapToEnv (asToHeap as) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>1\<^esub>) = heapToEnv (asToHeap as) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>2\<^esub>)"
proof (nominal_induct e and as avoiding: \<rho>1 \<rho>2 rule:exp_assn.strong_induct)
case (Var x \<rho>1 \<rho>2)
  show ?case
  proof(cases "x \<in> fdom \<rho>1")
  case True
    show ?thesis
      by (simp add: fmap_less_eqD[OF `\<rho>1 \<le> \<rho>2` True])
  next
  case False
    have "x \<notin> fdom \<rho>2"
    proof
      assume "x \<in> fdom \<rho>2"
      hence "x \<in> fdom \<rho>2 - fdom \<rho>1" using False by simp
      thus False
        using Var(2)
        apply (simp add: fresh_star_def)
        apply (erule ballE[where x = "x"])
        by auto
    qed
    with False
    show ?thesis
      by (auto simp add: lookup_not_fdom)
  qed
next
case (App e x \<rho>1 \<rho>2)
  from App(3)
  have "atom ` (fdom \<rho>2 - fdom \<rho>1) \<sharp>* e"
    by (auto simp add: fresh_star_def)
  note hyps = App.hyps[OF App.prems(1) this]
  moreover
  have "\<rho>1 f! x = \<rho>2 f! x"
  proof(cases "x \<in> fdom \<rho>1")
  case True
    show ?thesis
      by (simp add: fmap_less_eqD[OF `\<rho>1 \<le> \<rho>2` True])
  next
  case False
    have "x \<notin> fdom \<rho>2"
    proof
      assume "x \<in> fdom \<rho>2"
      hence "x \<in> fdom \<rho>2 - fdom \<rho>1" using False by simp
      thus False
        using App(3)
        apply (simp add: fresh_star_def)
        apply (erule ballE[where x = "x"])
        by auto
    qed
    with False
    show ?thesis
      by (auto simp add: lookup_not_fdom)
  qed
  ultimately
  show ?case
    by simp
next
case (Let as e \<rho>1 \<rho>2)
  have cond1: "HSem_cond' (asToHeap as) \<rho>1"
      (is "fix_join_cond ?\<rho>1 ?F1")
    apply (rule disjoint_is_HSem_cond)
    using Let(1)
    by (auto simp add: sharp_star_Env)
  have cond2: "HSem_cond' (asToHeap as) \<rho>2"
      (is "fix_join_cond ?\<rho>2 ?F2")
    apply (rule disjoint_is_HSem_cond)
    using Let(2)
    by (auto simp add: sharp_star_Env)

  have "fdom \<rho>1 \<subseteq> fdom \<rho>2" by (metis Let(5) fmap_less_fdom)

  have "\<lbrace>asToHeap as\<rbrace>\<rho>1 \<le> \<lbrace>asToHeap as\<rbrace>\<rho>2"
  proof (rule parallel_HSem_ind[OF cond1 cond2])
  case goal1 show ?case by (rule adm_is_adm_on, simp)
  case goal2
    show ?case
      apply (rule fmap_bottom_less)
      using `fdom \<rho>1 \<subseteq> fdom \<rho>2` apply auto[2]
      done
  case (goal3 \<rho>1' \<rho>2')
    have [simp]:"fdom \<rho>1' = fdom \<rho>1 \<union> heapVars (asToHeap as)" and [simp]:"fdom \<rho>2' = fdom \<rho>2 \<union> heapVars (asToHeap as)"
      using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond1] goal3(1)]
      using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond2] goal3(2)]
      by simp+
    note compat1 = rho_F_compat_fjc[OF cond1 goal3(1)]
    note compat2 = rho_F_compat_fjc[OF cond2 goal3(2)]

    have prem: "atom ` (fdom \<rho>2' - fdom \<rho>1') \<sharp>* as"
      using Let(6) Let(1) Let(2)
      apply (auto simp add: sharp_star_Env fresh_star_def)
      by (metis Diff_iff sharp_Env)

    show "?\<rho>1 \<squnion> ?F1 \<rho>1' \<le> ?\<rho>2 \<squnion> ?F2 \<rho>2'"
    proof(rule fmap_less_eqI)
    case goal1
      show ?case
        apply (subst fdom_join[OF compat1])
        apply (subst fdom_join[OF compat2])
        using `fdom \<rho>1 \<subseteq> fdom \<rho>2`
        by auto
    next
    case (goal2 x)
      hence dom: "x \<in> fdom \<rho>1 \<union> heapVars (asToHeap as)"
        apply (subst (asm) fdom_join[OF compat1])
        by simp
      hence dom2: "x \<in> fdom \<rho>2 \<union> heapVars (asToHeap as)"
        by (auto intro: set_mp[OF `fdom \<rho>1 \<subseteq> fdom \<rho>2`])

      have "lookup ?\<rho>1 x = lookup ?\<rho>2 x"
      proof (cases "x \<in> fdom \<rho>1")
      case True
        hence "x \<in> fdom \<rho>2" by (rule set_mp[OF `fdom \<rho>1 \<subseteq> fdom \<rho>2`])
        with True show ?thesis
          by (simp add: fmap_less_eqD[OF `\<rho>1 \<le> \<rho>2` True])
      next
      case False
        hence "x \<notin> fdom \<rho>2"
          using Let(2) dom
          by (auto simp add: sharp_star_Env)
        with False dom show ?thesis by (simp add: lookup_not_fdom)
      qed
      moreover
      have "lookup (?F1 \<rho>1') x = lookup (?F2 \<rho>2') x"
      proof (cases "x \<in> heapVars (asToHeap as)")
      case True
        thus ?thesis
          by (simp add: Let(3)[OF goal3(3) prem])
      next
      case False
        thus ?thesis
          using dom dom2 by simp
      qed
      ultimately
      show ?case
        apply (subst the_lookup_join[OF compat1])
        apply (subst the_lookup_join[OF compat2])
        by simp
    qed
  qed
  moreover
  have "atom ` (fdom (\<lbrace>asToHeap as\<rbrace>\<rho>2) - fdom (\<lbrace>asToHeap as\<rbrace>\<rho>1)) \<sharp>* e "
    using Let(6) Let(1) Let(2)
    apply (auto simp add: sharp_star_Env fresh_star_def)
    by (metis Diff_iff sharp_Env)
  ultimately
  have "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>\<rho>1\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>\<rho>2\<^esub>"
    apply (rule Let.hyps(4))
    done
  thus "\<lbrakk> Terms.Let as e \<rbrakk>\<^bsub>\<rho>1\<^esub> = \<lbrakk> Terms.Let as e \<rbrakk>\<^bsub>\<rho>2\<^esub>"
    using Let.hyps(1,2) by simp
next
case (Lam x e \<rho>1 \<rho>2)
  { fix v
    have "\<rho>1(x f\<mapsto> v) \<le> \<rho>2(x f\<mapsto> v)"
      apply (rule fmap_less_eqI)
      using fmap_less_fdom[OF Lam(4)] apply auto[1]
      apply (case_tac "xa = x")
      by (auto simp add: fmap_less_eqD[OF `\<rho>1 \<le> \<rho>2`])
    moreover
    have "atom ` (fdom (\<rho>2(x f\<mapsto> v)) - fdom (\<rho>1(x f\<mapsto> v))) \<sharp>* e"
      using Lam(5)
      by (auto simp add: fresh_star_def)
    ultimately
    have "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>1(x f\<mapsto> v)\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<rho>2(x f\<mapsto> v)\<^esub>"
      by (rule Lam(3))
  }
  thus "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>1\<^esub> = \<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>2\<^esub>"
    using Lam(1,2)
    by simp
next
case ANil
  thus ?case by simp
next
case (ACons x e as \<rho>1 \<rho>2)
  from ACons(4)
  have prem1: "atom ` (fdom \<rho>2 - fdom \<rho>1) \<sharp>* e" and  prem2: "atom ` (fdom \<rho>2 - fdom \<rho>1) \<sharp>* as"
    by (auto simp add: fresh_star_def)
  from ACons.hyps(1)[OF `\<rho>1 \<le> \<rho>2` prem1] ACons.hyps(2)[OF `\<rho>1 \<le> \<rho>2` prem2]
  show ?case by simp
qed

lemma HSem_add_fresh:
  assumes cond1: "HSem_cond' \<Gamma> \<rho>"
  assumes cond2: "HSem_cond' ((x,e) # \<Gamma>) \<rho>"
  assumes fresh: "atom x \<sharp> (\<rho>, \<Gamma>)"
  shows  "fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (\<lbrace>(x, e) # \<Gamma>\<rbrace>\<rho>) = \<lbrace>\<Gamma>\<rbrace>\<rho>"
proof(rule HSem_add_fresh[OF assms])
case (goal1 e \<rho>')
  assume "e \<in> snd ` set \<Gamma>"
  hence "atom x \<sharp> e"
    apply auto
    by (metis fresh fresh_PairD(2) fresh_list_elem)

  assume "fdom \<rho>' = fdom \<rho> \<union> heapVars ((x, e) # \<Gamma>)"
  hence [simp]:"fdom \<rho>' - fdom \<rho>' \<inter> (fdom \<rho>' - {x}) = {x}" by auto

  show ?case
    apply (rule ESem_ignores_fresh[symmetric, OF fmap_restr_less])
    apply (simp add: fresh_star_def)
    using `atom x \<sharp> e`.
qed

lemma ESem_add_fresh:
  assumes cond1: "HSem_cond' \<Gamma> \<rho>"
  assumes cond2: "HSem_cond' ((x,e') # \<Gamma>) \<rho>"
  assumes fresh: "atom x \<sharp> (\<rho>, \<Gamma>, e)"
  shows "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>"
proof(rule ESem_ignores_fresh[symmetric])
  have "\<lbrace>\<Gamma>\<rbrace>\<rho> = fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (\<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>) "
    apply (rule HSem_add_fresh[OF assms(1,2), symmetric])
    using fresh by (simp add: fresh_Pair)
  thus "\<lbrace>\<Gamma>\<rbrace>\<rho> \<le> \<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>"
    by (auto simp add: fmap_less_restrict)

  have "(insert x (fdom \<rho> \<union> heapVars \<Gamma>) - (fdom \<rho> \<union> heapVars \<Gamma>)) = {x}"
    using fresh
    apply (auto simp add: fresh_Pair sharp_Env)
    by (metis heapVars_not_fresh)
  thus "atom ` (fdom (\<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>) - fdom (\<lbrace>\<Gamma>\<rbrace>\<rho>)) \<sharp>* e"
    using fresh
    by (simp add: fresh_star_def fresh_Pair)
qed

subsubsection {* Replacing subexpressions by variables *}

lemma HSem_subst_var_app:
  assumes cond1: "HSem_cond' ((x, App (Var n) y) # (n, e) # \<Gamma>) \<rho>"
  assumes cond2: "HSem_cond' ((x, App e y) # (n, e) # \<Gamma>) \<rho>"
  assumes fresh: "atom n \<sharp> (x,\<rho>)"
  shows "\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho> = \<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho> "
proof(rule HSem_subst_expr[OF cond1 cond2])
  from fresh have [simp]:"n \<notin> fdom \<rho>" "n \<noteq> x" by (simp add: fresh_Pair sharp_Env fresh_at_base)+
  have ne: "(n,e) \<in> set ((x, App e y) # (n, e) # \<Gamma>)" by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho> f! n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    apply (subst HSem_eq[OF cond2])
    apply (subst the_lookup_join[OF rho_F_compat_fjc[OF cond2 HSem_there[OF cond2]]])
    apply simp
    done
  finally
  show "\<lbrakk> App (Var n) y \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> App e y \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp

 have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho> f! n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    apply (subst HSem_eq[OF cond1])
    apply (subst the_lookup_join[OF rho_F_compat_fjc[OF cond1 HSem_there[OF cond1]]])
    apply simp
    done
  finally
  show "\<lbrakk> App e y \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> App (Var n) y \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp
qed

lemma HSem_subst_var_var:
  assumes cond1: "HSem_cond' ((x, Var n) # (n, e) # \<Gamma>) \<rho>"
  assumes cond2: "HSem_cond' ((x, e) # (n, e) # \<Gamma>) \<rho>"
  assumes fresh: "atom n \<sharp> (x,\<rho>)"
  shows "\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho> = \<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho> "
proof(rule HSem_subst_expr[OF cond1 cond2])
  from fresh have [simp]:"n \<notin> fdom \<rho>" "n \<noteq> x" by (simp add: fresh_Pair sharp_Env fresh_at_base)+
  have ne: "(n,e) \<in> set ((x, e) # (n, e) # \<Gamma>)" by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho> f! n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    apply (subst HSem_eq[OF cond2])
    apply (subst the_lookup_join[OF rho_F_compat_fjc[OF cond2 HSem_there[OF cond2]]])
    apply simp
    done
  finally
  show "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho> f! n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    apply (subst HSem_eq[OF cond1])
    apply (subst the_lookup_join[OF rho_F_compat_fjc[OF cond1 HSem_there[OF cond1]]])
    apply simp
    done
  finally
  show "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp
qed

subsubsection {* Binding more variables increases knowledge *}

lemma HSem_subset_below:
  assumes cond2: "HSem_cond' (\<Delta>@\<Gamma>) \<rho>"
  assumes fresh: "atom ` heapVars \<Gamma> \<sharp>* (\<Delta>, \<rho>)"
  shows "(\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Delta>@\<Gamma>\<rbrace>\<rho>"
proof (rule HSem_ind) back
case goal1 show ?case by (auto intro!: adm_is_adm_on adm_subst[OF fmap_expand_cont])
next
case goal2 show ?case by (auto simp add: to_bot_fmap_def)
next
show rho: "(\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Delta>]\<^esub>)\<^bsub>[fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Delta> @ \<Gamma>\<rbrace>\<rho> "
  apply (subst fmap_expand_idem)
  apply auto[3]
  using HSem_refines[OF cond2]
  by (auto simp add: sup.assoc)

  from fresh
  have "heapVars \<Gamma> \<inter> (fdom \<rho> \<union> heapVars \<Delta>) = {}"
    by (auto dest: fresh_heapVars_distinct simp add: sharp_star_Env' fresh_star_Pair)
  hence fdoms: "fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma> - (fdom \<rho> \<union> heapVars \<Delta>) = heapVars \<Gamma>"
    by auto

case (goal3 x)
  note cond1 = goal3(1)
  have  "fdom x = fdom \<rho> \<union> heapVars \<Delta>"
    using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond1] goal3(2)]
    by simp
  {
    fix v e
    assume "e \<in> snd` set \<Delta>"
    thm fresh_star_heap_expr'
    from fresh_star_heap_expr'[OF _ this]
    have fresh_e: "atom ` heapVars \<Gamma> \<sharp>* e"
      by (metis fresh fresh_star_Pair)
    have "\<lbrakk> e \<rbrakk>\<^bsub>x\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>x\<^bsub>[fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma>]\<^esub>\<^esub>"
      apply (rule ESem_ignores_fresh)
      apply (rule less_fmap_expand)
        using `fdom x = _` apply auto[2]
      apply (simp add: `fdom x = _` fdoms)
      apply (rule fresh_e)
      done
    with goal3(3)
    have "\<lbrakk> e \<rbrakk>\<^bsub>x\<^esub> \<sqsubseteq> \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Delta> @ \<Gamma>\<rbrace>\<rho>\<^esub>"
      by (metis cont2monofunE[OF ESem_cont])
  } note e_less = this

  note compat = rho_F_compat_fjc[OF cond1 goal3(2)]
  note compat2 = rho_F_compat_fjc[OF cond2 HSem_there[OF cond2]]
  show ?case
    apply (subst fmap_expand_join[OF _ compat], simp)
    apply (rule join_below[OF fmap_expand_compatible[OF _ compat] rho], simp)
    apply (subst fmap_expand_idem)
      apply auto[3]
    apply (rule fmap_expand_belowI)
      apply auto[1]
    apply (subst HSem_eq[OF cond2])
    apply (subst the_lookup_join[OF compat2])
    apply (rule below_trans[OF _ join_above2[OF the_lookup_compatible[OF compat2]]])
    apply (subst lookup_fmap_expand1)
      apply auto[3]
    apply simp
    apply (subst lookupHeapToEnv, assumption)
    apply (subst lookupHeapToEnv)
      apply auto[1]
    apply (simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
    apply (rule e_less)
    by (metis the_map_of_snd)
qed

subsubsection {* Additional, fresh bindings in one or two steps *}

lemma HSem_merge:
  assumes distinct1: "distinctVars (\<Delta> @ \<Gamma>)"
  assumes fresh: "atom ` heapVars \<Gamma> \<sharp>* (\<Delta>, \<rho>)"
  assumes rho_fresh: "fdom \<rho> \<inter> heapVars (\<Gamma> @ \<Delta>) = {}"
  shows "\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> = \<lbrace>\<Gamma>@\<Delta>\<rbrace>\<rho>"
proof(rule below_antisym)
  from distinct1
  have distinct2: "distinctVars (\<Gamma> @ \<Delta>)"
    by (auto simp add: distinctVars_append)

  from fresh
  have Gamma_fresh: "heapVars \<Gamma> \<inter> (fdom \<rho> \<union> heapVars \<Delta>) = {}"
    by (auto dest: fresh_heapVars_distinct simp add: sharp_star_Env' fresh_star_Pair)
  hence fdoms: "fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma> - (fdom \<rho> \<union> heapVars \<Delta>) = heapVars \<Gamma>"
    by auto

  have cond1: "HSem_cond' \<Gamma> (\<lbrace>\<Delta>\<rbrace>\<rho>)"
    apply (rule disjoint_is_HSem_cond)
    using Gamma_fresh by auto
  have cond2: "HSem_cond' (\<Gamma>@\<Delta>) \<rho>"
    apply (rule disjoint_is_HSem_cond)
    using rho_fresh by auto
  have cond2': "HSem_cond' (\<Delta>@\<Gamma>) \<rho>"
    apply (rule disjoint_is_HSem_cond)
    using rho_fresh by auto
  have cond3: "HSem_cond' \<Delta> \<rho>"
    apply (rule disjoint_is_HSem_cond)
    using rho_fresh by auto

  show "\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> \<sqsubseteq> \<lbrace>\<Gamma>@\<Delta>\<rbrace>\<rho>"
  proof (rule HSem_ind) back
  case goal1 show ?case by (auto simp add: adm_is_adm_on)
  next
  case goal2 show ?case by (auto simp add: to_bot_fmap_def)
  next
  have "(\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom \<rho> \<union> heapVars \<Delta> \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Delta> @ \<Gamma>\<rbrace>\<rho>"
    by (rule HSem_subset_below[OF cond2' fresh])
  also have "\<lbrace>\<Delta> @ \<Gamma>\<rbrace>\<rho> = \<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho>"
    by (rule HSem_reorder[OF distinct1 distinct2], auto)
  finally
  show Delta_rho: "(\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom (\<lbrace>\<Delta>\<rbrace>\<rho>) \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho>"
    by simp

  case (goal3 \<rho>')
    note compat = rho_F_compat_fjc[OF cond1 goal3(2)]
    note compat2 = rho_F_compat_fjc[OF cond2 HSem_there[OF cond2]]

    have "heapToEnv \<Gamma> (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho>\<^esub>)\<^bsub>[fdom (\<lbrace>\<Delta>\<rbrace>\<rho>) \<union> heapVars \<Gamma>]\<^esub> \<sqsubseteq> \<lbrace>\<Gamma> @ \<Delta>\<rbrace>\<rho> "
    proof (rule fmap_expand_belowI)
    case goal1 thus ?case by auto
    case (goal2 x)
      hence x:"x \<in> heapVars \<Gamma>" by auto
      thus ?case
        apply (subst lookupHeapToEnv, assumption)
        apply (subst (2) HSem_eq[OF cond2])
        apply (subst the_lookup_join[OF compat2])
        apply (rule below_trans[OF _ join_above2[OF the_lookup_compatible[OF compat2]]])
        apply (subst lookup_fmap_expand1)
          using x apply auto[3]
        apply (subst lookupHeapToEnv)
          apply auto[1]
        apply (simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
        done
    qed
    thus ?case
      by (rule join_below[OF compat Delta_rho
          below_trans[OF cont2monofunE[OF cont_compose[OF fmap_expand_cont cont2cont_heapToEnv[OF ESem_cont]] goal3(3)]]])
  qed

  show "\<lbrace>\<Gamma>@\<Delta>\<rbrace>\<rho> \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>"
  proof (rule HSem_ind) back back
  case goal1 show ?case by (auto simp add: adm_is_adm_on)
  next
  case goal2 show ?case by (auto simp add: to_bot_fmap_def)
  next
  have "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub> = (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Delta>]\<^esub>)\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub>"
    by (rule fmap_expand_idem[symmetric], auto)
  also have "... \<sqsubseteq> (\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub>"
    by (rule cont2monofunE[OF fmap_expand_cont HSem_refines[OF cond3]])
  also have "... = (\<lbrace>\<Delta>\<rbrace>\<rho>)\<^bsub>[fdom (\<lbrace>\<Delta>\<rbrace>\<rho>) \<union> heapVars (\<Gamma>)]\<^esub>"
    apply (rule arg_cong) back
    by auto
  also have "... \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>"
    by (rule HSem_refines[OF cond1])
  finally
  show rho: "\<rho>\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub> \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho> ".

  case (goal3 \<rho>')
    note compat = rho_F_compat_fjc[OF cond2 goal3(2)]
    note compat2 = rho_F_compat_fjc[OF cond1 HSem_there[OF cond1]]
    note compat3 = rho_F_compat_fjc[OF cond3 HSem_there[OF cond3]]

    have "heapToEnv (\<Gamma> @ \<Delta>) (\<lambda>e. \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>\<^esub>)\<^bsub>[fdom \<rho> \<union> heapVars (\<Gamma> @ \<Delta>)]\<^esub> \<sqsubseteq> \<lbrace>\<Gamma>\<rbrace>\<lbrace>\<Delta>\<rbrace>\<rho>"
    proof (rule fmap_expand_belowI)
    case goal1 thus ?case by auto
    case (goal2 x)
      hence "x \<in> heapVars \<Gamma> \<or> (x \<notin> heapVars \<Gamma> \<and> x \<in> heapVars \<Delta>)" by auto
      thus ?case
      proof
        assume x: "x \<in> heapVars \<Gamma>"
        thus ?thesis
        apply (subst lookupHeapToEnv)
          apply auto[1]
        apply (subst (2) HSem_eq[OF cond1])
        apply (subst the_lookup_join[OF compat2])
        apply (rule below_trans[OF _ join_above2[OF the_lookup_compatible[OF compat2]]])
        apply (subst lookup_fmap_expand1)
          using x apply auto[3]
        apply (subst lookupHeapToEnv, assumption)
        apply (simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
        done
      next
        assume x: "x \<notin> heapVars \<Gamma> \<and> x \<in> heapVars \<Delta>"
        hence [simp]:"x \<notin> heapVars \<Gamma>" and  "x \<in> heapVars \<Delta>" by auto
        from this(2)
        show ?thesis
        apply (subst lookupHeapToEnv)
          apply auto[1]
        apply (subst the_lookup_HSem_other)
          apply simp
        apply (subst (2) HSem_eq[OF cond3])
        apply (subst the_lookup_join[OF compat3])
        apply (rule below_trans[OF _ join_above2[OF the_lookup_compatible[OF compat3]]])
        apply (subst lookup_fmap_expand1)
          using x apply auto[3]
        apply (subst lookupHeapToEnv, assumption)
        apply (simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
        apply (rule eq_imp_below)
        apply (rule ESem_ignores_fresh[symmetric])
        apply (rule HSem_disjoint_less)
          using Gamma_fresh apply auto[1]
        apply (simp add: fdoms)
        apply (erule fresh_star_heap_expr'[OF _ the_map_of_snd, rotated])
        by (metis fresh fresh_star_Pair)
      qed
    qed
    thus ?case
      by (rule join_below[OF compat rho
          below_trans[OF cont2monofunE[OF cont_compose[OF fmap_expand_cont cont2cont_heapToEnv[OF ESem_cont]] goal3(3)]]])
  qed
qed

subsubsection {* The semantics of let only adds new bindings *}

text {*
The following lemma is not as general as possible and specialized to @{text "\<rho> = fempty"}, as that is
the only case required later on, and easier to prove.
*}

lemma HSem_unfold_let:
  assumes cond1: "HSem_cond' ((x, Let as body) # \<Gamma>) \<rho>"
  assumes cond2: "HSem_cond' ((x, body) # asToHeap as @ \<Gamma>) \<rho>"
  assumes cond3: "HSem_cond' (asToHeap as @ ((x, body) # \<Gamma>)) \<rho>"
  assumes distinct1: "distinctVars (asToHeap as)"
  assumes distinct2: "distinctVars ((x, body) # \<Gamma>)"
  assumes fresh: "set (bn as) \<sharp>* (x, Let as body, \<Gamma>, \<rho>)"
  assumes too_lazy_to_do_it_for_more_than_fempty: "\<rho> = fempty"
  shows "\<lbrace>(x, Let as body) # \<Gamma>\<rbrace>\<rho> \<le> \<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>"
proof (rule iffD2[OF fmap_less_restrict])
  from fresh
  have fresh_Gamma: "atom ` heapVars (asToHeap as) \<sharp>* \<Gamma>"
    by (metis fresh_star_Pair set_bn_to_atom_heapVars)

  from fresh
  have "set (bn as) \<sharp>* ((x, Let as body) # \<Gamma>)"
    by (auto simp add: fresh_star_def fresh_Pair fresh_Cons)
  note notInAs = fresh_assn_distinct[OF this]

  from fresh
  have notInRho: "heapVars (asToHeap as) \<inter> fdom \<rho> = {}"
    by (auto simp add: fresh_star_Pair sharp_star_Env)

  have disjoint: "heapVars (asToHeap as) \<inter> insert x (fdom \<rho> \<union> heapVars \<Gamma>) = {}"
    using notInAs notInRho
    by auto
  hence x_not_as: "x \<notin> heapVars (asToHeap as)"
    by auto

  {
    fix x' e
    assume "e \<in> snd ` set \<Gamma>"

    have simp1: " fdom (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>) \<inter> insert x (fdom \<rho> \<union> heapVars \<Gamma>) = insert x (fdom \<rho> \<union> heapVars \<Gamma>)"
      by auto

    have simp2: "fdom (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>) - insert x (fdom \<rho> \<union> heapVars \<Gamma>) = heapVars (asToHeap as)"
      using disjoint
      by auto

    have fresh_e: "atom ` heapVars (asToHeap as) \<sharp>* e"
      by (rule fresh_star_heap_expr'[OF fresh_Gamma `_ \<in> snd\` set \<Gamma>`])

    have "\<lbrakk> e \<rbrakk>\<^bsub>fmap_restr (insert x (fdom \<rho> \<union> heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>)\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>\<^esub>"
      apply (rule ESem_ignores_fresh[OF fmap_restr_less])
      apply (subst fdom_fmap_restr)
        apply simp
      apply (subst simp1)
      apply (subst simp2)
      apply (rule fresh_e)
      done
  } note Gamma_eq = this

case goal1
  have "\<lbrace>(x, Let as body) # \<Gamma>\<rbrace>\<rho> = fmap_restr (insert x (fdom \<rho> \<union> heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>)"
  proof(rule below_antisym)
    show below: "\<lbrace>(x, Let as body) # \<Gamma>\<rbrace>\<rho> \<sqsubseteq> fmap_restr (insert x (fdom \<rho> \<union> heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>)"
    proof (rule HSem_ind'[OF cond1])
    case goal1 show ?case by (auto intro: adm_is_adm_on)
    case goal2 show ?case by (auto simp add: to_bot_fmap_def)
    case (goal3 \<rho>')
      have fdom: "fdom \<rho>' = insert x (fdom \<rho> \<union> heapVars \<Gamma>)"
        using fdom_fix_join_compat[OF fix_on_cond_fjc[OF cond1] goal3(1)]
        by simp

      hence [simp]: "set (bn as) \<sharp>* \<rho>'"
        using disjoint
        by (auto simp add: set_bn_to_atom_heapVars fresh_star_def sharp_Env)

      note compat1 = rho_F_compat_fjc[OF cond1 goal3(1)]
      note compat2 = rho_F_compat_fjc[OF cond2 HSem_there[OF cond2]]
      show ?case
      proof(rule fmap_belowI)
      case goal1 show ?case by (auto simp add: fdom_join[OF compat1, simplified])
      case (goal2 x')
        hence x': "x' \<in> insert x (fdom \<rho> \<union> heapVars \<Gamma>)"
          by (auto simp add: fdom_join[OF compat1, simplified])

        hence x'_not_as:"x' \<notin> heapVars (asToHeap as)"
          using disjoint
          by auto

        have "\<lbrakk> Terms.Let as body \<rbrakk>\<^bsub>\<rho>'\<^esub> = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>\<rho>'\<^esub>" by simp
        also have "... \<sqsubseteq> \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>(fmap_restr (insert x (fdom \<rho> \<union> heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>))\<^esub>"
          apply (rule cont2monofunE[OF ESem_cont])
          apply (rule HSem_mono[OF _ _ goal3(2)])
          apply (rule disjoint_is_HSem_cond)
          apply (subst fdom)
          using disjoint apply auto[1]
          apply (rule disjoint_is_HSem_cond)
          using disjoint apply auto[1]
          done
        also have "... = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>(fmap_restr (insert x (fdom \<rho> \<union> heapVars \<Gamma>)) (\<lbrace>asToHeap as @ ((x, body) # \<Gamma>)\<rbrace>\<rho>))\<^esub>"
          by (rule arg_cong[OF HSem_reorder_head_append[OF x_not_as]])
        also have "... = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as @ ((x, body) # \<Gamma>)\<rbrace>\<rho>\<^esub>"
          apply (rule arg_cong) back
          apply (rule HSem_redo[OF cond3, simplified (no_asm)])
          apply (rule disjoint_is_HSem_cond)
          using disjoint by auto
        also have "... = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>\<^esub>"
          by (rule arg_cong[OF HSem_reorder_head_append[OF x_not_as], symmetric])
        also note x = calculation

        show ?case
          apply (subst lookup_fmap_restr[OF _ x', simplified])
          apply (subst HSem_eq[OF cond2])
          apply (subst the_lookup_join[OF compat1])
          apply (subst the_lookup_join[OF compat2])
          apply (rule join_mono[OF the_lookup_compatible[OF compat1] the_lookup_compatible[OF compat2]])
            using x' apply (cases "x' \<in> fdom \<rho>", simp_all)[1]
          apply (cases "x' \<in> insert x (heapVars \<Gamma>)")
          defer
            using x' apply simp
          apply (cases "x' = x")
            using x apply simp
          apply (subst lookup_fmap_expand1)
            apply simp_all[3]
          apply (subst lookup_fmap_expand1)
            apply auto[3]
          apply (simp add: lookupHeapToEnvNotAppend[OF x'_not_as])
          apply (subst lookupHeapToEnv, assumption)
          apply (subst lookupHeapToEnv, assumption)
          apply (rule below_trans[OF cont2monofunE[OF ESem_cont goal3(2)] eq_imp_below])
          apply (erule Gamma_eq[OF the_map_of_snd])
          done
      qed
    qed

    have [simp]: "set (bn as) \<sharp>* (\<lbrace>(x, Terms.Let as body) # \<Gamma>\<rbrace>\<rho>)"
      apply (rule HSem_fresh_star)
      using fresh by (auto simp add: fresh_star_Pair fresh_star_Cons)

    have "(\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>) \<sqsubseteq> \<lbrace>asToHeap as\<rbrace>\<lbrace>(x, Let as body) # \<Gamma>\<rbrace>\<rho>"
    proof (rule HSem_below)
    case goal1
      show ?case
        apply (rule fmap_expand_belowI)
          apply auto[1]
        apply (rule below_trans[OF HSem_refines_lookup[OF cond1]], assumption)
        apply (rule HSem_refines_lookup)
          apply (rule disjoint_is_HSem_cond)
          using disjoint apply auto[1]
        apply simp
        done
    case (goal2 x')
      have body: "\<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>\<lbrace>(x, Terms.Let as body) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrace>asToHeap as\<rbrace>\<lbrace>(x, Terms.Let as body) # \<Gamma>\<rbrace>\<rho> f! x"
        apply (subst ESem.simps(4)[symmetric])
        apply simp
        apply (subst the_lookup_HSem_other)
        apply (metis x_not_as)
        apply (rule below_trans[OF eq_imp_below HSem_heap_below[OF cond1]])
        apply auto
        done
      show ?case
        apply (cases "x' = x")
          apply simp
          apply (rule body)

        apply (subst (1 2) HSem_merge)
          apply (metis distinct1 distinct2 distinctVars.intros(2) distinctVars_Cons distinctVars_ConsD(1) distinctVars_appendI inf_commute notInAs)
          using fresh apply (metis fresh_star_Pair fresh_star_Cons set_bn_to_atom_heapVars)
          using too_lazy_to_do_it_for_more_than_fempty apply simp
        apply (rule below_trans[OF eq_imp_below HSem_heap_below, rotated])
          apply (rule disjoint_is_HSem_cond) using too_lazy_to_do_it_for_more_than_fempty apply simp
          using goal2 apply simp
        apply (rule arg_cong) back
          apply (cases "x' \<in> heapVars (asToHeap as)")
          apply (simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
          apply (simp add: map_add_dom_app_simps dom_map_of_conv_image_fst)
        done
    qed
    thus "fmap_restr (insert x (fdom \<rho> \<union> heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<rho>) \<sqsubseteq> \<lbrace>(x, Let as body) # \<Gamma>\<rbrace>\<rho>"
      apply (rule below_trans[OF cont2monofunE[OF fmap_restr_cont] eq_imp_below])
      apply (rule fmap_restr_HSem_noop[of _ "\<lbrace>(x, Terms.Let as body) # \<Gamma>\<rbrace>\<rho>", simplified (no_asm)])
      using disjoint apply auto
      done
  qed
  thus ?case
    by (rule subst[where s = "insert q Q" for q Q, rotated], auto)
qed
end


theory DependentOrd
  imports Ordinal "../OPair/DependentSum"
begin

abbreviation (in Ordinal) (input) gt where "gt j i \<equiv> lt i j"

syntax
  "_depfun_ord" :: "[pttrn, 'a, bool] => bool" (\<open>(3\<Pi>_<_./ _)\<close> 10)
  "_depsum_ord" :: "[pttrn, 'a, bool] => bool" (\<open>(3\<Sigma>_<_./ _)\<close> 10)
translations
  "\<Pi> i<j. B" \<rightleftharpoons> "\<Pi> i:(CONST Ord \<triangle> (CONST gt) j). B"
  "\<Sigma> i<j. B" \<rightleftharpoons> "\<Sigma> i:(CONST Ord \<triangle> (CONST gt) j). B"

context Ordinal begin

subsection \<open>Rules for dependent functions on ordinals\<close>

lemma depfun_ordI :
  assumes i:"\<And>i. i : Ord \<Longrightarrow> i < j \<Longrightarrow> F i :  B i"
  shows "F : (\<Pi> i < j. B i)"
  by (rule depfunI, drule intE, use i in unfold_typs)

lemma depfun_ordE :
  assumes F:"F : (\<Pi> i < j. B i)"
      and i:"i : Ord" "i < j"
  shows "F i : B i"
  by (rule depfunE[OF F intI[OF i(1) tyI]], rule i(2))

end

class DepSumOrd =
  OPair + Ordinal

begin

subsection \<open>Rules for dependent sums on ordinals\<close>

lemma depsum_ordI :
  assumes ib:"<i,b> : Pair"
      and i:"i : Ord" "i < j" and b:"b : B i"
    shows "<i,b> : (\<Sigma> i < j. B i)"
  by (rule depsumI[OF ib intI[OF i(1) tyI]], rule i(2), rule b)

lemma depsum_ordD :
  assumes t:"t : (\<Sigma> i < j. B i)"
  shows "t : Pair" "\<tau> t : Ord" "\<tau> t < j" "\<pi> t : B (\<tau> t)"
  by (use depsumD[OF t] in unfold_typs)

lemma depsum_ordD_pair :
  assumes t:"<i,b> : (\<Sigma> i < j. B i)"
  shows "<i,b> : Pair" "i : Ord" "i < j" "b : B i"
  by (use depsumD_pair[OF t] in unfold_typs)

lemma depsum_ordE :
  assumes t:"t : (\<Sigma> i < j. B i)"
  obtains i b where "t : Pair" "t = <i,b>" "i : Ord" "i < j" "b : B i"
  by (rule depsumE[OF t], unfold_typs)

end
end