theory
  Refine_Unions
  imports
    Enclosure_Operations
    Weak_Set
begin

consts i_coll :: "interface \<Rightarrow> interface \<Rightarrow> interface" \<comment> \<open>collection of reachable sets\<close>

subsection \<open>composed set relations\<close>

definition Union_rel::"('l \<times> 'a set) set \<Rightarrow> ('a \<times> 'b set) set \<Rightarrow> ('l \<times> 'b set) set"
  where Union_rel_internal: "Union_rel L S = L O \<langle>S\<rangle>set_rel O br Union top"
lemmas [autoref_rel_intf] = REL_INTFI[of "Union_rel" "i_coll" for L S R]

lemma Union_rel_def: "\<langle>L, S\<rangle>Union_rel = L O \<langle>S\<rangle>set_rel O br Union top"
  unfolding relAPP_def Union_rel_internal ..

lemma single_valued_Union_rel[relator_props]:
  "single_valued L \<Longrightarrow> single_valued R \<Longrightarrow> single_valued (\<langle>L, R\<rangle>Union_rel)"
  unfolding relAPP_def
  by (auto simp: Union_rel_internal intro!: relator_props intro: single_valuedI)

lemma Union_rel_br: "\<langle>(br l lI), (br s sI)\<rangle>Union_rel = br (\<lambda>a. \<Union>(s ` (l a))) (\<lambda>a. lI a \<and> (\<forall>c \<in> l a. sI c))"
  unfolding Union_rel_def br_def
  apply (safe)
  subgoal by (force simp: set_rel_def)
  subgoal by (fastforce simp: set_rel_def)
  subgoal by (force simp: set_rel_def)
  subgoal for a
    by (auto intro!: relcompI[where b="l a"] relcompI[where b="s ` l a"] simp: set_rel_def)
  done

subsubsection \<open>Implementation of set as union of sets\<close>

context includes autoref_syntax begin

definition [simp]: "op_union_coll = (\<union>)"

definition "Id_arbitrary_interface = Id"
abbreviation "lw_rel \<equiv> \<langle>Id_arbitrary_interface\<rangle>list_wset_rel"
lemmas [autoref_rel_intf] = REL_INTFI[of Id_arbitrary_interface S for S::interface]
lemma single_valued_Id_arbitrary_interface[relator_props]: "single_valued Id_arbitrary_interface"
  by (auto simp: Id_arbitrary_interface_def)

lemma lw_rel_def: "lw_rel = br set top"
  by (simp add: list_wset_rel_def Id_arbitrary_interface_def)

abbreviation "clw_rel A \<equiv> \<langle>lw_rel, A\<rangle>Union_rel"

lemma clw_rel_def: "clw_rel A = lw_rel O \<langle>A\<rangle>set_rel O br Union top"
  unfolding Union_rel_def
  by simp

lemma op_wset_isEmpty_clw_rel[autoref_rules]:
  "(\<lambda>x. RETURN (x = []), isEmpty_spec) \<in> clw_rel A \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
  by (auto simp: nres_rel_def lw_rel_def Union_rel_def br_def set_rel_def)

lemma lift_clw_rel_map:
  assumes "single_valued A"
  assumes "single_valued B"
  assumes "(fi, f) \<in> A \<rightarrow> B"
  assumes f_distrib: "\<And>X. X \<subseteq> Range A \<Longrightarrow> f (\<Union>X) = \<Union>(f ` X)"
  shows "(map fi, f) \<in> clw_rel A \<rightarrow> clw_rel B"
  using assms(1-2)
  apply (auto simp: clw_rel_def)
  subgoal for xs X YY Z
    apply (rule relcompI[where b="fi ` X"])
     apply (force simp: lw_rel_def br_def)
    apply (rule relcompI[where b="f `  YY"])
     prefer 2
     apply (rule brI)
      apply (subst f_distrib[symmetric])
      apply (force simp: br_def set_rel_def)
      apply (force simp add: br_def)
    apply force
    using assms(3)
    apply parametricity
    done
  done

lemma list_rel_comp_Union_rel:
  "single_valued R \<Longrightarrow> (\<langle>R\<rangle>list_rel O \<langle>(\<langle>Id\<rangle>list_wset_rel), S\<rangle>Union_rel) =
    \<langle>(\<langle>Id\<rangle>list_wset_rel), (R O S)\<rangle>Union_rel"
  unfolding Union_rel_def
  unfolding O_assoc[symmetric]
  apply (subst list_rel_comp_list_wset_rel) apply simp apply (simp)
  by (simp add: O_assoc list_wset_rel_def set_rel_compp)

lemma Cons_mem_clw_rel_iff:
  assumes "single_valued A"
  shows "(x # xs, X) \<in> clw_rel A \<longleftrightarrow> (\<exists>Y YS. (x, Y) \<in> A \<and> (set xs, YS) \<in> \<langle>A\<rangle>set_rel \<and> X = Y \<union> \<Union>YS)"
  using assms
  unfolding clw_rel_def
  apply safe
  subgoal by (force simp add: br_def lw_rel_def insert_mem_set_rel_iff[OF assms])
  subgoal for Y YS
    apply (auto intro!: relcompI[where b="insert x (set xs)"] relcompI[where b="insert Y YS"]
        param_insert[param_fo]
        simp: lw_rel_def br_def)
    done
  done

lemma split_spec_exact_with_stepsize_autoref[autoref_rules]:
  assumes "PREFER single_valued A"
  shows "(\<lambda>xs. case xs of [] \<Rightarrow> SUCCEED | (x # xs) \<Rightarrow> RETURN (x, xs), split_spec_exact) \<in>
    clw_rel A \<rightarrow> \<langle>A \<times>\<^sub>r clw_rel A\<rangle>nres_rel"
proof -
  have "\<exists>a. (x, a) \<in> A \<and> (\<exists>b. (y, b) \<in> clw_rel A \<and> xs \<union> \<Union>YS = a \<union> b)"
    if "(x, xs) \<in> A" "(set y, YS) \<in> \<langle>A\<rangle>set_rel"
    for x y xs YS
    using that
    by (auto intro: exI[where x=xs] exI[where x="\<Union>YS"] simp: Union_rel_def lw_rel_def br_def)
  then show ?thesis
    using assms
    by (auto simp: split_spec_exact_def Cons_mem_clw_rel_iff
        intro!: nres_relI RETURN_SPEC_refine
        split: list.splits)
qed

definition "split_spec_coll = split_spec"
lemma clw_rel_split[autoref_rules]:
  assumes "PREFER single_valued A"
  shows "(\<lambda>xs. case xs of [] \<Rightarrow> SUCCEED | (x # xs) \<Rightarrow> RETURN (x, xs), split_spec_coll) \<in>
    clw_rel A \<rightarrow> \<langle>A \<times>\<^sub>r clw_rel A\<rangle>nres_rel"
proof -
  have "\<exists>a. (x, a) \<in> A \<and> (\<exists>b. (y, b) \<in> clw_rel A \<and> xs \<subseteq> a \<union> b \<and> \<Union>YS \<subseteq> a \<union> b)"
    if "(x, xs) \<in> A" "(set y, YS) \<in> \<langle>A\<rangle>set_rel"
    for x y xs YS
    using that
    by (auto intro: exI[where x=xs] exI[where x="\<Union>YS"] simp: Union_rel_def lw_rel_def br_def)
  then show ?thesis
    using assms
    by (auto simp: split_spec_coll_def split_spec_def Cons_mem_clw_rel_iff
        intro!: nres_relI RETURN_SPEC_refine
        split: list.splits)
qed

definition [simp]: "op_Union_coll = Union"
lemma [autoref_op_pat]: "Union \<equiv> OP op_Union_coll"
  by simp
lemma clw_rel_Union[autoref_rules]:
  includes autoref_syntax
  assumes [unfolded autoref_tag_defs, relator_props]: "PREFER single_valued A"
  shows "(concat, op_Union_coll) \<in> \<langle>clw_rel A\<rangle>list_wset_rel \<rightarrow> clw_rel A"
proof -
  have "(concat, concat) \<in> \<langle>\<langle>A\<rangle>list_rel\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" (is "_ \<in> ?L1 \<rightarrow> ?L2")
    by parametricity
  moreover have "(concat, op_Union_coll) \<in> \<langle>clw_rel Id\<rangle>list_wset_rel \<rightarrow> clw_rel Id"  (is "_ \<in> ?R1 \<rightarrow> ?R2")
    apply (auto simp: list_wset_rel_def Id_arbitrary_interface_def Union_rel_def
        br_chain o_def)
    apply (auto simp: br_def set_rel_def)
    apply force
    done
  ultimately have "(concat, op_Union_coll) \<in> (?L1 \<rightarrow> ?L2) O (?R1 \<rightarrow> ?R2)"
    by auto
  also have "\<dots> \<subseteq> (?L1 O ?R1) \<rightarrow> (?L2 O ?R2)" by (rule fun_rel_comp_dist)
  also have "?L1 O ?R1 = \<langle>clw_rel A\<rangle>list_wset_rel"
    apply (subst list_rel_comp_list_wset_rel)
    subgoal by (simp add: relator_props)
    subgoal using assms by (simp add: list_rel_comp_Union_rel Id_arbitrary_interface_def)
    done
  also have "?L2 O ?R2 = clw_rel A" using assms
    unfolding Id_arbitrary_interface_def
    by (subst list_rel_comp_Union_rel) simp_all
  finally show ?thesis .
qed

definition [simp]: "op_coll_is_empty \<equiv> is_empty"
lemma [autoref_op_pat]:  "is_empty \<equiv> OP op_coll_is_empty"
  by simp

lemma op_set_isEmpty_Union_rel[autoref_rules]:
  assumes "GEN_OP is_empty_i is_empty (A \<rightarrow> bool_rel)"
  shows "(\<lambda>xs. xs = [] \<or> list_all is_empty_i xs, op_coll_is_empty) \<in> clw_rel A \<rightarrow> bool_rel"
  using assms
  apply (auto simp: Union_rel_def lw_rel_def br_def set_rel_def op_set_isEmpty_def[abs_def]
      op_coll_is_empty_def
    list_all_iff dest: fun_relD)
  apply (fastforce dest: fun_relD)
  using fun_relD by fastforce

definition [simp]: "op_empty_coll = {}"
lemma Union_rel_empty[autoref_rules]:
  shows "([], op_empty_coll) \<in> clw_rel R"
  by (auto simp: br_def Union_rel_def
      intro!: relcompI[OF param_empty] relcompI[OF list_wset_autoref_empty])

definition mk_coll::"'a set \<Rightarrow> 'a set" where [refine_vcg_def, simp]: "mk_coll x = x"
lemma mk_coll[autoref_rules]:
  "PREFER single_valued R \<Longrightarrow> (\<lambda>x. [x], mk_coll) \<in> R \<rightarrow> clw_rel R"
  apply (rule fun_relI)
  subgoal for x x'
    by (auto simp: Union_rel_def list_wset_rel_def br_def set_rel_def single_valued_def
      Id_arbitrary_interface_def
      intro!: relcompI[where b="{xa. (x, xa) \<in> R}"] relcompI[where b="{x}"])
  done

lemma map_mem_clw_rel_br:
  assumes "\<Union>((\<lambda>x. a (f x)) ` set xs) = X"
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> I (f x)"
  shows "(map f xs, X) \<in> clw_rel (br a I)"
  using assms
  by (auto simp: lw_rel_def Union_rel_br intro!: brI)

lemma clw_rel_br: "clw_rel (br a I) = br (\<lambda>xs. \<Union>(a ` (set xs))) (\<lambda>xs. Ball (set xs) I)"
  unfolding lw_rel_def Union_rel_br by simp

lemma sets_of_coll_autoref[autoref_rules]:
  shows "(\<lambda>x. RETURN x, sets_of_coll) \<in> clw_rel R \<rightarrow> \<langle>\<langle>R\<rangle>list_wset_rel\<rangle>nres_rel"
  by (auto simp: lw_rel_def Union_rel_def br_def set_rel_def list_wset_rel_def sets_of_coll_def
    Id_arbitrary_interface_def
      elim!: single_valued_as_brE
      intro!: nres_relI RETURN_SPEC_refine)
    auto

lemma Nil_mem_clw_rel_iff[simp]: "([], X) \<in> clw_rel W \<longleftrightarrow> X = {}"
  by (auto simp: Union_rel_def br_def set_rel_def lw_rel_def)

end

end


theory Monad
  imports Main "HOL-Library.Monad_Syntax"
begin

datatype ('M, 'a) state = State (runState: "'M \<Rightarrow> 'a \<times> 'M")
term 0 (**)

definition return :: "'a \<Rightarrow> ('M, 'a) state" where
  "return a \<equiv> State (\<lambda>M. (a, M))"
term 0 (**)

definition bind :: "('M, 'a) state \<Rightarrow> ('a \<Rightarrow> ('M, 'b) state) \<Rightarrow> ('M, 'b) state" where
  "bind s k = State (\<lambda>M. let (a, M') = runState s M in runState (k a) M')"
term 0 (**)

adhoc_overloading
  Monad_Syntax.bind bind

definition get :: "('M, 'M) state" where
  "get \<equiv> State (\<lambda>M. (M, M))"

definition put :: "'M \<Rightarrow> ('M, unit) state" where
  "put M \<equiv> State (\<lambda>_. ((), M))"
term 0 (**)

term 0 (**)
lemma bind_assoc:
  "((s::(_,_)state) \<bind> k0) \<bind> k1 = s \<bind> (\<lambda>a. k0 a \<bind> k1)"
  unfolding bind_def by (auto split: prod.split)

lemma left_identity:
  "return v \<bind> k = k v"
  unfolding return_def bind_def by simp

lemma right_identity:
  "s \<bind> return = s"
  unfolding return_def bind_def by simp

lemma runState_return:
  "runState (return x) M = (x, M)"
  unfolding return_def by simp
end


(* Author: Joshua Schneider, ETH Zurich *)

section \<open>Common applicative functors\<close>

subsection \<open>Environment functor\<close>

theory Applicative_Environment imports
  Applicative
  "~~/src/Tools/Adhoc_Overloading"
begin

definition "const x = (\<lambda>_. x)"
definition "apf x y = (\<lambda>z. x z (y z))"

adhoc_overloading Applicative.pure const
adhoc_overloading Applicative.ap apf

text \<open>The declaration below demonstrates that applicative functors which lift the reductions
  for combinators K and W also lift C. However, the interchange law must be supplied in this case.\<close>

applicative env (K, W)
for
  pure: const
  ap: apf
  rel: "rel_fun op ="
  set: range
by(simp_all add: const_def apf_def rel_fun_def)

experiment begin
  interpretation applicative_syntax .

  lemma "const (\<lambda>f x y. f y x) \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x"
  by applicative_lifting simp
end

end


(*  Title:      HOL/Nitpick.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2008, 2009, 2010

Nitpick: Yet another counterexample generator for Isabelle/HOL.
*)

section {* Nitpick: Yet Another Counterexample Generator for Isabelle/HOL *}

theory Nitpick
imports Record
keywords
  "nitpick" :: diag and
  "nitpick_params" :: thy_decl
begin

datatype (plugins only: extraction) (dead 'a, dead 'b) fun_box = FunBox "'a \<Rightarrow> 'b"
datatype (plugins only: extraction) (dead 'a, dead 'b) pair_box = PairBox 'a 'b
datatype (plugins only: extraction) (dead 'a) word = Word "'a set"

typedecl bisim_iterator
typedecl unsigned_bit
typedecl signed_bit

consts
  unknown :: 'a
  is_unknown :: "'a \<Rightarrow> bool"
  bisim :: "bisim_iterator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  bisim_iterator_max :: bisim_iterator
  Quot :: "'a \<Rightarrow> 'b"
  safe_The :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"

text {*
Alternative definitions.
*}

lemma Ex1_unfold[nitpick_unfold]: "Ex1 P \<equiv> \<exists>x. {x. P x} = {x}"
  apply (rule eq_reflection)
  apply (simp add: Ex1_def set_eq_iff)
  apply (rule iffI)
   apply (erule exE)
   apply (erule conjE)
   apply (rule_tac x = x in exI)
   apply (rule allI)
   apply (rename_tac y)
   apply (erule_tac x = y in allE)
  by auto

lemma rtrancl_unfold[nitpick_unfold]: "r\<^sup>* \<equiv> (r\<^sup>+)\<^sup>="
  by (simp only: rtrancl_trancl_reflcl)

lemma rtranclp_unfold[nitpick_unfold]: "rtranclp r a b \<equiv> (a = b \<or> tranclp r a b)"
  by (rule eq_reflection) (auto dest: rtranclpD)

lemma tranclp_unfold[nitpick_unfold]:
  "tranclp r a b \<equiv> (a, b) \<in> trancl {(x, y). r x y}"
  by (simp add: trancl_def)

lemma [nitpick_simp]:
  "of_nat n = (if n = 0 then 0 else 1 + of_nat (n - 1))"
  by (cases n) auto

definition prod :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set" where
  "prod A B = {(a, b). a \<in> A \<and> b \<in> B}"

definition refl' :: "('a \<times> 'a) set \<Rightarrow> bool" where
  "refl' r \<equiv> \<forall>x. (x, x) \<in> r"

definition wf' :: "('a \<times> 'a) set \<Rightarrow> bool" where
  "wf' r \<equiv> acyclic r \<and> (finite r \<or> unknown)"

definition card' :: "'a set \<Rightarrow> nat" where
  "card' A \<equiv> if finite A then length (SOME xs. set xs = A \<and> distinct xs) else 0"

definition setsum' :: "('a \<Rightarrow> 'b\<Colon>comm_monoid_add) \<Rightarrow> 'a set \<Rightarrow> 'b" where
  "setsum' f A \<equiv> if finite A then listsum (map f (SOME xs. set xs = A \<and> distinct xs)) else 0"

inductive fold_graph' :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> bool" where
  "fold_graph' f z {} z" |
  "\<lbrakk>x \<in> A; fold_graph' f z (A - {x}) y\<rbrakk> \<Longrightarrow> fold_graph' f z A (f x y)"

text {*
The following lemmas are not strictly necessary but they help the
\textit{specialize} optimization.
*}

lemma The_psimp[nitpick_psimp]: "P = (op =) x \<Longrightarrow> The P = x"
  by auto

lemma Eps_psimp[nitpick_psimp]:
  "\<lbrakk>P x; \<not> P y; Eps P = y\<rbrakk> \<Longrightarrow> Eps P = x"
  apply (cases "P (Eps P)")
   apply auto
  apply (erule contrapos_np)
  by (rule someI)

lemma case_unit_unfold[nitpick_unfold]:
  "case_unit x u \<equiv> x"
  apply (subgoal_tac "u = ()")
   apply (simp only: unit.case)
  by simp

declare unit.case[nitpick_simp del]

lemma case_nat_unfold[nitpick_unfold]:
  "case_nat x f n \<equiv> if n = 0 then x else f (n - 1)"
  apply (rule eq_reflection)
  by (cases n) auto

declare nat.case[nitpick_simp del]

lemma size_list_simp[nitpick_simp]:
  "size_list f xs = (if xs = [] then 0 else Suc (f (hd xs) + size_list f (tl xs)))"
  "size xs = (if xs = [] then 0 else Suc (size (tl xs)))"
  by (cases xs) auto

text {*
Auxiliary definitions used to provide an alternative representation for
@{text rat} and @{text real}.
*}

function nat_gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nat_gcd x y = (if y = 0 then x else nat_gcd y (x mod y))"
  by auto
  termination
  apply (relation "measure (\<lambda>(x, y). x + y + (if y > x then 1 else 0))")
   apply auto
   apply (metis mod_less_divisor xt1(9))
  by (metis mod_mod_trivial mod_self nat_neq_iff xt1(10))

declare nat_gcd.simps[simp del]

definition nat_lcm :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nat_lcm x y = x * y div (nat_gcd x y)"

definition int_gcd :: "int \<Rightarrow> int \<Rightarrow> int" where
  "int_gcd x y = int (nat_gcd (nat (abs x)) (nat (abs y)))"

definition int_lcm :: "int \<Rightarrow> int \<Rightarrow> int" where
  "int_lcm x y = int (nat_lcm (nat (abs x)) (nat (abs y)))"

definition Frac :: "int \<times> int \<Rightarrow> bool" where
  "Frac \<equiv> \<lambda>(a, b). b > 0 \<and> int_gcd a b = 1"

consts
  Abs_Frac :: "int \<times> int \<Rightarrow> 'a"
  Rep_Frac :: "'a \<Rightarrow> int \<times> int"

definition zero_frac :: 'a where
  "zero_frac \<equiv> Abs_Frac (0, 1)"

definition one_frac :: 'a where
  "one_frac \<equiv> Abs_Frac (1, 1)"

definition num :: "'a \<Rightarrow> int" where
  "num \<equiv> fst o Rep_Frac"

definition denom :: "'a \<Rightarrow> int" where
  "denom \<equiv> snd o Rep_Frac"

function norm_frac :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
  "norm_frac a b =
    (if b < 0 then norm_frac (- a) (- b)
     else if a = 0 \<or> b = 0 then (0, 1)
     else let c = int_gcd a b in (a div c, b div c))"
  by pat_completeness auto
  termination by (relation "measure (\<lambda>(_, b). if b < 0 then 1 else 0)") auto

declare norm_frac.simps[simp del]

definition frac :: "int \<Rightarrow> int \<Rightarrow> 'a" where
  "frac a b \<equiv> Abs_Frac (norm_frac a b)"

definition plus_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  [nitpick_simp]: "plus_frac q r = (let d = int_lcm (denom q) (denom r) in
    frac (num q * (d div denom q) + num r * (d div denom r)) d)"

definition times_frac :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  [nitpick_simp]: "times_frac q r = frac (num q * num r) (denom q * denom r)"

definition uminus_frac :: "'a \<Rightarrow> 'a" where
  "uminus_frac q \<equiv> Abs_Frac (- num q, denom q)"

definition number_of_frac :: "int \<Rightarrow> 'a" where
  "number_of_frac n \<equiv> Abs_Frac (n, 1)"

definition inverse_frac :: "'a \<Rightarrow> 'a" where
  "inverse_frac q \<equiv> frac (denom q) (num q)"

definition less_frac :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  [nitpick_simp]: "less_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) < 0"

definition less_eq_frac :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  [nitpick_simp]: "less_eq_frac q r \<longleftrightarrow> num (plus_frac q (uminus_frac r)) \<le> 0"

definition of_frac :: "'a \<Rightarrow> 'b\<Colon>{inverse,ring_1}" where
  "of_frac q \<equiv> of_int (num q) / of_int (denom q)"

axiomatization wf_wfrec :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"

definition wf_wfrec' :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
  [nitpick_simp]: "wf_wfrec' R F x = F (cut (wf_wfrec R F) R x) x"

definition wfrec' ::  "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
  "wfrec' R F x \<equiv> if wf R then wf_wfrec' R F x else THE y. wfrec_rel R (\<lambda>f x. F (cut f R x) x) x y"

ML_file "Tools/Nitpick/kodkod.ML"
ML_file "Tools/Nitpick/kodkod_sat.ML"
ML_file "Tools/Nitpick/nitpick_util.ML"
ML_file "Tools/Nitpick/nitpick_hol.ML"
ML_file "Tools/Nitpick/nitpick_mono.ML"
ML_file "Tools/Nitpick/nitpick_preproc.ML"
ML_file "Tools/Nitpick/nitpick_scope.ML"
ML_file "Tools/Nitpick/nitpick_peephole.ML"
ML_file "Tools/Nitpick/nitpick_rep.ML"
ML_file "Tools/Nitpick/nitpick_nut.ML"
ML_file "Tools/Nitpick/nitpick_kodkod.ML"
ML_file "Tools/Nitpick/nitpick_model.ML"
ML_file "Tools/Nitpick/nitpick.ML"
ML_file "Tools/Nitpick/nitpick_commands.ML"
ML_file "Tools/Nitpick/nitpick_tests.ML"

setup {*
  Nitpick_HOL.register_ersatz_global
    [(@{const_name card}, @{const_name card'}),
     (@{const_name setsum}, @{const_name setsum'}),
     (@{const_name fold_graph}, @{const_name fold_graph'}),
     (@{const_name wf}, @{const_name wf'}),
     (@{const_name wf_wfrec}, @{const_name wf_wfrec'}),
     (@{const_name wfrec}, @{const_name wfrec'})]
*}

hide_const (open) unknown is_unknown bisim bisim_iterator_max Quot safe_The FunBox PairBox Word prod
  refl' wf' card' setsum' fold_graph' nat_gcd nat_lcm int_gcd int_lcm Frac Abs_Frac Rep_Frac
  zero_frac one_frac num denom norm_frac frac plus_frac times_frac uminus_frac number_of_frac
  inverse_frac less_frac less_eq_frac of_frac wf_wfrec wf_wfrec wfrec'

hide_type (open) bisim_iterator fun_box pair_box unsigned_bit signed_bit word

hide_fact (open) Ex1_unfold rtrancl_unfold rtranclp_unfold tranclp_unfold prod_def refl'_def wf'_def
  card'_def setsum'_def fold_graph'_def The_psimp Eps_psimp case_unit_unfold case_nat_unfold
  size_list_simp nat_gcd_def nat_lcm_def int_gcd_def int_lcm_def Frac_def zero_frac_def one_frac_def
  num_def denom_def norm_frac_def frac_def plus_frac_def times_frac_def uminus_frac_def
  number_of_frac_def inverse_frac_def less_frac_def less_eq_frac_def of_frac_def wf_wfrec'_def
  wfrec'_def

end


(* Author: Matthias Brun,   ETH Zürich, 2019 *)
(* Author: Dmitriy Traytel, ETH Zürich, 2019 *)

(*<*)
theory FMap_Lemmas
  imports "HOL-Library.Finite_Map"
          Nominal2_Lemmas
begin
(*>*)

text \<open>Nominal setup for finite maps.\<close>

abbreviation fmap_update ("_'(_ $$:= _')" [1000,0,0] 1000)  where "fmap_update \<Gamma> x \<tau> \<equiv> fmupd x \<tau> \<Gamma>"
notation fmlookup (infixl "$$" 999)
notation fmempty ("{$$}")

instantiation fmap :: (pt, pt) pt
begin

unbundle fmap.lifting

lift_definition
  permute_fmap :: "perm \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  is
  "permute :: perm \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"
proof -
  fix p and f :: "'a \<rightharpoonup> 'b"
  assume "finite (dom f)"
  then show "finite (dom (p \<bullet> f))"
  proof (rule finite_surj[of _ _ "permute p"]; unfold dom_def, safe)
    fix x y
    assume some: "(p \<bullet> f) x = Some y"
    show "x \<in> permute p ` {a. f a \<noteq> None}"
    proof (rule image_eqI[of _ _ "- p \<bullet> x"])
      from some show "- p \<bullet> x \<in> {a. f a \<noteq> None}"
        by (auto simp: permute_self pemute_minus_self
          dest: arg_cong[of _ _ "permute (- p)"] intro!: exI[of _ "- p \<bullet> y"])
    qed (simp only: permute_minus_cancel)
  qed
qed

instance
proof
  fix x :: "('a, 'b) fmap"
  show "0 \<bullet> x = x"
    by transfer simp
next
  fix p q and x :: "('a, 'b) fmap"
  show "(p + q) \<bullet> x = p \<bullet> q \<bullet> x"
    by transfer simp
qed

end

lemma fmempty_eqvt[eqvt]:
  shows "(p \<bullet> {$$}) = {$$}"
  by transfer simp

lemma fmap_update_eqvt[eqvt]:
  shows "(p \<bullet> f(a $$:= b)) = (p \<bullet> f)((p \<bullet> a) $$:= (p \<bullet> b))"
  by transfer (simp add: map_upd_def)

lemma fmap_apply_eqvt[eqvt]:
  shows "(p \<bullet> (f $$ b)) = (p \<bullet> f) $$ (p \<bullet> b)"
  by transfer simp

lemma fresh_fmempty[simp]:
  shows "a \<sharp> {$$}"
  unfolding fresh_def supp_def
  by transfer simp

lemma fresh_fmap_update:
  shows "\<lbrakk>a \<sharp> f; a \<sharp> x; a \<sharp> y\<rbrakk> \<Longrightarrow> a \<sharp> f(x $$:= y)"
  unfolding fresh_conv_MOST
  by (elim MOST_rev_mp) simp

lemma supp_fmempty[simp]:
  shows "supp {$$} = {}"
  by (simp add: supp_def)

lemma supp_fmap_update:
  shows "supp (f(x $$:= y)) \<subseteq> supp(f, x, y)"
  using fresh_fmap_update
  by (auto simp: fresh_def supp_Pair)

instance fmap :: (fs, fs) fs
proof
  fix x :: "('a, 'b) fmap"
  show "finite (supp x)"
    by (induct x rule: fmap_induct)
      (simp_all add: supp_Pair finite_supp finite_subset[OF supp_fmap_update])
qed

lemma fresh_transfer[transfer_rule]:
  "((=) ===> pcr_fmap (=) (=) ===> (=)) fresh fresh"
  unfolding fresh_def supp_def rel_fun_def pcr_fmap_def cr_fmap_def simp_thms
    option.rel_eq fun_eq_iff[symmetric]
  by (auto elim!: finite_subset[rotated] simp: fmap_ext)

lemma fmmap_eqvt[eqvt]: "p \<bullet> (fmmap f F) = fmmap (p \<bullet> f) (p \<bullet> F)"
  by (induct F arbitrary: f rule: fmap_induct) (auto simp add: fmap_update_eqvt fmmap_fmupd)

lemma fmap_freshness_lemma:
  fixes h :: "('a::at,'b::pt) fmap"
  assumes a: "\<exists>a. atom a \<sharp> (h, h $$ a)"
  shows  "\<exists>x. \<forall>a. atom a \<sharp> h \<longrightarrow> h $$ a = x"
  using assms unfolding fresh_Pair
  by transfer (simp add: fresh_Pair freshness_lemma)

lemma fmap_freshness_lemma_unique:
  fixes h :: "('a::at,'b::pt) fmap"
  assumes "\<exists>a. atom a \<sharp> (h, h $$ a)"
  shows "\<exists>!x. \<forall>a. atom a \<sharp> h \<longrightarrow> h $$ a = x"
  using assms unfolding fresh_Pair
  by transfer (rule freshness_lemma_unique, auto simp: fresh_Pair)

lemma fmdrop_fset_fmupd[simp]:
  "(fmdrop_fset A f)(x $$:= y) = fmdrop_fset (A |-| {|x|}) f(x $$:= y)"
  including fmap.lifting fset.lifting
  by transfer (auto simp: map_drop_set_def map_upd_def map_filter_def)

lemma fresh_fset_fminus:
  assumes "atom x \<sharp> A"
  shows   "A |-| {|x|} = A"
  using assms by (induct A) (simp_all add: finsert_fminus_if fresh_finsert)

lemma fresh_fun_app:
  shows "atom x \<sharp> F \<Longrightarrow> x \<noteq> y \<Longrightarrow> F y = Some a \<Longrightarrow> atom x \<sharp> a"
  using supp_fun_app[of F y]
  by (auto simp: fresh_def supp_Some atom_not_fresh_eq)

lemma fresh_fmap_fresh_Some:
  "atom x \<sharp> F \<Longrightarrow> x \<noteq> y \<Longrightarrow> F $$ y = Some a \<Longrightarrow> atom x \<sharp> a"
  including fmap.lifting
  by (transfer) (auto elim: fresh_fun_app)

lemma fmdrop_eqvt: "p \<bullet> fmdrop x F = fmdrop (p \<bullet> x) (p \<bullet> F)"
  by transfer (auto simp: map_drop_def map_filter_def)

lemma fmfilter_eqvt: "p \<bullet> fmfilter Q F = fmfilter (p \<bullet> Q) (p \<bullet> F)"
  by transfer (auto simp: map_filter_def)

lemma fmdrop_eq_iff:
  "fmdrop x B = fmdrop y B \<longleftrightarrow> x = y \<or> (x \<notin> fmdom' B \<and> y \<notin> fmdom' B)"
  by transfer (auto simp: map_drop_def map_filter_def fun_eq_iff, metis)

lemma fresh_fun_upd:
  shows "\<lbrakk>a \<sharp> f; a \<sharp> x; a \<sharp> y\<rbrakk> \<Longrightarrow> a \<sharp> f(x := y)"
  unfolding fresh_conv_MOST by (elim MOST_rev_mp) simp

lemma supp_fun_upd:
  shows "supp (f(x := y)) \<subseteq> supp(f, x, y)"
  using fresh_fun_upd by (auto simp: fresh_def supp_Pair)

lemma map_drop_fun_upd: "map_drop x F = F(x := None)"
  unfolding map_drop_def map_filter_def by auto

lemma fresh_fmdrop_in_fmdom: "\<lbrakk> x \<in> fmdom' B; y \<sharp> B; y \<sharp> x \<rbrakk> \<Longrightarrow> y \<sharp> fmdrop x B"
  by transfer (auto simp: map_drop_fun_upd fresh_None intro!: fresh_fun_upd)

lemma fresh_fmdrop:
  assumes "x \<sharp> B" "x \<sharp> y"
  shows   "x \<sharp> fmdrop y B"
  using assms by (cases "y \<in> fmdom' B") (auto dest!: fresh_fmdrop_in_fmdom simp: fmdrop_idle')

lemma fresh_fmdrop_fset:
  fixes x :: atom and A :: "(_ :: at_base) fset"
  assumes "x \<sharp> A" "x \<sharp> B"
  shows   "x \<sharp> fmdrop_fset A B"
  using assms(1) by (induct A) (auto simp: fresh_fmdrop assms(2) fresh_finsert)

(*<*)
end
(*>*)


section \<open>Exception-Aware Relational Framework\<close>
theory Run
imports "HOL-Imperative_HOL.Imperative_HOL"
begin

  text \<open>
    With Imperative HOL comes a relational framework.
    However, this can only be used if exception freeness is already assumed.
    This results in some proof duplication, because exception freeness and
    correctness need to be shown separately.

    In this theory, we develop a relational framework that is aware of
    exceptions, and makes it possible to show correctness and exception
    freeness in one run.
\<close>

  text \<open>
    There are two types of states:
    \begin{enumerate}
      \item A normal (Some) state contains the current heap.
      \item An exception state is None
    \end{enumerate}
    The two states exactly correspond to the option monad in Imperative HOL.
\<close>

type_synonym state = "Heap.heap option"

primrec is_exn where
  "is_exn (Some _) = False" |
  "is_exn None = True"

primrec the_state where
  "the_state (Some h) = h"

\<comment> \<open>The exception-aware, relational semantics\<close>

inductive run :: "'a Heap \<Rightarrow> state \<Rightarrow> state \<Rightarrow> 'a \<Rightarrow> bool" where
  push_exn: "is_exn \<sigma> \<Longrightarrow> run c \<sigma> \<sigma> r " |
  new_exn:  "\<lbrakk>\<not> is_exn \<sigma>; execute c (the_state \<sigma>) = None\<rbrakk>
    \<Longrightarrow> run c \<sigma> None r" |
  regular:  "\<lbrakk>\<not> is_exn \<sigma>; execute c (the_state \<sigma>) = Some (r, h')\<rbrakk>
    \<Longrightarrow> run c \<sigma> (Some h') r"

subsubsection "Link with \<open>effect\<close> and \<open>success\<close>"

lemma run_effectE:
  assumes "run c \<sigma> \<sigma>' r"
  assumes "\<not>is_exn \<sigma>'"
  obtains h h' where
    "\<sigma>=Some h" "\<sigma>' = Some h'"
    "effect c h h' r"
  using assms
  unfolding effect_def
  apply (cases \<sigma>)
  by (auto simp add: run.simps)

lemma run_effectI:
  assumes  "run c (Some h) (Some h') r"
  shows  "effect c h h' r"
  using run_effectE[OF assms] by auto

lemma effect_run:
  assumes "effect c h h' r"
  shows "run c (Some h) (Some h') r"
  using assms
  unfolding effect_def
  by (auto intro: run.intros)

lemma success_run:
  assumes "success f h"
  obtains h' r where "run f (Some h) (Some h') r"
proof -
  from assms obtain r h'
    where "Heap_Monad.execute f h = Some (r, h')"
    unfolding success_def by auto
  then show thesis by (rule that[OF regular[of "Some h", simplified]])
qed

text \<open>run always yields a result\<close>
lemma run_complete:
  obtains \<sigma>' r where "run c \<sigma> \<sigma>' r"
  apply (cases "is_exn \<sigma>")
  apply (auto intro: run.intros)
  apply (cases "execute c (the_state \<sigma>)")
  by (auto intro: run.intros)

lemma run_detE:
  assumes "run c \<sigma> \<sigma>' r" "run c \<sigma> \<tau> s"
          "\<not>is_exn \<sigma>"
  obtains "is_exn \<sigma>'" "\<sigma>' = \<tau>" | "\<not> is_exn \<sigma>'" "\<sigma>' = \<tau>" "r = s"
  using assms
  by (auto simp add: run.simps)

lemma run_detI:
  assumes "run c (Some h) (Some h') r" "run c (Some h) \<sigma> s"
  shows "\<sigma> = Some h' \<and> r = s"
  using assms
  by (auto simp add: run.simps)

subsubsection \<open>Elimination Rules for Basic Combinators\<close>

named_theorems run_elims "elemination rules for run"

lemma runE[run_elims]:
  assumes "run (f \<bind> g) \<sigma> \<sigma>'' r"
  obtains \<sigma>' r' where
    "run f \<sigma> \<sigma>' r'"
    "run (g r') \<sigma>' \<sigma>'' r"
using assms
apply (cases "is_exn \<sigma>")
apply (simp add: run.simps)
apply (cases "execute f (the_state \<sigma>)")
apply (simp add: run.simps bind_def)
by (auto simp add: bind_def run.simps)

lemma runE'[run_elims]:
  assumes "run (f \<then> g) \<sigma> \<sigma>'' res"
  obtains \<sigma>t rt where
    "run f \<sigma> \<sigma>t rt"
    "run g \<sigma>t \<sigma>'' res"
  using assms
  by (rule_tac runE)

lemma run_return[run_elims]:
  assumes "run (return x) \<sigma> \<sigma>' r"
  obtains "r = x" "\<sigma>' = \<sigma>" "\<not> is_exn \<sigma>" | "\<sigma> = None"
  using assms  apply (cases \<sigma>) apply (simp add: run.simps)
  by (auto simp add: run.simps execute_simps)

lemma run_raise_iff: "run (raise s) \<sigma> \<sigma>' r \<longleftrightarrow> (\<sigma>'=None)"
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

lemma run_raise[run_elims]:
  assumes "run (raise s) \<sigma> \<sigma>' r"
  obtains "\<sigma>' = None"
  using assms by (simp add: run_raise_iff)

lemma run_raiseI:
  "run (raise s) \<sigma> None r" by (simp add: run_raise_iff)

lemma run_if[run_elims]:
  assumes "run (if c then t else e) h h' r"
  obtains "c" "run t h h' r"
        | "\<not>c" "run e h h' r"
  using assms
  by (auto split: if_split_asm)

lemma run_case_option[run_elims]:
  assumes "run (case x of None \<Rightarrow> n | Some y \<Rightarrow> s y) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "x = None" "run n \<sigma> \<sigma>' r"
        | y where "x = Some y" "run (s y) \<sigma> \<sigma>' r"
  using assms
  by (cases x) simp_all

lemma run_heap[run_elims]:
  assumes "run (Heap_Monad.heap f) \<sigma> \<sigma>' res"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (f (the_state \<sigma>)))"
  and "res = (fst (f (the_state \<sigma>)))"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)

  apply (simp only: execute_simps)
  apply hypsubst_thin
  subgoal premises prems for a h'
  proof -
    from prems(2) have "h' = snd (f a)" "res = fst (f a)" by simp_all
    from prems(1)[OF this] show ?thesis .
  qed
  done

subsection \<open>Array Commands\<close>

lemma run_length[run_elims]:
  assumes "run (Array.len a) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<not>is_exn \<sigma>" "\<sigma>' = \<sigma>" "r = Array.length (the_state \<sigma>) a"
  using assms
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

lemma run_new_array[run_elims]:
  assumes "run (Array.new n x) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (Array.alloc (replicate n x) (the_state \<sigma>)))"
  and "r = fst (Array.alloc (replicate n x) (the_state \<sigma>))"
  and "Array.get (the_state \<sigma>') r = replicate n x"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)
  apply (simp add: Array.get_alloc)
  apply hypsubst_thin
  subgoal premises prems for a h'
  proof -
    from prems(2) have "h' = snd (Array.alloc (replicate n x) a)"
      "r = fst (Array.alloc (replicate n x) a)" by (auto simp add: execute_simps)
    then show ?thesis by (rule prems(1))
  qed
  done

lemma run_make[run_elims]:
  assumes "run (Array.make n f) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (Array.alloc (map f [0 ..< n]) (the_state \<sigma>)))"
          "r = fst (Array.alloc (map f [0 ..< n]) (the_state \<sigma>))"
          "Array.get (the_state \<sigma>') r = (map f [0 ..< n])"
  using assms
  apply (cases \<sigma>)
  subgoal by simp
  subgoal by (simp add: run.simps execute_simps Array.get_alloc; fastforce)
  done

lemma run_upd[run_elims]:
  assumes "run (Array.upd i x a) \<sigma> \<sigma>' res"
          "\<not>is_exn \<sigma>"
  obtains "\<not> i < Array.length (the_state \<sigma>) a"
          "\<sigma>' = None"
  |
          "i < Array.length (the_state \<sigma>) a"
          "\<sigma>' = Some (Array.update a i x (the_state \<sigma>))"
          "res = a"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (cases "i < Array.length (the_state \<sigma>) a")
  apply (auto simp add: run.simps)
  apply (simp_all only: execute_simps)
  prefer 3
  apply auto[2]
  apply hypsubst_thin
  subgoal premises prems for aa h'
  proof -
    from prems(3) have "h' = Array.update a i x aa" "res = a" by auto
    then show ?thesis by (rule prems(1))
  qed
  done

lemma run_nth[run_elims]:
  assumes "run (Array.nth a i) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<not>is_exn \<sigma>"
    "i < Array.length (the_state \<sigma>) a"
    "r = (Array.get (the_state \<sigma>) a) ! i"
    "\<sigma>' = \<sigma>"
  |
    "\<not> i < Array.length (the_state \<sigma>) a"
    "\<sigma>' = None"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (cases "i < Array.length (the_state \<sigma>) a")
  apply (auto simp add: run.simps)
  apply (simp_all only: execute_simps)
  prefer 3
  apply auto[2]
  apply hypsubst_thin
  subgoal premises prems for aa h'
  proof -
    from prems(3) have "r = Array.get aa a ! i" "h' = aa" by auto
    then show ?thesis by (rule prems(1))
  qed
  done

lemma run_of_list[run_elims]:
  assumes "run (Array.of_list xs) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (Array.alloc xs (the_state \<sigma>)))"
          "r = fst (Array.alloc xs (the_state \<sigma>))"
          "Array.get (the_state \<sigma>') r = xs"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)
  apply (simp add: Array.get_alloc)
  apply hypsubst_thin
  subgoal premises prems for a h'
  proof -
    from prems(2) have "h' = snd (Array.alloc xs a)"
      "r = fst (Array.alloc xs a)" by (auto simp add: execute_simps)
    then show ?thesis by (rule prems(1))
  qed
  done

lemma run_freeze[run_elims]:
  assumes "run (Array.freeze a) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = \<sigma>"
          "r = Array.get (the_state \<sigma>) a"
  using assms
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

subsection \<open>Reference Commands\<close>

lemma run_new_ref[run_elims]:
  assumes "run (ref x) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (snd (Ref.alloc x (the_state \<sigma>)))"
          "r = fst (Ref.alloc x (the_state \<sigma>))"
          "Ref.get (the_state \<sigma>') r = x"
  using assms
  apply (cases \<sigma>)
  apply simp
  apply (auto simp add: run.simps)
  apply (simp add: execute_simps)
  apply hypsubst_thin
  subgoal premises prems for a h'
  proof -
    from prems(2) have
      "h' = snd (Ref.alloc x a)"
      "r = fst (Ref.alloc x a)"
      by (auto simp add: execute_simps)
    then show ?thesis by (rule prems(1))
  qed
  done

lemma "fst (Ref.alloc x h) = Ref (lim h)"
  unfolding alloc_def
  by (simp add: Let_def)

lemma run_update[run_elims]:
  assumes "run (p := x) \<sigma> \<sigma>' r"
          "\<not>is_exn \<sigma>"
  obtains "\<sigma>' = Some (Ref.set p x (the_state \<sigma>))" "r = ()"
  using assms
  unfolding Ref.update_def
  by (auto elim: run_heap)

lemma run_lookup[run_elims]:
  assumes "run (!p) \<sigma> \<sigma>' r"
          "\<not> is_exn \<sigma>"
  obtains "\<not>is_exn \<sigma>" "\<sigma>' = \<sigma>" "r = Ref.get (the_state \<sigma>) p"
  using assms
  apply (cases \<sigma>)
  by (auto simp add: run.simps execute_simps)

end


section \<open>Foundations\<close>

theory "Thorn_Calculus-Foundations"
imports
  Main
  "HOL-Library.Stream"
begin

(* FIXME: Document the following at an appropriate place:

    \<^item> We use families for channels, because we need transitions to be homogeneous in channels. On
      the other hand, transitions must be able to be inhomogeneous in values in order to allow for
      computation, and thus we do not use families for values.

    \<^item> Environments are the HOAS-equivalent of assignments of channels to names. Families are then
      the HOAS analog of processes with free channel names.

    \<^item> The name introduced by a \<open>\<nu>\<close>-binder corresponds to the first element of an environment. All
      previous elements are shifted forward by one index. Thus the indexes of the elements of an
      environment correspond to the de~Bruijn indexes of the names.

    \<^item> We define environments as infinite lists, because we cannot track the lengths of finite
      channel lists using the type system, as Isabelle/HOL does not support dependent types nor
      heterogeneous inductive predicates (which would require higher-rank polymorphism). In
      practice we always deal with families that only depend on a finite prefix of the environment,
      but all the meta-theory works out without imposing such a restriction.
*)

(* FIXME:
  Maybe we should not have the policy of proving only those lemmas that we use later or which are of
  obvious use for other sessions. In particular, it might be good to include lemmas that are
  analogous to existing lemmas, like \<open>\<Delta>\<close>-counterparts of \<open>\<nabla>\<close>-lemmas or counterparts of process
  constructor lemmas for different process constructors.
*)

subsection \<open>Channels and Values\<close>

typedecl chan

axiomatization where
  more_than_one_chan:
    "\<exists>a b :: chan. a \<noteq> b"

typedecl val

subsection \<open>Environments\<close>

type_synonym environment = "chan stream"

text \<open>
  Regarding the naming, note that \<^const>\<open>insert\<close> is already taken. For adaptations, we do not use
  the \<open>_at\<close> suffix and thus have \<open>remove\<close> as the equivalent of \<open>delete_at\<close>.
\<close>

definition insert_at :: "nat \<Rightarrow> chan \<Rightarrow> environment \<Rightarrow> environment" where
  [simp]: "insert_at i a e = stake i e @- a ## sdrop i e"

definition delete_at :: "nat \<Rightarrow> environment \<Rightarrow> environment" where
  [simp]: "delete_at i e = stake i e @- sdrop (Suc i) e"

lemma insert_at_after_delete_at:
  shows "insert_at i (e !! i) (delete_at i e) = e"
  by (simp del: sdrop.simps(2) add: stake_shift sdrop_shift id_stake_snth_sdrop [symmetric])

lemma delete_at_after_insert_at:
  shows "delete_at i (insert_at i a e) = e"
  by (simp add: stake_append sdrop_shift stake_sdrop)

subsection \<open>Families\<close>

type_synonym 'a family = "environment \<Rightarrow> 'a"

definition constant_family :: "'a \<Rightarrow> 'a family" (\<open>\<box>\<close>) where
  [simp]: "\<box> v = (\<lambda>_. v)"

subsection \<open>Adaptations\<close>

typedef adaptation = "{E :: environment \<Rightarrow> environment. surj E}"
  by auto

text \<open>
  Surjectivity is needed for the following:

    \<^item> \<^theory_text>\<open>adapted_injectivity\<close>, used here:

        \<^item> Pre-simplification in proofs with concrete process families (well, the adaptations used in
          the transition system \<^emph>\<open>are\<close> surjective; the above surjectivity requirement just kind of
          centralizes the handling of the surjectivity of all of them

        \<^item> Handling of the ``non-constant'' requirement of the \<^theory_text>\<open>opening\<close> rule in that lemma on
          equivalence of transitions with transitions containing adaption

    \<^item> Deriving of the backward implication from the forward implication in the above-mentioned
      lemma
\<close>
(* FIXME: Check if there are more. *)

notation Rep_adaptation (\<open>(\<lfloor>_\<rfloor>)\<close>)

setup_lifting type_definition_adaptation

lift_definition adaptation_identity :: adaptation (\<open>\<one>\<close>)
  is id
  using surj_id .

lift_definition adaptation_composition :: "adaptation \<Rightarrow> adaptation \<Rightarrow> adaptation" (infixl "\<bullet>" 55)
  is "(\<circ>)"
  using comp_surj .

lemma adaptation_composition_associativity:
  shows "(\<E> \<bullet> \<D>) \<bullet> \<C> = \<E> \<bullet> (\<D> \<bullet> \<C>)"
  by transfer (rule comp_assoc)

lemma adaptation_composition_left_identity:
  shows "\<one> \<bullet> \<E> = \<E>"
  by transfer simp

lemma adaptation_composition_right_identity:
  shows "\<E> \<bullet> \<one> = \<E>"
  by transfer simp

lift_definition adapted :: "'a family \<Rightarrow> adaptation \<Rightarrow> 'a family" (infixl "\<guillemotleft>" 55)
  is "(\<circ>)" .

lemma identity_adapted:
  shows "V \<guillemotleft> \<one> = V"
  by transfer simp

lemma composition_adapted:
  shows "V \<guillemotleft> (\<E> \<bullet> \<D>) = V \<guillemotleft> \<E> \<guillemotleft> \<D>"
  by transfer (simp add: comp_assoc)

lemma adapted_undo:
  shows "V \<guillemotleft> \<E> \<circ> inv \<lfloor>\<E>\<rfloor> = V"
  by transfer (simp add: comp_assoc surj_iff)

text \<open>
  The following is not just a pre-simplification rules but a very important law, used as a
  simplification rule in several places. See above for the arguments in favor of surjectivity.
\<close>

lemma adapted_injectivity [induct_simp, iff]:
  shows "V \<guillemotleft> \<E> = W \<guillemotleft> \<E> \<longleftrightarrow> V = W"
proof
  assume "V \<guillemotleft> \<E> = W \<guillemotleft> \<E>"
  then have "V \<guillemotleft> \<E> \<circ> inv \<lfloor>\<E>\<rfloor> = W \<guillemotleft> \<E> \<circ> inv \<lfloor>\<E>\<rfloor>"
    by simp
  then show "V = W"
    unfolding adapted_undo .
next
  assume "V = W"
  then show "V \<guillemotleft> \<E> = W \<guillemotleft> \<E>"
    by simp
qed

subsubsection \<open>Injective Adaptations\<close>

lift_definition injective :: "adaptation \<Rightarrow> bool"
  is inj .

lemma injective_introduction:
  assumes "\<D> \<bullet> \<E> = \<one>"
  shows "injective \<E>"
  using assms
  by transfer (metis inj_on_id inj_on_imageI2)

text \<open>
  The following elimination rule captures two important properties:

    \<^item> The left inverse of an injective adaptation is surjective and thus and adaptation itself.

    \<^item> The left inverse of an injective adaptation is also a right inverse.
\<close>

lemma injective_elimination:
  assumes "injective \<E>"
  obtains \<D> where "\<D> \<bullet> \<E> = \<one>" and "\<E> \<bullet> \<D> = \<one>"
proof -
  from \<open>injective \<E>\<close> have "bijection \<lfloor>\<E>\<rfloor>"
    unfolding bijection_def
    by transfer (rule bijI)
  then have "surj (inv \<lfloor>\<E>\<rfloor>)" and "inv \<lfloor>\<E>\<rfloor> \<circ> \<lfloor>\<E>\<rfloor> = id" and "\<lfloor>\<E>\<rfloor> \<circ> inv \<lfloor>\<E>\<rfloor> = id"
    by (fact bijection.surj_inv, fact bijection.inv_comp_left, fact bijection.inv_comp_right)
  with that show ?thesis
    by transfer simp
qed

lemma identity_is_injective:
  shows "injective \<one>"
  by transfer simp

lemma composition_is_injective:
  assumes "injective \<E>" and "injective \<D>"
  shows "injective (\<E> \<bullet> \<D>)"
  using assms
  by transfer (rule inj_compose)

subsubsection \<open>Working with Suffixes\<close>

lift_definition suffix :: "nat \<Rightarrow> adaptation"
  is sdrop
proof (rule surjI)
  fix n and e'
  show "sdrop n (replicate n undefined @- e') = e'"
    by (simp add: sdrop_shift)
qed

definition tail :: adaptation where
  [simp]: "tail = suffix 1"

lift_definition on_suffix :: "nat \<Rightarrow> adaptation \<Rightarrow> adaptation"
  is "\<lambda>n E. \<lambda>e. stake n e @- E (sdrop n e)"
proof (rule surjI)
  fix n and E :: "environment \<Rightarrow> environment" and e'
  assume "surj E"
  then show "(\<lambda>e. stake n e @- E (sdrop n e)) (stake n e' @- inv E (sdrop n e')) = e'"
    by (simp add: stake_shift sdrop_shift surj_f_inv_f stake_sdrop)
qed

definition on_tail :: "adaptation \<Rightarrow> adaptation" where
  [simp]: "on_tail = on_suffix 1"

lemma identity_as_on_suffix:
  shows "\<one> = on_suffix n \<one>"
  by transfer (auto simp add: stake_sdrop)

lemma composition_as_on_suffix:
  shows "on_suffix n \<E> \<bullet> on_suffix n \<D> = on_suffix n (\<E> \<bullet> \<D>)"
  by transfer (simp add: comp_def stake_shift sdrop_shift)

lemma identity_as_partial_on_suffix:
  shows "id = on_suffix 0"
  by (rule ext, transfer) simp

lemma composition_as_partial_on_suffix:
  shows "on_suffix n \<circ> on_suffix m = on_suffix (n + m)"
  by (rule ext, transfer) (simp del: shift_append add: shift_append [symmetric])

lemma on_suffix_is_injective:
  assumes "injective \<E>"
  shows "injective (on_suffix n \<E>)"
proof -
  from \<open>injective \<E>\<close> obtain \<D> where "\<D> \<bullet> \<E> = \<one>"
    by (blast elim: injective_elimination)
  have "on_suffix n \<D> \<bullet> on_suffix n \<E> = on_suffix n (\<D> \<bullet> \<E>)"
    by transfer (simp add: comp_def stake_shift sdrop_shift)
  also have "\<dots> = on_suffix n \<one>"
    using \<open>\<D> \<bullet> \<E> = \<one>\<close>
    by simp
  also have "\<dots> = \<one>"
    using identity_as_on_suffix [symmetric] .
  finally show ?thesis
    by (fact injective_introduction)
qed

lemma suffix_after_on_suffix:
  shows "suffix n \<bullet> on_suffix n \<E> = \<E> \<bullet> suffix n"
  by transfer (simp add: comp_def sdrop_shift)

lemma suffix_adapted_and_on_suffix_adapted:
  assumes "V' \<guillemotleft> suffix n = W \<guillemotleft> on_suffix n \<E>"
  obtains V where "V' = V \<guillemotleft> \<E>" and "W = V \<guillemotleft> suffix n"
proof -
  have V'_definition: "V' = W \<circ> (\<lambda>e. replicate n undefined @- e) \<guillemotleft> \<E>"
  proof -
    have "V' = V' \<guillemotleft> suffix n \<circ> (\<lambda>e. replicate n undefined @- e)"
      by transfer (simp add: comp_def sdrop_shift)
    also have "\<dots> = W \<guillemotleft> on_suffix n \<E> \<circ> (\<lambda>e. replicate n undefined @- e)"
      by (simp only: assms)
    also have "\<dots> = W \<circ> (\<lambda>e. replicate n undefined @- e) \<guillemotleft> \<E>"
      by transfer (simp add: comp_def stake_shift sdrop_shift)
    finally show ?thesis.
  qed
  moreover
  have "W = W \<circ> (\<lambda>e. replicate n undefined @- e) \<guillemotleft> suffix n"
  proof -
    have "
      W \<circ> (\<lambda>e. replicate n undefined @- e) \<guillemotleft> suffix n \<guillemotleft> on_suffix n \<E>
      =
      W \<circ> (\<lambda>e. replicate n undefined @- e) \<guillemotleft> \<E> \<guillemotleft> suffix n"
      by transfer (simp_all add: comp_def sdrop_shift)
    also have "\<dots> = W \<guillemotleft> on_suffix n \<E>"
      using assms unfolding V'_definition .
    finally show ?thesis
      by simp
  qed
  ultimately show ?thesis
    using that
    by blast
qed

subsubsection \<open>Working with Elements\<close>

lift_definition remove :: "nat \<Rightarrow> adaptation"
  is delete_at
proof (rule surjI)
  fix n and e'
  show "delete_at n (insert_at n undefined e') = e'"
    using delete_at_after_insert_at .
qed

lift_definition move :: "nat \<Rightarrow> nat \<Rightarrow> adaptation"
  is "\<lambda>i j. \<lambda>e. insert_at j (e !! i) (delete_at i e)"
proof (rule surjI)
  fix i and j and e'
  show "(\<lambda>e. insert_at j (e !! i) (delete_at i e)) (insert_at i (e' !! j) (delete_at j e')) = e'"
    \<comment> \<open>This is essentially the statement of \<^theory_text>\<open>back_and_forth_moves\<close> below.\<close>
    using delete_at_after_insert_at and insert_at_after_delete_at
    by simp
qed

lemma identity_as_move:
  shows "\<one> = move i i"
  using insert_at_after_delete_at
  by transfer (simp add: id_def)

lemma composition_as_move:
  shows "move j k \<bullet> move i j = move i k"
  using delete_at_after_insert_at
  by transfer auto

lemma back_and_forth_moves:
  shows "move j i \<bullet> move i j = \<one>"
  using composition_as_move and identity_as_move [symmetric]
  by simp

lemma move_is_injective:
  shows "injective (move i j)"
  using back_and_forth_moves
  by (rule injective_introduction)

lemma on_suffix_remove:
  shows "on_suffix n (remove i) = remove (n + i)"
  by transfer (auto simp del: shift_append simp add: shift_append [symmetric])

lemma on_suffix_move:
  shows "on_suffix n (move i j) = move (n + i) (n + j)"
  by
    transfer
    (simp
      del: stake_add sdrop_add
      add: stake_add [symmetric] sdrop_add [symmetric] stake_shift sdrop_shift sdrop_snth
    )

lemma remove_after_suffix:
  shows "remove i \<bullet> suffix n = suffix n \<bullet> remove (n + i)"
  by transfer (simp add: comp_def sdrop_shift drop_stake)

lemma move_after_suffix:
  shows "move i j \<bullet> suffix n = suffix n \<bullet> move (n + i) (n + j)"
  by
    (transfer fixing: i j, cases "i < j")
    (simp_all
      add: comp_def stake_shift sdrop_shift take_stake drop_stake min_absorb2 min_absorb1 sdrop_snth
    )

lemma suffix_after_remove:
  assumes "i \<le> n"
  shows "suffix n \<bullet> remove i = suffix (Suc n)"
  using assms
  by transfer (auto simp add: sdrop_shift)

context begin

private lemma suffix_after_move_away_from_front:
  assumes "i \<le> j" and "j < n"
  shows "suffix n \<bullet> move i j = suffix n"
proof -
  from \<open>j < n\<close> obtain m where "n = Suc m" and "j \<le> m"
    by (auto elim: lessE)
  from \<open>i \<le> j\<close> and \<open>j \<le> m\<close> show ?thesis
    unfolding \<open>n = Suc m\<close>
    by transfer (auto simp add: sdrop_shift Suc_diff_le)
qed

lemma suffix_after_move:
  assumes "i < n" and "j < n"
  shows "suffix n \<bullet> move i j = suffix n"
proof (cases "i \<le> j")
  case True
  with \<open>j < n\<close> show ?thesis
    by (intro suffix_after_move_away_from_front)
next
  case False
  with \<open>i < n\<close> have "suffix n \<bullet> move i j = (suffix n \<bullet> move j i) \<bullet> move i j"
    by (simp only: suffix_after_move_away_from_front)
  also have "\<dots> = suffix n"
    by
      (simp only:
        adaptation_composition_associativity
        back_and_forth_moves
        adaptation_composition_right_identity
      )
  finally show ?thesis .
qed

end

lemma remove_after_on_suffix:
  assumes "i \<le> n"
  shows "remove i \<bullet> on_suffix (Suc n) \<E> = on_suffix n \<E> \<bullet> remove i"
  using assms
  by
    transfer
    (simp
      del: stake.simps(2)
      add: comp_def stake_shift sdrop_shift take_stake drop_stake min_absorb1 min_absorb2
    )

context begin

private definition finite_insert_at :: "nat \<Rightarrow> chan \<Rightarrow> chan list \<Rightarrow> chan list" where
  [simp]: "finite_insert_at i a e = take i e @ a # drop i e"

private definition finite_delete_at :: "nat \<Rightarrow> chan list \<Rightarrow> chan list" where
  [simp]: "finite_delete_at i e = take i e @ drop (Suc i) e"

lemma move_after_on_suffix:
  assumes "i < n" and "j < n"
  shows "move i j \<bullet> on_suffix n \<E> = on_suffix n \<E> \<bullet> move i j"
proof -
  have "
    (\<lambda>e'. insert_at j (e' !! i) (delete_at i e')) (stake n e @- E (sdrop n e)) =
    (\<lambda>e'. stake n e' @- E (sdrop n e')) (insert_at j (e !! i) (delete_at i e))"
    (is "?e\<^sub>1 = ?e\<^sub>2")
    for E and e
  proof -
    \<comment> \<open>Turn \<^term>\<open>e' !! i\<close> into \<^term>\<open>e !! i\<close>:\<close>
    have "?e\<^sub>1 = insert_at j (e !! i) (delete_at i (stake n e @- E (sdrop n e)))"
      using \<open>i < n\<close>
      by simp
    \<comment> \<open>Push deletion and insertion into the prefix argument of \<^term>\<open>(@-)\<close>:\<close>
    also have "\<dots> = insert_at j (e !! i) (finite_delete_at i (stake n e) @- E (sdrop n e))"
      using \<open>i < n\<close>
      by (simp add: stake_shift sdrop_shift)
    also have "\<dots> = finite_insert_at j (e !! i) (finite_delete_at i (stake n e)) @- E (sdrop n e)"
      using \<open>j < n\<close>
      by (simp add: stake_shift sdrop_shift)
    \<comment> \<open>Push deletion and insertion into the stream argument of \<^const>\<open>stake\<close>:\<close>
    also note stake_push_rules = take_stake drop_stake stake_shift min_absorb1 min_absorb2
    have "\<dots> = finite_insert_at j (e !! i) (stake (n - 1) (delete_at i e)) @- E (sdrop n e)"
      using \<open>i < n\<close>
      by (simp add: stake_push_rules)
    also have "\<dots> = stake n (insert_at j (e !! i) (delete_at i e)) @- E (sdrop n e)"
      using \<open>j < n\<close>
      by (simp del: delete_at_def add: stake_push_rules Suc_diff_Suc [symmetric])
    \<comment> \<open>Turn \<^term>\<open>sdrop n e\<close> into \<^term>\<open>sdrop n e'\<close>:\<close>
    also have "\<dots> =
      stake n (insert_at j (e !! i) (delete_at i e)) @- E (sdrop (n - 1) (delete_at i e))"
      using \<open>i < n\<close>
      by (simp del: sdrop.simps(2) add: sdrop_shift drop_stake)
    also have "\<dots> = ?e\<^sub>2"
      using \<open>j < n\<close>
      by (simp del: delete_at_def add: sdrop_shift drop_stake Suc_diff_Suc [symmetric])
    \<comment> \<open>Put everything together:\<close>
    finally show ?thesis .
  qed
  then show ?thesis
    by transfer auto
qed

end

lemma move_adapted_and_on_suffix_adapted:
  assumes "i < n" and "j < n" and "V' \<guillemotleft> move i j = W \<guillemotleft> on_suffix n \<E>"
  obtains V where "V' = V \<guillemotleft> on_suffix n \<E>" and "W = V \<guillemotleft> move i j"
proof -
  have "V' = W \<guillemotleft> move j i \<guillemotleft> on_suffix n \<E>"
  proof -
    have "V' = V' \<guillemotleft> move i j \<guillemotleft> move j i"
      by (simp only: composition_adapted [symmetric] back_and_forth_moves identity_adapted)
    also have "\<dots> = W \<guillemotleft> on_suffix n \<E> \<guillemotleft> move j i"
      using \<open>V' \<guillemotleft> move i j = W \<guillemotleft> on_suffix n \<E>\<close>
      by simp
    also have "\<dots> = W \<guillemotleft> move j i \<guillemotleft> on_suffix n \<E>"
      using \<open>i < n\<close> and \<open>j < n\<close>
      by (simp only: composition_adapted [symmetric] move_after_on_suffix)
    finally show ?thesis .
  qed
  moreover have "W = W \<guillemotleft> move j i \<guillemotleft> move i j"
    by (simp only: composition_adapted [symmetric] back_and_forth_moves identity_adapted)
  ultimately show ?thesis
    using that
    by blast
qed

lemma remove_adapted_and_on_suffix_adapted:
  assumes "i \<le> n" and "V' \<guillemotleft> remove i = W \<guillemotleft> on_suffix (Suc n) \<E>"
  obtains V where "V' = V \<guillemotleft> on_suffix n \<E>" and "W = V \<guillemotleft> remove i"
proof -
  from assms(2) have "V' \<guillemotleft> tail \<guillemotleft> move i 0 = W \<guillemotleft> on_suffix (Suc n) \<E>"
    unfolding tail_def
    by transfer (simp add: comp_def)
  then obtain V'' where "V' \<guillemotleft> tail = V'' \<guillemotleft> on_suffix (Suc n) \<E>" and "W = V'' \<guillemotleft> move i 0"
    using move_adapted_and_on_suffix_adapted [OF le_imp_less_Suc [OF \<open>i \<le> n\<close>]]
    by blast
  from this(1) have "V' \<guillemotleft> tail = V'' \<guillemotleft> on_tail (on_suffix n \<E>)"
    using composition_as_partial_on_suffix [THEN fun_cong]
    by simp
  then obtain V where "V' = V \<guillemotleft> on_suffix n \<E>" and "V'' = V \<guillemotleft> tail"
    unfolding tail_def and on_tail_def
    using suffix_adapted_and_on_suffix_adapted
    by blast
  from \<open>W = V'' \<guillemotleft> move i 0\<close> and \<open>V'' = V \<guillemotleft> tail\<close> have "W = V \<guillemotleft> remove i"
    unfolding tail_def
    by transfer (simp add: comp_def)
  with that and \<open>V' = V \<guillemotleft> on_suffix n \<E>\<close> show ?thesis .
qed

lemma remove_after_move:
  shows "remove j \<bullet> move i j = remove i"
  using delete_at_after_insert_at
  by transfer auto

lemma move_after_backyard_remove:
  assumes "j < i" and "k < i"
  shows "move j k \<bullet> remove i = remove i \<bullet> move j k"
proof -
  have "move j k \<bullet> remove i = move j k \<bullet> on_suffix i (remove 0)"
    by (simp add: on_suffix_remove)
  also have "\<dots> = on_suffix i (remove 0) \<bullet> move j k"
    using assms
    by (simp only: move_after_on_suffix)
  also have "\<dots> = remove i \<bullet> move j k"
    by (simp add: on_suffix_remove)
  finally show ?thesis .
qed

lemma move_after_backyard_move:
  assumes "k < i" and "k < j" and "l < i" and "l < j"
  shows "move k l \<bullet> move i j = move i j \<bullet> move k l"
proof -
  have "move k l \<bullet> move i j = move k l \<bullet> on_suffix (min i j) (move (i - min i j) (j - min i j))"
    by (simp add: on_suffix_move)
  also have "\<dots> = on_suffix (min i j) (move (i - min i j) (j - min i j)) \<bullet> move k l"
    using assms
    by (simp only: move_after_on_suffix)
  also have "\<dots> = move i j \<bullet> move k l"
    by (simp add: on_suffix_move)
  finally show ?thesis .
qed

lemma neighbor_commutation:
  shows "move i (Suc i) = move (Suc i) i"
proof -
  have "move 0 1 = move 1 0"
    by transfer simp
  then have "on_suffix i (move 0 1) = on_suffix i (move 1 0)"
    by simp
  then show ?thesis
    by (simp add: on_suffix_move)
qed

context begin

private lemma neighbor_commutation_after_tight_outer_move_away_from_front:
  shows "move i (Suc i) \<bullet> move i (Suc (Suc i)) = move i (Suc (Suc i)) \<bullet> move (Suc i) (Suc (Suc i))"
proof -
  have "move 0 1 \<bullet> move 0 2 = move 0 2 \<bullet> move 1 2"
    by transfer (simp add: comp_def numeral_2_eq_2)
  then have "on_suffix i (move 0 1 \<bullet> move 0 2) = on_suffix i (move 0 2 \<bullet> move 1 2)"
    by simp
  then show ?thesis
    by (simp add: composition_as_on_suffix [symmetric] on_suffix_move)
qed

private lemma neighbor_commutation_after_outer_move_away_from_front:
  assumes "i \<le> k" and "Suc k < j"
  shows "move k (Suc k) \<bullet> move i j = move i j \<bullet> move (Suc k) (Suc (Suc k))"
proof -
  have "
    move k (Suc k) \<bullet> move i j
    =
    move k (Suc k) \<bullet> (move (Suc (Suc k)) j \<bullet> move k (Suc (Suc k)) \<bullet> move i k)"
    by (simp only: composition_as_move)
  also have "\<dots> = (move k (Suc k) \<bullet> move (Suc (Suc k)) j) \<bullet> move k (Suc (Suc k)) \<bullet> move i k"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = (move (Suc (Suc k)) j \<bullet> move k (Suc k)) \<bullet> move k (Suc (Suc k)) \<bullet> move i k"
    using move_after_backyard_move and \<open>Suc k < j\<close>
    by (metis lessI Suc_lessD)
  also have "\<dots> = move (Suc (Suc k)) j \<bullet> (move k (Suc k) \<bullet> move k (Suc (Suc k))) \<bullet> move i k"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move (Suc (Suc k)) j \<bullet> (move k (Suc (Suc k)) \<bullet> move (Suc k) (Suc (Suc k))) \<bullet> move i k"
    by (simp only: neighbor_commutation_after_tight_outer_move_away_from_front)
  also have "\<dots> = move (Suc (Suc k)) j \<bullet> move k (Suc (Suc k)) \<bullet> (move (Suc k) (Suc (Suc k)) \<bullet> move i k)"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move (Suc (Suc k)) j \<bullet> move k (Suc (Suc k)) \<bullet> (move i k \<bullet> move (Suc k) (Suc (Suc k)))"
    using move_after_backyard_move and \<open>i \<le> k\<close>
    by (metis less_Suc_eq le_imp_less_Suc)
  also have "\<dots> = (move (Suc (Suc k)) j \<bullet> move k (Suc (Suc k)) \<bullet> move i k) \<bullet> move (Suc k) (Suc (Suc k))"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move i j \<bullet> move (Suc k) (Suc (Suc k))"
    by (simp only: composition_as_move)
  finally show ?thesis .
qed

private lemma move_away_from_front_after_outer_move_away_from_front:
  assumes "i \<le> k" and "k \<le> l" and "l < j"
  shows "move k l \<bullet> move i j = move i j \<bullet> move (Suc k) (Suc l)"
using \<open>k \<le> l\<close> proof (induction rule: dec_induct)
  case base
  then show ?case
    by
      (simp only:
        identity_as_move [symmetric]
        adaptation_composition_left_identity
        adaptation_composition_right_identity
      )
next
  case (step m)
  have "move k (Suc m) \<bullet> move i j = (move m (Suc m) \<bullet> move k m) \<bullet> move i j"
    by (simp only: composition_as_move)
  also have "\<dots> = move m (Suc m) \<bullet> (move k m \<bullet> move i j)"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move m (Suc m) \<bullet> (move i j \<bullet> move (Suc k) (Suc m))"
    by (simp only: step.IH)
  also have "\<dots> = (move m (Suc m) \<bullet> move i j) \<bullet> move (Suc k) (Suc m)"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = (move i j \<bullet> move (Suc m) (Suc (Suc m))) \<bullet> move (Suc k) (Suc m)"
    using \<open>i \<le> k\<close> and \<open>l < j\<close> and \<open>k \<le> m\<close> and \<open>m < l\<close>
    by (simp only: neighbor_commutation_after_outer_move_away_from_front)
  also have "\<dots> = move i j \<bullet> (move (Suc m) (Suc (Suc m)) \<bullet> move (Suc k) (Suc m))"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move i j \<bullet> move (Suc k) (Suc (Suc m))"
    by (simp only: composition_as_move)
  finally show ?case .
qed

lemma move_after_outer_move_away_from_front:
  assumes "i \<le> k" and "i \<le> l" and "k < j" and "l < j"
  shows "move k l \<bullet> move i j = move i j \<bullet> move (Suc k) (Suc l)"
proof (cases "k \<le> l")
  case True
  with \<open>i \<le> k\<close> and \<open>l < j\<close> show ?thesis
    by (intro move_away_from_front_after_outer_move_away_from_front)
next
  case False
  have "move k l \<bullet> move i j = move k l \<bullet> move i j \<bullet> (move (Suc l) (Suc k) \<bullet> move (Suc k) (Suc l))"
    by (simp only: back_and_forth_moves adaptation_composition_right_identity)
  also have "\<dots> = move k l \<bullet> (move i j \<bullet> move (Suc l) (Suc k)) \<bullet> move (Suc k) (Suc l)"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move k l \<bullet> (move l k \<bullet> move i j) \<bullet> move (Suc k) (Suc l)"
    using \<open>i \<le> l\<close> and \<open>k < j\<close> and \<open>\<not> k \<le> l\<close>
    by (simp only: move_away_from_front_after_outer_move_away_from_front)
  also have "\<dots> = (move k l \<bullet> move l k) \<bullet> move i j \<bullet> move (Suc k) (Suc l)"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move i j \<bullet> move (Suc k) (Suc l)"
    by (simp only: back_and_forth_moves adaptation_composition_left_identity)
  finally show ?thesis .
qed

end

lemma outer_move_towards_front_after_move:
  assumes "i \<le> k" and "i \<le> l" and "k < j" and "l < j"
  shows "move j i \<bullet> move k l = move (Suc k) (Suc l) \<bullet> move j i"
proof -
  have "move j i \<bullet> move k l = move j i \<bullet> move k l \<bullet> (move i j \<bullet> move j i)"
    by (simp only: back_and_forth_moves adaptation_composition_right_identity)
  also have "\<dots> = move j i \<bullet> (move k l \<bullet> move i j) \<bullet> move j i"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move j i \<bullet> (move i j \<bullet> move (Suc k) (Suc l)) \<bullet> move j i"
    using \<open>i \<le> k\<close> and \<open>i \<le> l\<close> and \<open>k < j\<close> and \<open>l < j\<close>
    by (simp only: move_after_outer_move_away_from_front)
  also have "\<dots> = (move j i \<bullet> move i j) \<bullet> move (Suc k) (Suc l) \<bullet> move j i"
    by (simp only: adaptation_composition_associativity)
  also have "\<dots> = move (Suc k) (Suc l) \<bullet> move j i"
    by (simp only: back_and_forth_moves adaptation_composition_left_identity)
  finally show ?thesis .
qed

subsection \<open>Currying\<close>

definition family_curry :: "'a family \<Rightarrow> (chan \<Rightarrow> 'a family)" (\<open>\<Delta>\<close>) where
  [simp]: "\<Delta> V = (\<lambda>a. \<lambda>e. V (a ## e))"

definition family_uncurry :: "(chan \<Rightarrow> 'a family) \<Rightarrow> 'a family" (\<open>\<nabla>\<close>) where
  [simp]: "\<nabla> \<V> = (\<lambda>e. \<V> (shd e) (stl e))"

definition deep_curry :: "nat \<Rightarrow> 'a family \<Rightarrow> (chan \<Rightarrow> 'a family)" (\<open>(\<Delta>\<^bsub>_\<^esub>)\<close>) where
  [simp]: "\<Delta>\<^bsub>i\<^esub> V = (\<lambda>a. \<lambda>e. V (insert_at i a e))"

definition deep_uncurry :: "nat \<Rightarrow> (chan \<Rightarrow> 'a family) \<Rightarrow> 'a family" (\<open>(\<nabla>\<^bsub>_\<^esub>)\<close>) where
  [simp]: "\<nabla>\<^bsub>i\<^esub> \<V> = (\<lambda>e. \<V> (e !! i) (delete_at i e))"

lemma family_curry_is_bijective:
  shows "bij \<Delta>"
  by (rule o_bij [of \<nabla>]) auto

lemma family_uncurry_is_bijective:
  shows "bij \<nabla>"
  by (rule o_bij [of \<Delta>]) auto

lemma deep_curry_after_deep_uncurry:
  shows "\<Delta>\<^bsub>i\<^esub> \<circ> \<nabla>\<^bsub>i\<^esub> = id"
  by (rule ext) (simp del: sdrop.simps(2) add: stake_shift sdrop_shift, simp add: stake_sdrop)

lemma deep_uncurry_after_deep_curry:
  shows "\<nabla>\<^bsub>i\<^esub> \<circ> \<Delta>\<^bsub>i\<^esub> = id"
  by
    (rule ext)
    (simp del: sdrop.simps(2) add: stake_shift sdrop_shift id_stake_snth_sdrop [symmetric])

lemma deep_curry_is_bijective:
  shows "bij \<Delta>\<^bsub>i\<^esub>"
  using deep_uncurry_after_deep_curry and deep_curry_after_deep_uncurry
  by (rule o_bij [of "\<nabla>\<^bsub>i\<^esub>"])

lemma deep_uncurry_is_bijective:
  shows "bij \<nabla>\<^bsub>i\<^esub>"
  using deep_curry_after_deep_uncurry and deep_uncurry_after_deep_curry
  by (rule o_bij [of "\<Delta>\<^bsub>i\<^esub>"])

lemma family_curry_as_deep_curry:
  shows "\<Delta> V = \<Delta>\<^bsub>0\<^esub> V"
  by simp

lemma family_uncurry_as_deep_uncurry:
  shows "\<nabla> \<V> = \<nabla>\<^bsub>0\<^esub> \<V>"
  by simp

lemma family_curry_after_on_suffix_adapted:
  shows "\<Delta> (V \<guillemotleft> on_suffix (Suc n) \<E>) = (\<lambda>a. \<Delta> V a \<guillemotleft> on_suffix n \<E>)"
  by transfer (simp add: comp_def)

lemma on_suffix_adapted_after_family_uncurry:
  shows "\<nabla> \<V> \<guillemotleft> on_suffix (Suc n) \<E> = \<nabla> (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>)"
  by transfer (simp add: comp_def)

lemma deep_curry_after_on_suffix_adapted:
  assumes "i \<le> n"
  shows "\<Delta>\<^bsub>i\<^esub> (V \<guillemotleft> on_suffix (Suc n) \<E>) = (\<lambda>a. \<Delta>\<^bsub>i\<^esub> V a \<guillemotleft> on_suffix n \<E>)"
proof -
  have "\<Delta>\<^bsub>i\<^esub> (V \<guillemotleft> on_suffix (Suc n) \<E>) = \<Delta> (V \<guillemotleft> on_suffix (Suc n) \<E> \<guillemotleft> move 0 i)"
    by transfer simp
  also have "\<dots> = \<Delta> (V \<guillemotleft> move 0 i \<guillemotleft> on_suffix (Suc n) \<E>)"
    using \<open>i \<le> n\<close>
    by (simp only: composition_adapted [symmetric] move_after_on_suffix)
  also have "\<dots> = (\<lambda>a. \<Delta> (V \<guillemotleft> move 0 i) a \<guillemotleft> on_suffix n \<E>)"
    using family_curry_after_on_suffix_adapted .
  also have "\<dots> = (\<lambda>a. \<Delta>\<^bsub>i\<^esub> V a \<guillemotleft> on_suffix n \<E>)"
    by transfer simp
  finally show ?thesis .
qed

lemma on_suffix_adapted_after_deep_uncurry:
  assumes "i \<le> n"
  shows "\<nabla>\<^bsub>i\<^esub> \<V> \<guillemotleft> on_suffix (Suc n) \<E> = \<nabla>\<^bsub>i\<^esub> (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>)"
proof -
  have "\<nabla>\<^bsub>i\<^esub> \<V> \<guillemotleft> on_suffix (Suc n) \<E> = \<nabla> \<V> \<guillemotleft> move i 0 \<guillemotleft> on_suffix (Suc n) \<E>"
    by transfer (simp add: comp_def)
  also have "\<dots> = \<nabla> \<V> \<guillemotleft> on_suffix (Suc n) \<E> \<guillemotleft> move i 0"
    using \<open>i \<le> n\<close>
    by (simp only: composition_adapted [symmetric] move_after_on_suffix)
  also have "\<dots> = \<nabla> (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>) \<guillemotleft> move i 0"
    by (simp only: on_suffix_adapted_after_family_uncurry)
  also have "\<dots> = \<nabla>\<^bsub>i\<^esub> (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>)"
    by transfer (simp add: comp_def)
  finally show ?thesis .
qed

lemma family_uncurry_and_on_suffix_adapted:
  assumes "\<nabla> \<V>' = W \<guillemotleft> on_suffix (Suc n) \<E>"
  obtains \<V> where "\<V>' = (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>)" and "W = \<nabla> \<V>"
proof -
  have "\<V>' = (\<lambda>a. \<Delta> W a \<guillemotleft> on_suffix n \<E>)"
  proof -
    have "\<V>' = \<Delta> (\<nabla> \<V>')"
      by simp
    also have "\<dots> = \<Delta> (W \<guillemotleft> on_suffix (Suc n) \<E>)"
      using \<open>\<nabla> \<V>' = W \<guillemotleft> on_suffix (Suc n) \<E>\<close>
      by simp
    also have "\<dots> = (\<lambda>a. \<Delta> W a \<guillemotleft> on_suffix n \<E>)"
      by (simp only: family_curry_after_on_suffix_adapted)
    finally show ?thesis .
  qed
  moreover have "W = \<nabla> (\<Delta> W)"
    by simp
  ultimately show ?thesis
    using that
    by blast
qed

lemma deep_uncurry_and_on_suffix_adapted:
  assumes "i \<le> n" and "\<nabla>\<^bsub>i\<^esub> \<V>' = W \<guillemotleft> on_suffix (Suc n) \<E>"
  obtains \<V> where "\<V>' = (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>)" and "W = \<nabla>\<^bsub>i\<^esub> \<V>"
proof -
  from assms(2) have "\<nabla> \<V>' \<guillemotleft> move i 0 = W \<guillemotleft> on_suffix (Suc n) \<E>"
    by transfer (simp add: comp_def)
  then obtain V where "\<nabla> \<V>' = V \<guillemotleft> on_suffix (Suc n) \<E>" and "W = V \<guillemotleft> move i 0"
    using move_adapted_and_on_suffix_adapted [OF le_imp_less_Suc [OF \<open>i \<le> n\<close>]]
    by blast
  from this(1) obtain \<V> where "\<V>' = (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>)" and "V = \<nabla> \<V>"
    using family_uncurry_and_on_suffix_adapted
    by blast
  from \<open>W = V \<guillemotleft> move i 0\<close> and \<open>V = \<nabla> \<V>\<close> have "W = \<nabla>\<^bsub>i\<^esub> \<V>"
    by transfer (simp add: comp_def)
  with that and \<open>\<V>' = (\<lambda>a. \<V> a \<guillemotleft> on_suffix n \<E>)\<close> show ?thesis .
qed

lemma constant_function_family_uncurry:
  shows "\<nabla> (\<lambda>_. A) = A \<guillemotleft> tail"
  unfolding tail_def
  by transfer (simp add: comp_def)

lemma constant_function_family_uncurry_as_remove_adapted:
  shows "\<nabla> (\<lambda>_. V) = V \<guillemotleft> remove 0"
  by transfer (simp add: comp_def)

lemma constant_function_deep_uncurry_as_remove_adapted:
  shows "\<nabla>\<^bsub>i\<^esub> (\<lambda>_. V) = V \<guillemotleft> remove i"
  by transfer (simp add: comp_def)

lemma family_curry_after_remove_adapted:
  shows "\<Delta> (V \<guillemotleft> remove (Suc i)) = (\<lambda>a. \<Delta> V a \<guillemotleft> remove i)"
  by transfer (simp add: comp_def)

lemma remove_adapted_after_family_uncurry:
  shows "\<nabla> \<V> \<guillemotleft> remove (Suc i) = \<nabla> (\<lambda>a. \<V> a \<guillemotleft> remove i)"
  by transfer (simp add: comp_def)

(* NOTE:
  With \<^theory_text>\<open>deep\<close> instead of \<^theory_text>\<open>deeper\<close>, the following lemmas would have to have the inequalities kind
  of reversed, making them analogous to the \<^theory_text>\<open>family\<close> versions.
*)

lemma deeper_curry_after_remove_adapted:
  assumes "i \<le> n"
  shows "\<Delta>\<^bsub>Suc n\<^esub> (V \<guillemotleft> remove i) = (\<lambda>a. \<Delta>\<^bsub>n\<^esub> V a \<guillemotleft> remove i)"
  using assms
  by
    transfer
    (
      simp
        del: stake.simps(2) sdrop.simps(2)
        add: comp_def stake_shift sdrop_shift,
      simp
        del: stake.simps(2)
        add: take_stake min_absorb1 drop_stake
    )

lemma remove_adapted_after_deeper_uncurry:
  assumes "i \<le> n"
  shows "\<nabla>\<^bsub>n\<^esub> \<V> \<guillemotleft> remove i = \<nabla>\<^bsub>Suc n\<^esub> (\<lambda>a. \<V> a \<guillemotleft> remove i)"
  using assms
  by
    transfer
    (
      simp
        del: stake.simps(2) sdrop.simps(2)
        add: comp_def stake_shift sdrop_shift sdrop_snth,
      simp
        del: stake.simps(2)
        add: take_stake min_absorb1 drop_stake
    )

lemma family_curry_after_move_adapted:
  shows "\<Delta> (V \<guillemotleft> move (Suc i) (Suc j)) = (\<lambda>a. \<Delta> V a \<guillemotleft> move i j)"
  by transfer (simp add: comp_def)

lemma move_adapted_after_family_uncurry:
  shows "\<nabla> \<V> \<guillemotleft> move (Suc i) (Suc j) = \<nabla> (\<lambda>a. \<V> a \<guillemotleft> move i j)"
  by transfer (simp add: comp_def)

(* NOTE:
  With \<^theory_text>\<open>deep\<close> instead of \<^theory_text>\<open>deeper\<close>, the following lemmas would have to have the inequalities kind
  of reversed, making them analogous to the \<^theory_text>\<open>family\<close> versions.
*)

lemma deeper_curry_after_move_adapted:
  assumes "i < n" and "j < n"
  shows "\<Delta>\<^bsub>n\<^esub> (V \<guillemotleft> move i j) = (\<lambda>a. \<Delta>\<^bsub>n\<^esub> V a \<guillemotleft> move i j)"
proof -
  have "\<Delta>\<^bsub>n\<^esub> (V \<guillemotleft> move i j) = \<Delta> (V \<guillemotleft> move i j \<guillemotleft> move 0 n)"
    by transfer simp
  also have "\<dots> = \<Delta> (V \<guillemotleft> move 0 n \<guillemotleft> move (Suc i) (Suc j))"
    using \<open>i < n\<close> and \<open>j < n\<close>
    by (simp only: composition_adapted [symmetric] move_after_outer_move_away_from_front)
  also have "\<dots> = (\<lambda>a. \<Delta> (V \<guillemotleft> move 0 n) a \<guillemotleft> move i j)"
    by (simp only: family_curry_after_move_adapted)
  also have "\<dots> = (\<lambda>a. \<Delta>\<^bsub>n\<^esub> V a \<guillemotleft> move i j)"
    by transfer simp
  finally show ?thesis .
qed

lemma move_adapted_after_deeper_uncurry:
  assumes "i < n" and "j < n"
  shows "\<nabla>\<^bsub>n\<^esub> \<V> \<guillemotleft> move i j = \<nabla>\<^bsub>n\<^esub> (\<lambda>a. \<V> a \<guillemotleft> move i j)"
proof -
  have "\<nabla>\<^bsub>n\<^esub> \<V> \<guillemotleft> move i j = \<nabla> \<V> \<guillemotleft> move n 0 \<guillemotleft> move i j"
    by transfer (simp add: comp_def)
  also have "\<dots> = \<nabla> \<V> \<guillemotleft> move (Suc i) (Suc j) \<guillemotleft> move n 0"
    using \<open>i < n\<close> and \<open>j < n\<close>
    by (simp only: composition_adapted [symmetric] outer_move_towards_front_after_move)
  also have "\<dots> = \<nabla> (\<lambda>a. \<V> a \<guillemotleft> move i j) \<guillemotleft> move n 0"
    by (simp only: move_adapted_after_family_uncurry)
  also have "\<dots> = \<nabla>\<^bsub>n\<^esub> (\<lambda>a. \<V> a \<guillemotleft> move i j)"
    by transfer (simp add: comp_def)
  finally show ?thesis .
qed

lemma source_curry_after_move_adapted:
  shows "\<Delta>\<^bsub>i\<^esub> (V \<guillemotleft> move i j) = \<Delta>\<^bsub>j\<^esub> V"
  using delete_at_after_insert_at
  by transfer auto

lemma move_adapted_after_source_uncurry:
  shows "\<nabla>\<^bsub>j\<^esub> \<V> \<guillemotleft> move i j = \<nabla>\<^bsub>i\<^esub> \<V>"
  using delete_at_after_insert_at
  by transfer auto

lemma deep_uncurry_reordering:
  assumes "i \<ge> j"
  shows "\<nabla>\<^bsub>Suc i\<^esub> (\<lambda>a. \<nabla>\<^bsub>j\<^esub> (\<lambda>b. \<V> a b)) = \<nabla>\<^bsub>j\<^esub> (\<lambda>b. \<nabla>\<^bsub>i\<^esub> (\<lambda>a. \<V> a b))"
  using assms
  by
    (simp
      del: stake.simps(2) sdrop.simps(2)
      add: sdrop_snth stake_shift sdrop_shift take_stake min_absorb1 min_absorb2 drop_stake
    )

subsection \<open>Dependencies\<close>

definition dependent_on_chan_at :: "nat \<Rightarrow> 'a family \<Rightarrow> bool" where
  [simp]: "dependent_on_chan_at i V \<longleftrightarrow> (\<exists>a\<^sub>1 a\<^sub>2. \<Delta>\<^bsub>i\<^esub> V a\<^sub>1 \<noteq> \<Delta>\<^bsub>i\<^esub> V a\<^sub>2)"

lemma dependent_on_chan_at_after_on_suffix_adapted:
  assumes "i \<le> n"
  shows "dependent_on_chan_at i (V \<guillemotleft> on_suffix (Suc n) \<E>) \<longleftrightarrow> dependent_on_chan_at i V"
proof -
  have "
    \<Delta>\<^bsub>i\<^esub> (V \<guillemotleft> on_suffix (Suc n) \<E>) a\<^sub>1 \<noteq> \<Delta>\<^bsub>i\<^esub> (V \<guillemotleft> on_suffix (Suc n) \<E>) a\<^sub>2
    \<longleftrightarrow>
    \<Delta>\<^bsub>i\<^esub> V a\<^sub>1 \<noteq> \<Delta>\<^bsub>i\<^esub> V a\<^sub>2"
    for a\<^sub>1 and a\<^sub>2
    using \<open>i \<le> n\<close>
    by (simp only: deep_curry_after_on_suffix_adapted adapted_injectivity)
  then show ?thesis
    by simp
qed

lemma dependent_on_chan_at_after_source_anchored_move_adapted:
  shows "dependent_on_chan_at i (V \<guillemotleft> move i j) \<longleftrightarrow> dependent_on_chan_at j V"
proof -
  have "\<Delta>\<^bsub>i\<^esub> (V \<guillemotleft> move i j) = \<Delta>\<^bsub>j\<^esub> V"
  proof -
    have "\<Delta>\<^bsub>i\<^esub> (V \<guillemotleft> move i j) = \<Delta>\<^bsub>i\<^esub> (\<nabla>\<^bsub>i\<^esub> (\<Delta>\<^bsub>j\<^esub> V))"
      by transfer simp
    also have "\<dots> = \<Delta>\<^bsub>j\<^esub> V"
      by (simp only: deep_curry_after_deep_uncurry pointfree_idE)
    finally show ?thesis .
  qed
  then show ?thesis
    by simp
qed

lemma dependent_on_chan_at_after_move_within_prefix_adapted:
  assumes "i < n" and "j < n"
  shows "dependent_on_chan_at n (V \<guillemotleft> move i j) \<longleftrightarrow> dependent_on_chan_at n V"
proof -
  have "
    \<Delta>\<^bsub>n\<^esub> (V \<guillemotleft> move i j) a\<^sub>1 \<noteq> \<Delta>\<^bsub>n\<^esub> (V \<guillemotleft> move i j) a\<^sub>2 \<longleftrightarrow> \<Delta>\<^bsub>n\<^esub> V a\<^sub>1 \<noteq> \<Delta>\<^bsub>n\<^esub> V a\<^sub>2"
    for a\<^sub>1 and a\<^sub>2
    using \<open>i < n\<close> and \<open>j < n\<close>
    by (simp only: deeper_curry_after_move_adapted adapted_injectivity)
  then show ?thesis
    by simp
qed

lemma not_dependent_on_chan_at:
  assumes "\<not> dependent_on_chan_at i V'"
  obtains V where "V' = V \<guillemotleft> remove i"
proof
  have "V' = (\<lambda>e. V' (insert_at i (e !! i) (delete_at i e)))"
    by (simp only: insert_at_after_delete_at)
  also have "\<dots> = (\<lambda>e. V' (insert_at i undefined (delete_at i e)))"
    using \<open>\<not> dependent_on_chan_at i V'\<close>
    unfolding dependent_on_chan_at_def and deep_curry_def
    by metis
  also have "\<dots> = V' \<circ> insert_at i undefined \<guillemotleft> remove i" (is "_ = ?V'")
    by transfer (simp only: comp_def)
  finally show "V' = ?V'" .
qed

subsection \<open>Channel Families\<close>

lemma constant_family_chan_family_uncurry:
  shows "\<nabla> \<box> = shd"
  by simp

lemma chan_family_distinctness:
  fixes A :: "chan family"
  shows "shd \<noteq> A \<guillemotleft> tail" and "A \<guillemotleft> tail \<noteq> shd"
proof -
  obtain a :: chan and b :: chan where "a \<noteq> b"
    using more_than_one_chan
    by blast
  then show "shd \<noteq> A \<guillemotleft> tail"
  proof (cases "A undefined = a")
    case True
    with \<open>a \<noteq> b\<close> have "shd (b ## undefined) \<noteq> (A \<guillemotleft> tail) (b ## undefined)"
      unfolding tail_def
      by transfer simp
    then show ?thesis
      by auto
  next
    case False
    then have "shd (a ## undefined) \<noteq> (A \<guillemotleft> tail) (a ## undefined)"
      unfolding tail_def
      by transfer simp
    then show ?thesis
      by auto
  qed
  then show "A \<guillemotleft> tail \<noteq> shd"
    by simp
qed

end


theory Seq_Hoare imports
  Seq "../../Hoare/Hoare" "../../Hoare/Hoare_Indexed" "../../Composition/Composition" "../../Composition/Dominant"
begin

(* Hoare rule for Seq language *)

(* TODO: this proof is currently rather nasty, as it
 * involves unfolding a bunch of liftings. This is an opportunity to improve
 * Auto_Lifter related automation.
 *)
(*
(*
 * Standard Seq Hoare rule. Included mostly for explanatory purposes since it is not able to
 * make any guarantees in the context of Seq merged with other languages - it is "closed"
 * in the sense of requiring a closed world (thus not especially useful).
 * (See HSeq, below).
 *)
lemma HSeq_closed :
  assumes H0 : "gs = seq_semx lfts"
  assumes H1 : "lfts Sseq' = Sseq"
  assumes H : "|gs| {- P1 -} cs {- P2 -}"
  shows "|gs| {- P1 -} [G Sseq' cs] {- P2 -}"
proof
  fix c'
  assume Safe : "|gs| {P2} c'"

  have Guarded : "|gs| {P1} (cs @ c')"
    using HTE[OF H Safe]
    by auto

  show "|gs| {P1} ([G Sseq' cs] @ c')"
  proof
    fix m :: "('a, 'b) control"
    assume Ok : "m \<in> ok_S"
    assume M : "P1 (payload m)"
    assume CM : "cont m = Inl ([G Sseq' cs] @ c')"

    show "(safe gs m)"
    proof(cases "(sem_step gs m)")
      case (Inr bad)

      then have False using CM H0
        by(auto simp add: sem_step_def)

      then show ?thesis by auto
    next
      case (Inl m')

(*TODO: make this less bad *)
      have CM1 :  "cont m' = Inl (cs @ c')"
        using Inl CM H0 H1
        by(cases m; auto simp add: schem_lift_defs sem_step_def seq_semx_def seq_sem_l_gen_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def
            prio_l_def option_l_def triv_l_def lift_map_s_def split: md_prio.splits option.splits md_triv.splits sum.splits if_splits)

(*TODO: make this less bad *)
      have M1_eq : "payload m' = payload m"
        using Inl H0
        by(cases m; auto simp add: schem_lift_defs sem_step_def seq_semx_def seq_sem_l_gen_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def
            prio_l_def option_l_def triv_l_def lift_map_s_def split: md_prio.splits option.splits md_triv.splits list.split_asm if_splits)

      have M1 : "P1 (payload m')" using M unfolding M1_eq by auto

      have Step : "sem_step_p gs m m'"
        using sem_step_sem_step_p[OF Inl] by auto

      obtain pri1 pri2 rest where Msplit :
        "m = (mdp pri1 (Some (mdt (G Sseq' cs # c'))), mdp pri2 (Some (mdt (STR ''''))), rest)"
        and Rest : "rest \<in> ok_S"
        using (*Gs_alt'*) CM Ok
        by(cases m; auto simp add: prod_ok_S cont_def split: md_prio.splits option.splits md_triv.splits if_splits)

      have Ok' : "m' \<in> ok_S"
        using Msplit M1_eq Ok Inl
        apply(cases m'; auto simp add: schem_lift_defs sem_step_def seq_semx_def seq_sem_l_gen_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def
            prio_l_def option_l_def triv_l_def lift_map_s_def prod_ok_S sem_step_p_sem_step
            split: md_prio.splits option.splits md_triv.splits sum.splits if_splits list.splits
            )

      have Conc' : "safe gs m'" using guardedD[OF Guarded _ M1 CM1]
        by auto

      show "safe gs m"
      proof
        fix m''
        assume XP : "sem_exec_p gs m m''"

        show "imm_safe gs m''" using XP unfolding sem_exec_p_def
        proof(cases rule: rtranclp.cases)
        case rtrancl_refl
          then show ?thesis using imm_safeI_Step[OF Step] by auto
        next
          case RT : (rtrancl_into_rtrancl b)

          have Exc : "sem_exec_p gs m' m''" unfolding sem_exec_p_def using rtranclp_bisect1[OF sem_step_determ RT(1) Step RT(2)] by auto

          then show ?thesis using safeD[OF Conc' Exc] by auto
        qed
      qed
    qed
  qed
qed
*)
(*
 * More general version of HSeq that applies for any list fs of composed functions meeting
 * certain conditions:
 * - fs is nonempty
 * - fs is dominated by sequence semantics for seq syntax
 *)
(* TODO: do we need the assumption that
fs is nonempty? *)

(*
 * This version is deprecated in favor of HxSeq; see below.
 * It is retained to give an idea of what a more conventional proof of this Hoare rule looks like.
 *)
(* TODO: need to figure out what set to use as the second argument for sups_pres. *)
(*
lemma HSeq_gen :
  assumes H0 : "gs = pcomps fs "
  (*assumes H1 : "seq_sem_l_gen lfts \<in> set fs" *)
  assumes HF : "f = seq_sem_l_gen lfts"
  assumes Hpres : "sups_pres (set fs) S"
  assumes Hnemp : "g \<in> set fs"
  assumes Hdom : "(f \<downharpoonleft> (set fs) Sseq')"
  assumes H2 : "lfts Sseq' = Sseq"
  assumes Hok : "\<And> x . P1 x \<Longrightarrow> x \<in> S"
  assumes H : "|gs| {- P1 -} cs {- P2 -}"
  shows "|gs| {- P1 -} [G Sseq' cs] {- P2 -}"
proof

  fix c'
  assume Guard : "|gs| {P2} c'"

  have Guarded : "|gs| {P1} (cs @ c')"
    using HTE[OF H Guard]
    by auto

  show "|gs| {P1} ([G Sseq' cs] @ c')"
  proof
    fix m :: "('a, 'b) control"
    assume M : "P1 (payload m)"
    assume CM : "cont m = Inl ([G Sseq' cs] @ c')"

    show "(safe gs m)"
    proof(cases "(sem_step gs m)")
      case (Inr bad)

      then have False using CM H0
        by(auto simp add: sem_step_def)

      then show ?thesis by auto
    next
      case (Inl m')

      term "fs"

      have F_eq : "sem_step f m = Inl m'"
        using sym[OF dominant_pcomps[OF Hpres Hnemp Hdom]] CM Inl H0 Hok[OF M]
        apply(cases m; auto simp add: sem_step_def)

      have Fcont : "cont m' = Inl (cs @ c')"
        using HF F_eq CM H2
          (* TODO: better automation here *)
        by(cases m; auto simp add: schem_lift_defs sem_step_def seq_sem_l_gen_def seq_semx_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def seq_sem_lifting'_def
            prio_l_def option_l_def triv_l_def split: md_prio.splits option.splits md_triv.splits list.split_asm)

      have Fstate : "payload m' = payload m"
        using HF F_eq CM H2
        by(cases m; auto simp add: schem_lift_defs sem_step_def seq_sem_l_gen_def seq_semx_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def seq_sem_lifting'_def
            prio_l_def option_l_def triv_l_def split: md_prio.splits option.splits md_triv.splits list.split_asm)

      hence M' :  "P1 (payload m')" using M unfolding Fstate by auto

      have Safe' : "safe gs m'" using guardedD[OF Guarded M' Fcont] by auto

      have Step : "sem_step_p gs m m'" using Inl
        unfolding sem_step_p_eq
        by auto

      show "safe gs m"
      proof(rule safeI)
        fix m''

        assume Exec : "sem_exec_p gs m m''"
        hence Exec' : "(sem_step_p gs)\<^sup>*\<^sup>* m m''"
          unfolding sem_exec_p_def by auto

        show "imm_safe gs m''" using Exec'
        proof(cases rule: rtranclp.cases)
          case rtrancl_refl
          then show ?thesis
            using Inl
            unfolding imm_safe_def sem_step_p_eq
            by(blast)
        next
          case (rtrancl_into_rtrancl b)

          have Exec_final : "sem_exec_p gs m' m''"
            using rtranclp_bisect1
              [OF sem_step_determ rtrancl_into_rtrancl(1)
                  Step rtrancl_into_rtrancl(2)]
            unfolding sem_exec_p_def
            by auto

          show ?thesis using safeD[OF Safe' Exec_final] by auto
        qed
      qed
    qed
  qed
qed
*)

lemma HxSeq :
  assumes H0 : "gs = pcomps fs "
  (*assumes H1 : "seq_sem_l_gen lfts \<in> set fs" *)
  assumes HF : "f = seq_sem_l_gen lfts"
  assumes Hpres : "sups_pres (set fs) (\<lambda> _ . ok_S)"
  assumes Hnemp : "g \<in> set fs"
  assumes Hdom : "(f \<downharpoonleft> (set fs) {Sseq'})"
  assumes H2 : "lfts Sseq' = Sseq"
  assumes H : "|gs| {~ P1 ~} cs {~ P2 ~}"
  shows "|gs| {~ P1 ~} [G Sseq' cs] {~ P2 ~}"
proof(rule HT'I)
  fix npost

  obtain nbody where Nbody : "|#gs#| {#-P1, (nbody + npost)-#} cs {#-P2, npost-#}"
    using HT'D[OF H]
    by blast

  have Conc' : "|#gs#| {#-P1, (nbody + npost)-#} [G Sseq' cs] {#-P2, npost-#}"
  proof
    fix c'

    assume Guard : "|#gs#| {#P2, npost#} c'"

    have Guard' : "|#gs#| {#P1, (nbody + npost)#} (cs @ c')"
      using HTiE[OF Nbody Guard]
      by auto

    show "|#gs#| {#P1, (nbody + npost)#} ([G Sseq' cs] @ c')"
    proof
      fix m :: "('a, 'b) control"
      assume Ok : "m \<in> ok_S"
      assume M : "P1 (payload m)"
      assume CM : "cont m = Inl ([G Sseq' cs] @ c')"

      show "safe_for gs m (nbody + npost)"
      proof(cases "(sem_step gs m)")
        case (Inr bad)

        then have False using CM H0
          by(auto simp add: sem_step_def)

        then show ?thesis by auto
      next
        case (Inl m')

        have F_eq : "sem_step f m = Inl m'"
          using sym[OF dominant_pcomps[OF Hpres Hnemp Hdom _ Ok]] CM Inl H0
          by(simp add: sem_step_def)

        have Fcont : "cont m' = Inl (cs @ c')"
          using HF F_eq CM H2
            (* TODO: better automation here *)
          by(cases m; auto simp add: schem_lift_defs sem_step_def seq_sem_l_gen_def seq_semx_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def seq_sem_lifting'_def
              lift_map_s_def
              prio_l_def option_l_def triv_l_def split: md_prio.splits option.splits md_triv.splits list.split_asm if_splits)

        have Fstate : "payload m' = payload m"
          using HF F_eq CM H2
          by(cases m; auto simp add: schem_lift_defs sem_step_def seq_sem_l_gen_def seq_semx_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def seq_sem_lifting'_def
              lift_map_s_def
              prio_l_def option_l_def triv_l_def split: md_prio.splits option.splits md_triv.splits list.split_asm if_splits)

        hence M' :  "P1 (payload m')" using M unfolding Fstate by auto

        have M'_ok : "m' \<in> ok_S"
          using HF F_eq CM H2 Fstate Ok
          by(cases m; cases m'; auto simp add: schem_lift_defs sem_step_def seq_sem_l_gen_def seq_semx_def seq_sem_def cont_def seq_sem_lifting_gen_def fst_l_def seq_sem_lifting'_def
              lift_map_s_def
              prio_l_def option_l_def triv_l_def
              prod_ok_S option_ok_S triv_ok_S prio_ok_S
              split: md_prio.splits option.splits md_triv.splits list.split_asm if_splits)

        have Safe' : "safe_for gs m' (nbody + npost)" using guardediD[OF Guard' M'_ok M' Fcont] by auto

        have Step : "sem_step_p gs m m'" using Inl
          unfolding sem_step_p_eq
          by auto

        have Step1 : "sem_exec_c_p gs m 1 m'"
          using Excp_1[OF Step] by simp

        have Safe'' : "safe_for gs m (1 + nbody + npost)"
          using safe_for_extend[OF Safe' Step1] by simp

        show "safe_for gs m (nbody + npost)"
          using safe_for_weaken[OF Safe'', of "nbody + npost"] by auto
      qed
    qed
  qed

  then show "\<exists>npre. |#gs#| {#-P1, (npre + npost)-#} [G Sseq' cs] {#-P2, npost-#}"
    by blast
qed

end