theory RelyGuarantee
  imports WeakTrioid HoareLogic
begin

class rg_algebra = weak_trioid + meet_semilattice +
  fixes RG :: "'a set"
  and hom :: "'a \<Rightarrow> 'a" ("\<lbrakk>_\<rbrakk>")
  assumes rg1: "r \<in> RG \<Longrightarrow> r \<parallel> r \<le> r"
  and rg2: "r \<in> RG \<Longrightarrow> s \<in> RG \<Longrightarrow> r \<le> r \<parallel> s"
  and rg3: "r \<in> RG \<Longrightarrow> r\<parallel>(x\<cdot>y) = (r\<parallel>x)\<cdot>(r\<parallel>y)"
  and rg4: "r \<in> RG \<Longrightarrow> r\<parallel>x\<^sup>+ \<le> (r\<parallel>x)\<^sup>+"
  and rg_unit: "1 \<in> RG"
  and rg_meet_closed: "\<lbrakk>r \<in> RG; s \<in> RG\<rbrakk> \<Longrightarrow> (r \<sqinter> s) \<in> RG"
  and rg_par_closed: "\<lbrakk>r \<in> RG; s \<in> RG\<rbrakk> \<Longrightarrow> (r \<parallel> s) \<in> RG"

  and hom_iso: "x \<le> y \<Longrightarrow> \<lbrakk>x\<rbrakk> \<le> \<lbrakk>y\<rbrakk>"
  and hom_meet: "\<lbrakk>x \<sqinter> y\<rbrakk> = \<lbrakk>x\<rbrakk> \<sqinter> \<lbrakk>y\<rbrakk>"
  and hom_join [simp]: "\<lbrakk>x + y\<rbrakk> = \<lbrakk>x\<rbrakk> + \<lbrakk>y\<rbrakk>"
  and hom_mult: "\<lbrakk>x\<cdot>y\<rbrakk> = \<lbrakk>\<lbrakk>x\<rbrakk>\<cdot>\<lbrakk>y\<rbrakk>\<rbrakk>"
  and hom_trancl_inductr: "\<lbrakk>z + y\<cdot>x\<rbrakk> \<le> \<lbrakk>y\<rbrakk> \<Longrightarrow> \<lbrakk>z\<cdot>x\<^sup>+\<rbrakk> \<le> \<lbrakk>y\<rbrakk>"

begin

  declare mult_onel [simp]
    and mult_oner [simp]
    and par_unitl [simp]
    and par_unitr [simp]

  definition quintuple :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_, _ \<turnstile> \<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>") where
    "r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> \<lbrakk>p\<cdot>(r\<parallel>c)\<rbrakk> \<le> \<lbrakk>q\<rbrakk> \<and> c \<le> g \<and> r \<in> RG \<and> g \<in> RG"

  lemma rg_idem_mult [simp]: "r \<in> RG \<Longrightarrow> r\<cdot>r = r"
    using rg3[where x = 1 and y = 1 and r = r, simplified] ..

  lemma rg_idem_par : "r \<in> RG \<Longrightarrow> r \<parallel> r = r"
    by (metis eq_iff rg1 rg2)

  lemma meet_iso: "x \<le> z \<Longrightarrow> y \<le> w \<Longrightarrow> x \<sqinter> y \<le> z \<sqinter> w"
    by (metis (full_types) bin_glb_var order_refl order_trans)

  theorem sequential:
    assumes "r, g \<turnstile> \<lbrace>p\<rbrace> c1 \<lbrace>q\<rbrace>" and "r, g \<turnstile> \<lbrace>q\<rbrace> c2 \<lbrace>s\<rbrace>"
    shows "r, g \<turnstile> \<lbrace>p\<rbrace> c1 \<cdot> c2 \<lbrace>s\<rbrace>"
  proof (simp add: quintuple_def, intro conjI)
    show "r \<in> RG" and "g \<in> RG"
      by (metis assms(1) quintuple_def)+

    hence "\<lbrakk>p \<cdot> (r \<parallel> c1 \<cdot> c2)\<rbrakk> \<le> \<lbrakk>p \<cdot> ((r \<parallel> c1) \<cdot> (r \<parallel> c2))\<rbrakk>"
      by (intro hom_iso mult_isol[rule_format]) (metis order_refl rg3)
    also have "... \<le> \<lbrakk>p \<cdot> (r \<parallel> c1) \<cdot> (r \<parallel> c2)\<rbrakk>"
      by (metis mult_assoc order_refl)
    also have "... \<le> \<lbrakk>q \<cdot> (r \<parallel> c2)\<rbrakk>"
      by (subst hom_mult, subst hom_mult, rule hom_iso, rule mult_isol[rule_format], metis assms(1) quintuple_def)
    also have "... \<le> \<lbrakk>s\<rbrakk>"
      by (metis assms(2) quintuple_def)
    finally show "\<lbrakk>p \<cdot> (r \<parallel> c1 \<cdot> c2)\<rbrakk> \<le> \<lbrakk>s\<rbrakk>" .

    have "c1 \<cdot> c2 \<le> g \<cdot> g"
      apply (intro mult_isol_var[rule_format] conjI)
      apply (metis assms(1) quintuple_def)
      by (metis assms(2) quintuple_def)
    also have "... = g"
      by (metis `g \<in> RG` rg_idem_mult)
    finally show "c1 \<cdot> c2 \<le> g" .
  qed

  theorem parallel:
    assumes "r1, g1 \<turnstile> \<lbrace>p1\<rbrace> c1 \<lbrace>q1\<rbrace>" and "g2 \<le> r1"
    and "r2, g2 \<turnstile> \<lbrace>p2\<rbrace> c2 \<lbrace>q2\<rbrace>" and "g1 \<le> r2"
    shows "(r1 \<sqinter> r2), (g1 \<parallel> g2) \<turnstile> \<lbrace>p1 \<sqinter> p2\<rbrace> c1 \<parallel> c2 \<lbrace>q1 \<sqinter> q2\<rbrace>"
  proof (simp add: quintuple_def, intro conjI)
    have "r1 \<in> RG" and "r2 \<in> RG" and "g1 \<in> RG" and "g2 \<in> RG"
      by (metis assms(1) assms(3) quintuple_def)+

    have "\<lbrakk>(p1 \<sqinter> p2) \<cdot> ((r1 \<sqinter> r2) \<parallel> (c1 \<parallel> c2))\<rbrakk> \<le> \<lbrakk>p1 \<cdot> ((r1 \<sqinter> r2) \<parallel> (c1 \<parallel> c2))\<rbrakk>"
      by (metis bin_glb_var hom_iso mult_isol order_refl par_comm)
    also have "... \<le> \<lbrakk>p1 \<cdot> ((r1 \<sqinter> r2) \<parallel> (c1 \<parallel> g2))\<rbrakk>"
      by (intro hom_iso mult_isol_var[rule_format] par_double_iso[rule_format] conjI order_refl) (metis assms(3) quintuple_def)
    also have "... \<le> \<lbrakk>p1 \<cdot> (r1 \<parallel> (c1 \<parallel> r1))\<rbrakk>"
      by (intro hom_iso mult_isol_var[rule_format] conjI order_refl) (metis assms(2) bin_glb_var eq_refl par_double_iso)
    also have "... \<le> \<lbrakk>p1 \<cdot> (r1 \<parallel> c1)\<rbrakk>"
      by (intro hom_iso mult_isor[rule_format])  (metis `r1 \<in> RG` eq_iff par_assoc par_comm rg_idem_par)
    also have "... \<le> \<lbrakk>q1\<rbrakk>"
      by (metis assms(1) quintuple_def)
    finally show "\<lbrakk>(p1 \<sqinter> p2) \<cdot> (r1 \<sqinter> r2 \<parallel> (c1 \<parallel> c2))\<rbrakk> \<le> \<lbrakk>q1\<rbrakk>" .

    have "\<lbrakk>(p1 \<sqinter> p2) \<cdot> (r1 \<sqinter> r2 \<parallel> (c1 \<parallel> c2))\<rbrakk> \<le> \<lbrakk>p2 \<cdot> (r1 \<sqinter> r2 \<parallel> (c1 \<parallel> c2))\<rbrakk>"
      by (metis bin_glb_var hom_iso mult_isol order_refl)
    also have "... \<le> \<lbrakk>p2 \<cdot> (r1 \<sqinter> r2 \<parallel> (g1 \<parallel> c2))\<rbrakk>"
      by (intro mult_isol_var[rule_format] conjI order_refl hom_iso par_double_iso[rule_format]) (metis assms(1) quintuple_def)
    also have "... \<le> \<lbrakk>p2 \<cdot> (r2 \<parallel> (r2 \<parallel> c2))\<rbrakk>"
      by (intro mult_isol_var[rule_format] hom_iso conjI order_refl) (metis assms(4) bin_glb_var order_refl par_double_iso)
    also have "... \<le> \<lbrakk>p2 \<cdot> (r2 \<parallel> c2)\<rbrakk>"
      by (intro hom_iso mult_isor[rule_format]) (metis `r2 \<in> RG` eq_iff par_comm par_comml rg_idem_par)
    also have "... \<le> \<lbrakk>q2\<rbrakk>"
      by (metis assms(3) quintuple_def)
    finally show "\<lbrakk>(p1 \<sqinter> p2) \<cdot> (r1 \<sqinter> r2 \<parallel> (c1 \<parallel> c2))\<rbrakk> \<le> \<lbrakk>q2\<rbrakk>" .

    show "c1 \<parallel> c2 \<le> g1 \<parallel> g2"
      by (rule par_double_iso[rule_format]) (metis assms(1) quintuple_def assms(3))

    show "r1 \<sqinter> r2 \<in> RG"
      by (metis `r1 \<in> RG` `r2 \<in> RG` rg_meet_closed)
    show "g1 \<parallel> g2 \<in> RG"
      by (metis `g1 \<in> RG` `g2 \<in> RG` rg_par_closed)
  qed

  theorem rg_star: "\<lbrakk>\<lbrakk>p\<cdot>r\<rbrakk> \<le> \<lbrakk>p\<rbrakk>; r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>p\<rbrace>\<rbrakk> \<Longrightarrow> r, g \<turnstile> \<lbrace>p\<rbrace> c\<^sup>* \<lbrace>p\<rbrace>"
    apply (simp add: quintuple_def)
    apply (intro conjI)
    apply (erule conjE)+
    apply (simp add: star_trancl2 par_distl mult_distl add_lub)
    apply (rule order_trans[where y = "\<lbrakk>p \<cdot> (r \<parallel> c)\<^sup>+\<rbrakk>"])
    apply (metis hom_iso mult_isor rg4)
    apply (rule hom_trancl_inductr)
    apply (simp add: add_lub)
    by (metis leq_def par_unitl rg2 rg_idem_mult rg_unit star_iso star_rtc3)

end

locale rg_module =
  fixes mod :: "'a::rg_algebra \<Rightarrow> 'b::boolean_algebra \<Rightarrow> 'b" (infixr "\<Colon>" 60)
  assumes mod_mult: "x \<cdot> y \<Colon> p \<le> y \<Colon> x \<Colon> p"
  and mod_isor: "p \<le> q \<Longrightarrow> x \<Colon> p \<le> x \<Colon> q"
  and mod_isol: "x \<le> y \<Longrightarrow> x \<Colon> p \<le> y \<Colon> p"

begin

definition quintuple :: "'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" ("_, _ \<turnstile> \<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>") where
  "r, g \<turnstile> \<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<longleftrightarrow> r \<parallel> c \<Colon> p \<le> q \<and> c \<le> g \<and> r \<in> I \<and> g \<in> I"

lemma inv_dist: "r \<in> I \<Longrightarrow> r\<parallel>(x\<cdot>y) \<le> (r\<parallel>x)\<cdot>(r\<parallel>y)"
  by (metis rg_algebra_class.inv_def)

lemma sequential:
  assumes "r, g1 \<turnstile> \<lbrace>p\<rbrace> c1 \<lbrace>q\<rbrace>" and "r, g2 \<turnstile> \<lbrace>q\<rbrace> c2 \<lbrace>s\<rbrace>"
  shows "r, (g1 \<parallel> g2) \<turnstile> \<lbrace>p\<rbrace> c1 \<cdot> c2 \<lbrace>s\<rbrace>"
proof -
  have r_inv: "r \<in> I"
    by (metis assms(1) quintuple_def)

  {
    have "r \<parallel> (c1 \<cdot> c2) \<Colon> p \<le> (r \<parallel> c1) \<cdot> (r \<parallel> c2) \<Colon> p"
      by (metis inv_dist mod_isol r_inv)
    also have "... \<le> r \<parallel> c2 \<Colon> r \<parallel> c1 \<Colon> p"
      by (metis mod_mult)
    also have "... \<le> r \<parallel> c2 \<Colon> q"
      by (metis assms(1) mod_isor quintuple_def)
    also have "... \<le> s"
      by (metis assms(2) quintuple_def)
    finally have "r \<parallel> (c1 \<cdot> c2) \<Colon> p \<le> s" .
  }
  moreover
  {
    have "c1 \<cdot> c2 \<le> g1 \<cdot> g2"
      by (metis assms(1) assms(2) mult_isol_var quintuple_def)
    also have "... \<le> g1 \<parallel> g2"
      by (metis assms(1) assms(2) inv_mult_par quintuple_def)
    finally have "c1 \<cdot> c2 \<le> g1 \<parallel> g2" .
  }
  ultimately show ?thesis
    by (metis assms(1) assms(2) inv_par_closed quintuple_def)
qed

end

end


section \<open>Converting bytes to integers\<close>

theory CakeML_Byte
imports
  CakeML.Evaluate_Single
  Show.Show_Instances
begin

definition pat :: Ast.pat where
"pat = Ast.Pcon (Some (Short ''String_char_Char'')) (map (\<lambda>n. Ast.Pvar (''b'' @ show n)) [0..<8])"

definition cake_plus :: "exp \<Rightarrow> exp \<Rightarrow> exp" where
"cake_plus t u = Ast.App (Ast.Opn Ast.Plus) [t, u]"

lemma cake_plus_correct:
  assumes "evaluate env s u = (s', Rval (Litv (IntLit y)))"
  assumes "evaluate env s' t = (s'', Rval (Litv (IntLit x)))"
  shows "evaluate env s (cake_plus t u) = (s'', Rval (Litv (IntLit (x + y))))"
unfolding cake_plus_def using assms by simp

definition cake_times :: "exp \<Rightarrow> exp \<Rightarrow> exp" where
"cake_times t u = Ast.App (Ast.Opn Ast.Times) [t, u]"

lemma cake_times_correct:
  assumes "evaluate env s u = (s', Rval (Litv (IntLit y)))"
  assumes "evaluate env s' t = (s'', Rval (Litv (IntLit x)))"
  shows "evaluate env s (cake_times t u) = (s'', Rval (Litv (IntLit (x * y))))"
unfolding cake_times_def using assms by simp

definition cake_int_of_bool :: "exp \<Rightarrow> exp" where
"cake_int_of_bool e = Ast.Mat e
  [(Ast.Pcon (Some (Short ''HOL_False'')) [], Lit (IntLit 0)),
   (Ast.Pcon (Some (Short ''HOL_True'')) [], Lit (IntLit 1))]"

definition summands :: "exp list" where
"summands = map (\<lambda>n. cake_times (Lit (IntLit (2 ^ n))) (cake_int_of_bool (Ast.Var (Short (''b'' @ show n))))) [0..<8]"

definition cake_int_of_byte :: "exp" where
"cake_int_of_byte =
  Ast.Fun ''x'' (Ast.Mat (Ast.Var (Short ''x'')) [(pat, foldl cake_plus (Lit (IntLit 0)) summands)])"

end


(*  Title:      ZF/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1994  University of Cambridge
*)

section {* Combinatory Logic example: the Church-Rosser Theorem *}

theory Comb imports Main begin

text {*
  Curiously, combinators do not include free variables.

  Example taken from @{cite camilleri92}.
*}

subsection {* Definitions *}

text {* Datatype definition of combinators @{text S} and @{text K}. *}

consts comb :: i
datatype comb =
    K
  | S
  | app ("p \<in> comb", "q \<in> comb")    (infixl "@@" 90)

notation (xsymbols)
  app  (infixl "\<bullet>" 90)

text {*
  Inductive definition of contractions, @{text "-1->"} and
  (multi-step) reductions, @{text "-\<longrightarrow>"}.
*}

consts
  contract  :: i

abbreviation
  contract_syntax :: "[i,i] => o"    (infixl "-1->" 50)
  where "p -1-> q == <p,q> \<in> contract"

abbreviation
  contract_multi :: "[i,i] => o"    (infixl "-\<longrightarrow>" 50)
  where "p -\<longrightarrow> q == <p,q> \<in> contract^*"

inductive
  domains "contract" \<subseteq> "comb \<times> comb"
  intros
    K:   "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q -1-> p"
    S:   "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r -1-> (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap1: "[| p-1->q;  r \<in> comb |] ==> p\<bullet>r -1-> q\<bullet>r"
    Ap2: "[| p-1->q;  r \<in> comb |] ==> r\<bullet>p -1-> r\<bullet>q"
  type_intros comb.intros

text {*
  Inductive definition of parallel contractions, @{text "=1=>"} and
  (multi-step) parallel reductions, @{text "===>"}.
*}

consts
  parcontract :: i

abbreviation
  parcontract_syntax :: "[i,i] => o"    (infixl "=1=>" 50)
  where "p =1=> q == <p,q> \<in> parcontract"

abbreviation
  parcontract_multi :: "[i,i] => o"    (infixl "===>" 50)
  where "p ===> q == <p,q> \<in> parcontract^+"

inductive
  domains "parcontract" \<subseteq> "comb \<times> comb"
  intros
    refl: "[| p \<in> comb |] ==> p =1=> p"
    K:    "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q =1=> p"
    S:    "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r =1=> (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap:   "[| p=1=>q;  r=1=>s |] ==> p\<bullet>r =1=> q\<bullet>s"
  type_intros comb.intros

text {*
  Misc definitions.
*}

definition
  I :: i  where
  "I == S\<bullet>K\<bullet>K"

definition
  diamond :: "i => o"  where
  "diamond(r) ==
    \<forall>x y. <x,y>\<in>r \<longrightarrow> (\<forall>y'. <x,y'>\<in>r \<longrightarrow> (\<exists>z. <y,z>\<in>r & <y',z> \<in> r))"

subsection {* Transitive closure preserves the Church-Rosser property *}

lemma diamond_strip_lemmaD [rule_format]:
  "[| diamond(r);  <x,y>:r^+ |] ==>
    \<forall>y'. <x,y'>:r \<longrightarrow> (\<exists>z. <y',z>: r^+ & <y,z>: r)"
  apply (unfold diamond_def)
  apply (erule trancl_induct)
   apply (blast intro: r_into_trancl)
  apply clarify
  apply (drule spec [THEN mp], assumption)
  apply (blast intro: r_into_trancl trans_trancl [THEN transD])
  done

lemma diamond_trancl: "diamond(r) ==> diamond(r^+)"
  apply (simp (no_asm_simp) add: diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule trancl_induct)
   apply auto
   apply (best intro: r_into_trancl trans_trancl [THEN transD]
     dest: diamond_strip_lemmaD)+
  done

inductive_cases Ap_E [elim!]: "p\<bullet>q \<in> comb"

subsection {* Results about Contraction *}

text {*
  For type checking: replaces @{term "a -1-> b"} by @{text "a, b \<in>
  comb"}.
*}

lemmas contract_combE2 = contract.dom_subset [THEN subsetD, THEN SigmaE2]
  and contract_combD1 = contract.dom_subset [THEN subsetD, THEN SigmaD1]
  and contract_combD2 = contract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_contract_eq: "field(contract) = comb"
  by (blast intro: contract.K elim!: contract_combE2)

lemmas reduction_refl =
  field_contract_eq [THEN equalityD2, THEN subsetD, THEN rtrancl_refl]

lemmas rtrancl_into_rtrancl2 =
  r_into_rtrancl [THEN trans_rtrancl [THEN transD]]

declare reduction_refl [intro!] contract.K [intro!] contract.S [intro!]

lemmas reduction_rls =
  contract.K [THEN rtrancl_into_rtrancl2]
  contract.S [THEN rtrancl_into_rtrancl2]
  contract.Ap1 [THEN rtrancl_into_rtrancl2]
  contract.Ap2 [THEN rtrancl_into_rtrancl2]

lemma "p \<in> comb ==> I\<bullet>p -\<longrightarrow> p"
  -- {* Example only: not used *}
  by (unfold I_def) (blast intro: reduction_rls)

lemma comb_I: "I \<in> comb"
  by (unfold I_def) blast

subsection {* Non-contraction results *}

text {* Derive a case for each combinator constructor. *}

inductive_cases
      K_contractE [elim!]: "K -1-> r"
  and S_contractE [elim!]: "S -1-> r"
  and Ap_contractE [elim!]: "p\<bullet>q -1-> r"

lemma I_contract_E: "I -1-> r ==> P"
  by (auto simp add: I_def)

lemma K1_contractD: "K\<bullet>p -1-> r ==> (\<exists>q. r = K\<bullet>q & p -1-> q)"
  by auto

lemma Ap_reduce1: "[| p -\<longrightarrow> q;  r \<in> comb |] ==> p\<bullet>r -\<longrightarrow> q\<bullet>r"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (erule trans_rtrancl [THEN transD])
  apply (blast intro: contract_combD2 reduction_rls)
  done

lemma Ap_reduce2: "[| p -\<longrightarrow> q;  r \<in> comb |] ==> r\<bullet>p -\<longrightarrow> r\<bullet>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
                      contract_combD2 reduction_rls)
  done

text {* Counterexample to the diamond property for @{text "-1->"}. *}

lemma KIII_contract1: "K\<bullet>I\<bullet>(I\<bullet>I) -1-> I"
  by (blast intro: comb_I)

lemma KIII_contract2: "K\<bullet>I\<bullet>(I\<bullet>I) -1-> K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I))"
  by (unfold I_def) (blast intro: contract.intros)

lemma KIII_contract3: "K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I)) -1-> I"
  by (blast intro: comb_I)

lemma not_diamond_contract: "\<not> diamond(contract)"
  apply (unfold diamond_def)
  apply (blast intro: KIII_contract1 KIII_contract2 KIII_contract3
    elim!: I_contract_E)
  done

subsection {* Results about Parallel Contraction *}

text {* For type checking: replaces @{text "a =1=> b"} by @{text "a, b
  \<in> comb"} *}
lemmas parcontract_combE2 = parcontract.dom_subset [THEN subsetD, THEN SigmaE2]
  and parcontract_combD1 = parcontract.dom_subset [THEN subsetD, THEN SigmaD1]
  and parcontract_combD2 = parcontract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_parcontract_eq: "field(parcontract) = comb"
  by (blast intro: parcontract.K elim!: parcontract_combE2)

text {* Derive a case for each combinator constructor. *}
inductive_cases
      K_parcontractE [elim!]: "K =1=> r"
  and S_parcontractE [elim!]: "S =1=> r"
  and Ap_parcontractE [elim!]: "p\<bullet>q =1=> r"

declare parcontract.intros [intro]

subsection {* Basic properties of parallel contraction *}

lemma K1_parcontractD [dest!]:
    "K\<bullet>p =1=> r ==> (\<exists>p'. r = K\<bullet>p' & p =1=> p')"
  by auto

lemma S1_parcontractD [dest!]:
    "S\<bullet>p =1=> r ==> (\<exists>p'. r = S\<bullet>p' & p =1=> p')"
  by auto

lemma S2_parcontractD [dest!]:
    "S\<bullet>p\<bullet>q =1=> r ==> (\<exists>p' q'. r = S\<bullet>p'\<bullet>q' & p =1=> p' & q =1=> q')"
  by auto

lemma diamond_parcontract: "diamond(parcontract)"
  -- {* Church-Rosser property for parallel contraction *}
  apply (unfold diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule parcontract.induct)
     apply (blast elim!: comb.free_elims  intro: parcontract_combD2)+
  done

text {*
  \medskip Equivalence of @{prop "p -\<longrightarrow> q"} and @{prop "p ===> q"}.
*}

lemma contract_imp_parcontract: "p-1->q ==> p=1=>q"
  by (induct set: contract) auto

lemma reduce_imp_parreduce: "p-\<longrightarrow>q ==> p===>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: r_into_trancl)
  apply (blast intro: contract_imp_parcontract r_into_trancl
    trans_trancl [THEN transD])
  done

lemma parcontract_imp_reduce: "p=1=>q ==> p-\<longrightarrow>q"
  apply (induct set: parcontract)
     apply (blast intro: reduction_rls)
    apply (blast intro: reduction_rls)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
    Ap_reduce1 Ap_reduce2 parcontract_combD1 parcontract_combD2)
  done

lemma parreduce_imp_reduce: "p===>q ==> p-\<longrightarrow>q"
  apply (frule trancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_parcontract_eq [THEN equalityD1, THEN subsetD])
  apply (erule trancl_induct, erule parcontract_imp_reduce)
  apply (erule trans_rtrancl [THEN transD])
  apply (erule parcontract_imp_reduce)
  done

lemma parreduce_iff_reduce: "p===>q \<longleftrightarrow> p-\<longrightarrow>q"
  by (blast intro: parreduce_imp_reduce reduce_imp_parreduce)

end


subsection \<open>More on Lists\label{sec:more-list}\<close>
theory More_List
  imports
    "List-Index.List_Index"
    "HOL-Library.Sublist"
    "HOL-Library.LaTeXsugar"
begin
text \<open>
  Permutations are modelled as distinct lists over some set in this formalization. That means both
  the arrival order of the online vertices $U$ and the (later random) ordering of the offline
  vertices $V$ are modelled as lists. We don't require \<^term>\<open>distinct\<close>ness for the most part in
  the combinatorial part, but rely quite heavily on it in the probabilistic part.

  To obtain an ordering from a list we use the \<^theory>\<open>List-Index.List_Index\<close> AFP entry by
  Nipkow~\cite{List-Index-AFP}.
\<close>

text \<open>
  An important strategy to prove properties of matchings produced by RANKING is by contradiction
  through construction of an infinite chain of vertices with decreasing (or increasing) index.
  The following two induction schemes are useful to this end. Of course, they are also useful
  on their own as specialized forms of strong induction.
\<close>
lemma index_less_induct[case_names index_less]:
  assumes "\<And>x. (\<And>y. index xs y < index xs x \<Longrightarrow> P y xs) \<Longrightarrow> P x xs"
  shows "P x xs"
  using assms
  by (rule measure_induct_rule)

lemma length_minus_index_less_index_gt:
  "length xs - index xs x < length xs - index xs x' \<longleftrightarrow> index xs x' < index xs x"
  by (induction xs) auto

lemma index_gt_induct[case_names index_gt]:
  assumes "\<And>x. (\<And>y. index xs x < index xs y \<Longrightarrow> P y xs) \<Longrightarrow> P x xs"
  shows "P x xs"
  using assms
proof (induction "length xs - index xs x" arbitrary: x rule: less_induct)
  case less

  show ?case
  proof (rule less(2), rule less.hyps, goal_cases)
    case (1 y)
    then show ?case
      by (simp add: length_minus_index_less_index_gt)
  next
    case (2 y x')
    with less show ?case
      by fast
  qed
qed

lemma index_less_in_set: "index xs x < index xs x' \<Longrightarrow> x \<in> set xs"
  by (metis index_conv_size_if_notin index_le_size leD)

lemma transp_index_less: "transp (\<lambda>a b. index xs a < index xs b)"
  by (auto intro: transpI)

lemma sorted_wrt_index_less_distinct:
  "sorted_wrt (\<lambda>a b. index \<sigma> a < index \<sigma> b) xs \<Longrightarrow> distinct xs"
  by (induction xs) auto

lemma index_filter_neq: "a \<noteq> v \<Longrightarrow> b \<noteq> v \<Longrightarrow> index xs a \<le> index xs b \<longleftrightarrow> index [x <- xs. x \<noteq> v] a \<le> index [x <- xs. x \<noteq> v] b"
  by (induction xs) auto

lemma length_at_least_two_Cons_Cons: "2 \<le> length xs \<Longrightarrow> \<exists>x x' xs'. xs = x # x' # xs'"
  by (metis Suc_le_length_iff numeral_2_eq_2)

lemma filter_take_filter: "filter P (take i (filter P xs)) = take i (filter P xs)"
  by (auto intro!: filter_True dest: in_set_takeD)

lemma filter_drop_filter: "filter P (drop i (filter P xs)) = drop i (filter P xs)"
  by (auto intro!: filter_True dest: in_set_dropD)

subsubsection \<open>Moving a vertex to a position\<close>
text \<open>
  Moving vertices to some index plays a crucial role in the probabilistic part of the proof.
  It is used to argue about the probability of the vertex at index $t$ being matched. Moving an
  arbitrary vertex to index $t$ in an arbitrary permutation $\sigma$ is needed to ensure the
  independence of certain events.
\<close>
no_syntax\<^marker>\<open>tag invisible\<close>
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /\<mapsto>/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[\<mapsto>]/ _")
  ""         :: "maplet \<Rightarrow> maplets"             ("_")
  "_Maplets" :: "[maplet, maplets] \<Rightarrow> maplets" ("_,/ _")
  "_MapUpd"  :: "['a \<rightharpoonup> 'b, maplets] \<Rightarrow> 'a \<rightharpoonup> 'b" ("_/'(_')" [900, 0] 900)
  "_Map"     :: "maplets \<Rightarrow> 'a \<rightharpoonup> 'b"            ("(1[_])")

no_syntax (ASCII)\<^marker>\<open>tag invisible\<close>
  "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /|->/ _")
  "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[|->]/ _")

no_translations\<^marker>\<open>tag invisible\<close>
  "_MapUpd m (_Maplets xy ms)"  \<rightleftharpoons> "_MapUpd (_MapUpd m xy) ms"
  "_MapUpd m (_maplet  x y)"    \<rightleftharpoons> "m(x := CONST Some y)"
  "_Map ms"                     \<rightleftharpoons> "_MapUpd (CONST empty) ms"
  "_Map (_Maplets ms1 ms2)"     \<leftharpoondown> "_MapUpd (_Map ms1) ms2"
  "_Maplets ms1 (_Maplets ms2 ms3)" \<leftharpoondown> "_Maplets (_Maplets ms1 ms2) ms3"

definition move_to :: "'a list \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a list" ("_[_ \<mapsto> _]" [100,100]) where
  "move_to xs v i \<equiv> (take i [x <- xs. x \<noteq> v]) @ v # (drop i [x <- xs. x \<noteq> v])"

text \<open>
  This induction scheme is helpful in proving properties about \<^term>\<open>move_to\<close>.
\<close>
lemma induct_list_nat[case_names nil_zero nil_suc cons_zero cons_suc]:
  assumes "P [] 0"
  assumes "\<And>n. P [] n \<Longrightarrow> P [] (Suc n)"
  assumes "\<And>x xs. P xs 0 \<Longrightarrow> P (x#xs) 0"
  assumes "\<And>x xs n. P xs n \<Longrightarrow> P (x#xs) (Suc n)"
  shows "P xs n"
  using assms
  by (induction_schema) (pat_completeness, lexicographic_order)

lemma append_cong: "xs = xs' \<Longrightarrow> ys = ys' \<Longrightarrow> xs @ ys = xs' @ ys'"
  by simp

lemma move_to_gt_length:
  "length xs \<le> i \<Longrightarrow> xs[v \<mapsto> i] = xs[v \<mapsto> length xs]"
  unfolding move_to_def
  by (auto intro!: append_cong dest: le_trans[OF length_filter_le])

lemma move_elem_to_gt_length:
  assumes "length xs \<le> i" "v \<in> set xs"
  shows "xs[v \<mapsto> i] = xs[v \<mapsto> length xs - 1]"
  unfolding move_to_def
proof (rule append_cong)
  have "length [x <- xs. x \<noteq> v] < length xs"
    using assms
    by (auto intro: length_filter_less)

  then have l: "length [x <- xs. x \<noteq> v] \<le> length xs - 1"
    by simp

  with assms show "take i [x <- xs. x \<noteq> v] = take (length xs - 1) [x <- xs. x \<noteq> v]"
    by simp

  from assms l show "v # drop i [x <- xs. x \<noteq> v] = v # drop (length xs - 1) [x <- xs. x \<noteq> v]"
    by simp
qed

lemma move_to_Cons_Suc:
  assumes "x \<noteq> v"
  assumes "Suc n = i"
  shows "(x#xs)[v \<mapsto> i] = x # xs[v \<mapsto> n]"
  using assms
  unfolding move_to_def
  by auto

lemma move_to_Cons_Cons_Suc:
  assumes "Suc n = i"
  assumes "x \<noteq> v"
  shows "(x#v#xs)[x \<mapsto> i] = v#xs[x \<mapsto> n]"
  using assms
  unfolding move_to_def
  by auto

lemma move_hd_to:
  "(v#xs)[v \<mapsto> i] = xs[v \<mapsto> i]"
  unfolding move_to_def
  by auto

lemma move_to_neq_0_Cons:
  assumes "x \<noteq> v"
  assumes "i \<noteq> 0"
  shows "(x#xs)[v \<mapsto> i] = x # xs[v \<mapsto> (i - 1)]"
  using assms
  unfolding move_to_def
  by (auto simp: drop_Cons' take_Cons')

lemma move_to_0:
  shows "xs[v \<mapsto> 0] = v # [x <- xs. x \<noteq> v]"
  unfolding move_to_def
  by simp

lemma move_to_Nil:
  shows "[][v \<mapsto> i] = [v]"
  unfolding move_to_def
  by simp

lemma move_to_last:
  shows "xs[v \<mapsto> length xs] = [x <- xs. x \<noteq> v] @ [v]"
  unfolding move_to_def
  by simp

lemma move_to_Cons_eq:
  "(v#xs)[v \<mapsto> i] = xs[v \<mapsto> i]"
  unfolding move_to_def
  by simp

lemma move_to_distinct:
  "distinct xs \<Longrightarrow> distinct xs[x \<mapsto> i]"
  unfolding move_to_def
  by (auto dest: in_set_dropD in_set_takeD distinct_filter set_take_disj_set_drop_if_distinct)

lemma count_list_append: "count_list (xs@ys) x = count_list xs x + count_list ys x"
  by (induction xs) auto

lemma move_to_set: "set xs[x \<mapsto> i] = set xs \<union> {x}"
  unfolding move_to_def
  by (auto dest: in_set_takeD in_set_dropD)
     (metis (mono_tags, lifting) append_take_drop_id filter_set last_index_append last_index_size_conv length_append member_filter)

lemma move_to_set_eq: "x \<in> set xs \<Longrightarrow> set xs[x \<mapsto> i] = set xs"
  by (auto simp: move_to_set)

lemma move_to_insert_before:
  "i \<le> index \<sigma> w \<Longrightarrow> v \<noteq> w \<Longrightarrow> v \<notin> set \<sigma> \<Longrightarrow> index \<sigma>[v \<mapsto> i] w = Suc (index \<sigma> w)"
  by (induction \<sigma> i rule: induct_list_nat)
     (auto simp: move_to_0 move_to_Cons_Suc)

lemma move_to_insert_after:
  "index \<sigma> w < i \<Longrightarrow> i \<le> length \<sigma> \<Longrightarrow> v \<noteq> w \<Longrightarrow> v \<notin> set \<sigma> \<Longrightarrow> index \<sigma>[v \<mapsto> i] w = index \<sigma> w"
  by (induction \<sigma> i rule: induct_list_nat)
     (auto simp: move_to_Cons_Suc)

lemma index_less_filter_eq: "index xs w < index xs v \<Longrightarrow> index [x <- xs. x \<noteq> v] w = index xs w"
  by (induction xs) auto

lemma index_less_filter: "w \<noteq> v \<Longrightarrow> w' \<noteq> v \<Longrightarrow> index xs w < index xs w' \<longleftrightarrow> index [x <- xs. x \<noteq> v] w < index [x <- xs. x \<noteq> v] w'"
  by (induction xs) auto

lemma not_in_take: "x \<notin> set xs \<Longrightarrow> x \<notin> set (take i xs)"
  by (auto dest: in_set_takeD)

lemma not_in_drop: "x \<notin> set xs \<Longrightarrow> x \<notin> set (drop i xs)"
  by (auto dest: in_set_dropD)

lemma not_in_set_filter_length_eq: "v \<notin> set xs \<Longrightarrow> length [x <- xs. x \<noteq> v] = length xs"
  by (induction xs) auto

lemma in_set_distinct_filter_length_eq: "v \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> length [x <- xs. x \<noteq> v] = length xs - 1"
  by (induction xs) (auto simp: not_in_set_filter_length_eq intro!: Suc_pred)

lemma distinct_filter_length: "distinct xs \<Longrightarrow> (length [x <- xs. x \<noteq> v] = length xs \<and> v \<notin> set xs) \<or> (length [x <- xs. x \<noteq> v] = length xs - 1 \<and> v \<in> set xs)"
  by (metis in_set_distinct_filter_length_eq not_in_set_filter_length_eq)

lemma filter_removeAll: "[x <- xs. x \<noteq> v] = removeAll v xs"
  by (induction xs) auto

lemma not_in_set_filter_id: "v \<notin> set xs \<Longrightarrow> [x <- xs. x \<noteq> v] = xs"
  by (simp add: filter_removeAll)

lemma count_zero: "count_list xs v = 0 \<Longrightarrow>  v \<notin> set xs"
  by (induction xs) (auto split: if_splits)

lemma count_in: "v \<in> set xs \<Longrightarrow> count_list xs v \<noteq> 0"
  by (induction xs) auto

lemma Suc_index_filter: "index xs v < index xs w \<Longrightarrow> v \<in> set xs \<Longrightarrow> count_list xs v = 1 \<Longrightarrow> Suc (index [x <- xs. x \<noteq> v] w) = index xs w"
  by (induction xs) (auto simp: not_in_set_filter_id[OF count_zero])

lemma not_Nil_length_SucE: "xs \<noteq> [] \<Longrightarrow> (\<And>n. length xs = Suc n \<Longrightarrow> P) \<Longrightarrow> P"
  by (induction xs) auto

lemma move_to_count_list:
  "count_list xs[x \<mapsto> i] x = 1"
  unfolding move_to_def
  by (auto simp: count_list_append intro!: count_notin simp: not_in_take not_in_drop)

lemma list_eq_count_list_eq:
 "xs = ys \<Longrightarrow> count_list xs x = count_list ys x"
  by simp

lemma move_to_id:
  "count_list \<sigma> v = 1 \<Longrightarrow> \<sigma>[v \<mapsto> index \<sigma> v] = \<sigma>"
  by (induction \<sigma>) (auto simp: move_to_0 filter_id_conv move_to_Cons_Suc count_zero)

lemma move_to_front_less:
  assumes "i < index \<sigma> v"
  assumes "index \<sigma> w < i"
  shows "index \<sigma>[v \<mapsto> i] w = index \<sigma> w"
  using assms
  by (induction \<sigma> arbitrary: i)
     (auto split: if_splits elim: less_natE simp: move_to_Cons_Suc)

lemma move_to_front_between:
  assumes "count_list \<sigma> v \<le> 1"
  assumes "i < index \<sigma> v"
  assumes "i \<le> index \<sigma> w" "index \<sigma> w < index \<sigma> v"
  shows "index \<sigma>[v \<mapsto> i] w = Suc (index \<sigma> w)"
  using assms
  by (induction \<sigma> i rule: induct_list_nat)
     (auto split: if_splits simp: move_to_0 move_to_Cons_Suc)

lemma move_to_front_gr:
  assumes "count_list \<sigma> v = 1"
  assumes "i < index \<sigma> v"
  assumes "index \<sigma> v < index \<sigma> w"
  shows "index \<sigma>[v \<mapsto> i] w = index \<sigma> w"
proof -
  have "v \<in> set \<sigma>"
    using assms count_notin by fastforce
  then have "count_list \<sigma> v = 1"
    using assms count_zero by blast

  with assms \<open>v \<in> set \<sigma>\<close> show ?thesis
    by (induction \<sigma> i rule: induct_list_nat)
       (auto split: if_splits simp: move_to_0 move_to_Cons_Suc Suc_index_filter)
qed

lemma move_to_back_less:
  assumes "index \<sigma> v < i"
  assumes "index \<sigma> w < index \<sigma> v"
  shows "index \<sigma>[v \<mapsto> i] w = index \<sigma> w"
  using assms
  by (induction \<sigma> arbitrary: i) (auto split: if_splits simp: move_to_neq_0_Cons)

lemma move_to_back_between:
  assumes "count_list \<sigma> v = 1"
  assumes "index \<sigma> v < i"
  assumes "i < length \<sigma>"
  assumes "index \<sigma> v < index \<sigma> w" "index \<sigma> w \<le> i"
  shows "index \<sigma>[v \<mapsto> i] w + 1 = index \<sigma> w"
proof -
  have "v \<in> set \<sigma>"
    using assms count_notin by fastforce
  then have "count_list \<sigma> v = 1"
    using assms count_zero by blast
  with \<open>v \<in> set \<sigma>\<close> assms show ?thesis
    by (induction \<sigma> arbitrary: i)
       (auto simp: move_to_Cons_eq move_to_neq_0_Cons move_to_insert_after split: if_splits dest!: count_zero)
qed

lemma move_to_back_gr:
  assumes "count_list \<sigma> v = 1"
  assumes "index \<sigma> v < i" "i < length \<sigma>"
  assumes "i < index \<sigma> w"
  shows "index \<sigma>[v \<mapsto> i] w = index \<sigma> w"
  using assms
  by (induction \<sigma> i rule: induct_list_nat)
     (auto split: if_splits dest: count_zero
           simp: move_to_Cons_eq move_to_Cons_Suc move_to_insert_before)

lemma distinct_count_list_le: "distinct xs \<Longrightarrow> count_list xs x \<le> 1"
  by (induction xs) auto

lemma distinct_count_in_set: "distinct xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> count_list xs x = 1"
  by (induction xs) auto

lemma move_to_index_v:
  assumes "distinct \<sigma>"
  assumes "i < length \<sigma>"
  shows "index \<sigma>[v \<mapsto> i] v = i"
  using assms
proof (induction \<sigma> i rule: induct_list_nat)
  case (cons_suc x xs n)
  then show ?case
    by (cases "x = v")
       (auto simp: move_to_Cons_Suc move_to_Cons_eq move_to_def index_append not_in_set_filter_id
             dest: in_set_takeD split: if_splits)
qed (auto simp add: move_to_0)

lemma move_to_index_nth:
  assumes "distinct \<sigma>"
  assumes "i < length \<sigma>"
  shows "\<sigma>[v \<mapsto> i] ! i = v"
  using assms
  by (metis count_notin move_to_count_list move_to_index_v nth_index one_neq_zero)

lemma move_to_index_less:
  assumes "distinct \<sigma>"
  assumes "i < length \<sigma>"
  assumes "v \<noteq> w"
  assumes "index \<sigma> w < i"
  shows "index \<sigma>[v \<mapsto> i] w \<le> index \<sigma> w"
  using assms
proof (induction \<sigma> i rule: induct_list_nat)
  case (cons_suc x xs n)
  then show ?case
    by (auto simp: move_to_Cons_Suc move_to_def index_append not_in_set_filter_id set_take_if_index
             dest: in_set_takeD index_take_if_set  split: if_splits)
qed auto

lemma move_to_front_decompE:
  assumes "distinct xs"
  assumes "xs = ps @ x # ss"
  assumes "i \<le> index xs x"
  obtains pps pss where "xs[x \<mapsto> i] = pps @ x # pss @ ss" "pps @ pss = ps"
  using assms
proof (induction xs i arbitrary: ps thesis rule: induct_list_nat)
  case (cons_zero a xs)
  then show ?case
    by (auto simp: move_to_0 not_in_set_filter_id) blast
next
  case (cons_suc a xs n)
  consider (eq) "a = x" | (neq) "a \<noteq> x" by blast
  then show ?case
  proof cases
    case eq
    with cons_suc.prems have "ps = []"
      by (auto simp: Cons_eq_append_conv)
    with cons_suc show ?thesis
      by (auto simp: move_to_0 not_in_set_filter_id)
  next
    case neq

    with cons_suc.prems obtain tl_ps where "ps = a # tl_ps"
      by (auto simp: Cons_eq_append_conv)

    with cons_suc.prems have "xs = tl_ps @ x # ss"
      by simp

    have "distinct xs"
      using cons_suc.prems(2) by simp

    have "n \<le> index xs x"
      using cons_suc.prems(4) neq by auto

    with cons_suc.IH \<open>distinct xs\<close> \<open>xs = tl_ps @ x # ss\<close>
    obtain pps pss where "xs[x \<mapsto> n] = pps @ x # pss @ ss" "pps @ pss = tl_ps"
      by blast

    with cons_suc show ?thesis
      by (metis \<open>ps = a # tl_ps\<close> append_Cons move_to_Cons_Suc neq)
  qed
qed auto

lemma move_to_others_less:
  assumes "v \<noteq> w" "v \<noteq> w'"
  shows "index xs w < index xs w' \<longleftrightarrow> index xs[v \<mapsto> i] w < index xs[v \<mapsto> i] w'"
  using assms
proof (induction xs arbitrary: i)
  case (Cons a xs)
  then show ?case
  proof (cases i)
    case 0
    with Cons show ?thesis
      by (auto simp: move_to_0 index_less_filter)
  next
    case (Suc nat)
    then show ?thesis
    proof (cases "a = v")
      case True
      with Cons show ?thesis
        by (auto simp: move_hd_to)
    next
      case False
      with Cons Suc show ?thesis
        by (auto split: if_splits simp: move_to_Cons_Suc index_less_filter)
    qed
  qed
qed (simp add: move_to_Nil)

lemma move_to_others_leq:
  assumes "v \<noteq> w" "v \<noteq> w'"
  shows "index xs w \<le> index xs w' \<longleftrightarrow> index xs[v \<mapsto> i] w \<le> index xs[v \<mapsto> i] w'"
  using assms
  by (metis linorder_not_le move_to_others_less)

lemma index_less_index_leq_move_to:
  "index \<sigma> w < index \<sigma> v \<Longrightarrow> index \<sigma>[v \<mapsto> i] w \<le> index \<sigma> v"
  by (induction \<sigma> i rule: induct_list_nat)
     (auto split: if_splits simp: move_to_0 move_to_Cons_Suc)

lemma distinct_move_to_filter_id: "distinct xs \<Longrightarrow> x \<notin> set xs \<Longrightarrow> filter (\<lambda>v. v \<noteq> x) (xs[x \<mapsto> i]) = xs"
  by (induction xs i rule: induct_list_nat)
     (auto simp: move_to_0 move_to_Nil move_to_Cons_Suc)

lemma move_to_move_back_id:
  assumes "distinct \<sigma>"
  assumes "v \<in> set \<sigma>"
  shows "\<sigma>[v \<mapsto> t][v \<mapsto> index \<sigma> v] = \<sigma>"
  using assms
proof (induction \<sigma> t rule: induct_list_nat)
  case cons_zero
  then show ?case
    by (auto simp: move_to_0 not_in_set_filter_id move_to_Cons_Suc move_to_Cons_eq)
next
  case (cons_suc _ xs _)
  then show ?case
  proof (cases xs)
    case Nil
    with cons_suc show ?thesis
      by (auto simp: move_to_0 move_to_set_eq)
  next
    case Cons
    with cons_suc show ?thesis
      by (auto simp: move_to_set_eq move_to_0 move_to_Cons_Suc distinct_move_to_filter_id move_to_Cons_Cons_Suc)
  qed
qed auto

lemma the_index:
  assumes "distinct \<sigma>"
  assumes "t < length \<sigma>"
  shows "(THE v. index \<sigma> v = t) = \<sigma> ! t"
  using assms
  by (auto intro: index_nth_id simp: index_less_size_conv)

lemma move_to_eq_if:
  "\<sigma>[v \<mapsto> t] = \<sigma>[w \<mapsto> t] \<Longrightarrow> v = w"
proof (induction \<sigma> t rule: induct_list_nat)
  case (cons_suc x xs n)
  consider "v = w" | "v \<noteq> w \<and> v = x" | "v \<noteq> w \<and> w = x" | "v \<noteq> w \<and> v \<noteq> x \<and> w \<noteq> x" by blast
  then show ?case
  proof cases
    case 2
    show ?thesis
    proof (cases xs)
      case Nil
      with cons_suc 2 show ?thesis
        by (auto simp: move_hd_to move_to_Nil move_to_Cons_Suc)
    next
      case (Cons a as)
      consider (snd_v_1) "v = a \<and> n = 0" | (snd_v_Suc) "v = a \<and> n \<noteq> 0" |
        (snd_not_v_1) "v \<noteq> a \<and> n = 0" | (snd_not_v_Suc) "v \<noteq> a \<and> n \<noteq> 0" by blast
      then show ?thesis
      proof cases
        case snd_v_1
        with cons_suc 2 Cons show ?thesis
          by (auto simp: move_to_0 move_to_Cons_Suc move_to_count_list dest: list_eq_count_list_eq[where x = x])
      next
        case snd_v_Suc
        then obtain n' where "n = Suc n'" "v = a"
          by (auto dest: gr0_implies_Suc)

        with cons_suc 2 Cons show ?thesis
          by (auto simp: move_hd_to move_to_Cons_Suc move_to_count_list dest: list_eq_count_list_eq[where x = x])
      next
        case snd_not_v_1
        with cons_suc 2 Cons show ?thesis
          by (auto simp: move_hd_to move_to_Cons_Suc)
      next
        case snd_not_v_Suc
        with cons_suc 2 Cons show ?thesis
          by (auto simp: move_hd_to move_to_Cons_Suc)
      qed
    qed
  next
    case 3
    show ?thesis
    proof (cases xs)
      case Nil
      with cons_suc 3 show ?thesis
        by (auto simp: move_hd_to move_to_Nil move_to_Cons_Suc)
    next
      case (Cons a as)
      consider (snd_w_1) "w = a \<and> n = 0" | (snd_w_Suc) "w = a \<and> n \<noteq> 0" |
        (snd_not_w_1) "w \<noteq> a \<and> n = 0" | (snd_not_w_Suc) "w \<noteq> a \<and> n \<noteq> 0" by blast
      then show ?thesis
      proof cases
        case snd_w_1
        with cons_suc 3 Cons show ?thesis
          by (auto simp: move_to_0 move_to_Cons_Suc move_to_count_list dest: list_eq_count_list_eq[where x = x])
      next
        case snd_w_Suc
        then obtain n' where "n = Suc n'" "w = a"
          by (auto dest: gr0_implies_Suc)

        with cons_suc 3 Cons show ?thesis
          by (auto simp: move_to_0 move_to_Cons_Suc move_to_count_list dest: list_eq_count_list_eq[where x = x])
      next
        case snd_not_w_1
        with cons_suc 3 Cons show ?thesis
          by (auto simp: move_hd_to move_to_Cons_Suc)
      next
        case snd_not_w_Suc
        with cons_suc 3 Cons show ?thesis
          by (auto simp: move_hd_to move_to_Cons_Suc)
      qed
    qed
  next
    case 4
    with cons_suc show ?thesis
      by (auto simp: move_to_Cons_Suc)
  qed simp
qed (auto simp: move_to_0 move_to_Nil)

lemma move_to_eq_iff: "\<sigma>[v \<mapsto> t] = \<sigma>[w \<mapsto> t] \<longleftrightarrow> v = w"
  by (auto dest: move_to_eq_if)

lemma subset_butlast_only_one:
  assumes "set (butlast xs) \<subseteq> X"
  assumes "x \<in> set xs" "y \<in> set xs" "x \<noteq> y" "x \<notin> X"
  shows "y \<in> X"
  using assms
  by (induction xs) (auto split: if_splits)

lemma filter_without_hd:
  assumes "v' \<notin> set \<sigma>'"
  assumes "v' # \<sigma>' = filter (\<lambda>v. v \<in> X) \<sigma>"
  shows "\<sigma>' = filter (\<lambda>v. v \<in> X - {v'}) \<sigma>"
  using assms
  by (induction \<sigma>)
     (auto split: if_splits intro: filter_cong)

lemma filter_tl:
  assumes "\<not>P (hd \<sigma>)"
  shows "filter P \<sigma> = filter P (tl \<sigma>)"
  using assms
  by (cases \<sigma>)
      auto

lemma filter_Cons_hd:
  assumes "P (hd xs)"
  assumes "y # ys = filter P xs"
  shows "hd xs = y"
  using assms
  by (auto dest!: Cons_eq_filterD simp: hd_append)

lemma filter_tl_without_hd:
  assumes "v' \<notin> set \<sigma>'"
  assumes "v' # \<sigma>' = filter (\<lambda>v. v \<in> X) \<sigma>"
  shows "\<sigma>' = filter (\<lambda>v. v \<in> X - {v'}) (tl \<sigma>)"
proof -
  from assms have "\<sigma>' = filter (\<lambda>v. v \<in> X - {v'}) \<sigma>"
    by (intro filter_without_hd)

  also from assms have "\<dots> = filter (\<lambda>v. v \<in> X - {v'}) (tl \<sigma>)"
    by (intro filter_tl, cases "hd \<sigma> \<in> X")
       (auto dest: filter_Cons_hd)

  finally show ?thesis .
qed

lemma sorted_list_of_set_image_Cons:
  assumes "finite X" "X \<noteq> {}"
  assumes "\<forall>x \<in> X. f m \<le> f x"
  assumes "m \<in> X"
  assumes "inj_on f X"
  shows "sorted_list_of_set (f ` X) = f m # sorted_list_of_set (f ` (X - {m}))" (is "?L = ?R")
proof -
  have min_fm: "Min (f ` X) = f m"
    using assms
    by (auto intro: Min_eqI)

  have image_Diff: "(f ` X) - {f m} = f ` (X - {m})"
    using assms
    by (simp add: inj_on_image_set_diff)

  have "?L = Min (f ` X) # sorted_list_of_set ((f ` X) - {Min (f ` X)})"
    using assms
    by (simp add: sorted_list_of_set_nonempty)

  also have "\<dots> = ?R"
    by (simp add: min_fm image_Diff)

  finally show ?thesis .
qed

lemma distinct_indexE:
  assumes "distinct xs"
  assumes "t < length xs"
  obtains x where "index xs x = t" "xs ! t = x" "x \<in> set xs"
proof
  from assms index_nth_id show "index xs (xs ! t) = t"
    by blast
next
  from \<open>t < length xs\<close> show "xs ! t \<in> set xs"
    by simp
qed blast

lemma distinct_same_order_list_eq:
  assumes "distinct xs" "distinct xs'"
  assumes "set xs = set xs'"
  assumes "\<forall>x y. index xs x \<le> index xs y \<longleftrightarrow> index xs' x \<le> index xs' y"
  shows "xs = xs'"
  using assms
proof (induction xs xs' rule: list_induct2')
  case (4 x xs x' xs')
  then have "x = x'"
    by (auto split: if_splits)

  from 4 have distinct: "distinct xs" "distinct xs'"
    by simp_all

  from 4 have "\<forall>x y. (index xs x \<le> index xs y) = (index xs' x \<le> index xs' y)"
    by (auto split: if_splits)
       (metis index_conv_size_if_notin index_le_size index_less_size_conv insert_eq_iff linorder_not_le)+

  with 4 distinct \<open>x = x'\<close> show ?case
    by fastforce
qed auto

lemma list_eq_same_order:
  assumes "xs = xs'"
  shows "\<forall>x y. index xs x \<le> index xs y \<longleftrightarrow> index xs' x \<le> index xs' y"
  using assms
  by blast

lemma move_to_filter_eq: "[x <- xs. x \<noteq> v][v \<mapsto> t] = xs[v \<mapsto> t]"
  by (metis filter_id_conv filter_set member_filter move_to_def)

lemma distinct_order_filter_eq:
  assumes "distinct xs" "distinct xs'"
  assumes "set xs = set xs'"
  assumes "\<forall>x y. x \<noteq> v \<and> y \<noteq> v \<longrightarrow> (index xs x \<le> index xs y \<longleftrightarrow> index xs' x \<le> index xs' y)"
  shows "[x <- xs. x \<noteq> v] = [x <- xs'. x \<noteq> v]"
  using assms
proof (intro distinct_same_order_list_eq, goal_cases)
  case 4
  show ?case
  proof (intro allI)
    fix x y

    consider "x = y" | "x = v \<and> x \<noteq> y" | "y = v \<and> x \<noteq> y" | "x \<noteq> y \<and> x \<noteq> v \<and> y \<noteq> v" by blast
    then show "index [x <- xs. x \<noteq> v] x \<le> index [x <- xs. x \<noteq> v] y \<longleftrightarrow> index [x <- xs'. x \<noteq> v] x \<le> index [x <- xs'. x \<noteq> v] y"
    proof cases
      case 2
      with assms(3) show ?thesis
        by auto
           (metis filter_set index_less_size_conv leD leI)+
    next
      case 3
      with assms(3) show ?thesis
        by (auto simp: index_le_size)
    next
      case 4
      with assms show ?thesis
        by (auto simp flip: index_filter_neq)
    qed blast
  qed
qed auto

lemma distinct_filter_eq_order:
  assumes "distinct xs" "distinct xs'"
  assumes "set xs = set xs'"
  assumes "[x <- xs. x \<noteq> v] = [x <- xs'. x \<noteq> v]"
  shows "\<forall>x y. x \<noteq> v \<and> y \<noteq> v \<longrightarrow> (index xs x \<le> index xs y \<longleftrightarrow> index xs' x \<le> index xs' y)"
  using assms
  by auto (metis index_filter_neq)+

lemma distinct_move_to_eq_if:
  assumes "distinct xs" "distinct xs'"
  assumes "set xs = set xs'"
  assumes "v \<in> set xs" "index xs v = t"
  assumes "\<forall>x y. x \<noteq> v \<and> y \<noteq> v \<longrightarrow> (index xs x \<le> index xs y \<longleftrightarrow> index xs' x \<le> index xs' y)"
  shows "xs'[v \<mapsto> t] = xs"
  using assms
  by (smt (verit, ccfv_SIG) distinct_count_in_set distinct_order_filter_eq move_to_def move_to_id)

lemma distinct_move_to_indices_if_eq:
  assumes "xs'[v \<mapsto> t] = xs"
  shows "\<forall>x y. x \<noteq> v \<and> y \<noteq> v \<longrightarrow> (index xs x \<le> index xs y \<longleftrightarrow> index xs' x \<le> index xs' y)"
  by (metis assms move_to_others_leq)

lemma set_take_insert_drop: "set ((take n xs) @ x # (drop n xs)) = {x} \<union> set xs"
  by (induction xs n rule: induct_list_nat)
     (simp_all add: insert_commute)

lemma list_emb_drop_before_first:
  assumes "list_emb P xs (ys@zs)"
  assumes "\<forall>y \<in> set ys. \<not>P (hd xs) y"
  shows "list_emb P xs zs"
  using assms
  by (induction ys; simp)
     (metis list.exhaust_sel list_emb_Cons_iff2 list_emb_Nil)

lemma sorted_strict_last_geq_length_offset:
  assumes "ns \<noteq> []"
  assumes "sorted_wrt (<) ns"
  assumes "h < hd ns"
  shows "length ns + h \<le> last ns"
  using assms
proof (induction ns arbitrary: h)
  case (Cons n ns)
  note cons' = Cons
  show ?case
  proof (cases ns)
    case Nil
    with Cons show ?thesis
      by simp
  next
    case (Cons n' ns')
    with cons' have "Suc h < hd ns" by simp

    with cons' show ?thesis
      by fastforce
  qed
qed simp

lemma sorted_strict_last_geq_length:
  assumes "ns \<noteq> []"
  assumes "sorted_wrt (<) ns"
  assumes "0 < hd ns"
  shows "length ns \<le> last ns"
  using assms
  by (auto dest: sorted_strict_last_geq_length_offset)

end


section \<open>\isaheader{Hashable Interface}\<close>
theory Intf_Hash
imports
    Main
    "../../Lib/HashCode"
    "../../Lib/Code_Target_ICF"
    "../../../Automatic_Refinement/Automatic_Refinement"
begin

type_synonym 'a eq = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'k bhc = "nat \<Rightarrow> 'k \<Rightarrow> nat"

subsection \<open>Abstract and concrete hash functions\<close>

definition is_bounded_hashcode :: "('c\<times>'a) set \<Rightarrow> 'c eq \<Rightarrow> 'c bhc \<Rightarrow> bool"
  where "is_bounded_hashcode R eq bhc \<equiv>
             ((eq,(=)) \<in> R \<rightarrow> R \<rightarrow> bool_rel) \<and>
             (\<forall>n. \<forall> x \<in> Domain R. \<forall> y \<in> Domain R. eq x y \<longrightarrow> bhc n x = bhc n y) \<and>
             (\<forall>n x. 1 < n \<longrightarrow> bhc n x < n)"
definition abstract_bounded_hashcode :: "('c\<times>'a) set \<Rightarrow> 'c bhc \<Rightarrow> 'a bhc"
  where "abstract_bounded_hashcode Rk bhc n x' \<equiv>
             if x' \<in> Range Rk
                 then THE c. \<exists>x. (x,x') \<in> Rk \<and> bhc n x = c
                 else 0"

lemma is_bounded_hashcodeI[intro]:
  "((eq,(=)) \<in> R \<rightarrow> R \<rightarrow> bool_rel) \<Longrightarrow>
   (\<And>x y n. x \<in> Domain R \<Longrightarrow> y \<in> Domain R \<Longrightarrow> eq x y \<Longrightarrow> bhc n x = bhc n y) \<Longrightarrow>
   (\<And>x n. 1 < n \<Longrightarrow> bhc n x < n) \<Longrightarrow> is_bounded_hashcode R eq bhc"
  unfolding is_bounded_hashcode_def by force

lemma is_bounded_hashcodeD[dest]:
  assumes "is_bounded_hashcode R eq bhc"
  shows "(eq,(=)) \<in> R \<rightarrow> R \<rightarrow> bool_rel" and
        "\<And>n x y. x \<in> Domain R \<Longrightarrow> y \<in> Domain R \<Longrightarrow> eq x y \<Longrightarrow> bhc n x = bhc n y" and
        "\<And>n x. 1 < n \<Longrightarrow> bhc n x < n"
  using assms unfolding is_bounded_hashcode_def by simp_all

lemma bounded_hashcode_welldefined:
  assumes BHC: "is_bounded_hashcode Rk eq bhc" and
          R1: "(x1,x') \<in> Rk" and R2: "(x2,x') \<in> Rk"
  shows "bhc n x1 = bhc n x2"
proof-
  from is_bounded_hashcodeD[OF BHC] have "(eq,(=)) \<in> Rk \<rightarrow> Rk \<rightarrow> bool_rel" by simp
  with R1 R2 have "eq x1 x2" by (force dest: fun_relD)
  thus ?thesis using R1 R2 BHC by blast
qed

lemma abstract_bhc_correct[intro]:
  assumes "is_bounded_hashcode Rk eq bhc"
  shows "(bhc, abstract_bounded_hashcode Rk bhc) \<in>
      nat_rel \<rightarrow> Rk \<rightarrow> nat_rel" (is "(bhc, ?bhc') \<in> _")
proof (intro fun_relI)
  fix n n' x x'
  assume A: "(n,n') \<in> nat_rel" and B: "(x,x') \<in> Rk"
  hence C: "n = n'" and D: "x' \<in> Range Rk" by auto
  have "?bhc' n' x' = bhc n x"
      unfolding abstract_bounded_hashcode_def
      apply (simp add: C D, rule)
      apply (intro exI conjI, fact B, rule refl)
      apply (elim exE conjE, hypsubst,
          erule bounded_hashcode_welldefined[OF assms _ B])
      done
  thus "(bhc n x, ?bhc' n' x') \<in> nat_rel" by simp
qed

lemma abstract_bhc_is_bhc[intro]:
  fixes Rk :: "('c\<times>'a) set"
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  shows "is_bounded_hashcode Id (=) (abstract_bounded_hashcode Rk bhc)"
      (is "is_bounded_hashcode _ (=) ?bhc'")
proof
  fix x'::'a and y'::'a and n'::nat assume "x' = y'"
  thus "?bhc' n' x' = ?bhc' n' y'" by simp
next
  fix x'::'a and n'::nat assume "1 < n'"
  from abstract_bhc_correct[OF bhc] show "?bhc' n' x' < n'"
  proof (cases "x' \<in> Range Rk")
    case False
      with \<open>1 < n'\<close> show ?thesis
          unfolding abstract_bounded_hashcode_def by simp
  next
    case True
      then obtain x where "(x,x') \<in> Rk" ..
      have "(n',n') \<in> nat_rel" ..
      from abstract_bhc_correct[OF assms] have "?bhc' n' x' = bhc n' x"
        apply -
        apply (drule fun_relD[OF _ \<open>(n',n') \<in> nat_rel\<close>],
               drule fun_relD[OF _ \<open>(x,x') \<in> Rk\<close>], simp)
        done
      also from \<open>1 < n'\<close> and bhc have "... < n'" by blast
      finally show "?bhc' n' x' < n'" .
  qed
qed simp

(*lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "\<lbrakk>STRUCT_EQ_tag eq (=;) REL_IS_ID R\<rbrakk> \<Longrightarrow> is_bounded_hashcode R eq bounded_hashcode"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_bounds)*)

(* TODO: This is a hack that causes the relation to be instantiated to Id, if it is not
    yet fixed! *)
lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "\<lbrakk>STRUCT_EQ_tag eq (=); REL_FORCE_ID R\<rbrakk> \<Longrightarrow> is_bounded_hashcode R eq bounded_hashcode_nat"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_nat_bounds)

subsection \<open>Default hash map size\<close>

definition is_valid_def_hm_size :: "'k itself \<Rightarrow> nat \<Rightarrow> bool"
    where "is_valid_def_hm_size type n \<equiv> n > 1"

lemma hashable_def_size_is_def_size[autoref_ga_rules]:
  shows "is_valid_def_hm_size TYPE('k::hashable) (def_hashmap_size TYPE('k))"
    unfolding is_valid_def_hm_size_def by (fact def_hashmap_size)

end


(* Title: Examples/TTS_Foundations/Foundations/FNDS_Set_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Extension of the theory \<^text>\<open>Set\<close>\<close>
theory FNDS_Set_Ext
  imports Main
begin

lemma Ex1_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "((A ===> (=)) ===> (=)) (\<lambda>P. (\<exists>!x\<in>(Collect (Domainp A)). P x)) Ex1"
  unfolding Ex1_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

text\<open>\newpage\<close>

end