section {* \isaheader{Specification of Sequences} *}
theory ListSpec
imports ICF_Spec_Base
begin

(*@intf List
  @abstype 'a list
  This interface specifies sequences.
*)

subsection "Definition"
locale list =
  -- "Abstraction to HOL-lists"
  fixes \<alpha> :: "'s \<Rightarrow> 'x list"
  -- "Invariant"
  fixes invar :: "'s \<Rightarrow> bool"

locale list_no_invar = list +
  assumes invar[simp, intro!]: "\<And>l. invar l"

subsection "Functions"

locale list_empty = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "\<alpha> (empty ()) = []"
    "invar (empty ())"

locale list_isEmpty = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
    "invar s \<Longrightarrow> isEmpty s \<longleftrightarrow> \<alpha> s = []"

locale poly_list_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
begin
  definition iteratei where
    iteratei_correct[code_unfold]: "iteratei s \<equiv> foldli (\<alpha> s)"
  definition iterate where
    iterate_correct[code_unfold]: "iterate s \<equiv> foldli (\<alpha> s) (\<lambda>_. True)"
end

locale poly_list_rev_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
begin
  definition rev_iteratei where
    rev_iteratei_correct[code_unfold]: "rev_iteratei s \<equiv> foldri (\<alpha> s)"
  definition rev_iterate where
    rev_iterate_correct[code_unfold]: "rev_iterate s \<equiv> foldri (\<alpha> s) (\<lambda>_. True)"
end

(*
locale list_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes iteratei :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
  assumes iteratei_correct:
    "invar s \<Longrightarrow> iteratei s = foldli (\<alpha> s)"
begin
  lemma iteratei_no_sel_rule:
    "invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> set_iterator (iteratei s) (set (\<alpha> s))"
    by (simp add: iteratei_correct set_iterator_foldli_correct)
end

lemma list_iteratei_iteratei_linord_rule:
  "list_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (\<alpha> s) \<Longrightarrow>
   set_iterator_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_iteratei_def set_iterator_linord_foldli_correct)

lemma list_iteratei_iteratei_rev_linord_rule:
  "list_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (rev (\<alpha> s)) \<Longrightarrow>
   set_iterator_rev_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_iteratei_def set_iterator_rev_linord_foldli_correct)

locale list_reverse_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes reverse_iteratei :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
  assumes reverse_iteratei_correct:
    "invar s \<Longrightarrow> reverse_iteratei s = foldri (\<alpha> s)"
begin
  lemma reverse_iteratei_no_sel_rule:
    "invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> set_iterator (reverse_iteratei s) (set (\<alpha> s))"
    by (simp add: reverse_iteratei_correct set_iterator_foldri_correct)
end

lemma list_reverse_iteratei_iteratei_linord_rule:
  "list_reverse_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (rev (\<alpha> s)) \<Longrightarrow>
   set_iterator_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_reverse_iteratei_def set_iterator_linord_foldri_correct)

lemma list_reverse_iteratei_iteratei_rev_linord_rule:
  "list_reverse_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (\<alpha> s) \<Longrightarrow>
   set_iterator_rev_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_reverse_iteratei_def set_iterator_rev_linord_foldri_correct)
*)

locale list_size = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes size :: "'s \<Rightarrow> nat"
  assumes size_correct:
    "invar s \<Longrightarrow> size s = length (\<alpha> s)"

locale list_appendl = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes appendl :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes appendl_correct:
    "invar s \<Longrightarrow> \<alpha> (appendl x s) = x#\<alpha> s"
    "invar s \<Longrightarrow> invar (appendl x s)"
begin
  abbreviation (input) "push \<equiv> appendl"
  lemmas push_correct = appendl_correct
end

locale list_removel = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes removel :: "'s \<Rightarrow> ('x \<times> 's)"
  assumes removel_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> fst (removel s) = hd (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (snd (removel s)) = tl (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> invar (snd (removel s))"
begin
  lemma removelE:
    assumes I: "invar s" "\<alpha> s \<noteq> []"
    obtains s' where "removel s = (hd (\<alpha> s), s')" "invar s'" "\<alpha> s' = tl (\<alpha> s)"
  proof -
    from removel_correct(1,2,3)[OF I] have
      C: "fst (removel s) = hd (\<alpha> s)"
         "\<alpha> (snd (removel s)) = tl (\<alpha> s)"
         "invar (snd (removel s))" .
    from that[of "snd (removel s)", OF _ C(3,2), folded C(1)] show thesis
      by simp
  qed

  text {* The following shortcut notations are not meant for generating efficient code,
    but solely to simplify reasoning *}
  (* TODO: Is this actually used somewhere ? *)
  (*
  definition "head s == fst (removef s)"
  definition "tail s == snd (removef s)"

  lemma tail_correct: "\<lbrakk>invar F; \<alpha> F \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (tail F) = tl (\<alpha> F)"
    by (simp add: tail_def removef_correct)

  lemma removef_split: "removef F = (head F, tail F)"
    apply (cases "removef F")
    apply (simp add: head_def tail_def)
    done
    *)

  abbreviation (input) "pop \<equiv> removel"
  lemmas pop_correct = removel_correct

  abbreviation (input) "dequeue \<equiv> removel"
  lemmas dequeue_correct = removel_correct
end

locale list_leftmost = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes leftmost :: "'s \<Rightarrow> 'x"
  assumes leftmost_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> leftmost s = hd (\<alpha> s)"
begin
  abbreviation (input) top where "top \<equiv> leftmost"
  lemmas top_correct = leftmost_correct
end

locale list_appendr = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes appendr :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes appendr_correct:
    "invar s \<Longrightarrow> \<alpha> (appendr x s) = \<alpha> s @ [x]"
    "invar s \<Longrightarrow> invar (appendr x s)"
begin
  abbreviation (input) "enqueue \<equiv> appendr"
  lemmas enqueue_correct = appendr_correct
end

locale list_remover = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes remover :: "'s \<Rightarrow> 's \<times> 'x"
  assumes remover_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (fst (remover s)) = butlast (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> snd (remover s) = last (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> invar (fst (remover s))"

locale list_rightmost = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes rightmost :: "'s \<Rightarrow> 'x"
  assumes rightmost_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> rightmost s = List.last (\<alpha> s)"
begin
  abbreviation (input) bot where "bot \<equiv> rightmost"
  lemmas bot_correct = rightmost_correct
end

subsubsection "Indexing"
locale list_get = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes get :: "'s \<Rightarrow> nat \<Rightarrow> 'x"
  assumes get_correct:
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> get s i = \<alpha> s ! i"

locale list_set = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes set :: "'s \<Rightarrow> nat \<Rightarrow> 'x \<Rightarrow> 's"
  assumes set_correct:
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> \<alpha> (set s i x) = \<alpha> s [i := x]"
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> invar (set s i x)"

record ('a,'s) list_ops =
  list_op_\<alpha> :: "'s \<Rightarrow> 'a list"
  list_op_invar :: "'s \<Rightarrow> bool"
  list_op_empty :: "unit \<Rightarrow> 's"
  list_op_isEmpty :: "'s \<Rightarrow> bool"
  list_op_size :: "'s \<Rightarrow> nat"
  list_op_appendl :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  list_op_removel :: "'s \<Rightarrow> 'a \<times> 's"
  list_op_leftmost :: "'s \<Rightarrow> 'a"
  list_op_appendr :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  list_op_remover :: "'s \<Rightarrow> 's \<times> 'a"
  list_op_rightmost :: "'s \<Rightarrow> 'a"
  list_op_get :: "'s \<Rightarrow> nat \<Rightarrow> 'a"
  list_op_set :: "'s \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 's"

locale StdListDefs =
  poly_list_iteratei "list_op_\<alpha> ops" "list_op_invar ops"
  + poly_list_rev_iteratei "list_op_\<alpha> ops" "list_op_invar ops"
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> \<equiv> list_op_\<alpha> ops"
  abbreviation invar where "invar \<equiv> list_op_invar ops"
  abbreviation empty where "empty \<equiv> list_op_empty ops"
  abbreviation isEmpty where "isEmpty \<equiv> list_op_isEmpty ops"
  abbreviation size where "size \<equiv> list_op_size ops"
  abbreviation appendl where "appendl \<equiv> list_op_appendl ops"
  abbreviation removel where "removel \<equiv> list_op_removel ops"
  abbreviation leftmost where "leftmost \<equiv> list_op_leftmost ops"
  abbreviation appendr where "appendr \<equiv> list_op_appendr ops"
  abbreviation remover where "remover \<equiv> list_op_remover ops"
  abbreviation rightmost where "rightmost \<equiv> list_op_rightmost ops"
  abbreviation get where "get \<equiv> list_op_get ops"
  abbreviation set where "set \<equiv> list_op_set ops"
end

locale StdList = StdListDefs ops
  + list \<alpha> invar
  + list_empty \<alpha> invar empty
  + list_isEmpty \<alpha> invar isEmpty
  + list_size \<alpha> invar size
  + list_appendl \<alpha> invar appendl
  + list_removel \<alpha> invar removel
  + list_leftmost \<alpha> invar leftmost
  + list_appendr \<alpha> invar appendr
  + list_remover \<alpha> invar remover
  + list_rightmost \<alpha> invar rightmost
  + list_get \<alpha> invar get
  + list_set \<alpha> invar set
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  lemmas correct =
    empty_correct
    isEmpty_correct
    size_correct
    appendl_correct
    removel_correct
    leftmost_correct
    appendr_correct
    remover_correct
    rightmost_correct
    get_correct
    set_correct

end

locale StdList_no_invar = StdList + list_no_invar \<alpha> invar

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Lambda Abstractions\<close>
theory TSFunctions_Lambda
  imports TSFunctions_Base
begin

unbundle no_restrict_syntax

lemma lambda_type [type]:
  "lambda : (A : Set) \<Rightarrow> ((x : Element A) \<Rightarrow> B x) \<Rightarrow> (x : Element A) \<rightarrow>cs B x"
  by unfold_types auto

(*TODO: it is necessery to specify this backward_derive rule since although
above type rule encodes that the type of f depends on A, this will not be
used in the type_derivator when proving `lambda A f : T`; more specifically,
the derivator will merely derivate types for A and f and then see if they can be
fed to Dep_fun_typeE together with lambda_type*)
lemma lambda_app_type [backward_derive]:
  assumes "f : (x : Element A) \<Rightarrow> B x"
  shows "lambda A f : (x : Element A) \<rightarrow>cs B x"
  by discharge_types

lemma Dep_Function_restrict_eq_lambdaI:
  assumes "f : (x : A) \<rightarrow>s B x"
  and "\<And>x. x \<in> A' \<Longrightarrow> x : A"
  shows "f\<restriction>\<^bsub>A'\<^esub> = (\<lambda>x \<in> A'. f`x)"
proof (rule eqI)
  fix p assume "p \<in> f\<restriction>\<^bsub>A'\<^esub>"
  then obtain x y where "p = \<langle>x, y\<rangle>" "\<langle>x, y\<rangle> \<in> f" "x \<in> A'" by auto
  with assms show "p \<in> \<lambda>x \<in> A'. f`x"
    using lambda_pair_mem_if_mem[where ?a=x and ?f="eval f"] by auto
qed (insert assms, auto)

lemma Dep_Function_lambda_bin_inter_type:
  assumes "f : (x : Element A) \<rightarrow>s B x"
  shows "(\<lambda>x \<in> A \<inter> A'. f`x) : (x : Element (A \<inter> A')) \<rightarrow>cs B x"
proof -
  from assms have "f : (x : Element (A \<inter> A')) \<rightarrow>s B x"
    by (elim Dep_Function_contravariant_dom) (unfold_types, auto)
  then show ?thesis by auto
qed

lemma Dep_Function_Element_lambda_subset_self [simp]:
  assumes "f : (x : Element A) \<rightarrow>s B x"
  shows "(\<lambda>x \<in> A. f`x) \<subseteq> f"
proof -
  from assms have "(\<lambda>x \<in> A. f`x) = f\<restriction>\<^bsub>A\<^esub>"
    by (elim Dep_Function_restrict_eq_lambdaI[symmetric]) discharge_types
  then show ?thesis by simp
qed

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
header {* \isaheader{Map implementation via tries} *}
theory TrieMapImpl imports
  Trie
  "../gen_algo/MapGA"
begin
(*@impl Map
  @type ('k,'v) tm
  @abbrv tm,t
  Maps over keys of type @{typ "'k list"} implemented by tries.
*)

subsection {* Operations *}

type_synonym ('k, 'v) tm = "('k, 'v) trie"

definition [icf_rec_def]: "tm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = Trie.lookup,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = (\<lambda>_::unit. Trie.empty),
  bmap_op_lookup = (\<lambda>k m. Trie.lookup m k),
  bmap_op_update = Trie.update,
  bmap_op_update_dj = Trie.update,
  bmap_op_delete = Trie.delete,
  bmap_op_list_it = Trie.iteratei
\<rparr>"

setup Locale_Code.open_block
interpretation tm_basic!: StdBasicMap tm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf Trie.finite_dom_lookup Trie.iteratei_correct)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "tm_ops \<equiv> tm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation tm!: StdMap tm_ops
  unfolding tm_ops_def
  by (rule tm_basic.dflt_ops_impl)
interpretation tm!: StdMap_no_invar tm_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "tm"*}

lemma pi_trie_impl[proper_it]:
  shows "proper_it'
    ((Trie_Impl.iteratei) :: _ \<Rightarrow> (_,'\<sigma>a) set_iterator)
    ((Trie_Impl.iteratei) :: _ \<Rightarrow> (_,'\<sigma>b) set_iterator)"
  unfolding Trie_Impl.iteratei_def[abs_def]
proof (rule proper_it'I)
  (*note [[show_types, show_consts]]*)
  fix t :: "('k,'v) Trie_Impl.trie"
  {
    fix l and t :: "('k,'v) Trie_Impl.trie"
    have "proper_it ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'\<sigma>a) set_iterator)
      ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'\<sigma>b) set_iterator)"
    proof (induct t arbitrary: l)
      case (Trie vo kvs l)

      let ?ITA = "\<lambda>l t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'\<sigma>a) set_iterator"
      let ?ITB = "\<lambda>l t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'\<sigma>b) set_iterator"

      show ?case
        unfolding Trie_Impl.iteratei_postfixed_alt_def
        apply (rule pi_union)
        apply (auto split: option.split intro: icf_proper_iteratorI) []
      proof (rule pi_image)
        def bs \<equiv> "\<lambda>(k,t). SOME l'::('k list \<times> 'v) list.
          ?ITA (k#l) t = foldli l' \<and> ?ITB (k#l) t = foldli l'"

        have EQ1: "\<forall>(k,t)\<in>set kvs. ?ITA (k#l) t = foldli (bs (k,t))" and
          EQ2: "\<forall>(k,t)\<in>set kvs. ?ITB (k#l) t = foldli (bs (k,t))"
        proof (safe)
          fix k t
          assume A: "(k,t) \<in> set kvs"
          from Trie.hyps[OF A, of "k#l"] have
            PI: "proper_it (?ITA (k#l) t) (?ITB (k#l) t)"
            by assumption
          obtain l' where
            "?ITA (k#l) t = foldli l'
          \<and> (?ITB (k#l) t) = foldli l'"
            by (blast intro: proper_itE[OF PI])
          thus "?ITA (k#l) t = foldli (bs (k,t))"
            "?ITB (k#l) t = foldli (bs (k,t))"
            unfolding bs_def
            apply auto
            apply (metis (lifting, full_types) someI_ex)
            apply (metis (lifting, full_types) someI_ex)
            done
        qed

        have PEQ1: "set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITA (k#l) t)
          = set_iterator_product (foldli kvs) (\<lambda>kt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ1 by auto
        have PEQ2: "set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITB (k#l) t)
          = set_iterator_product (foldli kvs) (\<lambda>kt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ2 by auto
        show "proper_it
          (set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITA (k#l) t))
          (set_iterator_product (foldli kvs) (\<lambda>(k,t). ?ITB (k#l) t))"
          apply (subst PEQ1)
          apply (subst PEQ2)
          apply (auto simp: set_iterator_product_foldli_conv)
          by (blast intro: proper_itI)
      qed
    qed
  } thus "proper_it
      (iteratei_postfixed [] t :: (_,'\<sigma>a) set_iterator)
      (iteratei_postfixed [] t :: (_,'\<sigma>b) set_iterator)" .
qed

lemma pi_trie[proper_it]:
  "proper_it' Trie.iteratei Trie.iteratei"
  unfolding Trie.iteratei_def[abs_def]
  apply (rule proper_it'I)
  apply (intro icf_proper_iteratorI)
  apply (rule proper_it'D)
  by (rule pi_trie_impl)

interpretation pi_trie: proper_it_loc Trie.iteratei Trie.iteratei
  apply unfold_locales
  apply (rule pi_trie)
  done

text {* Code generator test *}
definition "test_codegen \<equiv> (
  tm.add ,
  tm.add_dj ,
  tm.ball ,
  tm.bex ,
  tm.delete ,
  tm.empty ,
  tm.isEmpty ,
  tm.isSng ,
  tm.iterate ,
  tm.iteratei ,
  tm.list_it ,
  tm.lookup ,
  tm.restrict ,
  tm.sel ,
  tm.size ,
  tm.size_abort ,
  tm.sng ,
  tm.to_list ,
  tm.to_map ,
  tm.update ,
  tm.update_dj)"

export_code test_codegen in SML

end


(*  Title:      HOL/BNF_Greatest_Fixpoint.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Lorenz Panny, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Greatest fixpoint (codatatype) operation on bounded natural functors.
*)

section \<open>Greatest Fixpoint (Codatatype) Operation on Bounded Natural Functors\<close>

theory BNF_Greatest_Fixpoint
  imports BNF_Fixpoint_Base Types_to_PERs String
keywords
  "codatatype" :: thy_defn and
  "primcorecursive" :: thy_goal_defn and
  "primcorec" :: thy_defn
begin

alias proj = Equiv_Relations.proj

lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases s) auto

lemma not_TrueE: "\<not> True \<Longrightarrow> P"
  by (erule notE, rule TrueI)

lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
  by fast

lemma converse_Times: "(A \<times> B)\<inverse> = B \<times> A"
  by fast

lemma equiv_proj:
  assumes e: "equiv A R" and m: "z \<in> R"
  shows "(proj R \<circ> fst) z = (proj R \<circ> snd) z"
proof -
  from m have z: "(fst z, snd z) \<in> R" by auto
  with e have "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R"
    unfolding equiv_def sym_def trans_def by blast+
  then show ?thesis unfolding proj_def[abs_def] by auto
qed

(* Operators: *)
definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"

lemma Id_on_Gr: "Id_on A = Gr A id"
  unfolding Id_on_def Gr_def by auto

lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
  unfolding image2_def by auto

lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
  by auto

lemma image2_Gr: "image2 A f g = (Gr A f)\<inverse> O (Gr A g)"
  unfolding image2_def Gr_def by auto

lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
  unfolding Gr_def by simp

lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
  unfolding Gr_def by simp

lemma Gr_incl: "Gr A f \<subseteq> A \<times> B \<longleftrightarrow> f ` A \<subseteq> B"
  unfolding Gr_def by auto

lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
  by blast

lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
  by blast

lemma in_rel_Collect_case_prod_eq: "in_rel (Collect (case_prod X)) = X"
  unfolding fun_eq_iff by auto

lemma Collect_case_prod_in_rel_leI: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> Collect (case_prod (in_rel Y))"
  by auto

lemma Collect_case_prod_in_rel_leE: "X \<subseteq> Collect (case_prod (in_rel Y)) \<Longrightarrow> (X \<subseteq> Y \<Longrightarrow> R) \<Longrightarrow> R"
  by force

lemma conversep_in_rel: "(in_rel R)\<inverse>\<inverse> = in_rel (R\<inverse>)"
  unfolding fun_eq_iff by auto

lemma relcompp_in_rel: "in_rel R OO in_rel S = in_rel (R O S)"
  unfolding fun_eq_iff by auto

lemma in_rel_Gr: "in_rel (Gr A f) = Grp A f"
  unfolding Gr_def Grp_def fun_eq_iff by auto

definition relImage where
  "relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"

definition relInvImage where
  "relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"

lemma relImage_Gr:
  "\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)\<inverse> O R O Gr A f"
  unfolding relImage_def Gr_def relcomp_def by auto

lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)\<inverse>"
  unfolding Gr_def relcomp_def image_def relInvImage_def by auto

lemma relImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
  unfolding relImage_def by auto

lemma relInvImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
  unfolding relInvImage_def by auto

lemma relInvImage_Id_on:
  "(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
  unfolding relInvImage_def Id_on_def by auto

lemma relInvImage_UNIV_relImage:
  "R \<subseteq> relInvImage UNIV (relImage R f) f"
  unfolding relInvImage_def relImage_def by auto

lemma relImage_proj:
  assumes "equiv A R"
  shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
  unfolding relImage_def Id_on_def
  using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
  by (auto simp: proj_preserves)

lemma relImage_relInvImage:
  assumes "R \<subseteq> f ` A \<times> f ` A"
  shows "relImage (relInvImage A R f) f = R"
  using assms unfolding relImage_def relInvImage_def by fast

lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
  by simp

lemma fst_diag_id: "(fst \<circ> (\<lambda>x. (x, x))) z = id z" by simp
lemma snd_diag_id: "(snd \<circ> (\<lambda>x. (x, x))) z = id z" by simp

lemma fst_diag_fst: "fst \<circ> ((\<lambda>x. (x, x)) \<circ> fst) = fst" by auto
lemma snd_diag_fst: "snd \<circ> ((\<lambda>x. (x, x)) \<circ> fst) = fst" by auto
lemma fst_diag_snd: "fst \<circ> ((\<lambda>x. (x, x)) \<circ> snd) = snd" by auto
lemma snd_diag_snd: "snd \<circ> ((\<lambda>x. (x, x)) \<circ> snd) = snd" by auto

definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"

lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
  unfolding Shift_def Succ_def by simp

lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
  unfolding Succ_def by simp

lemmas SuccE = SuccD[elim_format]

lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
  unfolding Succ_def by simp

lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
  unfolding Shift_def by simp

lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
  unfolding Succ_def Shift_def by auto

lemma length_Cons: "length (x # xs) = Suc (length xs)"
  by simp

lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
  by simp

(*injection into the field of a cardinal*)
definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
definition "toCard A r \<equiv> SOME f. toCard_pred A r f"

lemma ex_toCard_pred:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
  unfolding toCard_pred_def
  using card_of_ordLeq[of A "Field r"]
    ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
  by blast

lemma toCard_pred_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
  unfolding toCard_def using someI_ex[OF ex_toCard_pred] .

lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> toCard A r x = toCard A r y \<longleftrightarrow> x = y"
  using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast

definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"

lemma fromCard_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
  unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)

lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma rec_nat_0_imp: "f = rec_nat f1 (\<lambda>n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
  by auto

lemma rec_nat_Suc_imp: "f = rec_nat f1 (\<lambda>n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
  by auto

lemma rec_list_Nil_imp: "f = rec_list f1 (\<lambda>x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
  by auto

lemma rec_list_Cons_imp: "f = rec_list f1 (\<lambda>x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
  by auto

lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
  by simp

definition image2p where
  "image2p f g R = (\<lambda>x y. \<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"

lemma image2pI: "R x y \<Longrightarrow> image2p f g R (f x) (g y)"
  unfolding image2p_def by blast

lemma image2pE: "\<lbrakk>image2p f g R fx gy; (\<And>x y. fx = f x \<Longrightarrow> gy = g y \<Longrightarrow> R x y \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
  unfolding image2p_def by blast

lemma rel_fun_iff_geq_image2p: "rel_fun R S f g = (image2p f g R \<le> S)"
  unfolding rel_fun_def image2p_def by auto

lemma rel_fun_image2p: "rel_fun R (image2p f g R) f g"
  unfolding rel_fun_def image2p_def by auto

subsection \<open>Equivalence relations, quotients, and Hilbert's choice\<close>

lemma equiv_Eps_in:
"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (\<lambda>x. x \<in> X) \<in> X"
  apply (rule someI2_ex)
  using in_quotient_imp_non_empty by blast

lemma equiv_Eps_preserves:
  assumes ECH: "equiv A r" and X: "X \<in> A//r"
  shows "Eps (\<lambda>x. x \<in> X) \<in> A"
  apply (rule in_mono[rule_format])
   using assms apply (rule in_quotient_imp_subset)
  by (rule equiv_Eps_in) (rule assms)+

lemma proj_Eps:
  assumes "equiv A r" and "X \<in> A//r"
  shows "proj r (Eps (\<lambda>x. x \<in> X)) = X"
unfolding proj_def
proof auto
  fix x assume x: "x \<in> X"
  thus "(Eps (\<lambda>x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
next
  fix x assume "(Eps (\<lambda>x. x \<in> X),x) \<in> r"
  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
qed

definition univ where "univ f X == f (Eps (\<lambda>x. x \<in> X))"

lemma univ_commute:
assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
shows "(univ f) (proj r x) = f x"
proof (unfold univ_def)
  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
  hence "Eps (\<lambda>y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
  moreover have "proj r (Eps (\<lambda>y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
  ultimately have "(x, Eps (\<lambda>y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
  thus "f (Eps (\<lambda>y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
qed

lemma univ_preserves:
  assumes ECH: "equiv A r" and RES: "f respects r" and PRES: "\<forall>x \<in> A. f x \<in> B"
  shows "\<forall>X \<in> A//r. univ f X \<in> B"
proof
  fix X assume "X \<in> A//r"
  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  hence "univ f X = f x" using ECH RES univ_commute by fastforce
  thus "univ f X \<in> B" using x PRES by simp
qed

ML_file \<open>Tools/BNF/bnf_gfp_util.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp_rec_sugar_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp_rec_sugar.ML\<close>

end


(*  Title:      HOL/ex/Reflection_Examples.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Examples for generic reflection and reification\<close>

theory Reflection_Examples
imports Complex_Main "HOL-Library.Reflection"
begin

text \<open>This theory presents two methods: reify and reflection\<close>

text \<open>
Consider an HOL type \<open>\<sigma>\<close>, the structure of which is not recongnisable
on the theory level.  This is the case of \<^typ>\<open>bool\<close>, arithmetical terms such as \<^typ>\<open>int\<close>,
\<^typ>\<open>real\<close> etc \dots  In order to implement a simplification on terms of type \<open>\<sigma>\<close> we
often need its structure.  Traditionnaly such simplifications are written in ML,
proofs are synthesized.

An other strategy is to declare an HOL datatype \<open>\<tau>\<close> and an HOL function (the
interpretation) that maps elements of \<open>\<tau>\<close> to elements of \<open>\<sigma>\<close>.

The functionality of \<open>reify\<close> then is, given a term \<open>t\<close> of type \<open>\<sigma>\<close>,
to compute a term \<open>s\<close> of type \<open>\<tau>\<close>.  For this it needs equations for the
interpretation.

N.B: All the interpretations supported by \<open>reify\<close> must have the type
\<open>'a list \<Rightarrow> \<tau> \<Rightarrow> \<sigma>\<close>.  The method \<open>reify\<close> can also be told which subterm
of the current subgoal should be reified.  The general call for \<open>reify\<close> is
\<open>reify eqs (t)\<close>, where \<open>eqs\<close> are the defining equations of the interpretation
and \<open>(t)\<close> is an optional parameter which specifies the subterm to which reification
should be applied to.  If \<open>(t)\<close> is abscent, \<open>reify\<close> tries to reify the whole
subgoal.

The method \<open>reflection\<close> uses \<open>reify\<close> and has a very similar signature:
\<open>reflection corr_thm eqs (t)\<close>.  Here again \<open>eqs\<close> and \<open>(t)\<close>
are as described above and \<open>corr_thm\<close> is a theorem proving
\<^prop>\<open>I vs (f t) = I vs t\<close>.  We assume that \<open>I\<close> is the interpretation
and \<open>f\<close> is some useful and executable simplification of type \<open>\<tau> \<Rightarrow> \<tau>\<close>.
The method \<open>reflection\<close> applies reification and hence the theorem \<^prop>\<open>t = I xs s\<close>
and hence using \<open>corr_thm\<close> derives \<^prop>\<open>t = I xs (f s)\<close>.  It then uses
normalization by equational rewriting to prove \<^prop>\<open>f s = s'\<close> which almost finishes
the proof of \<^prop>\<open>t = t'\<close> where \<^prop>\<open>I xs s' = t'\<close>.
\<close>

text \<open>Example 1 : Propositional formulae and NNF.\<close>
text \<open>The type \<open>fm\<close> represents simple propositional formulae:\<close>

datatype form = TrueF | FalseF | Less nat nat
  | And form form | Or form form | Neg form | ExQ form

primrec interp :: "form \<Rightarrow> ('a::ord) list \<Rightarrow> bool"
where
  "interp TrueF vs \<longleftrightarrow> True"
| "interp FalseF vs \<longleftrightarrow> False"
| "interp (Less i j) vs \<longleftrightarrow> vs ! i < vs ! j"
| "interp (And f1 f2) vs \<longleftrightarrow> interp f1 vs \<and> interp f2 vs"
| "interp (Or f1 f2) vs \<longleftrightarrow> interp f1 vs \<or> interp f2 vs"
| "interp (Neg f) vs \<longleftrightarrow> \<not> interp f vs"
| "interp (ExQ f) vs \<longleftrightarrow> (\<exists>v. interp f (v # vs))"

lemmas interp_reify_eqs = interp.simps
declare interp_reify_eqs [reify]

lemma "\<exists>x. x < y \<and> x < z"
  apply reify
  oops

datatype fm = And fm fm | Or fm fm | Imp fm fm | Iff fm fm | Not fm | At nat

primrec Ifm :: "fm \<Rightarrow> bool list \<Rightarrow> bool"
where
  "Ifm (At n) vs \<longleftrightarrow> vs ! n"
| "Ifm (And p q) vs \<longleftrightarrow> Ifm p vs \<and> Ifm q vs"
| "Ifm (Or p q) vs \<longleftrightarrow> Ifm p vs \<or> Ifm q vs"
| "Ifm (Imp p q) vs \<longleftrightarrow> Ifm p vs \<longrightarrow> Ifm q vs"
| "Ifm (Iff p q) vs \<longleftrightarrow> Ifm p vs = Ifm q vs"
| "Ifm (Not p) vs \<longleftrightarrow> \<not> Ifm p vs"

lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps)
oops

text \<open>Method \<open>reify\<close> maps a \<^typ>\<open>bool\<close> to an \<^typ>\<open>fm\<close>.  For this it needs the
semantics of \<open>fm\<close>, i.e.\ the rewrite rules in \<open>Ifm.simps\<close>.\<close>

text \<open>You can also just pick up a subterm to reify.\<close>
lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps ("((\<not> D) \<and> (\<not> F))"))
oops

text \<open>Let's perform NNF. This is a version that tends to generate disjunctions\<close>
primrec fmsize :: "fm \<Rightarrow> nat"
where
  "fmsize (At n) = 1"
| "fmsize (Not p) = 1 + fmsize p"
| "fmsize (And p q) = 1 + fmsize p + fmsize q"
| "fmsize (Or p q) = 1 + fmsize p + fmsize q"
| "fmsize (Imp p q) = 2 + fmsize p + fmsize q"
| "fmsize (Iff p q) = 2 + 2* fmsize p + 2* fmsize q"

lemma [measure_function]: "is_measure fmsize" ..

fun nnf :: "fm \<Rightarrow> fm"
where
  "nnf (At n) = At n"
| "nnf (And p q) = And (nnf p) (nnf q)"
| "nnf (Or p q) = Or (nnf p) (nnf q)"
| "nnf (Imp p q) = Or (nnf (Not p)) (nnf q)"
| "nnf (Iff p q) = Or (And (nnf p) (nnf q)) (And (nnf (Not p)) (nnf (Not q)))"
| "nnf (Not (And p q)) = Or (nnf (Not p)) (nnf (Not q))"
| "nnf (Not (Or p q)) = And (nnf (Not p)) (nnf (Not q))"
| "nnf (Not (Imp p q)) = And (nnf p) (nnf (Not q))"
| "nnf (Not (Iff p q)) = Or (And (nnf p) (nnf (Not q))) (And (nnf (Not p)) (nnf q))"
| "nnf (Not (Not p)) = nnf p"
| "nnf (Not p) = Not p"

text \<open>The correctness theorem of \<^const>\<open>nnf\<close>: it preserves the semantics of \<^typ>\<open>fm\<close>\<close>
lemma nnf [reflection]:
  "Ifm (nnf p) vs = Ifm p vs"
  by (induct p rule: nnf.induct) auto

text \<open>Now let's perform NNF using our \<^const>\<open>nnf\<close> function defined above.  First to the
  whole subgoal.\<close>
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps)
oops

text \<open>Now we specify on which subterm it should be applied\<close>
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps only: "B \<or> C \<and> (B \<longrightarrow> A \<or> D)")
oops

text \<open>Example 2: Simple arithmetic formulae\<close>

text \<open>The type \<open>num\<close> reflects linear expressions over natural number\<close>
datatype num = C nat | Add num num | Mul nat num | Var nat | CN nat nat num

text \<open>This is just technical to make recursive definitions easier.\<close>
primrec num_size :: "num \<Rightarrow> nat"
where
  "num_size (C c) = 1"
| "num_size (Var n) = 1"
| "num_size (Add a b) = 1 + num_size a + num_size b"
| "num_size (Mul c a) = 1 + num_size a"
| "num_size (CN n c a) = 4 + num_size a "

lemma [measure_function]: "is_measure num_size" ..

text \<open>The semantics of num\<close>
primrec Inum:: "num \<Rightarrow> nat list \<Rightarrow> nat"
where
  Inum_C  : "Inum (C i) vs = i"
| Inum_Var: "Inum (Var n) vs = vs!n"
| Inum_Add: "Inum (Add s t) vs = Inum s vs + Inum t vs "
| Inum_Mul: "Inum (Mul c t) vs = c * Inum t vs "
| Inum_CN : "Inum (CN n c t) vs = c*(vs!n) + Inum t vs "

text \<open>Let's reify some nat expressions \dots\<close>
lemma "4 * (2 * x + (y::nat)) + f a \<noteq> 0"
  apply (reify Inum.simps ("4 * (2 * x + (y::nat)) + f a"))
oops
text \<open>We're in a bad situation! \<open>x\<close>, \<open>y\<close> and \<open>f\<close> have been recongnized
as constants, which is correct but does not correspond to our intuition of the constructor C.
It should encapsulate constants, i.e. numbers, i.e. numerals.\<close>

text \<open>So let's leave the \<open>Inum_C\<close> equation at the end and see what happens \dots\<close>
lemma "4 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_Var Inum_Add Inum_Mul Inum_CN Inum_C ("4 * (2 * x + (y::nat))"))
oops
text \<open>Hm, let's specialize \<open>Inum_C\<close> with numerals.\<close>

lemma Inum_number: "Inum (C (numeral t)) vs = numeral t" by simp
lemmas Inum_eqs = Inum_Var Inum_Add Inum_Mul Inum_CN Inum_number

text \<open>Second attempt\<close>
lemma "1 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat))"))
oops

text\<open>That was fine, so let's try another one \dots\<close>

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text \<open>Oh!! 0 is not a variable \dots\ Oh! 0 is not a \<open>numeral\<close> \dots\ thing.
The same for 1. So let's add those equations, too.\<close>

lemma Inum_01: "Inum (C 0) vs = 0" "Inum (C 1) vs = 1" "Inum (C(Suc n)) vs = Suc n"
  by simp_all

lemmas Inum_eqs'= Inum_eqs Inum_01

text\<open>Third attempt:\<close>

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs' ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text \<open>Okay, let's try reflection. Some simplifications on \<^typ>\<open>num\<close> follow. You can
  skim until the main theorem \<open>linum\<close>.\<close>

fun lin_add :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "lin_add (CN n1 c1 r1) (CN n2 c2 r2) =
    (if n1 = n2 then
      (let c = c1 + c2
       in (if c = 0 then lin_add r1 r2 else CN n1 c (lin_add r1 r2)))
     else if n1 \<le> n2 then (CN n1 c1 (lin_add r1 (CN n2 c2 r2)))
     else (CN n2 c2 (lin_add (CN n1 c1 r1) r2)))"
| "lin_add (CN n1 c1 r1) t = CN n1 c1 (lin_add r1 t)"
| "lin_add t (CN n2 c2 r2) = CN n2 c2 (lin_add t r2)"
| "lin_add (C b1) (C b2) = C (b1 + b2)"
| "lin_add a b = Add a b"

lemma lin_add:
  "Inum (lin_add t s) bs = Inum (Add t s) bs"
  apply (induct t s rule: lin_add.induct, simp_all add: Let_def)
  apply (case_tac "c1+c2 = 0",case_tac "n1 \<le> n2", simp_all)
  apply (case_tac "n1 = n2", simp_all add: algebra_simps)
  done

fun lin_mul :: "num \<Rightarrow> nat \<Rightarrow> num"
where
  "lin_mul (C j) i = C (i * j)"
| "lin_mul (CN n c a) i = (if i=0 then (C 0) else CN n (i * c) (lin_mul a i))"
| "lin_mul t i = (Mul i t)"

lemma lin_mul:
  "Inum (lin_mul t i) bs = Inum (Mul i t) bs"
  by (induct t i rule: lin_mul.induct) (auto simp add: algebra_simps)

fun linum:: "num \<Rightarrow> num"
where
  "linum (C b) = C b"
| "linum (Var n) = CN n 1 (C 0)"
| "linum (Add t s) = lin_add (linum t) (linum s)"
| "linum (Mul c t) = lin_mul (linum t) c"
| "linum (CN n c t) = lin_add (linum (Mul c (Var n))) (linum t)"

lemma linum [reflection]:
  "Inum (linum t) bs = Inum t bs"
  by (induct t rule: linum.induct) (simp_all add: lin_mul lin_add)

text \<open>Now we can use linum to simplify nat terms using reflection\<close>

lemma "Suc (Suc 1) * (x + Suc 1 * y) = 3 * x + 6 * y"
  apply (reflection Inum_eqs' only: "Suc (Suc 1) * (x + Suc 1 * y)")
oops

text \<open>Let's lift this to formulae and see what happens\<close>

datatype aform = Lt num num  | Eq num num | Ge num num | NEq num num |
  Conj aform aform | Disj aform aform | NEG aform | T | F

primrec linaformsize:: "aform \<Rightarrow> nat"
where
  "linaformsize T = 1"
| "linaformsize F = 1"
| "linaformsize (Lt a b) = 1"
| "linaformsize (Ge a b) = 1"
| "linaformsize (Eq a b) = 1"
| "linaformsize (NEq a b) = 1"
| "linaformsize (NEG p) = 2 + linaformsize p"
| "linaformsize (Conj p q) = 1 + linaformsize p + linaformsize q"
| "linaformsize (Disj p q) = 1 + linaformsize p + linaformsize q"

lemma [measure_function]: "is_measure linaformsize" ..

primrec is_aform :: "aform => nat list => bool"
where
  "is_aform T vs = True"
| "is_aform F vs = False"
| "is_aform (Lt a b) vs = (Inum a vs < Inum b vs)"
| "is_aform (Eq a b) vs = (Inum a vs = Inum b vs)"
| "is_aform (Ge a b) vs = (Inum a vs \<ge> Inum b vs)"
| "is_aform (NEq a b) vs = (Inum a vs \<noteq> Inum b vs)"
| "is_aform (NEG p) vs = (\<not> (is_aform p vs))"
| "is_aform (Conj p q) vs = (is_aform p vs \<and> is_aform q vs)"
| "is_aform (Disj p q) vs = (is_aform p vs \<or> is_aform q vs)"

text\<open>Let's reify and do reflection\<close>
lemma "(3::nat) * x + t < 0 \<and> (2 * x + y \<noteq> 17)"
  apply (reify Inum_eqs' is_aform.simps)
oops

text \<open>Note that reification handles several interpretations at the same time\<close>
lemma "(3::nat) * x + t < 0 \<and> x * x + t * x + 3 + 1 = z * t * 4 * z \<or> x + x + 1 < 0"
  apply (reflection Inum_eqs' is_aform.simps only: "x + x + 1")
oops

text \<open>For reflection we now define a simple transformation on aform: NNF + linum on atoms\<close>

fun linaform:: "aform \<Rightarrow> aform"
where
  "linaform (Lt s t) = Lt (linum s) (linum t)"
| "linaform (Eq s t) = Eq (linum s) (linum t)"
| "linaform (Ge s t) = Ge (linum s) (linum t)"
| "linaform (NEq s t) = NEq (linum s) (linum t)"
| "linaform (Conj p q) = Conj (linaform p) (linaform q)"
| "linaform (Disj p q) = Disj (linaform p) (linaform q)"
| "linaform (NEG T) = F"
| "linaform (NEG F) = T"
| "linaform (NEG (Lt a b)) = Ge a b"
| "linaform (NEG (Ge a b)) = Lt a b"
| "linaform (NEG (Eq a b)) = NEq a b"
| "linaform (NEG (NEq a b)) = Eq a b"
| "linaform (NEG (NEG p)) = linaform p"
| "linaform (NEG (Conj p q)) = Disj (linaform (NEG p)) (linaform (NEG q))"
| "linaform (NEG (Disj p q)) = Conj (linaform (NEG p)) (linaform (NEG q))"
| "linaform p = p"

lemma linaform: "is_aform (linaform p) vs = is_aform p vs"
  by (induct p rule: linaform.induct) (auto simp add: linum)

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps rules: linaform)
oops

declare linaform [reflection]

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps)
oops

text \<open>We now give an example where interpretaions have zero or more than only
  one envornement of different types and show that automatic reification also deals with
  bindings\<close>

datatype rb = BC bool | BAnd rb rb | BOr rb rb

primrec Irb :: "rb \<Rightarrow> bool"
where
  "Irb (BC p) \<longleftrightarrow> p"
| "Irb (BAnd s t) \<longleftrightarrow> Irb s \<and> Irb t"
| "Irb (BOr s t) \<longleftrightarrow> Irb s \<or> Irb t"

lemma "A \<and> (B \<or> D \<and> B) \<and> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B)"
  apply (reify Irb.simps)
oops

datatype rint = IC int | IVar nat | IAdd rint rint | IMult rint rint
  | INeg rint | ISub rint rint

primrec Irint :: "rint \<Rightarrow> int list \<Rightarrow> int"
where
  Irint_Var: "Irint (IVar n) vs = vs ! n"
| Irint_Neg: "Irint (INeg t) vs = - Irint t vs"
| Irint_Add: "Irint (IAdd s t) vs = Irint s vs + Irint t vs"
| Irint_Sub: "Irint (ISub s t) vs = Irint s vs - Irint t vs"
| Irint_Mult: "Irint (IMult s t) vs = Irint s vs * Irint t vs"
| Irint_C: "Irint (IC i) vs = i"

lemma Irint_C0: "Irint (IC 0) vs = 0"
  by simp

lemma Irint_C1: "Irint (IC 1) vs = 1"
  by simp

lemma Irint_Cnumeral: "Irint (IC (numeral x)) vs = numeral x"
  by simp

lemmas Irint_simps = Irint_Var Irint_Neg Irint_Add Irint_Sub Irint_Mult Irint_C0 Irint_C1 Irint_Cnumeral

lemma "(3::int) * x + y * y - 9 + (- z) = 0"
  apply (reify Irint_simps ("(3::int) * x + y * y - 9 + (- z)"))
  oops

datatype rlist = LVar nat | LEmpty | LCons rint rlist | LAppend rlist rlist

primrec Irlist :: "rlist \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> int list"
where
  "Irlist (LEmpty) is vs = []"
| "Irlist (LVar n) is vs = vs ! n"
| "Irlist (LCons i t) is vs = Irint i is # Irlist t is vs"
| "Irlist (LAppend s t) is vs = Irlist s is vs @ Irlist t is vs"

lemma "[(1::int)] = []"
  apply (reify Irlist.simps Irint_simps ("[1] :: int list"))
  oops

lemma "([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs = [y * y - z - 9 + (3::int) * x]"
  apply (reify Irlist.simps Irint_simps ("([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs"))
  oops

datatype rnat = NC nat| NVar nat| NSuc rnat | NAdd rnat rnat | NMult rnat rnat
  | NNeg rnat | NSub rnat rnat | Nlgth rlist

primrec Irnat :: "rnat \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> nat list \<Rightarrow> nat"
where
  Irnat_Suc: "Irnat (NSuc t) is ls vs = Suc (Irnat t is ls vs)"
| Irnat_Var: "Irnat (NVar n) is ls vs = vs ! n"
| Irnat_Neg: "Irnat (NNeg t) is ls vs = 0"
| Irnat_Add: "Irnat (NAdd s t) is ls vs = Irnat s is ls vs + Irnat t is ls vs"
| Irnat_Sub: "Irnat (NSub s t) is ls vs = Irnat s is ls vs - Irnat t is ls vs"
| Irnat_Mult: "Irnat (NMult s t) is ls vs = Irnat s is ls vs * Irnat t is ls vs"
| Irnat_lgth: "Irnat (Nlgth rxs) is ls vs = length (Irlist rxs is ls)"
| Irnat_C: "Irnat (NC i) is ls vs = i"

lemma Irnat_C0: "Irnat (NC 0) is ls vs = 0"
  by simp

lemma Irnat_C1: "Irnat (NC 1) is ls vs = 1"
  by simp

lemma Irnat_Cnumeral: "Irnat (NC (numeral x)) is ls vs = numeral x"
  by simp

lemmas Irnat_simps = Irnat_Suc Irnat_Var Irnat_Neg Irnat_Add Irnat_Sub Irnat_Mult Irnat_lgth
  Irnat_C0 Irnat_C1 Irnat_Cnumeral

lemma "Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs) = length xs"
  apply (reify Irnat_simps Irlist.simps Irint_simps
     ("Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs)"))
  oops

datatype rifm = RT | RF | RVar nat
  | RNLT rnat rnat | RNILT rnat rint | RNEQ rnat rnat
  | RAnd rifm rifm | ROr rifm rifm | RImp rifm rifm| RIff rifm rifm
  | RNEX rifm | RIEX rifm | RLEX rifm | RNALL rifm | RIALL rifm | RLALL rifm
  | RBEX rifm | RBALL rifm

primrec Irifm :: "rifm \<Rightarrow> bool list \<Rightarrow> int list \<Rightarrow> (int list) list \<Rightarrow> nat list \<Rightarrow> bool"
where
  "Irifm RT ps is ls ns \<longleftrightarrow> True"
| "Irifm RF ps is ls ns \<longleftrightarrow> False"
| "Irifm (RVar n) ps is ls ns \<longleftrightarrow> ps ! n"
| "Irifm (RNLT s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns < Irnat t is ls ns"
| "Irifm (RNILT s t) ps is ls ns \<longleftrightarrow> int (Irnat s is ls ns) < Irint t is"
| "Irifm (RNEQ s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns = Irnat t is ls ns"
| "Irifm (RAnd p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<and> Irifm q ps is ls ns"
| "Irifm (ROr p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<or> Irifm q ps is ls ns"
| "Irifm (RImp p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<longrightarrow> Irifm q ps is ls ns"
| "Irifm (RIff p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns = Irifm q ps is ls ns"
| "Irifm (RNEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is ls (x # ns))"
| "Irifm (RIEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is (x # ls) ns)"
| "Irifm (RBEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p (x # ps) is ls ns)"
| "Irifm (RNALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is ls (x#ns))"
| "Irifm (RIALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is (x#ls) ns)"
| "Irifm (RBALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p (x # ps) is ls ns)"

lemma " \<forall>x. \<exists>n. ((Suc n) * length (([(3::int) * x + f t * y - 9 + (- z)] @ []) @ xs) = length xs) \<and> m < 5*n - length (xs @ [2,3,4,x*z + 8 - y]) \<longrightarrow> (\<exists>p. \<forall>q. p \<and> q \<longrightarrow> r)"
  apply (reify Irifm.simps Irnat_simps Irlist.simps Irint_simps)
oops

text \<open>An example for equations containing type variables\<close>

datatype prod = Zero | One | Var nat | Mul prod prod
  | Pw prod nat | PNM nat nat prod

primrec Iprod :: " prod \<Rightarrow> ('a::linordered_idom) list \<Rightarrow>'a"
where
  "Iprod Zero vs = 0"
| "Iprod One vs = 1"
| "Iprod (Var n) vs = vs ! n"
| "Iprod (Mul a b) vs = Iprod a vs * Iprod b vs"
| "Iprod (Pw a n) vs = Iprod a vs ^ n"
| "Iprod (PNM n k t) vs = (vs ! n) ^ k * Iprod t vs"

datatype sgn = Pos prod | Neg prod | ZeroEq prod | NZeroEq prod | Tr | F
  | Or sgn sgn | And sgn sgn

primrec Isgn :: "sgn \<Rightarrow> ('a::linordered_idom) list \<Rightarrow> bool"
where
  "Isgn Tr vs \<longleftrightarrow> True"
| "Isgn F vs \<longleftrightarrow> False"
| "Isgn (ZeroEq t) vs \<longleftrightarrow> Iprod t vs = 0"
| "Isgn (NZeroEq t) vs \<longleftrightarrow> Iprod t vs \<noteq> 0"
| "Isgn (Pos t) vs \<longleftrightarrow> Iprod t vs > 0"
| "Isgn (Neg t) vs \<longleftrightarrow> Iprod t vs < 0"
| "Isgn (And p q) vs \<longleftrightarrow> Isgn p vs \<and> Isgn q vs"
| "Isgn (Or p q) vs \<longleftrightarrow> Isgn p vs \<or> Isgn q vs"

lemmas eqs = Isgn.simps Iprod.simps

lemma "(x::'a::{linordered_idom}) ^ 4 * y * z * y ^ 2 * z ^ 23 > 0"
  apply (reify eqs)
  oops

end


theory Sep_SP
 imports
 Sep_Forward
 SP
begin

named_theorems sep_sp

ML {*
fun attrib thm ctxt thm' =
    ( [thm'] MRS thm)
    |> Goal.norm_result ctxt
  handle THM _ => thm'

fun try_then xs = Thm.rule_attribute [] (attrib xs o Context.proof_of )

*}

attribute_setup TRY_THEN = {* Attrib.thm >>  try_then *}

method sep_sp uses rl spec declares sep_sp  = (sp sp: spec[TRY_THEN sep_sp] rl )

lemma "(\<not>(P \<and>* (\<lambda>s. \<not> Q s)) s) = ((P \<leadsto>* Q) s)"
              "(\<not>((\<lambda>s. \<not> Q s) \<and>* P) s) = ((P \<leadsto>* Q) s)"
 apply (clarsimp simp: sep_coimpl_def pred_neg_def)
 by (clarsimp simp: sep_coimpl_def pred_neg_def sep_conj_commute)

lemma sep_conj_coimpl_precise: "(P \<and>* R) s \<Longrightarrow> precise P \<Longrightarrow> (P \<leadsto>* R) s"
  by (simp add: precise_conj_coimpl)

end


theory weird_nat_mul3acc_comm13
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

(*hipster add3acc mul3acc *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (mul3acc x y z) = (mul3acc z y x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section\<open>Firewall Basic Syntax\<close>
theory Firewall_Common
imports Main Simple_Firewall.Firewall_Common_Decision_State
  "Common/Repeat_Stabilize"
begin

text\<open>
Our firewall model supports the following actions.
\<close>
datatype action = Accept | Drop | Log | Reject | Call string | Return | Goto string | Empty | Unknown

text\<open>
We support the following algebra over primitives of type @{typ 'a}.
The type parameter @{typ 'a} denotes the primitive match condition. For example, matching
on source IP address or on protocol.
We lift the primitives to an algebra. Note that we do not have an Or expression.
\<close>
datatype 'a match_expr = Match 'a
                       | MatchNot "'a match_expr"
                       | MatchAnd "'a match_expr" "'a match_expr"
                       | MatchAny

definition MatchOr :: "'a match_expr \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr" where
  "MatchOr m1 m2 = MatchNot (MatchAnd (MatchNot m1) (MatchNot m2))"

text\<open>A firewall rule consists of a match expression and an action.\<close>
datatype 'a rule = Rule (get_match: "'a match_expr") (get_action: action)

lemma rules_singleton_rev_E:
  "[Rule m a] = rs\<^sub>1 @ rs\<^sub>2 \<Longrightarrow>
   (rs\<^sub>1 = [Rule m a] \<Longrightarrow> rs\<^sub>2 = [] \<Longrightarrow> P m a) \<Longrightarrow>
   (rs\<^sub>1 = [] \<Longrightarrow> rs\<^sub>2 = [Rule m a] \<Longrightarrow> P m a) \<Longrightarrow> P m a"
by (cases rs\<^sub>1) auto

section\<open>Basic Algorithms\<close>
text\<open>These algorithms should be valid for all firewall semantics.
     The corresponding proofs follow once the semantics are defined.\<close>

text\<open>The actions Log and Empty do not modify the packet processing in any way. They can be removed.\<close>
fun rm_LogEmpty :: "'a rule list \<Rightarrow> 'a rule list" where
  "rm_LogEmpty [] = []" |
  "rm_LogEmpty ((Rule _ Empty)#rs) = rm_LogEmpty rs" |
  "rm_LogEmpty ((Rule _ Log)#rs) = rm_LogEmpty rs" |
  "rm_LogEmpty (r#rs) = r # rm_LogEmpty rs"

lemma rm_LogEmpty_filter: "rm_LogEmpty rs = filter (\<lambda>r. get_action r \<noteq> Log \<and> get_action r \<noteq> Empty) rs"
 by(induction rs rule: rm_LogEmpty.induct) (simp_all)

lemma rm_LogEmpty_seq: "rm_LogEmpty (rs1@rs2) = rm_LogEmpty rs1 @ rm_LogEmpty rs2"
  by(simp add: rm_LogEmpty_filter)

text\<open>Optimize away MatchAny matches\<close>
fun opt_MatchAny_match_expr_once :: "'a match_expr \<Rightarrow> 'a match_expr" where
  "opt_MatchAny_match_expr_once MatchAny = MatchAny" |
  "opt_MatchAny_match_expr_once (Match a) = (Match a)" |
  "opt_MatchAny_match_expr_once (MatchNot (MatchNot m)) = (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchNot m) = MatchNot (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchAnd MatchAny MatchAny) = MatchAny" |
  "opt_MatchAny_match_expr_once (MatchAnd MatchAny m) = (opt_MatchAny_match_expr_once m)" |
  (*note: remove recursive call to opt_MatchAny_match_expr_once to make it probably faster*)
  "opt_MatchAny_match_expr_once (MatchAnd m MatchAny) = (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchAnd _ (MatchNot MatchAny)) = (MatchNot MatchAny)" |
  "opt_MatchAny_match_expr_once (MatchAnd (MatchNot MatchAny) _) = (MatchNot MatchAny)" |
  "opt_MatchAny_match_expr_once (MatchAnd m1 m2) = MatchAnd (opt_MatchAny_match_expr_once m1) (opt_MatchAny_match_expr_once m2)"
(* without recursive call: need to apply multiple times until it stabelizes *)

text\<open>It is still a good idea to apply @{const opt_MatchAny_match_expr_once} multiple times. Example:\<close>
lemma "MatchNot (opt_MatchAny_match_expr_once (MatchAnd MatchAny (MatchNot MatchAny))) = MatchNot (MatchNot MatchAny)" by simp
lemma "m = (MatchAnd (MatchAnd MatchAny MatchAny) (MatchAnd MatchAny MatchAny)) \<Longrightarrow>
  (opt_MatchAny_match_expr_once^^2) m \<noteq> opt_MatchAny_match_expr_once m" by(simp add: funpow_def)

definition opt_MatchAny_match_expr :: "'a match_expr \<Rightarrow> 'a match_expr" where
  "opt_MatchAny_match_expr m \<equiv> repeat_stabilize 2 opt_MatchAny_match_expr_once m"

text\<open>Rewrite @{const Reject} actions to @{const Drop} actions.
      If we just care about the filtering decision (@{const FinalAllow} or @{const FinalDeny}), they should be equal.\<close>
fun rw_Reject :: "'a rule list \<Rightarrow> 'a rule list" where
  "rw_Reject [] = []" |
  "rw_Reject ((Rule m Reject)#rs) = (Rule m Drop)#rw_Reject rs" |
  "rw_Reject (r#rs) = r # rw_Reject rs"

text\<open>We call a ruleset simple iff the only actions are @{const Accept} and @{const Drop}\<close>
  definition simple_ruleset :: "'a rule list \<Rightarrow> bool" where
    "simple_ruleset rs \<equiv> \<forall>r \<in> set rs. get_action r = Accept \<or> get_action r = Drop"

  lemma simple_ruleset_tail: "simple_ruleset (r#rs) \<Longrightarrow> simple_ruleset rs" by (simp add: simple_ruleset_def)

  lemma simple_ruleset_append: "simple_ruleset (rs\<^sub>1 @ rs\<^sub>2) \<longleftrightarrow> simple_ruleset rs\<^sub>1 \<and> simple_ruleset rs\<^sub>2"
    by(simp add: simple_ruleset_def, blast)

text\<open>Structural properties about match expressions\<close>
  fun has_primitive :: "'a match_expr \<Rightarrow> bool" where
    "has_primitive MatchAny = False" |
    "has_primitive (Match a) = True" |
    "has_primitive (MatchNot m) = has_primitive m" |
    "has_primitive (MatchAnd m1 m2) = (has_primitive m1 \<or> has_primitive m2)"

  text\<open>Is a match expression equal to the @{const MatchAny} expression?
        Only applicable if no primitives are in the expression.\<close>
  fun matcheq_matchAny :: "'a match_expr \<Rightarrow> bool" where
    "matcheq_matchAny MatchAny \<longleftrightarrow> True" |
    "matcheq_matchAny (MatchNot m) \<longleftrightarrow> \<not> (matcheq_matchAny m)" |
    "matcheq_matchAny (MatchAnd m1 m2) \<longleftrightarrow> matcheq_matchAny m1 \<and> matcheq_matchAny m2" |
    "matcheq_matchAny (Match _) = undefined"

  fun matcheq_matchNone :: "'a match_expr \<Rightarrow> bool" where
    "matcheq_matchNone MatchAny = False" |
    "matcheq_matchNone (Match _) = False" |
    "matcheq_matchNone (MatchNot MatchAny) = True" |
    "matcheq_matchNone (MatchNot (Match _)) = False" |
    "matcheq_matchNone (MatchNot (MatchNot m)) = matcheq_matchNone m" |
    "matcheq_matchNone (MatchNot (MatchAnd m1 m2)) \<longleftrightarrow> matcheq_matchNone (MatchNot m1) \<and> matcheq_matchNone (MatchNot m2)" |
    "matcheq_matchNone (MatchAnd m1 m2) \<longleftrightarrow>  matcheq_matchNone m1 \<or> matcheq_matchNone m2"

  lemma matachAny_matchNone: "\<not> has_primitive m \<Longrightarrow> matcheq_matchAny m \<longleftrightarrow> \<not> matcheq_matchNone m"
    by(induction m rule: matcheq_matchNone.induct)(simp_all)

  lemma matcheq_matchNone_no_primitive: "\<not> has_primitive m \<Longrightarrow> matcheq_matchNone (MatchNot m) \<longleftrightarrow> \<not> matcheq_matchNone m"
    by(induction m rule: matcheq_matchNone.induct) (simp_all)

text\<open>optimizing match expressions\<close>

fun optimize_matches_option :: "('a match_expr \<Rightarrow> 'a match_expr option) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
  "optimize_matches_option _ [] = []" |
  "optimize_matches_option f (Rule m a#rs) = (case f m of None \<Rightarrow> optimize_matches_option f rs | Some m \<Rightarrow> (Rule m a)#optimize_matches_option f rs)"

lemma optimize_matches_option_preserves:
  "(\<And> r m. r \<in> set rs \<Longrightarrow> f (get_match r) = Some m \<Longrightarrow> P m) \<Longrightarrow>
    \<forall> r \<in> set (optimize_matches_option f rs). P (get_match r)"
  apply(induction rs rule: optimize_matches_option.induct)
   apply(simp; fail)
  apply(simp split: option.split)
  by fastforce
(*
lemma optimize_matches_option_preserves':
  "\<forall> m \<in> set rs. P (get_match m) \<Longrightarrow> \<forall>m. P m \<longrightarrow> (\<forall>m'. f m = Some m' \<longrightarrow> P m') \<Longrightarrow> \<forall>m \<in> set (optimize_matches_option f rs). P (get_match m)"
  using optimize_matches_option_preserves[simplified] by metis
*)
lemma optimize_matches_option_append: "optimize_matches_option f (rs1@rs2) = optimize_matches_option f rs1 @ optimize_matches_option f rs2"
  proof(induction rs1 rule: optimize_matches_option.induct)
  qed(simp_all split: option.split)

definition optimize_matches :: "('a match_expr \<Rightarrow> 'a match_expr) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
  "optimize_matches f rs =  optimize_matches_option (\<lambda>m. (if matcheq_matchNone (f m) then None else Some (f m))) rs"

lemma optimize_matches_append: "optimize_matches f (rs1@rs2) = optimize_matches f rs1 @ optimize_matches f rs2"
  by(simp add: optimize_matches_def optimize_matches_option_append)

(*Warning: simplifier loops with this lemma*)
lemma optimize_matches_fst: "optimize_matches f (r#rs) = optimize_matches f [r]@optimize_matches f rs"
by(cases r)(simp add: optimize_matches_def)

lemma optimize_matches_preserves: "(\<And> r. r \<in> set rs \<Longrightarrow> P (f (get_match r))) \<Longrightarrow>
    \<forall> r \<in> set (optimize_matches f rs). P (get_match r)"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_preserves)
  by(auto split: if_split_asm)

lemma optimize_matches_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (optimize_matches f rs)"
  by(simp add: optimize_matches_def optimize_matches_option_simple_ruleset)

definition optimize_matches_a :: "(action \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
  "optimize_matches_a f rs = map (\<lambda>r. Rule (f (get_action r) (get_match r)) (get_action r)) rs"

lemma optimize_matches_a_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (optimize_matches_a f rs)"
  by(simp add: optimize_matches_a_def simple_ruleset_def)

lemma optimize_matches_a_simple_ruleset_eq:
  "simple_ruleset rs \<Longrightarrow> (\<And> m a. a = Accept \<or> a = Drop \<Longrightarrow> f1 a m = f2 a m) \<Longrightarrow> optimize_matches_a f1 rs = optimize_matches_a f2 rs"
apply(induction rs)
 apply(simp add: optimize_matches_a_def)
apply(simp add: optimize_matches_a_def)
apply(simp add: simple_ruleset_def)
done

lemma optimize_matches_a_preserves: "(\<And> r. r \<in> set rs \<Longrightarrow> P (f (get_action r) (get_match r)))
    \<Longrightarrow> \<forall> r \<in> set (optimize_matches_a f rs). P (get_match r)"
  by(induction rs)(simp_all add: optimize_matches_a_def)

end


subsection \<open>Polynomial Reductions\<close>

theory Polynomial_Reductions
  imports NREST.Refine_Foreach Reductions "Poly_Reductions_Lib.Polynomial_Growth_Functions"
begin

text \<open>
A program @{term_type "c :: 'a\<Rightarrow>'b nrest"}
is a poly_reduction wrt to a reduction @{term_type "red :: 'a\<Rightarrow>'b\<Rightarrow>bool"}
and a measure for the size of the problem  @{term_type "m :: 'a \<Rightarrow> nat"}
if there is a time funtion \<open>f\<close>, such that
  \<^item> \<open>f\<close> polynomial
  \<^item> and for any \<open>pi\<close>, \<open>c\<close> calculates a correct result in time \<open>f (m pi)\<close>
\<close>
definition "ispolyred c A B ma mb = (\<exists>f p ps. \<forall>pi. c pi \<le> SPEC (\<lambda>y. y = f pi) (\<lambda>_. p (ma pi))
                              \<and>  (\<forall>pi. mb (f pi) \<le> ps (ma pi))
                                   \<and> poly p \<and> poly ps \<and> is_reduction f A B )"

definition "ispolyredd c RI RO A B ma mb = (\<exists>f p ps. \<forall>pi pi'. ((pi',pi):RI \<longrightarrow>  c pi' \<le> \<Down>RO (SPEC (\<lambda>y. y = f pi) (\<lambda>_. p (ma pi))))
                              \<and>  (\<forall>pi. mb (f pi) \<le> ps (ma pi))
                                   \<and> poly p \<and> poly ps \<and> is_reduction f A B )"

lemma ispolyredd_generalizes_ispolyred:
  "ispolyred c A B ma mb = ispolyredd c Id Id A B ma mb"
  unfolding ispolyred_def ispolyredd_def by auto

lemma ispolyredd_generalizes_ispolyredD:
  "ispolyred c A B ma mb \<Longrightarrow> ispolyredd c Id Id A B ma mb"
  using ispolyredd_generalizes_ispolyred ..

thm conc_fun_chain

lemma ispolyredd_refine:
  assumes
    1: "ispolyredd c1 RA RB A B ma mb"
      and 2: "\<And>pi' pi''. (pi'',pi')\<in>RA' \<Longrightarrow>  c' pi'' \<le> \<Down>RB' (c1 pi')"
  shows
    "ispolyredd c' (RA' O RA) (RB' O RB) A B ma mb"
proof -
  from 1 obtain f1 p1 ps1 where
     spec1: "\<And>pi pi'. (pi',pi)\<in>RA \<Longrightarrow> c1 pi' \<le> \<Down>RB (SPEC (\<lambda>y. y = f1 pi) (\<lambda>_.  (p1 (ma pi))))"
   and size1: "\<And>pi. mb (f1 pi) \<le> ps1 (ma pi)"
    and p1: "poly p1" "poly ps1" and "is_reduction f1 A B" unfolding ispolyredd_def by blast

  show ?thesis
    unfolding ispolyredd_def
    apply(rule exI[where x=f1])
    apply(rule exI[where x=p1])
    apply(rule exI[where x=ps1])
    apply safe
    subgoal  apply(rule order.trans)
       apply(rule 2) apply simp
      apply(rule order.trans)
       apply(rule nrest_Rel_mono)
      apply(rule spec1) apply simp
      apply(subst conc_fun_chain) by simp
    subgoal by fact
    subgoal by fact
    subgoal by fact
    subgoal by fact
    done
qed

lemma poly_monoE:
  assumes "poly p2"
  obtains p2' where "\<And>x. p2 x \<le> p2' x" "poly p2'" "mono p2'"
  using assms by (intro that[where p2' = "make_mono p2"]) (auto simp: poly_make_mono_iff)

lemma ispolyredd_trans:
  assumes 1: "ispolyredd c1 RA RB A B ma mb"
    and 2: "ispolyredd c2 RB RC B C mb mc"
  shows
      "ispolyredd (\<lambda>a. bind (c1 a) c2) RA RC A C ma mc"
proof -
  from 1 obtain f1 p1 ps1 where
     spec1: "\<And>pi pi'. (pi',pi)\<in>RA \<Longrightarrow> c1 pi' \<le> \<Down>RB (SPEC (\<lambda>y. y = f1 pi) (\<lambda>_.  (p1 (ma pi))))"
   and size1: "\<And>pi. mb (f1 pi) \<le> ps1 (ma pi)"
    and p1: "poly p1" "poly ps1" and "is_reduction f1 A B" unfolding ispolyredd_def by blast

  from 2 obtain f2 p2 ps2 where
      spec2: "\<And>pi pi'. (pi',pi)\<in>RB \<Longrightarrow> c2 pi' \<le> \<Down>RC (SPEC (\<lambda>y. y = f2 pi) (\<lambda>_. enat (p2 (mb pi))))"
    and size2: "\<And>pi. mc (f2 pi) \<le> ps2 (mb pi)"
     and p2: "poly p2" "poly ps2" "is_reduction f2 B C" unfolding ispolyredd_def by blast

  thm spec1[unfolded SPEC_def ]
  thm spec2[unfolded SPEC_def ]

  from \<open>poly p2\<close> obtain p2' where p2'_ub: "\<And>x. p2 x \<le> p2' x" and p2'_poly: "poly p2'"
    and   p2'_mono: "\<And>i j. i\<le>j \<Longrightarrow> p2' i \<le> p2' j"
    by - (erule poly_monoE, auto simp: mono_def)

  obtain ps2' where "\<And>x. ps2 x \<le> ps2' x" and ps2'_poly: "poly ps2'"
    and   ps2'_mono: "\<And>i j. i\<le>j \<Longrightarrow> ps2 i \<le> ps2' j"
    subgoal premises that
      using \<open>poly ps2\<close>
      apply -
      apply (erule poly_monoE)
      apply (rule that)
        apply (auto simp: mono_def intro: order.trans)
      done
    done

  show ?thesis
    unfolding ispolyredd_def
    apply(rule exI[where x="f2 o f1"])
    apply(rule exI[where x="\<lambda>n. p1 n + p2' (ps1 n)"])
    apply(rule exI[where x="\<lambda>n. ps2' (ps1 n)"])
    apply safe
    subgoal unfolding SPEC_def
      apply(rule order.trans)
       apply(rule bindT_refine)
      apply (rule spec1) apply simp
       apply (rule spec2) apply simp
      apply(rule nrest_Rel_mono)
  apply(rule T_specifies_I)
      apply(vcg' \<open>-\<close> rules: T_SPEC )
      apply (auto split: if_splits)
      subgoal apply(rule order_trans[OF p2'_ub]) using size1 p2'_mono
        by auto
      done
    subgoal apply simp  apply(rule order_trans[OF size2])
      apply(rule ps2'_mono) by(rule size1)
    subgoal
      using p1 p2'_poly by(auto intro: poly_compose[unfolded comp_def])
    subgoal
      using p1 ps2'_poly by(auto intro: poly_compose[unfolded comp_def])
    subgoal
      apply(rule is_reduction_trans) by fact+
    done
qed

lemma ispolyred_trans:
  "ispolyred c1 A B ma mb \<Longrightarrow> ispolyred c2 B C mb mc
    \<Longrightarrow> ispolyred (\<lambda>a. bind (c1 a) c2) A C ma mc"
  using ispolyredd_generalizes_ispolyred ispolyredd_trans by metis

end


section \<open>Strong Eventual Consistency \label{sec:strong_eventual_consistency}\<close>

theory SEC
  imports StrongConvergence
begin

text \<open>In the following theorem we establish that all reached states are successful. This
implies with the unconditional termination property (Section \ref{sec:integrate_term}) of it that
the integration algorithm never fails.\<close>

theorem (in dist_execution) no_failure:
  fixes i
  assumes "is_valid_state_id i"
  shows "isOK (state i)"
  apply (cases "state i")
  by (metis assms state_is_associated_string is_certified_associated_string.simps(2), simp)

text \<open>The following theorem establishes that any pair of peers having received the same
set of updates, will be in the same state.\<close>

theorem (in dist_execution) strong_convergence:
  assumes "is_valid_state_id i"
  assumes "is_valid_state_id j"
  assumes "set (received_messages i) = set (received_messages j)"
  shows "state i = state j"
  using state_is_associated_string is_certified_associated_string_unique by (metis assms)

text \<open>As we noted in Section~\ref{sec:networkModel}, we have not assumed eventual delivery, but
  a corollary of this theorem with the eventual delivery assumption implies eventual consistency.
  Since finally all peer would have received all messages, i.e., an equal set.\<close>

section \<open>Code generation\<close>

export_code integrate create_insert create_delete in Haskell
  module_name WOOT file_prefix "code"

section \<open>Proof Outline\label{sec:proof_outline}\<close>

text \<open>
  In this section we outline and motivate the approach we took to prove the strong eventual
  consistency of WOOT.

  While introducing operation-based CRDTs Shapiro et al. also establish
  \<^cite>\<open>"shapiro2011conflict"\<close>[Theorem 2.2]. If the following two conditions are met:
  \begin{itemize}
    \item
      Concurrent operations commute, i.e., if a pair of operations @{text "m\<^sub>1"},
      @{text "m\<^sub>2"} is concurrent with respect to the order induced by the happened-before
      relation, and they are both applicable to a state @{text "s"}, then the message
      @{text "m\<^sub>1"} (resp. @{text "m\<^sub>2"}) is still applicable on the state reached by
      applying  @{text "m\<^sub>2"} (resp. @{text "m\<^sub>1"}) on @{text "s"} and the resulting
      states are equal.
    \item Assuming causal delivery, the messages are applicable.
  \end{itemize}
  Then the CRDT has strong convergence.
  The same authors extend the above result in \<^cite>\<open>\<open>Proposition 2.2\<close> in "shapiro:inria-00555588"\<close>
  to more general delivery orders $\xrightarrow{d}$ (weaker than the one induced by the
  happened-before relation), i.e., two messages may be causally dependent but concurrent with
  respect to $\xrightarrow{d}$. Assuming operations that are concurrent with respect to
  $\xrightarrow{d}$ commute, and messages are applicable, when the
  delivery order respects $\xrightarrow{d}$ then again the CRDT has strong convergence.

  A key difficulty of the consistency proof of the WOOT framework is that the applicability
  condition for the WOOT framework has three constraints:
  \begin{enumerate}
    \item \label{en:proof:deps_are_met} Dependencies must be met.
    \item \label{en:proof:id_distinct} Identifiers must be distinct.
    \item The order must be consistent, i.e. the predecessor W-character must appear before the
      successor W-character in the state an insert message is being integrated.
  \end{enumerate}

  The first constraint is a direct consequence of the semantic causal delivery order. The uniqueness
  of identifiers can be directly established by analyzing the implementation of the message creation
  algorithms. Alternatively, Gomes et al.~\<^cite>\<open>"gomes2017verifying"\<close> use an axiomatic approach, where
  they require the underlying network protocol to deliver messages with unique identifiers. They
  provide a formal framework in Isabelle/HOL that can be used to show consistency of arbitrary
  CRDTs. Their results could be used to establish constraints \ref{en:proof:deps_are_met} and
  \ref{en:proof:id_distinct}.

  The last constraint is the most intricate one, and forces us to use a different method to
  establish the strong eventual consistency. The fact that the order constraint is fulfilled is a
  consequence of the consistency property. But the current fundamental lemmas require applicability
  of the operations in the first place to establish consistency, which would result in a circular
  argument.

  Zeller et. al. actually predict the above circumstance in the context of state-based CRDTs
  \<^cite>\<open>"DBLP:conf/forte/ZellerBP14"\<close>:
  \begin{displayquote}
  In theory it could even be the case that there are two reachable states for which the merge
  operation does not yield the correct result, but where the two states can never be reached in the
  same execution.
  \end{displayquote}

  Because of the above, we treat WOOT as a distributed message passing algorithm and show
  convergence by establishing a global invariant, which is maintained during the execution of the
  framework. The invariant captures that the W-characters appear in the same order on all peers.
  It has strong convergence as a consequence, in the special case, when peers have received
  the same set of updates. It also implies that the generated messages will be applicable.

  \begin{figure}
    \centering
    \begin{tikzpicture}[
      statenode/.style={circle, draw=black, fill=black!20, thick, minimum size=5mm},
      curstatenode/.style={circle, draw=black, fill=black!60, thick, minimum size=5mm},
      peernode/.style={rectangle, draw=black, thick, minimum size=5mm},
    ]
    %Nodes
    \node[peernode] (peerA) at (1.5cm, 3cm) {Peer A};
    \node[peernode] (peerB) at (1.5cm, 2cm) {Peer B};
    \node[peernode] (peerC) at (1.5cm, 1cm) {Peer C};
    \node[statenode] (stateA2) at (4cm, 3cm) {};
    \node[curstatenode] (stateB2) at (5cm, 2cm) {};
    \node[statenode] (stateC2) at (3.5cm, 1cm) {};
    \node[statenode] (stateA3) at (5.5cm, 3cm) {};
    \node[statenode] (stateB3) at (7cm, 2cm) {};
    \node[statenode] (stateC3) at (6.5cm, 1cm) {};
    \node[statenode] (stateA4) at (7.5cm, 3cm) {};
    \draw[->] (peerA.east) -- (stateA2.west);
    \draw[->] (peerB.east) -- (stateB2.west);
    \draw[->] (peerC.east) -- (stateC2.west);
    \draw[->] (stateA2.east) -- (stateA3.west);
    \draw[->] (stateB2.east) -- (stateB3.west);
    \draw[->] (stateC2.east) -- (stateC3.west);
    \draw[->] (stateC2) -- (stateA2);
    \draw[->] (stateC2) -- (stateB2);
    \draw[->] (stateA3) -- (stateC3);
    \draw[->] (stateA3) -- (stateB3);
    \draw[->] (stateA3) -- (stateA4);
    \draw (5cm,3.5cm) to[bend right] (4.8cm,0.5cm);
    \end{tikzpicture}
    \caption{Example state graph, where the consistency is established left of the bend curve.}
    \label{fig:state_graph}
  \end{figure}

  In Figure~\ref{fig:state_graph}, we exemplify an induction step in a proof over the execution
  of the framework. The invariant is established for all states left of the dashed lines, and we
  show that it remains true if we include the state, drawn in dark gray. Note that induction
  proceeds in an order consistent with the happened-before relation.

  The technique we are using is to define a relation @{term is_associated_string} from a set of
  messages to the final state their application leads to. Crucially, that relation can be defined
  in a message-order independent way. We show that it correctly models the behaviour of Algorithm
  @{term "integrate"} by establishing that applying the integration algorithm to the associated
  string of a set @{term "M"} leads to the associated string of the set @{term "M \<union> {m}"}
  in Proposition @{thm [source] integrate_insert_commute}.

  We also show that at most one @{text s} fulfills @{term "is_associated_string M s"},
  which automatically implies commutativity (cf. Lemma @{thm [source] "associated_string_unique"}).

  Note that the domain of the relation @{term "is_associated_string"} consists of the sets of
  messages that we call @{term "consistent"}. We show that, in every state of a peer, the set of
  received messages will be consistent.
  The main ingredient required for the definition of a consistent set of messages as the relation
  @{term "is_associated_string"} are \emph{sort keys} associated to the W-characters, which we will
  explain in the following Section.
\<close>

subsection \<open> Sort Keys \<close>

text \<open>
  There is an implicit sort key, which is deterministically computable, using the immutable data
  associated to a W-character and the data of the W-characters it (transitively) depends on.

  We show that Algorithm @{term "integrate"} effectively maintains the W-characters ordered with
  respect to that sort key, which is the reason we can construct the mapping
  @{term "is_associated_string"} in a message-order
  independent way. An alternative viewpoint would be to see Algorithm @{term "integrate_insert"} as
  an optimized version of a more mundane algorithm, that just inserts the W-characters using this
  implicit sort key.

  Since the sort key is deterministically computable using the immutable data associated to a
  W-character and the data of the W-characters it (transitively) depends on, all peers could
  perform this computation independently, which leads to the conclusion that the W-characters
  will be ordered consistently across all peers.

  The construction relies on a combinator @{term "\<Psi>"} that computes the sort key for a
  W-character, and which requires as input:
  \begin{itemize}
    \item The unique identifier associated to a W-character.
    \item The sort keys of the predecessor/successor W-characters.
  \end{itemize}
  Its values are elements of a totally ordered space.

  Note that the predecessor (resp. successor) W-character of a W-character is the W-character that
  was immediately before (resp. after) it at the time it was inserted. Like its unique identifier,
  it is immutable data associated with that W-character. Sometimes a W-character is inserted at the
  beginning (resp. end) of the string. For those W-characters, we use the special smallest
  (resp. largest) sort keys, denoted by @{term "\<turnstile>"} (resp. @{term "\<stileturn>"}) as predecessor
  (resp. successor). These keys themselves are never associated to a W-character.

  We will write @{term "\<Psi> (l,u) i"} for the value computed by the combinator for a W-character
  with identifier @{term "i"}, assuming the sort key of its predecessor (resp. successor) is
  @{term "l"} (resp. @{term "u"}).

  For example, the sort key for a W-character with identifier @{term "i"} inserted in an empty
  string (hence its predecessor is @{term "\<turnstile>"} and its successor is @{term "\<stileturn>"})
  will be  @{term "\<Psi> (\<turnstile>,\<stileturn>) i"}. A W-character
  inserted between that character and the end of the string, with identifier j, would be assigned
  the sort key @{term "\<Psi> (\<lbrakk>\<Psi> (\<turnstile>,\<stileturn>) i\<rbrakk>,\<stileturn>) j"}.

  The sort key needs to fulfill a couple of properties, to be useful:

  There should never be a pair of W-characters with the same sort key. Note, if this happens, even
  if those W-characters were equal or ordered consistently, we would not be able to insert a new
  W-character between those W-characters.

  Since the W-characters have themselves unique identifiers, a method to insure the above property
  is to require that @{term "\<Psi>"} be injective with respect to the identifier of the W-character
  it computes a sort key for, i.e.,
  @{term "\<Psi> (l,u) i = \<Psi> (l',u') i' \<Longrightarrow> i = i'"}.

  Another essential property is that the W-characters with predecessor having the sort key
  @{term "l"} and successor having the sort key @{term "u"}  should have a sort key that is between
  @{term "l"} and @{term "u"}, such that the W-character is inserted between the preceding and
  succeeding W-character, i.e., @{text "l < \<Psi> (l,u) i < u"}.

  This latter property ensures intention preservation, i.e. the inserted W-character will be placed
  at the place the user intended.

  If we review function @{term "concurrent"}, then we see that the algorithm compares W-characters
  by identifier, in the special case, when the inserted W-character is compared to a W-character
  whose predecessor and successor are outside of the range it is to be inserted in. A careful
  investigation, leads to the conclusion that:

  If @{text "l \<le> l' < \<Psi> (l,u) i < u' \<le> u"} then @{text "\<Psi>(l,u) i"} can be compared
  with @{text "\<Psi>(l',u') i'"} by comparing @{text "i"} with @{text "i'"}, i.e.:
  \begin{itemize}
    \item @{text "i < i' \<Longrightarrow> \<Psi> (l,u) i < \<Psi>(l',u') i'"}
  \end{itemize}

  In Section \ref{sec:psi} we show that a combinator @{term "\<Psi>"} with the above properties can
  be constructed (cf. Propositions @{thm [source] psi_narrow psi_mono psi_elem}).
  Using the sort keys we can define the notion of a consistent set of messages as well as the
  relation @{term "is_associated_string"} in a message-order independent way.\<close>

subsection \<open> Induction \<close>

text \<open>
  We have a couple of criteria that define a consistent set of messages:

  \begin{itemize}
    \item Each insert message in the set has a unique identifier.
    \item If a message depends on another message identifier, a message with that identifier will
      be present. Note that for insert messages, these are the predecessor/successor W-characters
      if present. For delete messages it is the corresponding insert message.
    \item The dependencies form a well-order, i.e., there is no dependency cycle.
    \item It is possible to assign sort keys to each insert message, such that
      the assigned sort key for each insert message is equal to the value returned by the
      @{term "\<Psi>"} for it, using the associated sort keys of its predecessor and successors,
      i.e.,
      @{term "a (P m) < a (S m) \<and>
              a \<lbrakk>I m\<rbrakk> = \<lbrakk>\<Psi> (a (P m), a (S m)) (I m)\<rbrakk>"}.
      Note that we also require that sort key of the predecessor is smaller than the sort key of the
      successor.
  \end{itemize}

  The relation @{term "is_associated_string"} is then defined by ordering the insert messages
  according to the assigned sort keys above and marking W-characters, for which there are delete
  messages as deleted.

  The induction proof (Lemma @{thm [source] dist_execution.sent_messages_consistent}) over the
  states of the framework is straight forward: Using Lemma @{thm [source] top_sort} we find a
  possible order of the states consistent with the happened before relation. The induction invariant
  is that the set of generated messages by all peers is
  consistent (independent of whether they have been received by all peers (yet)). The latter also
  implies that the subset a peer has received in any of those states is consistent, using the
  additional fact that each messages dependencies will be delivered before the message itself
  (see also Lemma @{thm [source] consistent_subset} and
  Proposition @{thm [source] integrate_insert_commute'}).
  For the induction step, we rely on the results from Section \ref{sec:create_consistent} that any
  additional created messages will keep the set of messages consistent and that the peers' states
  will be consistent with the (consistent subset of) messages they received (Lemma @{thm [source]
  dist_execution.state_is_associated_string'}).\<close>
end