(*
 * Copyright (c) 2020, CleanQ Project - Systems Group, ETH Zurich
 * All rights reserved.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 *
 * See "LICENSE" for details.
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Set Model COMPLX proofs\<close>

text \<open>
  Due to problems importing both SIMPL and COMPLX we split the files and have all the proofs
  using COMPLX in this file
\<close>

theory CleanQ_SetModel_Complx
(*<*)
imports
  Main
  CleanQ_SetModel
  "../Complx/OG_Hoare"
 "../Complx/OG_Syntax"
begin
(*>*)

record CleanQ_Set_st =
  SRB :: "nat CleanQ_Set_State"

(* ==================================================================================== *)
subsection \<open>Integration in COMPLX\<close>
(* ==================================================================================== *)

text \<open>
  We now integrate the the CleanQ Set Model into COMPLX. For each of the two operations,
  enqueue and dequeue, we specify a Hoare-triple with pre and post conditions, and
  the operation.
\<close>

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Enqueue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We first show, that we can define a Hoare triple for the enqueue operations from both
  agents X and Y, and that in both cases the invariant is preserved.
\<close>
lemma CleanQ_Set_enq_x_preserves_invariants :
  "\<Gamma>, \<Theta> |\<turnstile>\<^bsub>/ F\<^esub>
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB \<and>  b \<in> SX \<acute>SRB\<rbrace>
          \<acute>SRB := (CleanQ_Set_enq_x b \<acute>SRB)
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB\<rbrace>, \<lbrace>True\<rbrace>"
  unfolding CleanQ_Set_Invariants_def
  apply(oghoare)
  by (simp add: CleanQ_Set_enq_x_I1 CleanQ_Set_enq_x_I2 Collect_mono_iff)

lemma CleanQ_Set_enq_y_preserves_invariants :
  "\<Gamma>, \<Theta> |\<turnstile>\<^bsub>/ F\<^esub>
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB \<and> b \<in> SY \<acute>SRB\<rbrace>
          \<acute>SRB := (CleanQ_Set_enq_y b \<acute>SRB)
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB\<rbrace>, \<lbrace>True\<rbrace>"
  unfolding CleanQ_Set_Invariants_def
  apply(oghoare)
  by (simp add: CleanQ_Set_enq_y_I1 CleanQ_Set_enq_y_I2 Collect_mono_iff)

text \<open>
  The same applies for the multi-step \verb+eneuque_n+ operation.
\<close>

lemma CleanQ_Set_enq_n_x_preserves_invariants :
  "\<Gamma>, \<Theta> |\<turnstile>\<^bsub>/ F\<^esub>
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB \<and>  (\<forall>b \<in> B. b \<in> (SX \<acute>SRB)) \<rbrace>
          \<acute>SRB := (CleanQ_Set_enq_n_x B \<acute>SRB)
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB\<rbrace>, \<lbrace>True\<rbrace>"
  unfolding CleanQ_Set_Invariants_def
  apply(oghoare)
  by (simp add: CleanQ_Set_enq_n_x_I1 CleanQ_Set_enq_n_x_I2 Collect_mono)

lemma CleanQ_Set_enq_n_y_preserves_invariants :
  "\<Gamma>, \<Theta> |\<turnstile>\<^bsub>/ F\<^esub>
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB \<and>  (\<forall>b \<in> B. b \<in> (SY \<acute>SRB)) \<rbrace>
          \<acute>SRB := (CleanQ_Set_enq_n_y B \<acute>SRB)
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB\<rbrace>, \<lbrace>True\<rbrace>"
  unfolding CleanQ_Set_Invariants_def
  apply(oghoare)
  by (simp add: CleanQ_Set_enq_n_y_I1 CleanQ_Set_enq_n_y_I2 Collect_mono)

text \<open>
  The enqueue operation  happens in two steps. The buffer element is removed
  from one set and added to a new set. We can express this as two sequential operations
  in the next lemma, where we show that the invariant is still preserved and that
  the outcome is the same, as with the definition above.
\<close>

lemma CleanQ_Set_enq_x_two_step :
  "\<Gamma>, \<Theta> |\<turnstile>\<^bsub>/ F\<^esub>
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB \<and>  b \<in> SX \<acute>SRB \<rbrace>
        \<acute>SRB := \<acute>SRB \<lparr> SX := (SX \<acute>SRB) - {b} \<rparr> ;;
        \<lbrace>CleanQ_Set_Invariants (K-{b}) \<acute>SRB  \<rbrace>
        \<acute>SRB := \<acute>SRB \<lparr> TXY := (TXY \<acute>SRB) \<union> {b} \<rparr>
        \<lbrace>CleanQ_Set_Invariants K \<acute>SRB\<rbrace>, \<lbrace>True\<rbrace>"
  apply (oghoare, auto)
  oops

(*<*)
end
(*>*)


section "More on Substitutions"

(*
  Originally for stuff from Term_Subst.ML

  Now has little do to with it and contains stuff about various substitutions in general
  Problem: Inconsistent naming
*)

theory Term_Subst
  imports Term
begin

fun subst_typ :: "((variable \<times> sort) \<times> typ) list \<Rightarrow> typ \<Rightarrow> typ" where
  "subst_typ insts (Ty a Ts) =
    Ty a (map (subst_typ insts) Ts)"
| "subst_typ insts (Tv idn S) = the_default (Tv idn S)
    (lookup (\<lambda>x . x = (idn, S)) insts)"

lemma subst_typ_nil[simp]: "subst_typ [] T = T"
  by (induction T) (auto simp add: map_idI)

lemma subst_typ_irrelevant_order:
  assumes "distinct (map fst pairs)" and "distinct (map fst pairs')" and "set pairs = set pairs'"
shows "subst_typ pairs T = subst_typ pairs' T"
  using assms
proof(induction T)
  case (Ty n Ts)
  then show ?case by (induction Ts) auto
next
  case (Tv idn S)
  then show ?case using lookup_eq_order_irrelevant by (metis subst_typ.simps(2))
qed

(* Core lemma, Isabelle/Pure's instantiateT_same function can simulate abstract type subtitutions
  in types *)
lemma subst_typ_simulates_tsubstT_gen': "distinct l \<Longrightarrow> tvsT T \<subseteq> set l
  \<Longrightarrow> tsubstT T \<rho> = subst_typ (map (\<lambda>(x,y).((x,y), \<rho> x y)) l) T"
proof(induction T arbitrary: l)
  case (Ty n Ts)
  then show ?case by (induction Ts) auto
next
  case (Tv idn S)
  hence d: "distinct (map fst (map (\<lambda>(x,y).((x,y), \<rho> x y)) l))"
    by (simp add: case_prod_beta map_idI)
  hence el: "((idn,S), \<rho> idn S) \<in> set (map (\<lambda>a. case a of (x, y) \<Rightarrow> ((x, y), \<rho> x y)) l)"
    using Tv by auto
  show ?case using iffD1[OF lookup_present_eq_key, OF _ el]  Tv.prems d by auto
qed

lemma subst_typ_simulates_tsubstT_gen: "tsubstT T \<rho>
  = subst_typ (map (\<lambda>(x,y).((x,y), \<rho> x y)) (SOME l . distinct l \<and> tvsT T \<subseteq> set l)) T"
proof(rule someI2_ex)
  show "\<exists>a. distinct a \<and> tvsT T \<subseteq> set a"
    using finite_tvsT finite_distinct_list
    by (metis order_refl)
next
  fix l assume l: "distinct l \<and> tvsT T \<subseteq> set l"
  then show "tsubstT T \<rho> = subst_typ (map (\<lambda>a. case a of (x, y) \<Rightarrow> ((x, y), \<rho> x y)) l) T"
    using subst_typ_simulates_tsubstT_gen' by blast
qed

corollary subst_typ_simulates_tsubstT: "tsubstT T \<rho>
  = subst_typ (map (\<lambda>(x,y).((x,y), \<rho> x y)) (SOME l . distinct l \<and> set l = tvsT T)) T"
  apply (rule someI2_ex)
  using finite_tvsT finite_distinct_list apply metis
  using subst_typ_simulates_tsubstT_gen' apply simp
  done

(* Other direction, can construct a abstract substitution for one performed by instantiateT_same *)
lemma tsubstT_simulates_subst_typ: "subst_typ insts T
  = tsubstT T (\<lambda>idn S . the_default (Tv idn S) (lookup (\<lambda>x. x=(idn, S)) insts))"
  by (induction T) auto

(* Somewhat janky version of "composition" for subst_typ *)
lemma subst_typ_comp:
  "subst_typ inst1 (subst_typ inst2 T) = subst_typ (map (apsnd (subst_typ inst1)) inst2 @ inst1) T"
proof (induction inst2 T arbitrary: inst1 rule: subst_typ.induct)
  case (1 insts a Ts)
  then show ?case
    by auto
next
  case (2 insts idn S)
  then show ?case
    by (induction insts) auto
qed
(* To make insts distinct again *)
lemma subst_typ_AList_clearjunk: "subst_typ insts T = subst_typ (AList.clearjunk insts) T"
proof (induction T)
  case (Ty n Ts)
  then show ?case
    by auto
next
  case (Tv n S)
  then show ?case
  proof(induction insts)
    case Nil
    then show ?case
      by auto
  next
    case (Cons inst insts)
    then show ?case
      by simp (metis clearjunk.simps(2) lookup_AList_clearjunk)
  qed
qed

fun subst_type_term :: "((variable \<times> sort) \<times> typ) list \<Rightarrow>
    ((variable \<times> typ) \<times> term) list \<Rightarrow> term \<Rightarrow> term" where
  "subst_type_term instT insts (Ct c T) = Ct c (subst_typ instT T)"
| "subst_type_term instT insts (Fv idn T) = (let T' = subst_typ instT T in
    the_default (Fv idn T') (lookup (\<lambda>x. x = (idn, T')) insts))"
| "subst_type_term _ _ (Bv n) = Bv n"
| "subst_type_term instT insts (Abs T t) = Abs (subst_typ instT T) (subst_type_term instT insts t)"
| "subst_type_term instT insts (t $ u) = subst_type_term instT insts t $ subst_type_term instT insts u"

lemma subst_type_term_empty_no_change[simp]: "subst_type_term [] [] t = t"
  by (induction t) (simp_all add:)

lemma subst_type_term_irrelevant_order:
  assumes instT_assms: "distinct (map fst instT)" "distinct (map fst instT')" "set instT = set instT'"
  assumes insts_assms: "distinct (map fst insts)" "distinct (map fst insts')" "set insts = set insts'"
shows "subst_type_term instT insts t = subst_type_term instT' insts' t"
  using assms
proof(induction t)
  case (Fv idn T)
  then show ?case
    apply (simp add: Let_def subst_typ_irrelevant_order[OF Fv.prems(1-3)])
    using lookup_eq_order_irrelevant by (metis Fv.prems(4) Fv.prems(5) insts_assms)
next
  case (Abs T t)
  then show ?case using subst_typ_irrelevant_order[OF instT_assms] by simp
qed (simp_all add: subst_typ_irrelevant_order[OF instT_assms])

(* Core lemma, Isabelle/Pure's instantiate_same function can simulate abstract
  term/type subtitutions in terms

  The tsubst should be no problem, can be rewritten to subst_type using previous simulation lemma
*)
lemma subst_type_term_simulates_subst_tsubst_gen':
  assumes lty_assms: "distinct lty" "tvs t \<subseteq> set lty"
  assumes lt_assms: "distinct lt" "fv (tsubst t \<rho>ty) \<subseteq> set lt"
  shows "subst (tsubst t \<rho>ty) \<rho>t
    = subst_type_term (map (\<lambda>(x,y).((x,y), \<rho>ty x y)) lty) (map (\<lambda>(x,y).((x,y), \<rho>t x y)) lt) t"
proof-
  let ?lty = "map (\<lambda>(x,y).((x,y), \<rho>ty x y)) lty"

  have p1ty: "distinct (map fst ?lty)" using lty_assms
    by (simp add: case_prod_beta map_idI)

  let ?lt = "map (\<lambda>(x,y).((x,y), \<rho>t x y)) lt"

  have p1t: "distinct (map fst ?lt)" using lt_assms
    by (simp add: case_prod_beta map_idI)

  show ?thesis using assms
  proof(induction t arbitrary: lty lt)
    case (Fv idn T)

    let ?T = "tsubstT T \<rho>ty"
    have el: "((idn, ?T), \<rho>t idn ?T) \<in> set (map (\<lambda>(x,y).((x,y), \<rho>t x y)) lt)"
      using Fv by auto
    have d: "distinct (map fst (map (\<lambda>(x,y).((x,y), \<rho>t x y)) lt))"
      using Fv by (simp add: case_prod_beta map_idI)
    show ?case using  Fv.prems d
      by (auto simp add: iffD1[OF lookup_present_eq_key, OF d el]
          subst_typ_simulates_tsubstT_gen'[symmetric] Let_def)
  qed (simp_all add: subst_typ_simulates_tsubstT_gen')
qed

corollary subst_type_term_simulates_subst_tsubst: "subst (tsubst t \<rho>ty) \<rho>t
    = subst_type_term (map (\<lambda>(x,y).((x,y), \<rho>ty x y)) (SOME lty . distinct lty \<and> tvs t = set lty))
      (map (\<lambda>(x,y).((x,y), \<rho>t x y)) (SOME lt . distinct lt \<and> fv (tsubst t \<rho>ty) = set lt)) t"
  apply (rule someI2_ex)
  using finite_fv finite_distinct_list apply metis
  apply (rule someI2_ex)
  using finite_tvs finite_distinct_list apply metis
  using subst_type_term_simulates_subst_tsubst_gen' by simp

abbreviation "subst_typ' pairs t \<equiv> map_types (subst_typ pairs) t"

lemma subst_typ'_nil[simp]: "subst_typ' [] A = A"
  by (induction A) (auto simp add:)

lemma subst_typ'_simulates_tsubst_gen': "distinct pairs \<Longrightarrow> tvs t \<subseteq> set pairs
  \<Longrightarrow> tsubst t \<rho> = subst_typ' (map (\<lambda>(x,y).((x,y), \<rho> x y)) pairs) t"
  by (induction t arbitrary: pairs \<rho>)
    (auto simp add: subst_typ_simulates_tsubstT_gen')

lemma subst_typ'_simulates_tsubst_gen: "tsubst t \<rho>
  = subst_typ' (map (\<lambda>(x,y).((x,y), \<rho> x y)) (SOME l . distinct l \<and> tvs t \<subseteq> set l)) t"
proof(rule someI2_ex)
  show "\<exists>a. distinct a \<and> tvs t \<subseteq> set a"
    using finite_tvs finite_distinct_list
    by (metis order_refl)
next
  fix l assume l: "distinct l \<and> tvs t \<subseteq> set l"

  then show "tsubst t \<rho> = subst_typ' (map (\<lambda>a. case a of (x, y) \<Rightarrow> ((x, y), \<rho> x y)) l) t"
    using subst_typ'_simulates_tsubst_gen' by blast
qed

lemma tsubst_simulates_subst_typ': "subst_typ' insts T
  = tsubst T (\<lambda>idn S . the_default (Tv idn S) (lookup (\<lambda>x. x=(idn, S)) insts))"
  by (induction T) (auto simp add: tsubstT_simulates_subst_typ)

(*
  Naming!
*)
lemma subst_type_add_degenerate_instance:
  "(idx,s) \<notin> set (map fst insts) \<Longrightarrow> subst_typ insts T = subst_typ (((idx,s), Tv idx s)#insts) T"
  by (induction T) (auto simp add: lookup_eq_key_not_present)

lemma subst_typ'_add_degenerate_instance:
  "(idx,s) \<notin> set (map fst insts) \<Longrightarrow> subst_typ' insts t = subst_typ' (((idx,s), Tv idx s)#insts) t"
  by (induction t) (auto simp add: subst_type_add_degenerate_instance)

(* Again, janky composition *)
lemma subst_typ'_comp:
  "subst_typ' inst1 (subst_typ' inst2 t) = subst_typ' (map (apsnd (subst_typ inst1)) inst2 @ inst1) t"
  by (induction t) (use subst_typ_comp in auto)

(* To make insts distinct again *)
lemma subst_typ'_AList_clearjunk: "subst_typ' insts t = subst_typ' (AList.clearjunk insts) t"
  by (induction t) (use subst_typ_AList_clearjunk in auto)

fun subst_term :: "((variable * typ) * term) list \<Rightarrow> term \<Rightarrow> term" where
  "subst_term insts (Ct c T) = Ct c T"
| "subst_term insts (Fv idn T) = the_default (Fv idn T) (lookup (\<lambda>x. x=(idn, T)) insts)"
| "subst_term _ (Bv n) = Bv n"
| "subst_term insts (Abs T t) = Abs T (subst_term insts t)"
| "subst_term insts (t $ u) = subst_term  insts t $ subst_term insts u"

lemma subst_term_empty_no_change[simp]: "subst_term [] t = t"
  by (induction t) auto

lemma subst_type_term_without_type_insts_eq_subst_term[simp]:
  "subst_type_term [] insts t = subst_term insts t"
  by (induction insts t rule: subst_term.induct) simp_all

lemma subst_type_term_split_levels:
  "subst_type_term instT insts t = subst_term insts (subst_typ' instT t)"
  by (induction t) (auto simp add: Let_def)

(* Express parallel substitution as a series of single substitutions. *)

(* Deleted assms in the induction once, recheck proofs, maybe some get easier. *)
lemma subst_typ_stepwise:
  assumes "distinct (map fst instT)"
  assumes "\<And>x . x \<in> (\<Union>t \<in> snd ` set instT . tvsT t) \<Longrightarrow> x \<notin> fst ` set instT"
  shows "subst_typ instT T = fold (\<lambda>single acc . subst_typ [single] acc) instT T"
using assms proof (induction instT T rule: subst_typ.induct)
  case (1 inst a Ts)
  then show ?case
  proof (induction Ts arbitrary: inst)
    case Nil
    then show ?case by (induction inst) auto
  next
    case (Cons T Ts)
    hence "subst_typ inst (Ty a Ts) = fold (\<lambda>single. subst_typ [single]) inst (Ty a Ts)"
      by simp
    moreover have "subst_typ inst T = fold (\<lambda>single. subst_typ [single]) inst T"
        using Cons 1 by simp
    moreover have "fold (\<lambda>single. subst_typ [single]) inst (Ty a (T#Ts))
      = (Ty a (map (fold (\<lambda>single. subst_typ [single]) inst) (T#Ts)))"
    proof (induction inst rule: rev_induct)
      case Nil
      then show ?case by simp
    next
      case (snoc x xs)
      hence "fold (\<lambda>single. subst_typ [single]) (xs @ [x]) (Ty a (T # Ts)) =
        Ty a (map (subst_typ [x]) (map (fold (\<lambda>single. subst_typ [single]) xs) (T # Ts)))"
        by simp
      then show ?case by simp
    qed
    ultimately show ?case
      using Cons.prems(1) Cons.prems(2) local.Cons(4) by auto
  qed
next
  case (2 inst idn S)
  then show ?case
  proof (cases "lookup (\<lambda>x . x = (idn, S)) (inst)")
    case None
    hence "fst p \<noteq> (idn, S)" if "p\<in>set inst" for p using that by (auto simp add: lookup_None_iff)
    hence "subst_typ [p] (Tv idn S) = Tv idn S" if "p\<in>set inst" for p
      using that by (cases p) fastforce
    from this None show ?thesis by (induction inst) (auto split: if_splits)
  next
    case (Some a)

    have elem: "((idn, S), a) \<in> set inst" using Some lookup_present_eq_key'' 2 by fastforce
    from this obtain fs bs where split: "inst = fs @ ((idn, S), a) # bs"
      by (meson split_list)
    hence "(idn, S) \<notin> set (map fst fs)" and "(idn, S) \<notin> set (map fst bs)" using 2 by simp_all

    hence "fst p \<noteq> (idn, S)" if "p\<in>set fs" for p
      using that by force
    hence id_subst_fs: "subst_typ [p] (Tv idn S) = Tv idn S" if "p\<in>set fs" for p
      using that by (cases p) fastforce
    hence fs_step: "fold (\<lambda>single. subst_typ [single]) fs (Tv idn S) = Tv idn S"
      by (induction fs) (auto split: if_splits)

    have change_step: "subst_typ [((idn, S), a)] (Tv idn S) = a" by simp

    have bs_sub: "set bs \<subseteq> set inst" using split by auto
    hence "x \<notin> fst ` set bs"
      if "x\<in> \<Union> (tvsT ` snd ` set bs)" for x
      using 2 that split by (auto simp add: image_iff)

    have "v \<notin> fst ` set bs" if "v \<in> tvsT a" for v
      using that 2 elem bs_sub by (fastforce simp add: image_iff)

    hence id_subst_bs: "subst_typ [p] a = a" if "p \<in> set bs" for p
    using that proof(cases p, induction a)
      case (Ty n Ts)
      then show ?case
        by (induction Ts) auto
    next
      case (Tv n S)
      then show ?case
        by force
    qed
    hence bs_step: "fold (\<lambda>single. subst_typ [single]) bs a = a"
      by (induction bs) auto

    from fs_step change_step bs_step split Some show ?thesis by simp
  qed
qed

corollary subst_typ_split_first:
  assumes "distinct (map fst (x#xs))"
  assumes "\<And>y . y \<in> (\<Union>t \<in> snd ` set (x#xs) . tvsT t) \<Longrightarrow> y \<notin> fst ` (set (x#xs))"
  shows "subst_typ (x#xs) T = subst_typ xs (subst_typ [x] T)"
proof-
  have "subst_typ (x#xs) T = fold (\<lambda>single . subst_typ [single]) (x#xs) T"
    using assms subst_typ_stepwise by blast
  also have "\<dots> = fold (\<lambda>single . subst_typ [single]) xs (subst_typ [x] T)"
    by simp
  also have "\<dots> = subst_typ xs (subst_typ [x] T)"
    using assms subst_typ_stepwise by simp
  finally show ?thesis .
qed

corollary subst_typ_split_last:
  assumes "distinct (map fst (xs @ [x]))"
  assumes "\<And>y . y \<in> (\<Union>t \<in> snd ` (set (xs @ [x])) . tvsT t) \<Longrightarrow> y \<notin> fst ` (set (xs @ [x]))"
  shows "subst_typ (xs @ [x]) T = subst_typ [x] (subst_typ xs T)"
proof-
  have "subst_typ (xs @ [x]) T = fold (\<lambda>single . subst_typ [single]) (xs@[x]) T"
    using assms subst_typ_stepwise by blast
  also have "\<dots> = subst_typ [x] (fold (\<lambda>single . subst_typ [single]) xs T)"
    by simp
  also have "\<dots> = subst_typ [x] (subst_typ xs T)"
    using assms subst_typ_stepwise by simp
  finally show ?thesis .
qed

lemma subst_typ'_stepwise:
  assumes "distinct (map fst instT)"
  assumes "\<And>x . x \<in> (\<Union>t \<in> snd ` (set instT) . tvsT t) \<Longrightarrow> x \<notin> fst ` (set instT)"
  shows "subst_typ' instT t = fold (\<lambda>single acc . subst_typ' [single] acc) instT t"
(* I switched the order of inductions and 99% of the proof vanished *)
using assms proof (induction instT arbitrary: t rule: rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  then show ?case
    apply (induction t)
    using subst_typ_split_last apply simp_all
    apply (metis map_types.simps)+ (* ... *)
    done
qed

lemma subst_term_stepwise:
  assumes "distinct (map fst insts)"
  assumes "\<And>x . x \<in> (\<Union>t \<in> snd ` (set insts) . fv t) \<Longrightarrow> x \<notin> fst ` (set insts)"
  shows "subst_term insts t = fold (\<lambda>single acc . subst_term [single] acc) insts t"
using assms proof (induction insts arbitrary: t rule: rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  then show ?case
  proof (induction t)
    case (Fv idn T)
    (* Allows more direct copy paste, hide structure of list, do proof properly later *)
    define insts where insts_def: "insts = xs @ [x]"
    have insts_thm1: "distinct (map fst insts)" using insts_def snoc by simp
    have insts_thm2: "x \<notin> fst ` set insts" if "x \<in> \<Union> (fv ` snd ` set insts)" for x
      using insts_def snoc that by blast
    from Fv show ?case
    (* Proof copied from subst_typ *)
    proof (cases "lookup (\<lambda>x . x = (idn, T)) insts")
      case None
      hence "fst p \<noteq> (idn, T)" if "p\<in>set insts" for p using that by (auto simp add: lookup_None_iff)
      hence "subst_term [p] (Fv idn T) = Fv idn T" if "p\<in>set insts" for p
        using that by (cases p) fastforce
      from this None show ?thesis
        unfolding insts_def[symmetric]
        by (induction insts) (auto split: if_splits)
    next
      case (Some a)

      have elem: "((idn, T), a) \<in> set insts" using Some lookup_present_eq_key'' insts_thm1 by fastforce
      from this obtain fs bs where split: "insts = fs @ ((idn, T), a) # bs"
        by (meson split_list)
      hence "(idn, T) \<notin> set (map fst fs)" and "(idn, T) \<notin> set (map fst bs)" using insts_thm1 by simp_all

      hence "fst p ~= (idn, T)" if "p\<in>set fs" for p
        using that by force
      hence id_subst_fs: "subst_term [p] (Fv idn T) = Fv idn T" if "p\<in>set fs" for p
        using that by (cases p) fastforce
      hence fs_step: "fold (\<lambda>single. subst_term [single]) fs (Fv idn T) = Fv idn T"
        by (induction fs) (auto split: if_splits)

      have change_step: "subst_term [((idn, T), a)] (Fv idn T) = a" by simp

      have bs_sub: "set bs \<subseteq> set insts" using split by auto
      hence "x \<notin> fst ` set bs"
        if "x\<in> \<Union> (fv ` snd ` set bs)" for x
        using insts_thm2 that split by (auto simp add: image_iff)

      have "v \<notin> fst ` set bs" if "v \<in> fv a" for v
        using that insts_thm2 elem bs_sub by (fastforce simp add: image_iff)

      hence id_subst_bs: "subst_term [p] a = a" if "p\<in>set bs" for p
        using that by (cases p, induction a) force+
      hence bs_step: "fold (\<lambda>single. subst_term [single]) bs a = a"
        by (induction bs) auto

      from fs_step change_step bs_step split Some show ?thesis by (simp add: insts_def)
    qed
  qed (simp, metis subst_term.simps)+
qed

corollary subst_term_split_last:
  assumes "distinct (map fst (xs @ [x]))"
  assumes "\<And>y . y \<in> (\<Union>t \<in> snd ` (set (xs @ [x])) . fv t) \<Longrightarrow> y \<notin> fst ` (set (xs @ [x]))"
  shows "subst_term (xs @ [x]) t = subst_term [x] (subst_term xs t)"
proof-
  have "subst_term (xs @ [x]) t = fold (\<lambda>single . subst_term [single]) (xs@[x]) t"
    using assms subst_term_stepwise by blast
  also have "\<dots> = subst_term [x] (fold (\<lambda>single . subst_term [single]) xs t)"
    by simp
  also have "\<dots> = subst_term [x] (subst_term xs t)"
    using assms subst_term_stepwise by simp
  finally show ?thesis .
qed

corollary subst_type_term_stepwise:
  assumes "distinct (map fst instT)"
  assumes "\<And>x . x \<in> (\<Union>T \<in> snd ` (set instT) . tvsT T) \<Longrightarrow> x \<notin> fst ` (set instT)"
  assumes "distinct (map fst insts)"
  assumes "\<And>x . x \<in> (\<Union>t \<in> snd ` (set insts) . fv t) \<Longrightarrow> x \<notin> fst ` (set insts)"
  shows "subst_type_term instT insts t
    = fold (\<lambda>single . subst_term [single]) insts (fold (\<lambda>single . subst_typ' [single]) instT t)"
  using assms subst_typ'_stepwise subst_term_stepwise subst_type_term_split_levels by auto

(* MOVE *)
lemma distinct_fst_imp_distinct: "distinct (map fst l) \<Longrightarrow> distinct l" by (induction l) auto
lemma distinct_kv_list: "distinct l \<Longrightarrow> distinct (map (\<lambda>x. (x, f x)) l)" by (induction l) auto

lemma subst_subst_term:
  assumes "distinct l" and "fv t \<subseteq> set l"
  shows "subst t \<rho> = subst_term (map (\<lambda>x.(x, case_prod \<rho> x)) l) t"
using assms proof (induction t arbitrary: l)
  case (Fv idn T)
  then show ?case
  proof (cases "(idn, T) \<in> set l")
    case True
    hence "((idn, T), \<rho> idn T) \<in> set (map (\<lambda>x.(x, case_prod \<rho> x)) l)" by auto
    moreover have "distinct (map fst (map (\<lambda>x.(x, case_prod \<rho> x)) l))"
      using Fv(1) by (induction l) auto
    ultimately have "(lookup (\<lambda>x. x = (idn, T)) (map (\<lambda>x. (x, case x of (x, xa) \<Rightarrow> \<rho> x xa)) l))
      = Some (\<rho> idn T)" using lookup_present_eq_key by fast
    then show ?thesis by simp
  next
    case False
    then show ?thesis using Fv by simp
  qed
qed auto

lemma subst_term_subst:
  assumes "distinct (map fst l)"
  shows "subst_term l t = subst t (fold (\<lambda>((idn, T), t) f x y. if x=idn \<and>y=T then t else f x y) l Fv)"
using assms proof (induction t)
  case (Fv idn T)
  then show ?case
  proof (cases "lookup (\<lambda>x. x = (idn, T)) l")
    case None
    hence "(idn, T) \<notin> set (map fst l)"
      by (metis (full_types) lookup_None_iff)

    hence "(fold (\<lambda>((idn, T), t) f x y. if x=idn \<and>y=T then t else f x y) l Fv) idn T = Fv idn T"
      by (induction l rule: rev_induct) (auto split: if_splits prod.splits)

    then show ?thesis by (simp add: None)
  next
    case (Some a)

    have elem: "((idn, T), a) \<in> set l"
      using Some lookup_present_eq_key'' Fv by fastforce
    from this obtain fs bs where split: "l = fs @ ((idn, T), a) # bs"
      by (meson split_list)
    hence "(idn, T) \<notin> set (map fst fs)" and not_in_bs: "(idn, T) \<notin> set (map fst bs)" using Fv by simp_all

    hence "fst p ~= (idn, T)" if "p\<in>set fs" for p
      using that by force
    hence fs_step: "(fold (\<lambda>((idn, T), t) f x y. if x=idn \<and>y=T then t else f x y) fs Fv) idn T = Fv idn T"
      by (induction fs rule: rev_induct) (fastforce split: if_splits prod.splits)+

    have bs_sub: "set bs \<subseteq> set l" using split by auto

    have "fst p ~= (idn, T)" if "p\<in>set bs" for p
      using that not_in_bs by force
    hence bs_step: "(fold (\<lambda>((idn, T), t) f x y. if x=idn \<and>y=T then t else f x y) bs f) idn T = f idn T"
      for f
      by (induction bs rule: rev_induct) (fastforce split: if_splits prod.splits)+

    from fs_step bs_step split Some show ?thesis by simp
  qed
qed auto

lemma subst_typ_combine_single:
  assumes "fresh_idn \<notin> fst ` tvsT \<tau>"
  shows "subst_typ [((fresh_idn, S), \<tau>2)] (subst_typ [((idn, S), Tv fresh_idn S)] \<tau>)
    = subst_typ [((idn, S), \<tau>2)] \<tau>"
  using assms by (induction \<tau>) auto

lemma subst_typ_combine:
  assumes "length fresh_idns = length insts"
  assumes "distinct fresh_idns"
  assumes "distinct (map fst insts)"
  assumes "\<forall>idn \<in> set fresh_idns . idn \<notin> fst ` (tvsT \<tau> \<union> (\<Union>ty\<in>snd ` set insts . (tvsT ty))
    \<union> (fst ` set insts))"
  shows "subst_typ insts \<tau>
    = subst_typ (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
      (subst_typ (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>)"
  using assms proof (induction insts \<tau> arbitrary: fresh_idns rule: subst_typ.induct)
  case (1 inst a Ts)
  then show ?case by fastforce (* LOL, I wanted to do another induction *)
next
  case (2 inst idn S)
  show ?case
  proof (cases "lookup (\<lambda>x. x = (idn, S)) inst")
    case None
    hence "((idn, S)) \<notin> fst ` set inst"
      by (metis (mono_tags, lifting) list.set_map lookup_None_iff)
    hence 1: "(lookup (\<lambda>x. x = (idn, S))
      (zip (map fst inst) (map2 Tv fresh_idns (map (snd \<circ> fst) inst)))) = None"
      using 2 by (simp add: lookup_eq_key_not_present)

    have "(idn, S) \<notin> set (zip fresh_idns (map (snd \<circ> fst) inst))"
      using 2 set_zip_leftD by fastforce
    hence "(lookup (\<lambda>x. x = (idn, S))
      (zip (zip fresh_idns (map (snd \<circ> fst) inst)) (map snd inst))) = None"
      using 2 by (simp add: lookup_eq_key_not_present)

    then show ?thesis using None 1 by simp
  next
    case (Some ty)
    from this obtain idx where idx: "inst ! idx = ((idn, S), ty)" "idx < length inst"
    proof (induction inst)
      case Nil
      then show ?case
        by simp
    next
      case (Cons a as) thm Cons.IH
      have "(\<And>idx. as ! idx = ((idn, S), ty) \<Longrightarrow> idx < length as \<Longrightarrow> thesis)"
        by (metis Cons.prems(1) in_set_conv_nth list.set_intros(2))
      then show ?case
        by (meson Cons.prems(1) Cons.prems(2) in_set_conv_nth lookup_present_eq_key')
    qed

    from this obtain fresh_idn where fresh_idn: "fresh_idns ! idx = fresh_idn" by simp

    from 2(1) idx fresh_idn have ren:
      "(zip (map fst inst) (map2 Tv fresh_idns (map (snd \<circ> fst) inst))) ! idx
      = ((idn, S), Tv fresh_idn S) "
      by auto
    from this idx(2) have "((idn, S), Tv fresh_idn S) \<in> set
      (zip (map fst inst) (map2 Tv fresh_idns (map (snd \<circ> fst) inst)))"
      by (metis (no_types, opaque_lifting) "2.prems"(1) length_map map_fst_zip map_map map_snd_zip nth_mem)
    from this have 1: "(lookup (\<lambda>x. x = (idn, S))
      (zip (map fst inst) (map2 Tv fresh_idns (map (snd \<circ> fst) inst)))) = Some (Tv fresh_idn S)"
      by (simp add: "2.prems"(1) "2.prems"(3) lookup_present_eq_key'')

    from 2(1) idx fresh_idn 1 have "((fresh_idn, S), ty)
      \<in> set (zip (zip fresh_idns (map (snd \<circ> fst) inst)) (map snd inst))"
      using in_set_conv_nth by fastforce
    hence 2: "(lookup (\<lambda>x. x = (fresh_idn, S))
      (zip (zip fresh_idns (map (snd \<circ> fst) inst)) (map snd inst))) = Some ty"
      by (simp add: "2.prems"(1) "2.prems"(2) distinct_zipI1 lookup_present_eq_key'')
    then show ?thesis using Some 1 2 by simp
  qed
qed

lemma subst_typ_combine':
  assumes "length fresh_idns = length insts"
  assumes "distinct fresh_idns"
  assumes "distinct (map fst insts)"
  assumes "\<forall>idn \<in> set fresh_idns . idn \<notin> fst ` (tvsT \<tau> \<union> (\<Union>ty\<in>snd ` set insts . (tvsT ty))
    \<union> (fst ` set insts))"
  shows "subst_typ insts \<tau>
    = fold (\<lambda>single acc . subst_typ [single] acc) (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
      (fold (\<lambda>single acc . subst_typ [single] acc) (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>)"
proof-
  have s1: "fst ` set (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts))))
    = fst ` set insts "
  proof-
    have "fst ` set (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts))))
      = set (map fst (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))))"
      by auto
    also have "\<dots> = set (map fst insts)" using map_fst_zip assms(1) by auto
    also have "\<dots> = fst ` set insts" by simp
    finally show ?thesis .
  qed

  have "snd ` set (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts))))
    = set (map2 Tv fresh_idns (map snd (map fst insts)))" using map_snd_zip assms(1)
    by (metis (no_types, lifting) image_set length_map)
  hence "(\<Union> (tvsT ` snd ` set (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts))))))
    = (\<Union> (tvsT ` set (map2 Tv fresh_idns (map snd (map fst insts)))))"
    by simp
  from assms(1) this have s2:
    "(\<Union> (tvsT ` snd ` set (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts))))))
    = (set (zip fresh_idns (map snd (map fst insts))))"
    using assms(1) by (induction fresh_idns insts rule: list_induct2) auto
  hence s3: "\<Union> (tvsT ` snd ` set (zip (map fst insts)
                   (map2 Tv fresh_idns (map (snd \<circ> fst) insts))))
    = set (zip fresh_idns (map snd (map fst insts)))" by simp
  have "idn \<notin> fst ` fst ` set insts" if "idn \<in> set fresh_idns" for idn
    using that assms by auto
  hence I: "(idn, S) \<notin> fst ` set insts" if "idn \<in> set fresh_idns" for idn S
    using that assms by (metis fst_conv image_eqI)

  have u1: "(subst_typ (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>)
    = fold (\<lambda>single acc . subst_typ [single] acc) (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>"
    apply (rule subst_typ_stepwise)
    using assms apply simp
    apply (simp only: s1 s2)
     using assms I by (metis prod.collapse set_zip_leftD)

  moreover have u2: "subst_typ (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
    (subst_typ (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>)
  = fold (\<lambda>single acc . subst_typ [single] acc) (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
    (subst_typ (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>)"
   apply (rule subst_typ_stepwise)
   using assms apply (simp add: distinct_zipI1)
   using assms
   by (smt UnCI imageE image_eqI length_map map_snd_zip prod.collapse set_map set_zip_leftD)
  ultimately have unfold: "subst_typ (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
    (subst_typ (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>)
   = fold (\<lambda>single acc . subst_typ [single] acc) (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
        (fold (\<lambda>single acc . subst_typ [single] acc) (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) \<tau>)"
     by simp
  show ?thesis using assms subst_typ_combine unfold by auto
qed

lemma subst_typ'_combine:
  assumes "length fresh_idns = length insts"
  assumes "distinct fresh_idns"
  assumes "distinct (map fst insts)"
  assumes "\<forall>idn \<in> set fresh_idns . idn \<notin> fst ` (tvs t \<union> (\<Union>ty\<in>snd ` set insts . (tvsT ty))
    \<union> (fst ` set insts))"
  shows "subst_typ' insts t
    = subst_typ' (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
      (subst_typ' (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) t)"
using assms proof (induction t arbitrary: fresh_idns insts)
  case (Abs T t)
  moreover have "tvs t \<subseteq> tvs (Abs T t) " by simp
  ultimately have "subst_typ' insts t =
    subst_typ' (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
     (subst_typ' (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) t)"
    by blast
  moreover have "subst_typ insts T =
    subst_typ (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
     (subst_typ (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) T)"
    using subst_typ_combine Abs.prems by fastforce
  ultimately show ?case by simp
next
  case (App t1 t2)
  moreover have "tvs t1 \<subseteq> tvs (t1 $ t2)" "tvs t2 \<subseteq> tvs (t1 $ t2)" by auto
  ultimately have "subst_typ' insts t1 =
    subst_typ' (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
     (subst_typ' (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) t1)"
  and "subst_typ' insts t2 =
    subst_typ' (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
     (subst_typ' (zip (map fst insts) (map2 Tv fresh_idns (map snd (map fst insts)))) t2)"
    by blast+
  then show ?case by simp
qed (use subst_typ_combine in auto)

(* Only interesting case is Fv, and that one is copied directly from subst_typ *)
lemma subst_term_combine:
  assumes "length fresh_idns = length insts"
  assumes "distinct fresh_idns"
  assumes "distinct (map fst insts)"
  assumes "\<forall>idn \<in> set fresh_idns . idn \<notin> fst ` (fv t \<union> (\<Union>t\<in>snd ` set insts . (fv t))
    \<union> (fst ` set insts))"
  shows "subst_term insts t
    = subst_term (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
      (subst_term (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t)"
using assms proof (induction t arbitrary: fresh_idns insts)
  case (Fv idn ty)

  then show ?case
  proof (cases "lookup (\<lambda>x. x = (idn, ty)) insts")
    case None
    hence "((idn, ty)) \<notin> fst ` set insts"
      by (metis (mono_tags, lifting) list.set_map lookup_None_iff)
    hence 1: "(lookup (\<lambda>x. x = (idn, ty))
      (zip (map fst insts) (map2 Fv fresh_idns (map (snd \<circ> fst) insts)))) = None"
      using Fv by (simp add: lookup_eq_key_not_present)

    have "(idn, ty) \<notin> set (zip fresh_idns (map (snd \<circ> fst) insts))"
      using Fv set_zip_leftD by fastforce
    hence "(lookup (\<lambda>x. x = (idn, ty))
      (zip (zip fresh_idns (map (snd \<circ> fst) insts)) (map snd insts))) = None"
      using Fv by (simp add: lookup_eq_key_not_present)

    then show ?thesis using None 1 by simp
  next
    case (Some u)
    from this obtain idx where idx: "insts ! idx = ((idn, ty), u)" "idx < length insts"
    proof (induction insts)
      case Nil
      then show ?case
        by simp
    next
      case (Cons a as)
      have "(\<And>idx. as ! idx = ((idn, ty), u) \<Longrightarrow> idx < length as \<Longrightarrow> thesis)"
        by (metis Cons.prems(1) in_set_conv_nth insert_iff list.set(2))
      then show ?case
        by (meson Cons.prems(1) Cons.prems(2) in_set_conv_nth lookup_present_eq_key')
    qed

    from this obtain fresh_idn where fresh_idn: "fresh_idns ! idx = fresh_idn" by simp

    from Fv(1) idx fresh_idn have ren:
      "(zip (map fst insts) (map2 Fv fresh_idns (map (snd \<circ> fst) insts))) ! idx
      = ((idn, ty), Fv fresh_idn ty)"
      by auto
    from this idx(2) have "((idn, ty), Fv fresh_idn ty) \<in> set
      (zip (map fst insts) (map2 Fv fresh_idns (map (snd \<circ> fst) insts)))"
      by (metis (no_types, opaque_lifting) "Fv.prems"(1) length_map map_fst_zip map_map map_snd_zip nth_mem)
    from this have 1: "(lookup (\<lambda>x. x = (idn, ty))
      (zip (map fst insts) (map2 Fv fresh_idns (map (snd \<circ> fst) insts)))) = Some (Fv fresh_idn ty)"
      by (simp add: "Fv.prems"(1) "Fv.prems"(3) lookup_present_eq_key'')

    (* Feels doable with better simp setup *)
    from Fv(1) idx fresh_idn 1 have "((fresh_idn, ty), u)
      \<in> set (zip (zip fresh_idns (map (snd \<circ> fst) insts)) (map snd insts))"
      using in_set_conv_nth by fastforce
    hence 2: "(lookup (\<lambda>x. x = (fresh_idn, ty))
      (zip (zip fresh_idns (map (snd \<circ> fst) insts)) (map snd insts))) = Some u"
      by (simp add: "Fv.prems"(1) "Fv.prems"(2) distinct_zipI1 lookup_present_eq_key'')
    then show ?thesis using Some 1 2 by simp
  qed
next
  case (App t1 t2)
  moreover have "fv t1 \<subseteq> fv (t1 $ t2)" "fv t2 \<subseteq> fv (t1 $ t2)" by simp_all
  ultimately have "subst_term insts t1 =
    subst_term (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
     (subst_term (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t1)"
  and "subst_term insts t2 =
    subst_term (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
     (subst_term (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t2)"
    by blast+
  then show ?case by simp
qed auto

corollary subst_term_combine':
  assumes "length fresh_idns = length insts"
  assumes "distinct fresh_idns"
  assumes "distinct (map fst insts)"
  assumes "\<forall>idn \<in> set fresh_idns . idn \<notin> fst ` (fv t \<union> (\<Union>t\<in>snd ` set insts . (fv t))
    \<union> (fst ` set insts))"
  shows "subst_term insts t
    = fold (\<lambda>single acc . subst_term [single] acc) (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
      (fold (\<lambda>single acc . subst_term [single] acc) (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t)"
proof-
  have s1: "fst ` set (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts))))
    = fst ` set insts "
  proof-
    have "fst ` set (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts))))
      = set (map fst (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))))"
      by auto
    also have "\<dots> = set (map fst insts)" using map_fst_zip assms(1) by auto
    also have "\<dots> = fst ` set insts" by simp
    finally show ?thesis .
  qed

  have "snd ` set (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts))))
    = set (map2 Fv fresh_idns (map snd (map fst insts)))" using map_snd_zip assms(1)
    by (metis (no_types, lifting) image_set length_map)
  hence "(\<Union> (fv ` snd ` set (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts))))))
    = (\<Union> (fv ` set (map2 Fv fresh_idns (map snd (map fst insts)))))"
    by simp
  from assms(1) this have s2:
    "(\<Union> (fv ` snd ` set (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts))))))
    = (set (zip fresh_idns (map snd (map fst insts))))"
    using assms(1) by (induction fresh_idns insts rule: list_induct2) auto
  hence s3: "\<Union> (fv ` snd ` set (zip (map fst insts)
                   (map2 Fv fresh_idns (map (snd \<circ> fst) insts))))
    = set (zip fresh_idns (map snd (map fst insts)))" by simp
  have "idn \<notin> fst ` fst ` set insts" if "idn \<in> set fresh_idns" for idn
    using that assms by auto
  hence I: "(idn, T) \<notin> fst ` set insts" if "idn \<in> set fresh_idns" for idn T
    using that assms by (metis fst_conv image_eqI)

  have u1: "(subst_term (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t)
    = fold (\<lambda>single acc . subst_term [single] acc) (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t"
    apply (rule subst_term_stepwise)
    using assms apply simp
    apply (simp only: s1 s2)
     using assms I by (metis prod.collapse set_zip_leftD)

  moreover have u2: "subst_term (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
    (subst_term (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t)
  = fold (\<lambda>single acc . subst_term [single] acc) (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
    (subst_term (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t)"
   apply (rule subst_term_stepwise)
   using assms apply (simp add: distinct_zipI1)
   using assms
   by (smt UnCI imageE image_eqI length_map map_snd_zip prod.collapse set_map set_zip_leftD)
  ultimately have unfold: "subst_term (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
    (subst_term (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t)
   = fold (\<lambda>single acc . subst_term [single] acc) (zip (zip fresh_idns (map snd (map fst insts))) (map snd insts))
        (fold (\<lambda>single acc . subst_term [single] acc) (zip (map fst insts) (map2 Fv fresh_idns (map snd (map fst insts)))) t)"
     by simp
  show ?thesis using assms subst_term_combine unfold by auto
qed

lemma subst_term_not_loose_bvar:
  assumes "\<not> loose_bvar t n" "is_closed b"
  shows "\<not> loose_bvar (subst_term [((idn,T),b)] t) n"
  using assms by (induction t arbitrary: n idn T b) (auto simp add: is_open_def loose_bvar_leq)

(* This seems a bit to weak, second premise probably needs to be more general *)
lemma bind_fv2_subst_bv1_eq_subst_term:
  assumes "\<not>loose_bvar t n" "is_closed b"
  shows "subst_term [((idn,T),b)] t = subst_bv1 (bind_fv2 (idn, T) n t) n b"
  using assms by (induction t arbitrary: n idn T b) (auto simp add: is_open_def incr_boundvars_def)

corollary
  assumes "is_closed t" "is_closed b"
  shows "subst_bv b (bind_fv (idn, T) t) = (subst_term [((idn, T),b)] t)"
  using assms bind_fv2_subst_bv1_eq_subst_term
  by (simp add: bind_fv_def subst_bv_def is_open_def)

corollary instantiate_var_same_typ:
  assumes typ_a: "typ_of a = Some \<tau>"
  assumes closed_B: "\<not> loose_bvar B lev"
  shows "subst_bv1 (bind_fv2 (x, \<tau>) lev B) lev a = subst_term [((x, \<tau>), a)] B"
  using bind_fv2_subst_bv1_eq_subst_term assms typ_of_imp_closed by metis

corollary instantiate_var_same_typ':
  assumes typ_a: "typ_of a = Some \<tau>"
  assumes closed_B: "is_closed B"
  shows "subst_bv a (bind_fv (x, \<tau>) B) = subst_term [((x, \<tau>), a)] B"
  using instantiate_var_same_typ bind_fv_def subst_bv_def is_open_def assms by auto

corollary instantiate_var_same_type'':
  assumes typ_a: "typ_of a = Some \<tau>"
  assumes closed_B: "is_closed B"
  shows "Abs \<tau> (bind_fv (x, \<tau>) B) \<bullet> a = subst_term [((x, \<tau>), a)] B"
  using assms instantiate_var_same_typ' by simp

lemma instantiate_vars_same_typ:
  assumes typs: "list_all (\<lambda>((idx, ty), t) . typ_of t = Some ty) insts"
  assumes closed_B: "\<not> loose_bvar B lev"
  shows "fold (\<lambda>((idx, ty), t) B . subst_bv1 (bind_fv2 (idx, ty) lev B) lev t) insts B
    = fold (\<lambda>single . subst_term [single]) insts B"
using assms proof (induction insts arbitrary: B lev)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)

  from this obtain idn ty t where x: "x = ((idn, ty), t)" by (metis prod.collapse)

  hence typ_a: "typ_of t = Some ty" using Cons.prems by simp
  have typs: "list_all (\<lambda>((idx, ty), t) . typ_of t = Some ty) xs" using Cons.prems by simp
  have not_loose: "\<not> loose_bvar (subst_term [((idn, ty), t)] B) lev"
    using Cons.prems subst_term_not_loose_bvar typ_a typ_of_imp_closed by simp

  note single = instantiate_var_same_typ[OF typ_a Cons.prems(2), of idn]

  have "fold (\<lambda>((idx, ty), t) B . subst_bv1 (bind_fv2 (idx, ty) lev B) lev t) (x # xs) B
    = fold (\<lambda>((idx, ty), t) B. subst_bv1 (bind_fv2 (idx, ty) lev B) lev t) xs
        (subst_bv1 (bind_fv2 (idn, ty) lev B) lev t)"
    by (simp add: x)
  also have "\<dots> = fold (\<lambda>((idx, ty), t) B. subst_bv1 (bind_fv2 (idx, ty) lev B) lev t) xs
    (subst_term [((idn, ty), t)] B)"
    using single by simp
  also have "\<dots> = fold (\<lambda>single. subst_term [single]) xs (subst_term [((idn, ty), t)] B)"
    using Cons.IH[where B = "subst_term [((idn, ty), t)] B", OF typs not_loose] Cons.prems by blast
  also have "\<dots> = fold (\<lambda>single. subst_term [single]) (x # xs) B"
    by (simp add: x)
  finally show ?case .
qed

corollary instantiate_vars_same_typ':
  assumes typs: "list_all (\<lambda>((idx, ty), t) . typ_of t = Some ty) insts"
  assumes closed_B: "\<not> loose_bvar B lev"
  assumes distinct: "distinct (map fst insts)"
  assumes no_overlap: "\<And>x . x \<in> (\<Union>t \<in> snd ` (set insts) . fv t) \<Longrightarrow> x \<notin> fst ` (set insts)"
  shows "fold (\<lambda>((idx, ty), t) B . subst_bv1 (bind_fv2 (idx, ty) lev B) lev t) insts B
    = subst_term insts B"
  using instantiate_vars_same_typ subst_term_stepwise[symmetric] assms by simp

end


chapter \<open>Definition\<close>

theory %invisible Definition
imports Main
begin

text \<open>\label{chap:definition}\<close>

text \<open>In stepwise refinement~\cite{DijkstraConstructive,WirthRefinement},
a program is derived from a specification
via a sequence of intermediate specifications.\<close>

text \<open>Pop-refinement (where `pop' stands for `predicates over programs')
is an approach to stepwise refinement,
carried out inside an interactive theorem prover
(e.g.\ Isabelle/HOL, HOL4, Coq, PVS, ACL2)
as follows:
\begin{enumerate}
\item
Formalize the syntax and semantics
of (the needed subset of) the target programming language (and libraries),
as a deep embedding.
\item
Specify the requirements
by defining a predicate over programs
that characterizes the possible implementations.
\item
Refine the specification stepwise
by defining monotonically decreasing predicates over programs
(decreasing with respect to inclusion, i.e.\ logical implication),
according to decisions that narrow down the possible implementations.
\item
Conclude the derivation
with a predicate that characterizes a unique program in explicit syntactic form,
from which the program text is readily obtained.
\end{enumerate}\<close>

end %invisible


section \<open> Dwarf Signal \<close>

theory DwarfSignal_safe
  imports "../ITree_Circus"
begin lit_vars

datatype LampId = L1 | L2 | L3

type_synonym Signal = "LampId set"

datatype ProperState = dark | stop | warning | drive

definition "ProperState = {dark, stop, warning, drive}"

fun signalLamps :: "ProperState \<Rightarrow> LampId set" where
"signalLamps dark = {}" |
"signalLamps stop = {L1, L2}" |
"signalLamps warning = {L1, L3}" |
"signalLamps drive = {L2, L3}"

text \<open> Could we have separate processes for the actual lamp and its controller? We would then
  try to verify that the controller preserves the lamp-based safety properties. The current
  set up doesn't preserve them. \<close>

alphabet Dwarf =
  last_proper_state :: "ProperState"
  turn_off :: "LampId set"
  turn_on  :: "LampId set"
  last_state :: "Signal"
  current_state :: "Signal"
  desired_proper_state :: "ProperState"

definition Dwarf_inv :: "Dwarf \<Rightarrow> bool" where
  "Dwarf_inv =
  ((current_state - turn_off) \<union> turn_on = signalLamps desired_proper_state
  \<and> turn_on \<inter> turn_off = {})\<^sub>e"

instantiation Dwarf_ext :: (default) default
begin
  definition default_Dwarf_ext :: "'a Dwarf_scheme" where
    "default_Dwarf_ext = Dwarf.extend (Dwarf.make dark {} {} (signalLamps stop) (signalLamps stop) stop) default"

instance ..
end

chantype chan =
  shine :: "LampId set"
  setNewProperState :: ProperState
  turnOff :: "LampId"
  turnOn :: "LampId"
  lastProperState :: ProperState

definition Init :: "Dwarf subst" where
  "Init =
  [ last_proper_state \<leadsto> stop
  , turn_off \<leadsto> {}
  , turn_on \<leadsto> {}
  , last_state \<leadsto> signalLamps stop
  , current_state \<leadsto> signalLamps stop
  , desired_proper_state \<leadsto> stop ]"

lemma Init_establishes_inv: "Init \<dagger> Dwarf_inv = (True)\<^sub>e"
  by (simp add: Dwarf_inv_def Init_def usubst_eval)

definition
  "SetNewProperState =
    \<questiondown>current_state = signalLamps desired_proper_state? \<Zcomp>
    setNewProperState?(st):(ProperState - {desired_proper_state}) \<rightarrow>
      (last_proper_state := desired_proper_state \<Zcomp>
       turn_off := (current_state - signalLamps st) \<Zcomp>
       turn_on := (signalLamps st - current_state) \<Zcomp>
       last_state := current_state \<Zcomp>
       desired_proper_state := st)"

definition
  "TurnOff =
   turnOff?(l):turn_off \<rightarrow>
    (turn_off := (turn_off - {l}) \<Zcomp>
     turn_on := (turn_on - {l}) \<Zcomp>
     last_state := current_state \<Zcomp>
     current_state := (current_state - {l}))"

text \<open> Add an extra precondition to make sure turnOn only enabled when
there are nothing to turn off. This ensures the safety property:
NeverShowAll.
\<close>
definition
  "TurnOn =
  \<questiondown>turn_off = {}? \<Zcomp>
   turnOn?(l):turn_on \<rightarrow>
    (turn_off := (turn_off - {l}) \<Zcomp>
     turn_on := (turn_on - {l}) \<Zcomp>
     last_state := current_state \<Zcomp>
     current_state := (current_state \<union> {l}))"

definition "Shine = shine!(current_state) \<rightarrow> Skip"

(* This query is only available at a stable state;
In the original document, safety properties 3, 4, and 5 depends on
last_proper_state. Actually, last_proper_state would be
desired_proper_state in the definition of SetNewProperState.
So here the controller should query desired_proper_state
*)
definition "LastProperState =
  \<questiondown>current_state = signalLamps desired_proper_state? \<Zcomp>
  lastProperState!(desired_proper_state) \<rightarrow> Skip"

definition "Dwarf
  = proc Init (loop (SetNewProperState \<box> TurnOn \<box> TurnOff \<box> Shine \<box> LastProperState))"

text \<open> A separate controller process for preserving safety properties \<close>
definition "
  SP345 =
    lastProperState?(l):(ProperState) \<rightarrow>
      (
          \<questiondown>(l = stop) ? \<Zcomp> setNewProperState?(st):(ProperState - {drive}) \<rightarrow> Skip
        \<box> \<questiondown>(l = dark) ? \<Zcomp>  setNewProperState?(st):{dark, stop} \<rightarrow> Skip
        \<box> \<questiondown>(l \<noteq> dark \<and> l \<noteq> stop) ? \<Zcomp> setNewProperState?(st):(ProperState - {dark}) \<rightarrow> Skip
      )
 "

definition Ctrl:: "chan process" where
"Ctrl  = proc ([\<leadsto>]:: Dwarf \<Rightarrow> Dwarf) (loop (SP345))"

definition Dwarf_safe_nh :: "chan process" where
  "Dwarf_safe_nh =
    (Dwarf
      \<parallel>\<^bsub>set ([lastProperState_C (s). s \<leftarrow> [dark, stop, warning, drive]]
           @ [setNewProperState_C (s). s \<leftarrow> [dark, stop, warning, drive]])\<^esub>
     Ctrl)
"

definition Dwarf_safe :: "chan process" where
  "Dwarf_safe =
    hide Dwarf_safe_nh (set ([lastProperState_C (s). s \<leftarrow> [dark, stop, warning, drive]]))
"

export_code Dwarf Dwarf_safe_nh Dwarf_safe in Haskell
  (* module_name DwarfSignal_safe *)
  file_prefix DwarfSignal
  (string_classes)

end


section \<open>Union Find in Sepref\<close>

theory SeprefUF
imports Refine_Imperative_HOL.Sepref "Separation_Logic_Imperative_HOL.Union_Find"
begin

(* TODO:  move to sepref/IICF *)

  type_synonym 'a per = "('a\<times>'a) set"

  definition "per_init D \<equiv> {(i,i) | i. i\<in>D}"
  definition [simp]: "per_compare R a b \<equiv> (a,b)\<in>R"

  definition per_init' :: "nat \<Rightarrow> nat per" where "per_init' n \<equiv> {(i,i) |i. i<n}"

  lemma per_init_of_nat_range: "per_init {i. i<N} = per_init' N"
    by (auto simp: per_init_def per_init'_def)

  lemma per_init_per[simp, intro!]:
    "part_equiv (per_init D)"
    unfolding per_init_def
    by (auto simp: part_equiv_def sym_def trans_def)

  lemma per_init_self: "(a,b)\<in>per_init D \<Longrightarrow> a=b"
    unfolding per_init_def by simp

  lemma per_union_impl: "(i,j)\<in>R \<Longrightarrow> (i,j)\<in>per_union R a b"
    by (auto simp: per_union_def)

  lemma per_union_related:
    "part_equiv R \<Longrightarrow> a\<in>Domain R \<Longrightarrow> b\<in>Domain  R \<Longrightarrow> (a,b)\<in>per_union R a b"
    unfolding per_union_def
    by (auto simp: part_equiv_refl)

  lemma part_equiv_refl':
    "part_equiv R \<Longrightarrow> x\<in>Domain R \<Longrightarrow> (x,x)\<in>R"
    using part_equiv_refl[of R x] by blast

  definition per_supset_rel :: "('a per \<times> 'a per) set" where
    "per_supset_rel
      \<equiv> {(p1,p2). p1 \<inter> Domain p2 \<times> Domain p2 = p2 \<and> p1 - (Domain p2 \<times> Domain p2) \<subseteq> Id}"

  lemma per_supset_rel_dom: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> Domain p1 \<supseteq> Domain p2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_compare:
    "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow> per_compare p1 x1 x2 \<longleftrightarrow> per_compare p2 x1 x2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_union: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow>
    (per_union p1 x1 x2, per_union p2 x1 x2) \<in> per_supset_rel"
    apply (clarsimp simp: per_supset_rel_def per_union_def Domain_unfold )
    apply (intro subsetI conjI)
     apply blast
    apply force
    done

  sepref_register per_init per_init' per_compare per_union

  lemma per_init_Domain[simp]: "Domain (per_init D) = D"
    by (auto simp: per_init_def)

  lemma per_init'_Domain[simp]: "Domain (per_init' N) = {i. i<N}"
    by (auto simp: per_init'_def)

  lemma per_init'_sepref_rule[sepref_fr_rules]: "(uf_init,RETURN o per_init') \<in> nat_assn\<^sup>k \<rightarrow>\<^sub>a is_uf"
    unfolding per_init'_def
    apply sepref_to_hoare
    by sep_auto

  lemma per_compare_sepref_rule[sepref_fr_rules]: "(uncurry2 uf_cmp, uncurry2 (RETURN ooo per_compare)) \<in>
    is_uf\<^sup>k *\<^sub>a nat_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding per_compare_def
    apply sepref_to_hoare
    by sep_auto

  definition "abs_test \<equiv> do {
    let u = per_init' (5::nat);
    let u = per_union u 1 2;
    let u = per_union u 2 3;
    RETURN (per_compare u 1 3)
  }"

  sepref_definition abs_test_impl is "uncurry0 abs_test" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding abs_test_def
    by sepref

end


section \<open> Lifting Expressions \<close>

theory utp_lift
  imports
    utp_alphabet utp_lift_pretty
begin

subsection \<open> Lifting definitions \<close>

text \<open> We define operators for converting an expression to and from a relational state space
  with the help of alphabet extrusion and restriction. In general throughout Isabelle/UTP
  we adopt the notation $\lceil P \rceil$ with some subscript to denote lifting an expression
  into a larger alphabet, and $\lfloor P \rfloor$ for dropping into a smaller alphabet.

  The following two functions lift and drop an expression, respectively, whose alphabet is
  @{typ "'\<alpha>"}, into a product alphabet @{typ "'\<alpha> \<times> '\<beta>"}. This allows us to deal with expressions
  which refer only to undashed variables, and use the type-system to ensure this. \<close>

abbreviation lift_pre :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uexpr" ("\<lceil>_\<rceil>\<^sub><")
where "\<lceil>P\<rceil>\<^sub>< \<equiv> P \<oplus>\<^sub>p fst\<^sub>L"

notation lift_pre ("_\<^sup><" [999] 999)

abbreviation drop_pre :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<lfloor>_\<rfloor>\<^sub><")
where "\<lfloor>P\<rfloor>\<^sub>< \<equiv> P \<restriction>\<^sub>e fst\<^sub>L"

text \<open> The following two functions lift and drop an expression, respectively, whose alphabet is
  @{typ "'\<beta>"}, into a product alphabet @{typ "'\<alpha> \<times> '\<beta>"}. This allows us to deal with expressions
  which refer only to dashed variables. \<close>

abbreviation lift_post :: "('a, '\<beta>) uexpr \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uexpr" ("\<lceil>_\<rceil>\<^sub>>")
where "\<lceil>P\<rceil>\<^sub>> \<equiv> P \<oplus>\<^sub>p snd\<^sub>L"

notation lift_post ("_\<^sup>>" [999] 999)

abbreviation drop_post :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta>) uexpr" ("\<lfloor>_\<rfloor>\<^sub>>")
where "\<lfloor>P\<rfloor>\<^sub>> \<equiv> P \<restriction>\<^sub>e snd\<^sub>L"

subsection \<open> Lifting Laws \<close>

text \<open> With the help of our alphabet laws, we can prove some intuitive laws about alphabet
  lifting. For example, lifting variables yields an unprimed or primed relational variable
  expression, respectively. \<close>

lemma lift_pre_var [simp]:
  "\<lceil>var x\<rceil>\<^sub>< = $x"
  by (alpha_tac)

lemma lift_post_var [simp]:
  "\<lceil>var x\<rceil>\<^sub>> = $x\<acute>"
  by (alpha_tac)

subsection \<open> Substitution Laws \<close>

lemma pre_var_subst [usubst]:
  "\<sigma>($x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> \<lceil>P\<rceil>\<^sub>< = \<sigma> \<dagger> \<lceil>P\<lbrakk>\<guillemotleft>v\<guillemotright>/&x\<rbrakk>\<rceil>\<^sub><"
  by (pred_simp)

subsection \<open> Unrestriction laws \<close>

text \<open> Crucially, the lifting operators allow us to demonstrate unrestriction properties. For
  example, we can show that no primed variable is restricted in an expression over only the
  first element of the state-space product type. \<close>

lemma unrest_dash_var_pre [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "$x\<acute> \<sharp> \<lceil>p\<rceil>\<^sub><"
  by (pred_auto)

subsection \<open> Parser and Pretty Printer \<close>

utp_const lift_pre drop_pre lift_post drop_post

term "U((p::'a upred)\<^sup>< \<le> p\<^sup><)"

term "U(1\<^sup>< \<le> p\<^sup>< \<and> true)"

term "U(p\<^sup>< \<le> p\<^sup>>)"

end


theory Balance_Opt_LR
  imports
    "../Balance_LR"
    "../../Insert/Alloc_Optimized/Insert_Opt"
begin

context rbt_impl
begin
interpretation rbt_impl_deps .

definition "bl_opt_case_1 n_p \<equiv>
  do {
    l_p \<leftarrow> left n_p;
    set_color_p 0 n_p;
    set_color_p 1 l_p;
    return n_p
  }
"

definition "bl_opt_case_2 n_p \<equiv>
  do {
    r_p \<leftarrow> right n_p;
    set_color_p 0 r_p;
    set_color_p 1 n_p;
    balance_opt n_p
  }
"

definition "bl_opt_case_3 n_p \<equiv>
  do {
    r_p \<leftarrow> right n_p;

    r_p \<leftarrow> rotate_right r_p;
    set_right_p r_p n_p;

    n2_p \<leftarrow> rotate_left n_p;

    r_p \<leftarrow> right n2_p;
    rr_p \<leftarrow> right r_p;
    (if rr_p = null then return () else set_color_p 0 rr_p);

    set_color_p 1 r_p;
    r_p \<leftarrow> balance_opt r_p;
    set_right_p r_p n2_p;

    set_color_p 1 n_p;
    set_color_p 0 n2_p;
    return n2_p
  }
"

definition [llvm_inline]: "TFail \<equiv> fail" (*avoids VCG assuming fail can't be reached*)

definition "balance_left_opt n_p \<equiv>
  do {
    n \<leftarrow> ll_load n_p;
    case n of (RBT_NODE _ l_p k v r_p) \<Rightarrow>
    if! ll_matches_rbt bl_pat_1 l_p
    then! bl_opt_case_1 n_p
    else! if! ll_matches_rbt bl_pat_2 r_p
    then! bl_opt_case_2 n_p
    else! if! ll_matches_rbt bl_pat_3 r_p
    then! bl_opt_case_3 n_p
    else! do {
      free n_p;
      empty
    }
  }"

lemma balance_left_opt_correct [vcg_rules]:
  "
    llvm_htriple
    (
      rbt_assn l li **
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi **
      rbt_assn r ri **
      color_assn c ci **
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) n_p **

      \<up>(matches_rbt (RP_Branch CP_B RP_Var RP_Var) l_pre) **
      \<up>(inv1 (Branch c l_pre k v r)) **
      \<up>(inv2 (Branch c l_pre k v r))
    )
    (balance_left_opt n_p)
    (\<lambda>res. rbt_assn (rbt_balance_left l k v r) res)
  "
  unfolding
    balance_left_opt_def
    bl_opt_case_1_def
    bl_opt_case_2_def
    bl_opt_case_3_def
    rotate_left_def
    rotate_right_def
    left_def
    right_def
  apply vcg
  subgoal (*case 1*)
    apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_left.cases)
              apply auto
       apply vcg
    done
  subgoal (*case 2+*)
    apply vcg

    subgoal (*case 2*)
      apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_left.cases)
                apply auto
       apply vcg
      done
    subgoal (*case 3+*)
      apply vcg
      subgoal (*case 4*)
        apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_left.cases)
                  apply (auto elim!: matches_rbt.elims)
        done
      done
    done
  done

definition "br_opt_case_1 n_p \<equiv>
  do {
    l_p \<leftarrow> right n_p;
    set_color_p 0 n_p;
    set_color_p 1 l_p;
    return n_p
  }
"

definition "br_opt_case_2 n_p \<equiv>
  do {
    r_p \<leftarrow> left n_p;
    set_color_p 0 r_p;
    set_color_p 1 n_p;
    balance_opt n_p
  }
"

definition "br_opt_case_3 n_p \<equiv>
  do {
    r_p \<leftarrow> left n_p;

    r_p \<leftarrow> rotate_left r_p;
    set_left_p r_p n_p;

    n2_p \<leftarrow> rotate_right n_p;

    r_p \<leftarrow> left n2_p;
    rr_p \<leftarrow> left r_p;
    (if rr_p = null then return () else set_color_p 0 rr_p);

    set_color_p 1 r_p;
    r_p \<leftarrow> balance_opt r_p;
    set_left_p r_p n2_p;

    set_color_p 1 n_p;
    set_color_p 0 n2_p;
    return n2_p
  }
"

definition "balance_right_opt n_p \<equiv>
  do {
    n \<leftarrow> ll_load n_p;
    case n of (RBT_NODE _ l_p k v r_p) \<Rightarrow>
    if! ll_matches_rbt br_pat_1 r_p
    then! br_opt_case_1 n_p
    else! if! ll_matches_rbt br_pat_2 l_p
    then! br_opt_case_2 n_p
    else! if! ll_matches_rbt br_pat_3 l_p
    then! br_opt_case_3 n_p
    else! do {
      free n_p;
      empty
    }
  }"

lemma balance_right_opt_correct [vcg_rules]:
  "
    llvm_htriple
    (
      rbt_assn l li **
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi **
      rbt_assn r ri **
      color_assn c ci **
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) n_p **

      \<up>(matches_rbt (RP_Branch CP_B RP_Var RP_Var) r_pre) **
      \<up>(inv1 (Branch c l k v r_pre)) **
      \<up>(inv2 (Branch c l k v r_pre))
    )
    (balance_right_opt n_p)
    (\<lambda>res. rbt_assn (rbt_balance_right l k v r) res)
  "
  unfolding
    balance_right_opt_def
    br_opt_case_1_def
    br_opt_case_2_def
    br_opt_case_3_def
    rotate_right_def
    rotate_left_def
    right_def
    left_def

  apply vcg
  subgoal (*case 1*)
    apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_right.cases)
              apply auto
       apply vcg
    done
  subgoal (*case 2+*)
    apply vcg

    subgoal (*case 2*)
      apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_right.cases)
                apply auto
       apply vcg
      done
    subgoal (*case 3+*)
      apply vcg
      subgoal (*case 4*)
        apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_right.cases)
                  apply (auto elim: matches_rbt.elims)
        done
      done
    done
  done

lemmas [llvm_inline] =
  br_opt_case_1_def
  br_opt_case_2_def
  br_opt_case_3_def
  bl_opt_case_1_def
  bl_opt_case_2_def
  bl_opt_case_3_def

lemmas [llvm_code] =
  balance_right_opt_def
  balance_left_opt_def

lemma balance_left_opt_correct_combine [vcg_rules]:
  "
    llvm_htriple
    (
      rbt_assn l li **
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi **
      rbt_assn r ri **
      color_assn c ci **
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) n_p **

      \<up>(matches_rbt (RP_Branch CP_B RP_Var RP_Var) r)
    )
    (balance_left_opt n_p)
    (\<lambda>res. rbt_assn (rbt_balance_left l k v r) res)
  "
  unfolding
    balance_left_opt_def
    bl_opt_case_1_def
    bl_opt_case_2_def
    bl_opt_case_3_def
    rotate_left_def
    rotate_right_def
    left_def
    right_def
  apply vcg
  subgoal (*case 1*)
    apply (cases "(l, k, v, r)" rule: RBT_Impl.balance_left.cases)
              apply auto
    apply vcg
    done
  subgoal (*case 2+*)
    apply vcg
    done
  done

end

end


theory utp_frame
  imports utp_rel
begin

text \<open> The frame operator restricts the relation P to only operate on variables in the frame a \<close>

definition frame :: "'s frame \<Rightarrow> ('s ::scene_space) rel \<Rightarrow> 's rel" where
"frame a P = {(s, s'). s \<approx>\<^sub>F s' on - a \<and> (s, s') \<in> P}"
(*
text \<open> The frame extension operator take a lens @{term a}, and a relation @{term P}. It constructs
  a relation such that all variables outside of @{term a} are unchanged, and the valuations for
  @{term a} are drawn from @{term P}. Intuitively, this can be seen as extending the alphabet
  of @{term P}. \<close>

definition frame_ext :: "('s\<^sub>1 \<Longrightarrow> ('s\<^sub>2 :: scene_space)) \<Rightarrow> 's\<^sub>1 rel \<Rightarrow> 's\<^sub>2 rel" where
  "frame_ext a P = frame \<lbrace>a\<rbrace>\<^sub>F (P \<up> (a \<times> a))"

syntax
  "_frame" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]")
  "_frame_ext" :: "svid \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sub>\<up>")

translations
  "_frame a P" == "CONST frame a P"
  "_frame_ext a P" == "CONST frame_ext a P"

abbreviation modifies ("_ mods _") where
"modifies P a \<equiv> P is frame a"

abbreviation not_modifies ("_ nmods _") where
"not_modifies P a \<equiv> P is frame (-a)"

text \<open> Variable restriction - assign arbitrary values to a scene, effectively forbidding the
  relation from using its value\<close>

definition rrestr :: "('s :: scene_space) frame \<Rightarrow> 's rel \<Rightarrow> 's rel" where
[rel]: "rrestr x P = (\<Union>t t'. frame (-x) ((\<lambda>(s,s'). (t \<oplus>\<^sub>S s on \<lbrakk>x\<rbrakk>\<^sub>F, t' \<oplus>\<^sub>S s' on \<lbrakk>x\<rbrakk>\<^sub>F))`P))"

abbreviation not_uses ("_ nuses _") where
"not_uses P a \<equiv> P is rrestr a"

lemma nuses_nmods: "P nuses x \<Longrightarrow> P nmods x"
  unfolding Healthy_def rrestr_def frame_def by (transfer, auto)

lemma nuses_assign_commute:
  assumes "vwb_lens x" "P nuses $x"
  shows "(x := v) \<Zcomp> P = P \<Zcomp> (x := v)"
  oops

text \<open> Promotion takes a partial lens @{term a} and a relation @{term P}. It constructs a relation
  that firstly restricts the state to valuations where @{term a} is valid (i.e. defined), and
  secondly uses the lens to promote @{term P} so that it acts only on the @{term a} region of
  the state space. \<close>

definition promote :: "'c rel \<Rightarrow> ('c \<Longrightarrow> ('s::scene_space)) \<Rightarrow> 's rel" where
[rel]: "promote P a = \<questiondown>\<^bold>D(a)? \<Zcomp> a:[P]\<^sub>\<up>"

syntax "_promote" :: "logic \<Rightarrow> svid \<Rightarrow> logic" (infix "\<Up>" 60)
translations "_promote P a" == "CONST promote P a"

lemma rel_frame [rel]: "\<lbrakk>a:[P]\<rbrakk>\<^sub>P (s, s') = (s \<approx>\<^sub>F s' on -a \<and> \<lbrakk>P\<rbrakk>\<^sub>P (s, s'))"
  by (expr_auto add: frame_def)

lemma rel_frame_ext [rel]: "\<lbrakk>a:[P]\<^sub>\<up>\<rbrakk>\<^sub>P (s, s') = (s \<approx>\<^sub>S s' on (-\<lbrakk>a\<rbrakk>\<^sub>\<sim>) \<and> \<lbrakk>P\<rbrakk>\<^sub>P (get\<^bsub>a\<^esub> s, get\<^bsub>a\<^esub> s'))"
  apply (expr_auto add: frame_ext_def frame_def subst_app_pred_def)
  oops

section \<open> Frame laws \<close>

named_theorems frame

lemma frame_all [frame]: "top:[P] = P"
  by rel_auto

lemma frame_none [frame]: "bot:[P] = (P \<and> II)"
  by rel_auto

lemma frame_commute:
  assumes "($y\<^sup><) \<sharp> P" "($y\<^sup>>) \<sharp> P""($x\<^sup><) \<sharp> Q" "($x\<^sup>>) \<sharp> Q" "x \<bowtie> y"
  shows "$x:[P] \<Zcomp> $y:[Q] = $y:[Q] \<Zcomp> $x:[P]"
  oops
  (*apply (insert assms)
  apply (rel_auto)
   apply (rename_tac s s' s\<^sub>0)
   apply (subgoal_tac "(s \<oplus>\<^sub>L s' on y) \<oplus>\<^sub>L s\<^sub>0 on x = s\<^sub>0 \<oplus>\<^sub>L s' on y")
    apply (metis lens_indep_get lens_indep_sym lens_override_def)
   apply (simp add: lens_indep.lens_put_comm lens_override_def)
  apply (rename_tac s s' s\<^sub>0)
  apply (subgoal_tac "put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> s (get\<^bsub>x\<^esub> (put\<^bsub>x\<^esub> s\<^sub>0 (get\<^bsub>x\<^esub> s')))) (get\<^bsub>y\<^esub> (put\<^bsub>y\<^esub> s (get\<^bsub>y\<^esub> s\<^sub>0)))
                      = put\<^bsub>x\<^esub> s\<^sub>0 (get\<^bsub>x\<^esub> s')")
   apply (metis lens_indep_get lens_indep_sym)
  apply (metis lens_indep.lens_put_comm)
  done*)

lemma frame_miracle [simp]:
  "x:[false] = false"
  by (rel_auto)

lemma frame_skip [simp]:
  "x:[II] = II"
  by (rel_auto)

lemma frame_assign_in [frame]:
  "\<lbrakk> var_lens a; x \<subseteq>\<^sub>L a \<rbrakk> \<Longrightarrow> (\<lbrace>a\<rbrace>\<^sub>F):[x := v] = x := v"
  apply (rel_auto add: lens_insert_def, transfer, auto)
  by (metis lens_override_def lens_scene_override scene_equiv_def scene_override_commute
       var_lens.axioms(1) vwb_lens.put_eq vwb_lens_def)

lemma frame_conj_true [frame]:
  "\<lbrakk>-{x\<^sup><, x\<^sup>>} \<sharp> P; var_lens x \<rbrakk> \<Longrightarrow> (P \<and> $x:[true]) = $x:[P]"
  by (rel_auto)

(*lemma frame_is_assign [frame]:
  "vwb_lens x \<Longrightarrow> x:[$x\<acute> =\<^sub>u \<lceil>v\<rceil>\<^sub><] = x := v"
  by (rel_auto)
  *)
lemma frame_seq [frame]:
  assumes "vwb_lens x" "-{x\<^sup>>,x\<^sup><} \<sharp> P" "-{x\<^sup><,x\<^sup>>} \<sharp> Q"
  shows "$x:[P \<Zcomp> Q] = $x:[P] \<Zcomp> $x:[Q]"
  unfolding frame_def apply (rel_auto)
  oops

lemma frame_assign_commute_unrest:
  assumes "vwb_lens x" "x \<bowtie> a" "$a \<sharp> v" "$x\<^sup>< \<sharp> P" "$x\<^sup>> \<sharp> P"
  shows "(x := v) \<Zcomp> $a:[P] = $a:[P] \<Zcomp> (x := v)"
  using assms apply (rel_auto)
  oops

lemma frame_to_antiframe [frame]:
  "\<lbrakk> x \<bowtie>\<^sub>S y; x \<squnion>\<^sub>S y = \<top>\<^sub>S \<rbrakk> \<Longrightarrow> x:[P] = (-y):[P]"
  apply rel_auto
  by (metis scene_indep_compat scene_indep_override scene_override_commute scene_override_id scene_override_union)+

lemma rel_frext_miracle [frame]:
  "a:[false]\<^sup>+ = false"
  by (metis false_pred_def frame_miracle trancl_empty)

lemma rel_frext_skip [frame]:
  "idem_scene a \<Longrightarrow> a:[II]\<^sup>+ = II"
  by (metis frame_skip rtrancl_empty rtrancl_trancl_absorb)

lemma rel_frext_seq [frame]:
  "idem_scene a \<Longrightarrow> a:[P \<Zcomp> Q]\<^sup>+ = (a:[P]\<^sup>+ \<Zcomp> a:[Q]\<^sup>+)"
  apply (rel_auto)
  oops (* gets nitpicked *)

lemma rel_frext_assigns [frame]:
  "vwb_lens a \<Longrightarrow> a:[\<langle>\<sigma>\<rangle>\<^sub>a]\<^sup>+ = \<langle>\<sigma> \<oplus>\<^sub>s a\<rangle>\<^sub>a"
  by (rel_auto)

lemma rel_frext_rcond [frame]:
  "a:[P \<triangleleft> b \<triangleright>\<^sub>r Q]\<^sup>+ = (a:[P]\<^sup>+ \<triangleleft> b \<oplus>\<^sub>p a \<triangleright>\<^sub>r a:[Q]\<^sup>+)"
  by (rel_auto)

lemma rel_frext_commute:
  "x \<bowtie> y \<Longrightarrow> x:[P]\<^sup>+ \<Zcomp> y:[Q]\<^sup>+ = y:[Q]\<^sup>+ \<Zcomp> x:[P]\<^sup>+"
  apply (rel_auto)
   apply (rename_tac a c b)
   apply (subgoal_tac "\<And>b a. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b a) = get\<^bsub>y\<^esub> b")
    apply (metis (no_types, hide_lams) lens_indep_comm lens_indep_get)
   apply (simp add: lens_indep.lens_put_irr2)
  apply (subgoal_tac "\<And>b c. get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> b c) = get\<^bsub>x\<^esub> b")
   apply (subgoal_tac "\<And>b a. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b a) = get\<^bsub>y\<^esub> b")
    apply (metis (mono_tags, lifting) lens_indep_comm)
   apply (simp_all add: lens_indep.lens_put_irr2)
  done

lemma antiframe_disj [frame]: "(x:\<lbrakk>P\<rbrakk> \<or> x:\<lbrakk>Q\<rbrakk>) = x:\<lbrakk>P \<or> Q\<rbrakk>"
  by (rel_auto)

lemma antiframe_seq [frame]:
  "\<lbrakk> vwb_lens x; $x\<acute> \<sharp> P; $x \<sharp> Q \<rbrakk>  \<Longrightarrow> (x:\<lbrakk>P\<rbrakk> \<Zcomp> x:\<lbrakk>Q\<rbrakk>) = x:\<lbrakk>P \<Zcomp> Q\<rbrakk>"
  apply (rel_auto)
   apply (metis vwb_lens_wb wb_lens_def weak_lens.put_get)
  apply (metis vwb_lens_wb wb_lens.put_twice wb_lens_def weak_lens.put_get)
  done

lemma antiframe_copy_assign:
  "vwb_lens x \<Longrightarrow> (x := \<guillemotleft>v\<guillemotright> \<Zcomp> x:\<lbrakk>P\<rbrakk> \<Zcomp> x := \<guillemotleft>v\<guillemotright>) = (x := \<guillemotleft>v\<guillemotright> \<Zcomp> x:\<lbrakk>P\<rbrakk>)"
  by rel_auto

lemma nameset_skip: "vwb_lens x \<Longrightarrow> (\<^bold>n\<^bold>s x \<bullet> II) = II\<^bsub>x\<^esub>"
  by (rel_auto, meson vwb_lens_wb wb_lens.get_put)

lemma nameset_skip_ra: "vwb_lens x \<Longrightarrow> (\<^bold>n\<^bold>s x \<bullet> II\<^bsub>x\<^esub>) = II\<^bsub>x\<^esub>"
  by (rel_auto)

declare sublens_def [lens_defs]

subsection \<open> Modification laws \<close>
lemma "(rrestr x P) nmods x"
  oops
*)
end


theory IteratedFixedPoint
imports Plain_HOLCF
begin

definition cfun_upd :: "('a::discrete_cpo \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b \<rightarrow> ('a \<rightarrow> 'b)" where
 "cfun_upd = (\<Lambda> f a b x. if x=a then b else f\<cdot>x)"

abbreviation cfun_upd_syn :: "('a::discrete_cpo \<rightarrow> 'b) => 'a => 'b => ('a \<rightarrow> 'b)" where
 "cfun_upd_syn f a b == cfun_upd\<cdot>f\<cdot>a\<cdot>b"

nonterminal cupdbinds and cupdbind

syntax
  "_cupdbind" :: "['a, 'a] => cupdbind"               ("(2_ :\<cdot>=/ _)")
  ""         :: "cupdbind => cupdbinds"               ("_")
  "_cupdbinds":: "[cupdbind, cupdbinds] => cupdbinds" ("_,/ _")
  "_cUpdate"  :: "['a, cupdbinds] => 'a"              ("_/'((_)')" [1000, 0] 900)

translations
  "_cUpdate f (_cupdbinds b bs)" == "_cUpdate (_cUpdate f b) bs"
  "f(x:\<cdot>=y)" == "CONST cfun_upd_syn f x y"

lemma cfun_upd_apply[simp]: "(f(x :\<cdot>= v))\<cdot>y = (if y=x then v else f\<cdot>y)"
  unfolding cfun_upd_def by simp

(*
lemma cfun_upd_eqvt[eqvt]: "p \<bullet> (cfun_upd f (x::'a::{cont_pt,discrete_cpo}) y) = cfun_upd (p \<bullet> f) (p \<bullet> x) (p \<bullet> y)"
 by (auto simp add:permute_cfun_def cfun_eq_iff cfun_upd_def)
*)

lemma fun_upd_cont[simp,cont2cont]:
  assumes "cont f" and "cont h"
  shows "cont (\<lambda> x. fun_upd (f x) v (h x) :: 'a \<Rightarrow> 'b::cpo)"
proof (intro contI2  monofunI fun_belowI)
  fix x1 x2 :: 'c
  fix v'
  assume "x1 \<sqsubseteq> x2"
  thus "((f x1)(v := h x1)) v' \<sqsubseteq> ((f x2)(v := h x2)) v'"
    by (metis assms(1) assms(2) cont2monofunE fun_belowD fun_upd_apply)
next
  fix Y
  assume c1: "chain (Y :: nat \<Rightarrow> 'c)"
  assume c2: "chain (\<lambda>i. (f (Y i))(v := h (Y i)))"
  have "Y 0 \<sqsubseteq> Lub Y" by (metis is_ub_thelub[OF c1])
  hence "f (Y 0) \<sqsubseteq> f (Lub Y)" by (rule cont2monofunE[OF `cont f`])
  fix v'
  show "(((f (\<Squnion> i. Y i))(v := h (\<Squnion> i. Y i))) v') \<sqsubseteq> ((\<Squnion> i. (f (Y i))(v := h (Y i))) v') "
  proof(cases "v = v'")
    case True
    thus ?thesis
      using lub_fun[OF c2] cont2contlubE[OF `cont h` c1]
      by simp
  next
    case False
    thus ?thesis
      using lub_fun[OF c2] cont2contlubE[OF `cont f` c1]
            lub_fun[OF ch2ch_cont[OF `cont f` `chain Y`]]
      by simp
  qed
qed

lemma fun_upd_belowI:
  assumes "v \<sqsubseteq> g x"
  and "\<And> y. x \<noteq> y \<Longrightarrow> f y \<sqsubseteq> g y"
  shows "f(x := v) \<sqsubseteq> g"
  using assms
  by (metis fun_belowI fun_upd_def)

lemma cfun_upd_belowI:
  assumes "v \<sqsubseteq> g\<cdot>x"
  and "\<And> y. x \<noteq> y \<Longrightarrow> f\<cdot>y \<sqsubseteq> g\<cdot>y"
  shows "f(x :\<cdot>= v) \<sqsubseteq> g"
  using assms
  by -(rule cfun_belowI, simp)

lemma fun_upd2_belowI:
  assumes "v \<sqsubseteq> g x"
  assumes "v2 \<sqsubseteq> g y"
  and "\<And> z. z \<noteq> y \<Longrightarrow> z \<noteq> x \<Longrightarrow> f z \<sqsubseteq> g z"
  shows "f(x := v, y := v2) \<sqsubseteq> g"
  using assms
  by (metis fun_belowI fun_upd_def)

lemma cfun_upd2_belowI:
  assumes "v \<sqsubseteq> g\<cdot>x"
  assumes "v2 \<sqsubseteq> g\<cdot>y"
  and "\<And> z. z \<noteq> y \<Longrightarrow> z \<noteq> x \<Longrightarrow> f\<cdot>z \<sqsubseteq> g\<cdot>z"
  shows "f(x :\<cdot>= v, y :\<cdot>= v2) \<sqsubseteq> g"
  using assms
  by -(rule cfun_belowI, simp)

lemma
  fixes \<rho> :: "'a \<Rightarrow> 'b::pcpo"
   and e1 :: "('a \<Rightarrow> 'b) \<rightarrow> 'b"
   and e2 :: "('a \<Rightarrow> 'b) \<rightarrow> 'b"
   and x1 :: 'a and x2 :: 'a
  assumes ne:"x1 \<noteq> x2"
  shows "fix\<cdot>(\<Lambda> \<rho>'. \<rho> (x1 := e1\<cdot>\<rho>', x2 := e2\<cdot>\<rho>')) =
         fix\<cdot>(\<Lambda> \<rho>'. \<rho> (x1 := (fix\<cdot>(\<Lambda> \<rho>''. \<rho>' (x1 := e1\<cdot>\<rho>''))) x1, x2 := e2\<cdot>\<rho>'))" (is "fix_syn ?L = fix_syn ?R")
proof(rule below_antisym[OF fix_least_below fix_least_below])
  let ?H = "\<lambda> \<rho>' \<rho>''. \<rho>'(x1 := e1\<cdot>\<rho>'')"

  { fix y \<rho>
    assume "y \<noteq> x1"
    hence "fix_syn (?H \<rho>) y = \<rho> y"
    unfolding fix_def
    apply simp
    apply (subst lub_fun[OF chain_iterate])
    apply (subst lub_range_shift[symmetric, where j = 1, simplified, OF ch2ch_fun[OF chain_iterate]])
    apply simp
    done
  } note H_ignores_not_x1 = this

  { fix \<rho> \<rho>'
    assume "e1\<cdot>\<rho>' \<sqsubseteq> \<rho> x1"
    hence "?H \<rho> \<rho>' \<sqsubseteq> \<rho>"
      by (metis below_refl fun_upd_belowI)
  } note H_noop = this

  have [simp]: "cont ?R"
    apply (intro cont2cont)
    apply (rule cont2cont_fun) back
    apply (intro cont2cont)
    done

  note fix_eq_R = fix_eq[where F = "Abs_cfun ?R", unfolded beta_cfun[OF `cont ?R`]]

  have HR_is_R: "fix_syn (?H (fix_syn ?R)) = fix_syn ?R"
  proof
    case (goal1 x)
    show ?case
    proof(cases "x = x1")
    case True
      have "fix_syn (?H (fix_syn ?R)) x1 = fix_syn ?R x1"
        apply (subst (2) fix_eq_R)
        by (simp add: ne)
      with True
      show ?thesis by simp
    next
    case False
      thus ?thesis
        apply (subst fix_eq[where F = "Abs_cfun (?H (fix_syn ?R))"])
        by simp
    qed
  qed

  case goal2
  have "?R (fix_syn ?L) \<sqsubseteq> fix_syn ?L"
  proof(rule fun_upd2_belowI)
    have "e1\<cdot>(fix_syn ?L) \<sqsubseteq> (fix_syn ?L) x1"
      by (subst fix_eq, simp add: ne)
    hence "?H (fix_syn ?L) (fix_syn ?L) \<sqsubseteq> (fix_syn ?L)"
      by (rule H_noop)
    hence "(fix_syn (?H (fix_syn ?L))) \<sqsubseteq> (fix_syn ?L)"
      by -(rule fix_least_below, simp)
    thus "(fix_syn (?H (fix_syn ?L))) x1 \<sqsubseteq> (fix_syn ?L) x1"
      by (rule fun_belowD)
    show "e2\<cdot>(fix_syn ?L) \<sqsubseteq> (fix_syn ?L) x2"
      by (subst (2) fix_eq, simp)
    case goal3 thus ?case
      by (subst fix_eq, simp)
  qed
  thus ?case by simp

  case goal1
  have "?L (fix_syn ?R) \<sqsubseteq> fix_syn ?R"
  proof(rule fun_upd2_belowI)
    have "e1\<cdot>(fix_syn ?R) \<sqsubseteq> e1\<cdot>(fix_syn (?H (fix_syn ?R)))"
      by (simp add: HR_is_R)
    hence "e1\<cdot>(fix_syn ?R) \<sqsubseteq> (fix_syn (?H (fix_syn ?R))) x1"
      apply (subst fix_eq[of "Abs_cfun (?H (fix_syn ?R))"])
      by simp
    thus "e1\<cdot>(fix_syn ?R) \<sqsubseteq> (fix_syn ?R) x1"
      apply (subst (3) fix_eq)
      by (simp add: ne)
    show "e2\<cdot>(fix_syn ?R) \<sqsubseteq> (fix_syn ?R) x2"
      apply (subst (3) fix_eq)
      by simp
    fix y
    assume "y \<noteq> x1" and "y \<noteq> x2"
    thus "\<rho> y \<sqsubseteq> (fix_syn ?R) y"
      by (subst fix_eq, simp)
  qed
  thus ?case by simp
qed

lemma
  fixes \<rho> :: "'a::discrete_cpo \<rightarrow> 'b::pcpo"
   and e1 :: "('a \<rightarrow> 'b) \<rightarrow> 'b"
   and e2 :: "('a \<rightarrow> 'b) \<rightarrow> 'b"
   and x1 :: 'a and x2 :: 'a
  assumes ne:"x1 \<noteq> x2"
  shows "fix\<cdot>(\<Lambda> \<rho>'. \<rho> (x1 :\<cdot>= e1\<cdot>\<rho>', x2 :\<cdot>= e2\<cdot>\<rho>')) =
         fix\<cdot>(\<Lambda> \<rho>'. \<rho> (x1 :\<cdot>= (fix\<cdot>(\<Lambda> \<rho>''. \<rho>'(x1 :\<cdot>= e1\<cdot>\<rho>'')))\<cdot>x1, x2 :\<cdot>= e2\<cdot>\<rho>'))" (is "fix_syn ?L = fix_syn ?R")
proof(rule below_antisym[OF fix_least_below fix_least_below])
  let ?H = "\<lambda> \<rho>' \<rho>''. \<rho>'(x1 :\<cdot>= e1\<cdot>\<rho>'')"

  { fix y \<rho>
    assume "y \<noteq> x1"
    hence "fix_syn (?H \<rho>)\<cdot>y = \<rho>\<cdot>y"
    unfolding fix_def
    apply simp
    apply (subst lub_cfun[OF chain_iterate])
    apply (subst lub_range_shift[symmetric, where j = 1, simplified, OF ch2ch_Rep_cfunL[OF chain_iterate]])
    apply simp
    done
  } note H_ignores_not_x1 = this

  { fix \<rho> \<rho>'
    assume "e1\<cdot>\<rho>' \<sqsubseteq> \<rho>\<cdot>x1"
    hence "?H \<rho> \<rho>' \<sqsubseteq> \<rho>"
      by (metis below_refl cfun_upd_belowI)
  } note H_noop = this

  note fix_eq_R = fix_eq[where F = "Abs_cfun ?R", simplified]

  have HR_is_R: "fix_syn (?H (fix_syn ?R)) = fix_syn ?R"
  proof(rule cfun_eqI)
    case (goal1 x)
    show ?case
    proof(cases "x = x1")
    case True
      have "fix_syn (?H (fix_syn ?R))\<cdot>x1 = fix_syn ?R\<cdot>x1"
        apply (subst (2) fix_eq_R)
        by (simp add: ne)
      with True
      show ?thesis by simp
    next
    case False
      thus ?thesis
        apply (subst fix_eq[where F = "Abs_cfun (?H (fix_syn ?R))"])
        by simp
    qed
  qed

  case goal2
  have "?R (fix_syn ?L) \<sqsubseteq> fix_syn ?L"
  proof(rule cfun_upd2_belowI)
    have "e1\<cdot>(fix_syn ?L) \<sqsubseteq> (fix_syn ?L)\<cdot>x1"
      by (subst fix_eq, simp add: ne)
    hence "?H (fix_syn ?L) (fix_syn ?L) \<sqsubseteq> (fix_syn ?L)"
      by (rule H_noop)
    hence "(fix_syn (?H (fix_syn ?L))) \<sqsubseteq> (fix_syn ?L)"
      by -(rule fix_least_below, simp)
    thus "(fix_syn (?H (fix_syn ?L)))\<cdot>x1 \<sqsubseteq> (fix_syn ?L)\<cdot>x1"
      by (rule monofun_cfun_fun)
    show "e2\<cdot>(fix_syn ?L) \<sqsubseteq> (fix_syn ?L)\<cdot>x2"
      by (subst (2) fix_eq, simp)
    case goal3 thus ?case
      by (subst fix_eq, simp)
  qed
  thus ?case by simp

  case goal1
  have "?L (fix_syn ?R) \<sqsubseteq> fix_syn ?R"
  proof(rule cfun_upd2_belowI)
    have "e1\<cdot>(fix_syn ?R) \<sqsubseteq> e1\<cdot>(fix_syn (?H (fix_syn ?R)))"
      by (simp add: HR_is_R)
    hence "e1\<cdot>(fix_syn ?R) \<sqsubseteq> (fix_syn (?H (fix_syn ?R)))\<cdot>x1"
      apply (subst fix_eq[of "Abs_cfun (?H (fix_syn ?R))"])
      by simp
    thus "e1\<cdot>(fix_syn ?R) \<sqsubseteq> (fix_syn ?R)\<cdot>x1"
      apply (subst (3) fix_eq)
      by (simp add: ne)
    show "e2\<cdot>(fix_syn ?R) \<sqsubseteq> (fix_syn ?R)\<cdot>x2"
      apply (subst (3) fix_eq)
      by simp
    fix y
    assume "y \<noteq> x1" and "y \<noteq> x2"
    thus "\<rho>\<cdot>y \<sqsubseteq> (fix_syn ?R)\<cdot>y"
      by (subst fix_eq, simp)
  qed
  thus ?case by simp
qed

definition cfun_upd_on :: "('a::discrete_cpo \<rightarrow> 'b) \<rightarrow> 'a set discr \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b)" where
 "cfun_upd_on = (\<Lambda> f S g x. if x \<in> undiscr S then g\<cdot>x else f\<cdot>x)"

abbreviation cfun_upd_on_syn :: "('a::discrete_cpo \<rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a \<rightarrow> 'b) \<Rightarrow> ('a \<rightarrow> 'b)" ("_ ++\<^bsub>_\<^esub> _" [60,60,60] 60)
  where "cfun_upd_on_syn f S g == cfun_upd_on\<cdot>f\<cdot>(Discr S)\<cdot>g"

lemma cfun_upd_on_apply[simp]: "(f ++\<^bsub>S\<^esub> g)\<cdot>x = (if x \<in> S then g\<cdot>x else f\<cdot>x)"
  unfolding cfun_upd_on_def by simp

lemma cfun_upd_on_belowI:
  assumes "\<And>x. x \<in> S \<Longrightarrow> g\<cdot>x \<sqsubseteq> h\<cdot>x"
  assumes "\<And>x. x \<notin> S \<Longrightarrow> f\<cdot>x \<sqsubseteq> h\<cdot>x"
  shows "f ++\<^bsub>S\<^esub> g \<sqsubseteq> h"
  using assms
  by -(rule cfun_belowI, simp)

lemma
  fixes \<rho> :: "'a::discrete_cpo \<rightarrow> 'b::pcpo"
   and e1 :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b)"
   and e2 :: "('a \<rightarrow> 'b) \<rightarrow> 'b"
   and S :: "'a set" and x2 :: 'a
  assumes ne:"x2 \<notin> S"
  shows "fix\<cdot>(\<Lambda> \<rho>'. (\<rho> ++\<^bsub>S\<^esub> e1\<cdot>\<rho>')(x2 :\<cdot>= e2\<cdot>\<rho>')) =
         fix\<cdot>(\<Lambda> \<rho>'. (\<rho> ++\<^bsub>S\<^esub> (fix\<cdot>(\<Lambda> \<rho>''. \<rho>' ++\<^bsub>S\<^esub> e1\<cdot>\<rho>'')))(x2 :\<cdot>= e2\<cdot>\<rho>'))" (is "fix_syn ?L = fix_syn ?R")
proof(rule below_antisym[OF fix_least_below fix_least_below])
  let ?H = "\<lambda> \<rho>' \<rho>''. \<rho>' ++\<^bsub>S\<^esub> e1\<cdot>\<rho>''"

  { fix y \<rho>
    assume "y \<notin> S"
    hence "fix_syn (?H \<rho>)\<cdot>y = \<rho>\<cdot>y"
    unfolding fix_def
    apply simp
    apply (subst lub_cfun[OF chain_iterate])
    apply (subst lub_range_shift[symmetric, where j = 1, simplified, OF ch2ch_Rep_cfunL[OF chain_iterate]])
    apply simp
    done
  } note H_ignores_not_S = this

  { fix \<rho> \<rho>'
    assume "\<And> x. x \<in> S \<Longrightarrow> e1\<cdot>\<rho>'\<cdot>x \<sqsubseteq> \<rho>\<cdot>x"
    hence "?H \<rho> \<rho>' \<sqsubseteq> \<rho>"
      by (metis cfun_upd_on_belowI below_refl)
  } note H_noop = this

  note fix_eq_R = fix_eq[where F = "Abs_cfun ?R", simplified]
  note fix_eq_L = fix_eq[where F = "Abs_cfun ?L", simplified]
  note fix_eq_HR = fix_eq[where F = "Abs_cfun (?H (fix_syn ?R))", simplified]

  have HR_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> fix_syn (?H (fix_syn ?R))\<cdot>x = fix_syn ?R \<cdot> x"
     by (subst fix_eq_HR, simp)

  have HR_S[simp]: "\<And> x. x \<in> S \<Longrightarrow> fix_syn (?H (fix_syn ?R))\<cdot>x = e1\<cdot>(fix_syn (?H (fix_syn ?R)))\<cdot>x"
    apply (subgoal_tac "x \<noteq> x2")
    apply (subst fix_eq_HR)
    apply simp
    using ne by metis

  have L_S[simp]: "\<And> x. x \<in> S \<Longrightarrow> (fix_syn ?L)\<cdot>x = e1\<cdot>(fix_syn ?L)\<cdot>x"
    apply (subgoal_tac "x \<noteq> x2")
    apply (subst (1) fix_eq_L)
    apply simp
    using ne by metis

  have L_x2[simp]: "(fix_syn ?L)\<cdot>x2 = e2\<cdot>(fix_syn ?L)"
    by (subst (1) fix_eq_L, simp)

  have L_not_S_x2[simp]: "\<And> x. x \<notin> S \<Longrightarrow> x \<noteq> x2 \<Longrightarrow> (fix_syn ?L)\<cdot>x = \<rho>\<cdot>x"
    by (subst (1) fix_eq_L, simp)

  have R_S[simp]: "\<And> x. x \<in> S \<Longrightarrow> fix_syn ?R \<cdot> x = e1\<cdot>(fix_syn (?H (fix_syn ?R)))\<cdot>x"
    apply (subgoal_tac "x \<noteq> x2")
    apply (subst fix_eq_R)
    apply simp
    using ne by metis

  have R_x2[simp]: "fix_syn ?R \<cdot> x2 = e2\<cdot>(fix_syn ?R)"
    by (subst fix_eq_R, simp)

  have R_not_S[simp]: "\<And> x. x \<notin> S \<Longrightarrow> x \<noteq> x2 \<Longrightarrow> fix_syn ?R \<cdot> x = \<rho>\<cdot>x"
    by (subst fix_eq_R, simp)

  have HR_is_R[simp]: "fix_syn (?H (fix_syn ?R)) = fix_syn ?R"
    apply (rule cfun_eqI)
    apply (case_tac "x \<in> S")
    apply simp_all
    done

  have HLL_below_L: "?H (fix_syn ?L) (fix_syn ?L) \<sqsubseteq> (fix_syn ?L)"
    by (rule H_noop, simp)

  case goal2
  have "?R (fix_syn ?L) \<sqsubseteq> fix_syn ?L"
  proof(rule cfun_upd_belowI)
    show "e2\<cdot>(fix_syn ?L) \<sqsubseteq> (fix_syn ?L)\<cdot>x2"
      by simp
    fix x
    assume "x2 \<noteq> x"
    hence [simp]:"x \<noteq> x2" by metis
    show "(\<rho> ++\<^bsub>S\<^esub> (fix_syn (?H (fix_syn ?L))))\<cdot>x \<sqsubseteq> (fix_syn ?L)\<cdot>x"
    proof(cases "x \<in> S")
    case True[simp]
      from HLL_below_L
      have "(fix_syn (?H (fix_syn ?L))) \<sqsubseteq> (fix_syn ?L)"
        by -(rule fix_least_below, simp)
      hence "(fix_syn (?H (fix_syn ?L)))\<cdot>x \<sqsubseteq> (fix_syn ?L)\<cdot>x"
        by (rule monofun_cfun_fun)
      thus ?thesis
        by simp
    next
    case False
      thus ?thesis by simp
    qed
  qed
  thus ?case by simp

  case goal1
  have "?L (fix_syn ?R) \<sqsubseteq> fix_syn ?R"
    apply(rule cfun_upd_belowI)
    apply simp
    apply (case_tac "x \<notin> S")
    apply simp_all
    done
  thus ?case by simp
qed

end