section\<open>Network Interfaces\<close>
theory Iface
imports String
        "~~/src/HOL/Library/Char_ord" (*WARNING: importing char ord*)
begin

text\<open>Network interfaces, e.g. \texttt{eth0}, \texttt{wlan1}, ...

iptables supports wildcard matching, e.g. \texttt{eth+} will match \texttt{eth}, \texttt{eth1}, \texttt{ethFOO}, ...
The character `+' is only a wildcard if it appears at the end.
\<close>

datatype iface = Iface (iface_sel: "string")  --"no negation supported, but wildcards"

text\<open>Just a normal lexicographical ordering on the interface strings. Used only for optimizing code.
     WARNING: not a semantic ordering.\<close>
(*We cannot use List_lexord because it clashed with the Word_Lib imported ordering!*)
instantiation iface :: linorder
begin
  function (sequential) less_eq_iface :: "iface \<Rightarrow> iface \<Rightarrow> bool" where
    "(Iface []) \<le> (Iface _) \<longleftrightarrow> True" |
    "(Iface _) \<le> (Iface []) \<longleftrightarrow> False" |
    "(Iface (a#as)) \<le> (Iface (b#bs)) \<longleftrightarrow> (if a = b then Iface as \<le> Iface bs else a \<le> b)"
   by(pat_completeness) auto
  termination "less_eq :: iface \<Rightarrow> _ \<Rightarrow> bool"
    apply(relation "measure (\<lambda>is. size (iface_sel (fst is)) + size (iface_sel (snd is)))")
    apply(rule wf_measure, unfold in_measure comp_def)
    apply(simp)
    done

  lemma Iface_less_eq_empty: "Iface x \<le> Iface [] \<Longrightarrow> x = []"
    by(induction "Iface x" "Iface []" rule: less_eq_iface.induct) auto
  lemma less_eq_empty: "Iface [] \<le> q"
    by(induction "Iface []" q rule: less_eq_iface.induct) auto
  lemma iface_cons_less_eq_i:
    "Iface (b # bs) \<le> i \<Longrightarrow> \<exists> q qs. i=Iface (q#qs) \<and> (b < q \<or> (Iface bs) \<le> (Iface qs))"
    apply(induction "Iface (b # bs)" i rule: less_eq_iface.induct)
     apply(simp_all split: if_split_asm)
    apply(clarify)
    apply(simp)
    done

  function (sequential) less_iface :: "iface \<Rightarrow> iface \<Rightarrow> bool" where
    "(Iface []) < (Iface []) \<longleftrightarrow> False" |
    "(Iface []) < (Iface _) \<longleftrightarrow> True" |
    "(Iface _) < (Iface []) \<longleftrightarrow> False" |
    "(Iface (a#as)) < (Iface (b#bs)) \<longleftrightarrow> (if a = b then Iface as < Iface bs else a < b)"
   by(pat_completeness) auto
  termination "less :: iface \<Rightarrow> _ \<Rightarrow> bool"
    apply(relation "measure (\<lambda>is. size (iface_sel (fst is)) + size (iface_sel (snd is)))")
    apply(rule wf_measure, unfold in_measure comp_def)
    apply(simp)
    done
instance
  proof
    fix n m :: iface
    show "n < m \<longleftrightarrow> n \<le> m \<and> \<not> m \<le> n"
      proof(induction rule: less_iface.induct)
      case 4 thus ?case by simp fastforce
      qed(simp+)
  next
    fix n :: iface have "n = m \<Longrightarrow> n \<le> m" for m
      by(induction n m rule: less_eq_iface.induct) simp+
    thus "n \<le> n" by simp
  next
    fix n m :: iface
    show "n \<le> m \<Longrightarrow> m \<le> n \<Longrightarrow> n = m"
      proof(induction n m rule: less_eq_iface.induct)
      case 1 thus ?case using Iface_less_eq_empty by blast
      next
      case 3 thus ?case by (simp split: if_split_asm)
      qed(simp)+
  next
    fix n m q :: iface show "n \<le> m \<Longrightarrow> m \<le> q \<Longrightarrow> n \<le> q"
      proof(induction n q arbitrary: m rule: less_eq_iface.induct)
      case 1 thus ?case by simp
      next
      case 2 thus ?case
        apply simp
        apply(drule iface_cons_less_eq_i)
        apply(elim exE conjE disjE)
         apply(simp; fail)
        by fastforce
      next
      case 3 thus ?case
        apply simp
        apply(frule iface_cons_less_eq_i)
         by(auto split: if_split_asm)
      qed
  next
    fix n m :: iface show "n \<le> m \<or> m \<le> n"
      apply(induction n m rule: less_eq_iface.induct)
        apply(simp_all)
      by fastforce
  qed
end

definition ifaceAny :: iface where
  "ifaceAny \<equiv> Iface ''+''"
(* there is no IfaceFalse, proof below *)

text\<open>If the interface name ends in a ``+'', then any interface which begins with this name will match.
  (man iptables)

Here is how iptables handles this wildcard on my system.
A packet for the loopback interface \texttt{lo} is matched by the following expressions
  \<^item> lo
  \<^item> lo+
  \<^item> l+
  \<^item> +

It is not matched by the following expressions
  \<^item> lo++
  \<^item> lo+++
  \<^item> lo1+
  \<^item> lo1

By the way: \texttt{Warning: weird characters in interface ` ' ('/' and ' ' are not allowed by the kernel).}
However, happy snowman and shell colors are fine.
\<close>

context
begin
  subsection\<open>Helpers for the interface name (@{typ string})\<close>
    (*Do not use outside this thy! Type is really misleading.*)
    text\<open>
      argument 1: interface as in firewall rule - Wildcard support
      argument 2: interface a packet came from - No wildcard support\<close>
    fun internal_iface_name_match :: "string \<Rightarrow> string \<Rightarrow> bool" where
      "internal_iface_name_match []     []         \<longleftrightarrow> True" |
      "internal_iface_name_match (i#is) []         \<longleftrightarrow> (i = CHR ''+'' \<and> is = [])" |
      "internal_iface_name_match []     (_#_)      \<longleftrightarrow> False" |
      "internal_iface_name_match (i#is) (p_i#p_is) \<longleftrightarrow> (if (i = CHR ''+'' \<and> is = []) then True else (
            (p_i = i) \<and> internal_iface_name_match is p_is
      ))"

    (*<*)
    --"Examples"
      lemma "internal_iface_name_match ''lo'' ''lo''" by eval
      lemma "internal_iface_name_match ''lo+'' ''lo''" by eval
      lemma "internal_iface_name_match ''l+'' ''lo''" by eval
      lemma "internal_iface_name_match ''+'' ''lo''" by eval
      lemma "\<not> internal_iface_name_match ''lo++'' ''lo''" by eval
      lemma "\<not> internal_iface_name_match ''lo+++'' ''lo''" by eval
      lemma "\<not> internal_iface_name_match ''lo1+'' ''lo''" by eval
      lemma "\<not> internal_iface_name_match ''lo1'' ''lo''" by eval
      text\<open>The wildcard interface name\<close>
      lemma "internal_iface_name_match ''+'' ''''" by eval (*>*)

    fun iface_name_is_wildcard :: "string \<Rightarrow> bool" where
      "iface_name_is_wildcard [] \<longleftrightarrow> False" |
      "iface_name_is_wildcard [s] \<longleftrightarrow> s = CHR ''+''" |
      "iface_name_is_wildcard (_#ss) \<longleftrightarrow> iface_name_is_wildcard ss"
    private lemma iface_name_is_wildcard_alt: "iface_name_is_wildcard eth \<longleftrightarrow> eth \<noteq> [] \<and> last eth = CHR ''+''"
      proof(induction eth rule: iface_name_is_wildcard.induct)
      qed(simp_all)
    private lemma iface_name_is_wildcard_alt': "iface_name_is_wildcard eth \<longleftrightarrow> eth \<noteq> [] \<and> hd (rev eth) = CHR ''+''"
      unfolding iface_name_is_wildcard_alt using hd_rev by fastforce
    private lemma iface_name_is_wildcard_fst: "iface_name_is_wildcard (i # is) \<Longrightarrow> is \<noteq> [] \<Longrightarrow> iface_name_is_wildcard is"
      by(simp add: iface_name_is_wildcard_alt)

    private fun internal_iface_name_to_set :: "string \<Rightarrow> string set" where
      "internal_iface_name_to_set i = (if \<not> iface_name_is_wildcard i
        then
          {i}
        else
          {(butlast i)@cs | cs. True})"
    private lemma "{(butlast i)@cs | cs. True} = (\<lambda>s. (butlast i)@s) ` (UNIV::string set)" by fastforce
    private lemma internal_iface_name_to_set: "internal_iface_name_match i p_iface \<longleftrightarrow> p_iface \<in> internal_iface_name_to_set i"
      proof(induction i p_iface rule: internal_iface_name_match.induct)
      case 4 thus ?case
        apply(simp)
        apply(safe)
               apply(simp_all add: iface_name_is_wildcard_fst)
         apply (metis (full_types) iface_name_is_wildcard.simps(3) list.exhaust)
        by (metis append_butlast_last_id)
      qed(simp_all)
    private lemma internal_iface_name_to_set2: "internal_iface_name_to_set ifce = {i. internal_iface_name_match ifce i}"
      by (simp add: internal_iface_name_to_set)

    private lemma internal_iface_name_match_refl: "internal_iface_name_match i i"
     proof -
     { fix i j
       have "i=j \<Longrightarrow> internal_iface_name_match i j"
         by(induction i j rule: internal_iface_name_match.induct)(simp_all)
     } thus ?thesis by simp
     qed

  subsection\<open>Matching\<close>
    fun match_iface :: "iface \<Rightarrow> string \<Rightarrow> bool" where
      "match_iface (Iface i) p_iface \<longleftrightarrow> internal_iface_name_match i p_iface"

    --"Examples"
      lemma "  match_iface (Iface ''lo'')    ''lo''"
            "  match_iface (Iface ''lo+'')   ''lo''"
            "  match_iface (Iface ''l+'')    ''lo''"
            "  match_iface (Iface ''+'')     ''lo''"
            "\<not> match_iface (Iface ''lo++'')  ''lo''"
            "\<not> match_iface (Iface ''lo+++'') ''lo''"
            "\<not> match_iface (Iface ''lo1+'')  ''lo''"
            "\<not> match_iface (Iface ''lo1'')   ''lo''"
            "  match_iface (Iface ''+'')     ''eth0''"
            "  match_iface (Iface ''+'')     ''eth0''"
            "  match_iface (Iface ''eth+'')  ''eth0''"
            "\<not> match_iface (Iface ''lo+'')   ''eth0''"
            "  match_iface (Iface ''lo+'')   ''loX''"
            "\<not> match_iface (Iface '''')      ''loX''"
            (*<*)by eval+(*>*)

    lemma match_ifaceAny: "match_iface ifaceAny i"
      by(cases i, simp_all add: ifaceAny_def)
    lemma match_IfaceFalse: "\<not>(\<exists> IfaceFalse. (\<forall>i. \<not> match_iface IfaceFalse i))"
      apply(simp)
      apply(intro allI, rename_tac IfaceFalse)
      apply(case_tac IfaceFalse, rename_tac name)
      apply(rule_tac x="name" in exI)
      by(simp add: internal_iface_name_match_refl)

    --\<open>@{const match_iface} explained by the individual cases\<close>
    lemma match_iface_case_nowildcard: "\<not> iface_name_is_wildcard i \<Longrightarrow> match_iface (Iface i) p_i \<longleftrightarrow> i = p_i"
      proof(induction i p_i rule: internal_iface_name_match.induct)
      qed(auto simp add: iface_name_is_wildcard_alt split: if_split_asm)
    lemma match_iface_case_wildcard_prefix:
      "iface_name_is_wildcard i \<Longrightarrow> match_iface (Iface i) p_i \<longleftrightarrow> butlast i = take (length i - 1) p_i"
      apply(induction i p_i rule: internal_iface_name_match.induct)
         apply(simp; fail)
        apply(simp add: iface_name_is_wildcard_alt split: if_split_asm; fail)
       apply(simp; fail)
      apply(simp)
      apply(intro conjI)
       apply(simp add: iface_name_is_wildcard_alt split: if_split_asm; fail)
      apply(simp add: iface_name_is_wildcard_fst)
      by (metis One_nat_def length_0_conv list.sel(1) list.sel(3) take_Cons')
    lemma match_iface_case_wildcard_length: "iface_name_is_wildcard i \<Longrightarrow> match_iface (Iface i) p_i \<Longrightarrow> length p_i \<ge> (length i - 1)"
      proof(induction i p_i rule: internal_iface_name_match.induct)
      qed(simp_all add: iface_name_is_wildcard_alt split: if_split_asm)
    corollary match_iface_case_wildcard:
      "iface_name_is_wildcard i \<Longrightarrow> match_iface (Iface i) p_i \<longleftrightarrow> butlast i = take (length i - 1) p_i \<and> length p_i \<ge> (length i - 1)"
      using match_iface_case_wildcard_length match_iface_case_wildcard_prefix by blast

    lemma match_iface_set: "match_iface (Iface i) p_iface \<longleftrightarrow> p_iface \<in> internal_iface_name_to_set i"
      using internal_iface_name_to_set by simp

    private definition internal_iface_name_wildcard_longest :: "string \<Rightarrow> string \<Rightarrow> string option" where
      "internal_iface_name_wildcard_longest i1 i2 = (
        if
          take (min (length i1 - 1) (length i2 - 1)) i1 = take (min (length i1 - 1) (length i2 - 1)) i2
        then
          Some (if length i1 \<le> length i2 then i2 else i1)
        else
          None)"
    private lemma "internal_iface_name_wildcard_longest ''eth+'' ''eth3+'' = Some ''eth3+''" by eval
    private lemma "internal_iface_name_wildcard_longest ''eth+'' ''e+'' = Some ''eth+''" by eval
    private lemma "internal_iface_name_wildcard_longest ''eth+'' ''lo'' = None" by eval

    private  lemma internal_iface_name_wildcard_longest_commute: "iface_name_is_wildcard i1 \<Longrightarrow> iface_name_is_wildcard i2 \<Longrightarrow>
      internal_iface_name_wildcard_longest i1 i2 = internal_iface_name_wildcard_longest i2 i1"
      apply(simp add: internal_iface_name_wildcard_longest_def)
      apply(safe)
        apply(simp_all add: iface_name_is_wildcard_alt)
        apply (metis One_nat_def append_butlast_last_id butlast_conv_take)
       by (metis min.commute)+
    private  lemma internal_iface_name_wildcard_longest_refl: "internal_iface_name_wildcard_longest i i = Some i"
      by(simp add: internal_iface_name_wildcard_longest_def)

    private lemma internal_iface_name_wildcard_longest_correct:
      "iface_name_is_wildcard i1 \<Longrightarrow> iface_name_is_wildcard i2 \<Longrightarrow>
       match_iface (Iface i1) p_i \<and> match_iface (Iface i2) p_i \<longleftrightarrow>
       (case internal_iface_name_wildcard_longest i1 i2 of None \<Rightarrow> False | Some x \<Rightarrow> match_iface (Iface x) p_i)"
    proof -
      assume assm1: "iface_name_is_wildcard i1"
         and assm2: "iface_name_is_wildcard i2"
      { assume assm3: "internal_iface_name_wildcard_longest i1 i2 = None"
        have "\<not> (internal_iface_name_match i1 p_i \<and> internal_iface_name_match i2 p_i)"
        proof -
          from match_iface_case_wildcard_prefix[OF assm1] have 1:
            "internal_iface_name_match i1 p_i = (take (length i1 - 1) i1 = take (length i1 - 1) p_i)" by(simp add: butlast_conv_take)
          from match_iface_case_wildcard_prefix[OF assm2] have 2:
            "internal_iface_name_match i2 p_i = (take (length i2 - 1) i2 = take (length i2 - 1) p_i)" by(simp add: butlast_conv_take)
          from assm3 have 3: "take (min (length i1 - 1) (length i2 - 1)) i1 \<noteq> take (min (length i1 - 1) (length i2 - 1)) i2"
           by(simp add: internal_iface_name_wildcard_longest_def split: if_split_asm)
          from 3 show ?thesis using 1 2 min.commute take_take by metis
        qed
      } note internal_iface_name_wildcard_longest_correct_None=this

      { fix X
        assume assm3: "internal_iface_name_wildcard_longest i1 i2 = Some X"
        have "(internal_iface_name_match i1 p_i \<and> internal_iface_name_match i2 p_i) \<longleftrightarrow> internal_iface_name_match X p_i"
        proof -
          from assm3 have assm3': "take (min (length i1 - 1) (length i2 - 1)) i1 = take (min (length i1 - 1) (length i2 - 1)) i2"
            unfolding internal_iface_name_wildcard_longest_def by(simp split: if_split_asm)

          { fix i1 i2
            assume iw1: "iface_name_is_wildcard i1" and iw2: "iface_name_is_wildcard i2" and len: "length i1 \<le> length i2" and
                   take_i1i2: "take (length i1 - 1) i1 = take (length i1 - 1) i2"
            from len have len': "length i1 - 1 \<le> length i2 - 1" by fastforce
            { fix x::string
             from len' have "take (length i1 - 1) x = take (length i1 - 1) (take (length i2 - 1) x)" by(simp add: min_def)
            } note takei1=this

            { fix m::nat and n::nat and a::string and b c
              have "m \<le> n \<Longrightarrow> take n a = take n b \<Longrightarrow> take m a = take m c \<Longrightarrow> take m c = take m b" by (metis min_absorb1 take_take)
            } note takesmaller=this

            from match_iface_case_wildcard_prefix[OF iw1, simplified] have 1:
                "internal_iface_name_match i1 p_i \<longleftrightarrow> take (length i1 - 1) i1 = take (length i1 - 1) p_i" by(simp add: butlast_conv_take)
            also have "\<dots> \<longleftrightarrow> take (length i1 - 1) (take (length i2 - 1) i1) = take (length i1 - 1) (take (length i2 - 1) p_i)" using takei1 by simp
            finally have  "internal_iface_name_match i1 p_i = (take (length i1 - 1) (take (length i2 - 1) i1) = take (length i1 - 1) (take (length i2 - 1) p_i))" .
            from match_iface_case_wildcard_prefix[OF iw2, simplified] have 2:
                "internal_iface_name_match i2 p_i \<longleftrightarrow> take (length i2 - 1) i2 = take (length i2 - 1) p_i" by(simp add: butlast_conv_take)

            have "internal_iface_name_match i2 p_i \<Longrightarrow> internal_iface_name_match i1 p_i"
              unfolding 1 2
              apply(rule takesmaller[of "(length i1 - 1)" "(length i2 - 1)" i2 p_i])
                using len' apply (simp; fail)
               apply (simp; fail)
              using take_i1i2 by simp
          } note longer_iface_imp_shorter=this

         show ?thesis
          proof(cases "length i1 \<le> length i2")
          case True
            with assm3 have "X = i2" unfolding internal_iface_name_wildcard_longest_def by(simp split: if_split_asm)
            from True assm3' have take_i1i2: "take (length i1 - 1) i1 = take (length i1 - 1) i2" by linarith
            from longer_iface_imp_shorter[OF assm1 assm2 True take_i1i2] \<open>X = i2\<close>
            show "(internal_iface_name_match i1 p_i \<and> internal_iface_name_match i2 p_i) \<longleftrightarrow> internal_iface_name_match X p_i" by fastforce
          next
          case False
            with assm3 have "X = i1" unfolding internal_iface_name_wildcard_longest_def by(simp split: if_split_asm)
            from False assm3' have take_i1i2: "take (length i2 - 1) i2 = take (length i2 - 1) i1" by (metis min_def min_diff)
            from longer_iface_imp_shorter[OF assm2 assm1 _ take_i1i2] False \<open>X = i1\<close>
            show "(internal_iface_name_match i1 p_i \<and> internal_iface_name_match i2 p_i) \<longleftrightarrow> internal_iface_name_match X p_i" by auto
          qed
        qed
      } note internal_iface_name_wildcard_longest_correct_Some=this

      from internal_iface_name_wildcard_longest_correct_None internal_iface_name_wildcard_longest_correct_Some show ?thesis
        by(simp split:option.split)
    qed

    fun iface_conjunct :: "iface \<Rightarrow> iface \<Rightarrow> iface option" where
      "iface_conjunct (Iface i1) (Iface i2) = (case (iface_name_is_wildcard i1, iface_name_is_wildcard i2) of
        (True,  True) \<Rightarrow> map_option Iface  (internal_iface_name_wildcard_longest i1 i2) |
        (True,  False) \<Rightarrow> (if match_iface (Iface i1) i2 then Some (Iface i2) else None) |
        (False, True) \<Rightarrow> (if match_iface (Iface i2) i1 then Some (Iface i1) else None) |
        (False, False) \<Rightarrow> (if i1 = i2 then Some (Iface i1) else None))"

    lemma iface_conjunct_Some: "iface_conjunct i1 i2 = Some x \<Longrightarrow>
          match_iface x p_i \<longleftrightarrow> match_iface i1 p_i \<and> match_iface i2 p_i"
      apply(cases i1, cases i2, rename_tac i1name i2name)
      apply(simp)
      apply(case_tac "iface_name_is_wildcard i1name")
       apply(case_tac [!] "iface_name_is_wildcard i2name")
         apply(simp_all)
         using internal_iface_name_wildcard_longest_correct apply auto[1]
        apply (metis match_iface.simps match_iface_case_nowildcard option.distinct(1) option.sel)
       apply (metis match_iface.simps match_iface_case_nowildcard option.distinct(1) option.sel)
      by (metis match_iface.simps option.distinct(1) option.inject)
    lemma iface_conjunct_None: "iface_conjunct i1 i2 = None \<Longrightarrow> \<not> (match_iface i1 p_i \<and> match_iface i2 p_i)"
      apply(cases i1, cases i2, rename_tac i1name i2name)
      apply(simp split: bool.split_asm if_split_asm)
         using internal_iface_name_wildcard_longest_correct apply fastforce
        apply (metis match_iface.simps match_iface_case_nowildcard)+
      done
    lemma iface_conjunct: "match_iface i1 p_i \<and> match_iface i2 p_i \<longleftrightarrow>
           (case iface_conjunct i1 i2 of None \<Rightarrow> False | Some x \<Rightarrow> match_iface x p_i)"
    apply(simp split: option.split)
    by(blast dest: iface_conjunct_Some iface_conjunct_None)

    lemma match_iface_refl: "match_iface (Iface x) x" by (simp add: internal_iface_name_match_refl)
    lemma match_iface_eqI: assumes "x = Iface y" shows "match_iface x y"
      unfolding assms using match_iface_refl .

    lemma iface_conjunct_ifaceAny: "iface_conjunct ifaceAny i = Some i"
      apply(simp add: ifaceAny_def)
      apply(case_tac i, rename_tac iname)
      apply(simp)
      apply(case_tac "iface_name_is_wildcard iname")
       apply(simp add: internal_iface_name_wildcard_longest_def iface_name_is_wildcard_alt Suc_leI; fail)
      apply(simp)
      using internal_iface_name_match.elims(3) by fastforce

    lemma iface_conjunct_commute: "iface_conjunct i1 i2 = iface_conjunct i2 i1"
    apply(induction i1 i2 rule: iface_conjunct.induct)
    apply(rename_tac i1 i2, simp)
    apply(case_tac "iface_name_is_wildcard i1")
     apply(case_tac [!] "iface_name_is_wildcard i2")
       apply(simp_all)
    by (simp add: internal_iface_name_wildcard_longest_commute)

    private definition internal_iface_name_subset :: "string \<Rightarrow> string \<Rightarrow> bool" where
      "internal_iface_name_subset i1 i2 = (case (iface_name_is_wildcard i1, iface_name_is_wildcard i2) of
        (True,  True) \<Rightarrow> length i1 \<ge> length i2 \<and> take ((length i2) - 1) i1 = butlast i2 |
        (True,  False) \<Rightarrow> False |
        (False, True) \<Rightarrow> take (length i2 - 1) i1 = butlast i2 |
        (False, False) \<Rightarrow> i1 = i2
        )"

    private lemma butlast_take_length_helper:
      fixes x ::"char list"
      assumes a1: "length i2 \<le> length i1"
      assumes a2: "take (length i2 - Suc 0) i1 = butlast i2"
      assumes a3: "butlast i1 = take (length i1 - Suc 0) x"
      shows "butlast i2 = take (length i2 - Suc 0) x"
    proof - (*sledgehammer spass Isar proof*)
      have f4: "List.gen_length 0 i2 \<le> List.gen_length 0 i1"
        using a1 by (simp add: length_code)
      have f5: "\<And>cs. List.gen_length 0 (cs::char list) - Suc 0 = List.gen_length 0 (tl cs)"
        by (metis (no_types) One_nat_def length_code length_tl)
      obtain nn :: "(nat \<Rightarrow> nat) \<Rightarrow> nat" where
        "\<And>f. \<not> f (nn f) \<le> f (Suc (nn f)) \<or> f (List.gen_length 0 i2) \<le> f (List.gen_length 0 i1)"
        using f4 by (meson lift_Suc_mono_le)
      hence "\<not> nn (\<lambda>n. n - Suc 0) - Suc 0 \<le> nn (\<lambda>n. n - Suc 0) \<or> List.gen_length 0 (tl i2) \<le> List.gen_length 0 (tl i1)"
        using f5 by (metis (lifting) diff_Suc_Suc diff_zero)
      hence f6: "min (List.gen_length 0 (tl i2)) (List.gen_length 0 (tl i1)) = List.gen_length 0 (tl i2)"
        using diff_le_self min.absorb1 by blast
      { assume "take (List.gen_length 0 (tl i2)) i1 \<noteq> take (List.gen_length 0 (tl i2)) x"
        have "List.gen_length 0 (tl i2) = 0 \<or> take (List.gen_length 0 (tl i2)) i1 = take (List.gen_length 0 (tl i2)) x"
          using f6 f5 a3 by (metis (lifting) One_nat_def butlast_conv_take length_code take_take)
        hence "take (List.gen_length 0 (tl i2)) i1 = take (List.gen_length 0 (tl i2)) x"
          by force }
      thus "butlast i2 = take (length i2 - Suc 0) x"
        using f5 a2 by (metis (full_types) length_code)
    qed

    private lemma internal_iface_name_subset: "internal_iface_name_subset i1 i2 \<longleftrightarrow>
        {i. internal_iface_name_match i1 i} \<subseteq> {i. internal_iface_name_match i2 i}"
      unfolding internal_iface_name_subset_def
      proof(cases "iface_name_is_wildcard i1", case_tac [!] "iface_name_is_wildcard i2", simp_all)
        assume a1: "iface_name_is_wildcard i1"
        assume a2: "iface_name_is_wildcard i2"
        show "(length i2 \<le> length i1 \<and> take (length i2 - Suc 0) i1 = butlast i2) \<longleftrightarrow>
            ({i. internal_iface_name_match i1 i} \<subseteq> {i. internal_iface_name_match i2 i})" (is "?l \<longleftrightarrow> ?r")
          proof(rule iffI)
            assume ?l with a1 a2 show ?r
             apply(clarify, rename_tac x)
             apply(drule_tac p_i=x in match_iface_case_wildcard_prefix)+
             apply(simp)
             using butlast_take_length_helper by blast
          next
            assume ?r hence r': "internal_iface_name_to_set i1 \<subseteq> internal_iface_name_to_set i2 "
              apply -
              apply(subst(asm) internal_iface_name_to_set2[symmetric])+
              by assumption
            have hlp1: "\<And>i1 i2. {x. \<exists>cs. x = i1 @ cs} \<subseteq> {x. \<exists>cs. x = i2 @ cs} \<Longrightarrow> length i2 \<le> length i1"
              apply(simp add: Set.Collect_mono_iff)
              by force
            have hlp2: "\<And>i1 i2. {x. \<exists>cs. x = i1 @ cs} \<subseteq> {x. \<exists>cs. x = i2 @ cs} \<Longrightarrow> take (length i2) i1 = i2"
              apply(simp add: Set.Collect_mono_iff)
              by force
            from r' a1 a2 show ?l
              apply(simp add: internal_iface_name_to_set)
              apply(safe)
               apply(drule hlp1)
               apply(simp)
               apply (metis One_nat_def Suc_pred diff_Suc_eq_diff_pred diff_is_0_eq iface_name_is_wildcard.simps(1) length_greater_0_conv)
              apply(drule hlp2)
              apply(simp)
              by (metis One_nat_def butlast_conv_take length_butlast length_take take_take)
          qed
      next
      show "iface_name_is_wildcard i1 \<Longrightarrow> \<not> iface_name_is_wildcard i2 \<Longrightarrow>
            \<not> Collect (internal_iface_name_match i1) \<subseteq> Collect (internal_iface_name_match i2)"
        using internal_iface_name_match_refl match_iface_case_nowildcard by fastforce
      next
      show "\<not> iface_name_is_wildcard i1 \<Longrightarrow> iface_name_is_wildcard i2 \<Longrightarrow>
            (take (length i2 - Suc 0) i1 = butlast i2) \<longleftrightarrow> ({i. internal_iface_name_match i1 i} \<subseteq> {i. internal_iface_name_match i2 i})"
        using match_iface_case_nowildcard match_iface_case_wildcard_prefix by force
      next
      show " \<not> iface_name_is_wildcard i1 \<Longrightarrow> \<not> iface_name_is_wildcard i2 \<Longrightarrow>
           (i1 = i2) \<longleftrightarrow> ({i. internal_iface_name_match i1 i} \<subseteq> {i. internal_iface_name_match i2 i})"
        using match_iface_case_nowildcard  by force
      qed

    definition iface_subset :: "iface \<Rightarrow> iface \<Rightarrow> bool" where
      "iface_subset i1 i2 \<longleftrightarrow> internal_iface_name_subset (iface_sel i1) (iface_sel i2)"

    lemma iface_subset: "iface_subset i1 i2 \<longleftrightarrow> {i. match_iface i1 i} \<subseteq> {i. match_iface i2 i}"
      unfolding iface_subset_def
      apply(cases i1, cases i2)
      by(simp add: internal_iface_name_subset)

    definition iface_is_wildcard :: "iface \<Rightarrow> bool" where
      "iface_is_wildcard ifce \<equiv> iface_name_is_wildcard (iface_sel ifce)"

    lemma iface_is_wildcard_ifaceAny: "iface_is_wildcard ifaceAny"
      by(simp add: iface_is_wildcard_def ifaceAny_def)

  subsection\<open>Enumerating Interfaces\<close>
    private definition all_chars :: "char list" where
      "all_chars \<equiv> Enum.enum"
    private lemma all_chars: "set all_chars = (UNIV::char set)"
       by(simp add: all_chars_def enum_UNIV)

    text\<open>we can compute this, but its horribly inefficient!\<close>
    (*valid chars in an interface are NOT limited to the printable ones!*)
    private lemma strings_of_length_n: "set (List.n_lists n all_chars) = {s::string. length s = n}"
      apply(induction n)
       apply(simp; fail)
      apply(simp add: all_chars)
      apply(safe)
       apply(simp; fail)
      apply(simp)
      apply(rename_tac n x)
      apply(rule_tac x="drop 1 x" in exI)
      apply(simp)
      apply(case_tac x)
       apply(simp_all)
      done

    text\<open>Non-wildacrd interfaces of length @{term n}\<close>
    private definition non_wildcard_ifaces :: "nat \<Rightarrow> string list" where
     "non_wildcard_ifaces n \<equiv> filter (\<lambda>i. \<not> iface_name_is_wildcard i) (List.n_lists n all_chars)"

    text\<open>Example: (any number higher than zero are probably too inefficient)\<close>
    private lemma "non_wildcard_ifaces 0 = ['''']" by eval

    private lemma non_wildcard_ifaces: "set (non_wildcard_ifaces n) = {s::string. length s = n \<and> \<not> iface_name_is_wildcard s}"
      using strings_of_length_n non_wildcard_ifaces_def by auto

    private lemma "(\<Union> i \<in> set (non_wildcard_ifaces n). internal_iface_name_to_set i) = {s::string. length s = n \<and> \<not> iface_name_is_wildcard s}"
     by(simp add: non_wildcard_ifaces)

    text\<open>Non-wildacrd interfaces up to length @{term n}\<close>
    private fun non_wildcard_ifaces_upto :: "nat \<Rightarrow> string list" where
      "non_wildcard_ifaces_upto 0 = [[]]" |
      "non_wildcard_ifaces_upto (Suc n) = (non_wildcard_ifaces (Suc n)) @ non_wildcard_ifaces_upto n"
    private lemma non_wildcard_ifaces_upto: "set (non_wildcard_ifaces_upto n) = {s::string. length s \<le> n \<and> \<not> iface_name_is_wildcard s}"
      apply(induction n)
       apply fastforce
      using non_wildcard_ifaces by fastforce

  subsection\<open>Negating Interfaces\<close>
    private lemma inv_iface_name_set: "- (internal_iface_name_to_set i) = (
      if iface_name_is_wildcard i
      then
        {c |c. length c < length (butlast i)} \<union> {c @ cs |c cs. length c = length (butlast i) \<and> c \<noteq> butlast i}
      else
        {c | c. length c < length i} \<union> {c@cs | c cs. length c \<ge> length i \<and> c \<noteq> i}
    )"
    proof -
      { fix i::string
        have inv_i_wildcard: "- {i@cs | cs. True} = {c | c. length c < length i} \<union> {c@cs | c cs. length c = length i \<and> c \<noteq> i}"
          apply(rule Set.equalityI)
           prefer 2
           apply(safe)[1]
            apply(simp;fail)
           apply(simp;fail)
          apply(simp)
          apply(rule Compl_anti_mono[where B="{i @ cs |cs. True}" and A="- ({c | c. length c < length i} \<union> {c@cs | c cs. length c = length i \<and> c \<noteq> i})", simplified])
          apply(safe)
          apply(simp)
          apply(case_tac "(length i) = length x")
           apply(erule_tac x=x in allE, simp)
           apply(blast)
          apply(erule_tac x="take (length i) x" in allE)
          apply(simp add: min_def)
          by (metis append_take_drop_id)
      } note inv_i_wildcard=this
      { fix i::string
        have inv_i_nowildcard: "- {i::string} = {c | c. length c < length i} \<union> {c@cs | c cs. length c \<ge> length i \<and> c \<noteq> i}"
        proof -
          have x: "{c | c. length c = length i \<and> c \<noteq> i}  \<union> {c | c. length c > length i} = {c@cs | c cs. length c \<ge> length i \<and> c \<noteq> i}"
            apply(safe)
              apply force+
            done
          have "- {i::string} = {c |c . c \<noteq> i}"
           by(safe, simp)
          also have "\<dots> = {c | c. length c < length i} \<union> {c | c. length c = length i \<and> c \<noteq> i}  \<union> {c | c. length c > length i}"
            by(auto)
          finally show ?thesis using x by auto
        qed
      } note inv_i_nowildcard=this
    show ?thesis
      proof(cases "iface_name_is_wildcard i")
      case True with inv_i_wildcard show ?thesis by force
      next
      case False with inv_i_nowildcard show ?thesis by force
      qed
    qed

    text\<open>Negating is really not intuitive.
          The Interface @{term "''et''"} is in the negated set of @{term "''eth+''"}.
          And the Interface @{term "''et+''"} is also in this set! This is because @{term "''+''"}
          is a normal interface character and not a wildcard here!
          In contrast, the set described by @{term "''et+''"} (with @{term "''+''"} a wildcard)
          is not a subset of the previously negated set.\<close>
    lemma "''et'' \<in> - (internal_iface_name_to_set ''eth+'')" by(simp)
    lemma "''et+'' \<in> - (internal_iface_name_to_set ''eth+'')" by(simp)
    lemma "''+'' \<in> - (internal_iface_name_to_set ''eth+'')" by(simp)
    lemma "\<not> {i. match_iface (Iface ''et+'') i} \<subseteq> - (internal_iface_name_to_set ''eth+'')" by force

    text\<open>Because @{term "''+''"} can appear as interface wildcard and normal interface character,
          we cannot take negate an @{term "Iface i"} such that we get back @{typ "iface list"} which
          describe the negated interface.\<close>
    lemma "''+'' \<in> - (internal_iface_name_to_set ''eth+'')" by(simp)

  fun compress_pos_interfaces :: "iface list \<Rightarrow> iface option" where
    "compress_pos_interfaces [] = Some ifaceAny" |
    "compress_pos_interfaces [i] = Some i" |
    "compress_pos_interfaces (i1#i2#is) = (case iface_conjunct i1 i2 of None \<Rightarrow> None | Some i \<Rightarrow> compress_pos_interfaces (i#is))"

  lemma compress_pos_interfaces_Some: "compress_pos_interfaces ifces = Some ifce \<Longrightarrow>
          match_iface ifce p_i \<longleftrightarrow> (\<forall> i\<in> set ifces. match_iface i p_i)"
  proof(induction ifces rule: compress_pos_interfaces.induct)
    case 1 thus ?case by (simp add: match_ifaceAny)
    next
    case 2 thus ?case by simp
    next
    case (3 i1 i2) thus ?case
    apply(simp)
    apply(case_tac "iface_conjunct i1 i2")
     apply(simp; fail)
    apply(simp)
    using iface_conjunct_Some by presburger
  qed

  lemma compress_pos_interfaces_None: "compress_pos_interfaces ifces = None \<Longrightarrow>
          \<not> (\<forall> i\<in> set ifces. match_iface i p_i)"
  proof(induction ifces rule: compress_pos_interfaces.induct)
    case 1 thus ?case by (simp add: match_ifaceAny)
    next
    case 2 thus ?case by simp
    next
    case (3 i1 i2) thus ?case
      apply(cases "iface_conjunct i1 i2", simp_all)
       apply (blast dest: iface_conjunct_None)
      by (blast dest: iface_conjunct_Some)
  qed

  declare match_iface.simps[simp del]
  declare iface_name_is_wildcard.simps[simp del]
end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                  April 2006               |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_norm
imports CSP_F_law_basic CSP_T.CSP_T_law_norm
begin

(*********************************************************
                       ?-div
 *********************************************************)

lemma cspF_input_DIV:
  "? :A -> Pf =F[M,M] (? :A -> Pf [+] DIV) |~| ? a:A -> DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_input_DIV)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_failures in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)

(* <= *)
 apply (rule)
 apply (simp add: in_failures in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)
done

(*********************************************************
                    !!-!set-div
 *********************************************************)

lemma cspF_Rep_int_choice_sum_set_Ext_pre_choice_DIV:
  "!! c:C .. (!set X:(Xsf c) .. (? a:X -> DIV))
   =F[M1,M2] !set X:(Union {(Xsf c) |c. c : sumset C}) .. (? a:X -> DIV)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_set_Ext_pre_choice_DIV)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim disjE conjE bexE exE)

  apply (rule_tac x="Xsf c" in exI)
  apply (rule conjI)
  apply (force)

  apply (rule_tac x="Xa" in bexI)
  apply (simp)
  apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim disjE conjE exE bexE)
 apply (simp)
  apply (rule_tac x="c" in bexI)
  apply (rule_tac x="Xa" in bexI)
  apply (simp_all)
done

lemma cspF_Rep_int_choice_set_set_Ext_pre_choice_DIV:
  "!set Y:Ys .. (!set X:(Xsf Y) .. (? a:X -> DIV))
   =F[M1,M2] !set X:(Union {(Xsf Y) |Y. Y : Ys}) .. (? a:X -> DIV)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_set_Ext_pre_choice_DIV)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim disjE conjE bexE exE)

  apply (rule_tac x="Xsf Xa" in exI)
  apply (rule conjI)
  apply (force)

  apply (rule_tac x="Xb" in bexI)
  apply (simp)
  apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim disjE conjE exE bexE)
 apply (simp)
  apply (rule_tac x="Y" in bexI)
  apply (rule_tac x="Xa" in bexI)
  apply (simp_all)
done

lemma cspF_Rep_int_choice_nat_set_Ext_pre_choice_DIV:
  "!nat n:N .. (!set X:(Xsf n) .. (? a:X -> DIV))
   =F[M1,M2] !set X:(Union {(Xsf n) |n. n : N}) .. (? a:X -> DIV)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_set_Ext_pre_choice_DIV)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim disjE conjE bexE exE)

  apply (rule_tac x="Xsf n" in exI)
  apply (rule conjI)
  apply (force)

  apply (rule_tac x="Xa" in bexI)
  apply (simp)
  apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim disjE conjE exE bexE)
 apply (simp)
  apply (rule_tac x="n" in bexI)
  apply (rule_tac x="Xa" in bexI)
  apply (simp_all)
done

lemmas cspF_Rep_int_choice_set_Ext_pre_choice_DIV =
       cspF_Rep_int_choice_sum_set_Ext_pre_choice_DIV
       cspF_Rep_int_choice_set_set_Ext_pre_choice_DIV
       cspF_Rep_int_choice_nat_set_Ext_pre_choice_DIV

(*********************************************************
                      ?-!set-<=
 *********************************************************)

lemma cspF_input_Rep_int_choice_set_subset:
  "[| Xs <= Ys ; ALL Y:Ys. EX X:Xs. X <= Y & Y <= A |] ==>
   ((? :A -> Pf) [+] Q)
   |~| (!set X : Xs .. ? a:X -> DIV)
   =F[M,M]
   ((? :A -> Pf) [+] Q)
   |~| (!set Y : Ys .. ? a:Y -> DIV)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_input_Rep_int_choice_set_subset)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_failures)
 apply (elim disjE conjE bexE exE)
 apply (simp_all)
 apply (rule disjI2)
 apply (rule disjI2)
 apply (rule_tac x="Xa" in bexI)
 apply (simp)
 apply (force)

(* <= *)
 apply (rule, simp add: in_failures)
 apply (elim disjE conjE bexE exE)
 apply (simp_all)
 apply (rule disjI2)
 apply (rule disjI2)
 apply (drule_tac x="Xa" in bspec, simp)
 apply (elim conjE bexE)
 apply (rule_tac x="Xb" in bexI)
 apply (blast)
 apply (simp)
done

lemmas cspF_norm = cspF_input_DIV
                   cspF_Rep_int_choice_set_Ext_pre_choice_DIV
                   cspF_input_Rep_int_choice_set_subset

end


theory Disassemble
  imports MachineCode "../13AssemblyCode/AssemblyCode" "../00Utils/Utils" "../00Utils/Iteration"
begin

primrec register_map :: "register \<Rightarrow> reg" where
  "register_map Hp = R1"
| "register_map Env = R2"
| "register_map Vals = R3"
| "register_map Stk = R4"

primrec register_offset :: "register \<Rightarrow> nat" where
  "register_offset Hp = 0"
| "register_offset Env = 1"
| "register_offset Vals = 2"
| "register_offset Stk = 3"

primrec pseudoreg_size :: "pseudoreg \<Rightarrow> nat" where
  "pseudoreg_size (Reg r) = 4"
| "pseudoreg_size (PC _) = 1"
| "pseudoreg_size (Con k) = 1"
| "pseudoreg_size (Acc _) = 1"

fun pseudoreg_map :: "pseudoreg \<times> nat \<Rightarrow> nat" where
  "pseudoreg_map (Reg r, x) = 4 * x + register_offset r"
| "pseudoreg_map (PC _, x) = x"
| "pseudoreg_map (Con k, x) = x"
| "pseudoreg_map (Acc _, x) = x"

fun disassemble' :: "assm \<Rightarrow> mach" where
  "disassemble' (AMov (Reg r)) = MOV R5 (register_map r)"
| "disassemble' (AMov (PC _)) = MVP R5"
| "disassemble' (AMov (Con k)) = LDI R5 k"
| "disassemble' (AMov (Acc _)) = undefined"
| "disassemble' (AGet (Reg r) t) = LOD R5 (register_map r)"
| "disassemble' (AGet (PC _) t) = undefined"
| "disassemble' (AGet (Con k) t) = undefined"
| "disassemble' (AGet (Acc r) t) = LOD R5 R5"
| "disassemble' (APut r (Reg r')) = STO (register_map r) (register_map r')"
| "disassemble' (APut r (PC k)) = STI (register_map r) k"
| "disassemble' (APut r (Con k)) = STI (register_map r) k"
| "disassemble' (APut r (Acc _)) = STO (register_map r) R5"
| "disassemble' (ASub (Reg r) k) = SUB (register_map r) (4 * k)"
| "disassemble' (ASub (PC _) k) = undefined"
| "disassemble' (ASub (Con m) k) = undefined"
| "disassemble' (ASub (Acc t) k) = SUB R5 (pseudoreg_size t * k)"
| "disassemble' (AAdd (Reg r) k) = ADD (register_map r) (4 * k)"
| "disassemble' (AAdd (PC _) k) = undefined"
| "disassemble' (AAdd (Con m) k) = undefined"
| "disassemble' (AAdd (Acc t) k) = ADD R5 (pseudoreg_size t * k)"
| "disassemble' AJmp = JMP R5"

definition disassemble :: "assm list \<Rightarrow> mach list" where
  "disassemble cd = map disassemble' cd"

fun unmap_mem' :: "nat \<Rightarrow> register \<times> nat" where
  "unmap_mem' 0 = (Hp, 0)"
| "unmap_mem' (Suc 0) = (Env, 0)"
| "unmap_mem' (Suc (Suc 0)) = (Vals, 0)"
| "unmap_mem' (Suc (Suc (Suc 0))) = (Stk, 0)"
| "unmap_mem' (Suc (Suc (Suc (Suc x)))) = (case unmap_mem' x of (a, b) \<Rightarrow> (a, Suc b))"

definition unmap_mem :: "(register \<Rightarrow> nat \<Rightarrow> pseudoreg \<times> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "unmap_mem m x = (case unmap_mem' x of (r, p) \<Rightarrow> pseudoreg_map (m r p))"

primrec inv_register_map :: "(register \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> pseudoreg \<Rightarrow> reg \<Rightarrow> nat" where
  "inv_register_map rs a t R1 = rs Hp * 4"
| "inv_register_map rs a t R2 = rs Env * 4 + 1"
| "inv_register_map rs a t R3 = rs Vals * 4 + 2"
| "inv_register_map rs a t R4 = rs Stk * 4 + 3"
| "inv_register_map rs a t R5 = pseudoreg_map (t, a)"

primrec disassemble_state :: "assm_state \<Rightarrow> mach_state" where
  "disassemble_state (AS mem rs a t pc) = MS (inv_register_map rs a t) (unmap_mem mem) pc"

primrec dissassembleable :: "assm_state \<Rightarrow> nat \<Rightarrow> bool" where
  "dissassembleable (AS mem rs a t pc) lcd = (pc < lcd)"

lemma [dest]: "R1 = register_map r \<Longrightarrow> r = Hp"
  by (induction r) simp_all

lemma [dest]: "R2 = register_map r \<Longrightarrow> r = Env"
  by (induction r) simp_all

lemma [dest]: "R3 = register_map r \<Longrightarrow> r = Vals"
  by (induction r) simp_all

lemma [dest]: "R4 = register_map r \<Longrightarrow> r = Stk"
  by (induction r) simp_all

lemma [dest]: "R5 = register_map r \<Longrightarrow> False"
  by (induction r) simp_all

lemma unmap_times_4 [simp]: "unmap_mem' (4 * k) = (Hp, k)"
  by (induction k) (simp_all add: numeral_def)

lemma [simp]: "length (disassemble cd) = length cd"
  by (simp add: disassemble_def)

lemma [dest]: "unmap_mem' x = (Hp, ps Hp) \<Longrightarrow> x = ps Hp * 4"
  by (induction x arbitrary: ps rule: unmap_mem'.induct) (auto split: prod.splits)

lemma [dest]: "unmap_mem' x = (Env, ps Env) \<Longrightarrow> x = Suc (ps Env * 4)"
  by (induction x arbitrary: ps rule: unmap_mem'.induct) (auto split: prod.splits)

lemma [dest]: "unmap_mem' x = (Vals, ps Vals) \<Longrightarrow> x = Suc (Suc (ps Vals * 4))"
  by (induction x arbitrary: ps rule: unmap_mem'.induct) (auto split: prod.splits)

lemma [dest]: "unmap_mem' x = (Stk, ps Stk) \<Longrightarrow> x = Suc (Suc (Suc (ps Stk * 4)))"
  by (induction x arbitrary: ps rule: unmap_mem'.induct) (auto split: prod.splits)

lemma [simp]: "unmap_mem' 2 = (Vals, 0)"
  by (simp add: numeral_def)

lemma [simp]: "unmap_mem' (16 + 16 * x) = (Hp, 4 + 4 * x)"
proof -
  have "unmap_mem' (4 * (4 * Suc x)) = (Hp, 4 * Suc x)" by (metis unmap_times_4)
  thus ?thesis by simp
qed

(*

TODO

theorem completem [simp]: "cd\<^sub>m \<tturnstile> \<Sigma>\<^sub>m \<leadsto>\<^sub>m \<Sigma>\<^sub>m' \<Longrightarrow>
  \<exists>cd\<^sub>a \<Sigma>\<^sub>a \<Sigma>\<^sub>a'. cd\<^sub>m = disassemble cd\<^sub>a \<and> disassemble_state \<Sigma>\<^sub>a = \<Sigma>\<^sub>m \<and>
    disassemble_state \<Sigma>\<^sub>a' = \<Sigma>\<^sub>m' \<and> cd\<^sub>a \<tturnstile> \<Sigma>\<^sub>a \<leadsto>\<^sub>a \<Sigma>\<^sub>a'"
  by simp

*)

lemma inv_reg_map_reg: "
  (inv_register_map ps a act)(R5 := inv_register_map ps a act (register_map r)) =
    inv_register_map ps (ps r) (Reg r)"
proof
  fix x
  show "((inv_register_map ps a act)(R5 := inv_register_map ps a act (register_map r))) x =
      inv_register_map ps (ps r) (Reg r) x"
  proof (induction x)
    case R5
    thus ?case by (induction r) simp_all
  qed simp_all
qed

lemma inv_reg_map_pc: "(inv_register_map ps a act)(R5 := pc) = inv_register_map ps pc (PC 0)"
proof
  fix x
  show "((inv_register_map ps a act)(R5 := pc)) x = inv_register_map ps pc (PC 0) x"
    by (induction x) simp_all
qed

lemma inv_reg_map_con: "(inv_register_map ps a act)(R5 := k) = inv_register_map ps k (Con 0)"
proof
  fix x
  show "((inv_register_map ps a act)(R5 := k)) x = inv_register_map ps k (Con 0) x"
    by (induction x) simp_all
qed

lemma [simp]: "unmap_mem' (k * 4) = (Hp, k)"
  by (induction k) (simp_all add: numeral_def)

lemma [simp]: "unmap_mem' (Suc (k * 4)) = (Env, k)"
  by (induction k) (simp_all add: numeral_def)

lemma [simp]: "unmap_mem' (Suc (Suc (k * 4))) = (Vals, k)"
  by (induction k) (simp_all add: numeral_def)

lemma [simp]: "unmap_mem' (k * 4 + 3) = (Stk, k)"
  by (induction k) (simp_all add: numeral_def)

lemma [simp]: "unmap_mem' (4 * k + register_offset m) = (m, k)"
proof (induction k)
  case 0
  thus ?case by (induction m) (simp_all add: numeral_def)
qed (simp_all add: numeral_def)

lemma [simp]: "inv_register_map (ps(r := k)) a act R5 = inv_register_map ps a act R5"
  by (induction act) simp_all

lemma [simp]: "inv_register_map (ps(r := ps r + k)) a act =
  ((inv_register_map ps a act)
    (register_map r := inv_register_map ps a act (register_map r) + 4 * k))"
proof
  fix x
  show "inv_register_map (ps(r := ps r + k)) a act x =
    ((inv_register_map ps a act)
      (register_map r := inv_register_map ps a act (register_map r) + 4 * k)) x"
    by (induction x) auto
qed

lemma [simp]: "(inv_register_map ps a act) (R5 := pseudoreg_map (act, a) + pseudoreg_size act * k) =
  inv_register_map ps (a + k) act"
proof
  fix x
  show "((inv_register_map ps a act) (R5 := pseudoreg_map (act, a) + pseudoreg_size act * k)) x =
    inv_register_map ps (a + k) act x"
  proof (induction x)
    case R5
    thus ?case by (induction act) simp_all
  qed simp_all
qed

lemma [simp]: "ps r \<ge> k \<Longrightarrow>
  inv_register_map (ps(r := ps r - k)) a act = ((inv_register_map ps a act)
    (register_map r := inv_register_map ps a act (register_map r) - 4 * k))"
proof
  fix x
  assume "ps r \<ge> k"
  thus "inv_register_map (ps(r := ps r - k)) a act x =
    ((inv_register_map ps a act)
      (register_map r := inv_register_map ps a act (register_map r) - 4 * k)) x"
    by (induction x) auto
qed

lemma [simp]: "a \<ge> k \<Longrightarrow>
  (inv_register_map ps a act) (R5 := pseudoreg_map (act, a) - pseudoreg_size act * k) =
    inv_register_map ps (a - k) act"
proof
  fix x
  assume "a \<ge> k"
  thus "((inv_register_map ps a act)
    (R5 := pseudoreg_map (act, a) - pseudoreg_size act * k)) x =
      inv_register_map ps (a - k) act x"
  proof (induction x)
    case R5
    thus ?case by (induction act) simp_all
  qed simp_all
qed

lemma [simp]: "unmap_mem mem (inv_register_map ps a (Reg r) (register_map r)) =
    pseudoreg_map (mem r (ps r))"
  by (induction r) (simp_all add: unmap_mem_def split: prod.splits)

lemma [simp]: "((inv_register_map ps a (PC 0))(R5 := 0)) = inv_register_map ps 0 (Con 0)"
proof
  fix x
  show "((inv_register_map ps a (PC 0))(R5 := 0)) x = inv_register_map ps 0 (Con 0) x"
    by (induction x) simp_all
qed

lemma [simp]: "mem r (ps r) = (t, b) \<Longrightarrow>
  (inv_register_map ps a act)(R5 := unmap_mem mem (inv_register_map ps a act (register_map r))) =
    inv_register_map ps b t"
proof
  fix x
  assume "mem r (ps r) = (t, b)"
  thus "((inv_register_map ps a act)(R5 :=
    unmap_mem mem (inv_register_map ps a act (register_map r)))) x = inv_register_map ps b t x"
  proof (induction x)
    case R5
    thus ?case by (induction r) (simp_all add: unmap_mem_def)
  qed simp_all
qed

lemma unmap_upd_k: "(unmap_mem mem)(inv_register_map ps a act (register_map r) := k) =
  unmap_mem (mem_upd mem r (ps r) (Con 0, k))"
proof
  fix x
  show "((unmap_mem mem)(inv_register_map ps a act (register_map r) := k)) x =
      unmap_mem (mem_upd mem r (ps r) (Con 0, k)) x"
    by (induction r) (auto simp add: unmap_mem_def split: prod.splits)
qed

lemma unmap_upd_pc: "(unmap_mem mem)(inv_register_map ps a act (register_map r) := k) =
  unmap_mem (mem_upd mem r (ps r) (PC 0, k))"
proof
  fix x
  show "((unmap_mem mem)(inv_register_map ps a act (register_map r) := k)) x =
      unmap_mem (mem_upd mem r (ps r) (PC 0, k)) x"
    by (induction r) (auto simp add: unmap_mem_def split: prod.splits)
qed

lemma [simp]: "((unmap_mem mem)
  (inv_register_map ps a act (register_map r) := inv_register_map ps a act (register_map r'))) =
    unmap_mem (mem_upd mem r (ps r) (Reg r', ps r'))"
proof
  fix x
  show "((unmap_mem mem)
    (inv_register_map ps a act (register_map r) := inv_register_map ps a act (register_map r'))) x =
      unmap_mem (mem_upd mem r (ps r) (Reg r', ps r')) x"
  proof (induction r)
    case Hp
    thus ?case by (induction r') (auto simp add: unmap_mem_def split: prod.splits)
  next
    case Env
    thus ?case by (induction r') (auto simp add: unmap_mem_def split: prod.splits)
  next
    case Vals
    thus ?case by (induction r') (auto simp add: unmap_mem_def split: prod.splits)
  next
    case Stk
    thus ?case by (induction r') (auto simp add: unmap_mem_def split: prod.splits)
  qed
qed

lemma [simp]: "((unmap_mem mem)(inv_register_map ps a act (register_map r) :=
    pseudoreg_map (act, a))) = unmap_mem (mem_upd mem r (ps r) (act, a))"
proof
  fix x
  show "((unmap_mem mem)(inv_register_map ps a act (register_map r) :=
    pseudoreg_map (act, a))) x = unmap_mem (mem_upd mem r (ps r) (act, a)) x"
      by (induction r) (auto simp add: unmap_mem_def split: prod.splits)
qed

lemma [simp]: "mem m a = (t, b) \<Longrightarrow>
  ((inv_register_map ps a (Reg m))(R5 := unmap_mem mem (4 * a + register_offset m))) =
    inv_register_map ps b t"
proof
  fix x
  assume "mem m a = (t, b)"
  thus "((inv_register_map ps a (Reg m))(R5 := unmap_mem mem (4 * a + register_offset m)))
    x = inv_register_map ps b t x"
      by (induction x) (auto simp add: unmap_mem_def)
qed

lemma [simp]: "lookup cd pc = Some op \<Longrightarrow> disassemble cd ! pc = disassemble' op"
proof (induction cd)
  case (Cons op cd)
  thus ?case by (induction pc) (simp_all add: disassemble_def)
qed simp_all

theorem correctm [simp]: "cd\<^sub>a \<tturnstile> \<Sigma>\<^sub>a \<leadsto>\<^sub>a \<Sigma>\<^sub>a' \<Longrightarrow>
  disassemble cd\<^sub>a \<tturnstile> disassemble_state \<Sigma>\<^sub>a \<leadsto>\<^sub>m disassemble_state \<Sigma>\<^sub>a'"
proof (induction cd\<^sub>a \<Sigma>\<^sub>a \<Sigma>\<^sub>a' rule: evala.induct)
  case (eva_movr cd pc r mem ps a act)
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a act)(R5 := (inv_register_map ps a act) (register_map r)))
      (unmap_mem mem) pc" by simp
  thus ?case by (simp add: inv_reg_map_reg)
next
  case (eva_movp cd pc x mem ps a act)
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a act)(R5 := pc)) (unmap_mem mem) pc" by simp
  thus ?case by (simp add: inv_reg_map_pc)
next
  case (eva_movk cd pc k mem ps a act)
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a act)(R5 := k)) (unmap_mem mem) pc" by simp
  thus ?case by (simp add: inv_reg_map_con)
next
  case (eva_geta cd pc m t mem a b ps)
  hence "disassemble cd ! pc = LOD R5 R5" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a (Reg m)) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a (Reg m))(R5 := unmap_mem mem (inv_register_map ps a (Reg m) R5)))
      (unmap_mem mem) pc" by (metis evm_lod)
  with eva_geta(2) show ?case by simp
next
  case (eva_get cd pc r t mem ps b a act)
  hence "disassemble cd ! pc = LOD R5 (register_map r)" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a act)(R5 := (unmap_mem mem) ((inv_register_map ps a act)
      (register_map r)))) (unmap_mem mem) pc" by (metis evm_lod)
  with eva_get(2) show ?case by simp
next
  case (eva_puta cd pc r x mem ps a act)
  hence "disassemble cd ! pc = STO (register_map r) R5" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS (inv_register_map ps a act) ((unmap_mem mem)(inv_register_map ps a act (register_map r) :=
      inv_register_map ps a act R5)) pc" by (metis evm_sto)
  thus ?case by simp
next
  case (eva_putp cd pc r k mem ps a act)
  hence "disassemble cd ! pc = STI (register_map r) k" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS (inv_register_map ps a act) ((unmap_mem mem)((inv_register_map ps a act) (register_map r) :=
      k)) pc" by (metis evm_sti)
  thus ?case by (simp add: unmap_upd_pc)
next
  case (eva_putr cd pc r r' mem ps a act)
  hence "disassemble cd ! pc = STO (register_map r) (register_map r')" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS (inv_register_map ps a act) ((unmap_mem mem)(inv_register_map ps a act (register_map r) :=
      inv_register_map ps a act (register_map r'))) pc" by (metis evm_sto)
  thus ?case by simp
next
  case (eva_putk cd pc r k mem ps a act)
  hence "disassemble cd ! pc = STI (register_map r) k" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS (inv_register_map ps a act)
      ((unmap_mem mem)(inv_register_map ps a act (register_map r) := k)) pc" by (metis evm_sti)
  thus ?case by (simp add: unmap_upd_k)
next
  case (eva_suba cd pc act k a mem ps)
  hence "disassemble cd ! pc = SUB R5 (pseudoreg_size act * k)" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a act)(R5 := inv_register_map ps a act R5 - pseudoreg_size act * k))
      (unmap_mem mem) pc" by (metis evm_sub)
  with eva_suba show ?case by simp
next
  case (eva_adda cd pc act k mem ps a)
  hence "disassemble cd ! pc = ADD R5 (pseudoreg_size act * k)" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a act) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a act)(R5 := inv_register_map ps a act R5 + pseudoreg_size act * k))
      (unmap_mem mem) pc" by (metis evm_add)
  thus ?case by simp
next
  case (eva_jmp cd pc mem ps a)
  hence "disassemble cd ! pc = JMP R5" by simp
  hence "disassemble cd \<tturnstile> MS (inv_register_map ps a (PC 0)) (unmap_mem mem) (Suc pc) \<leadsto>\<^sub>m
    MS ((inv_register_map ps a (PC 0))(R5 := 0)) (unmap_mem mem) (inv_register_map ps a (PC 0) R5)"
      by (metis evm_jmp)
  thus ?case by simp
qed simp_all

theorem correctm_iter [simp]: "iter (\<tturnstile> cd\<^sub>a \<leadsto>\<^sub>a) \<Sigma>\<^sub>a \<Sigma>\<^sub>a' \<Longrightarrow>
    iter (\<tturnstile> disassemble cd\<^sub>a \<leadsto>\<^sub>m) (disassemble_state \<Sigma>\<^sub>a) (disassemble_state \<Sigma>\<^sub>a')"
  by (induction \<Sigma>\<^sub>a \<Sigma>\<^sub>a' rule: iter.induct) (simp, metis correctm iter_append iter_one)

lemma [simp]: "inv_register_map (case_register 0 0 0 2) 0 (Con 0) = case_reg 0 1 2 11 0"
  by (auto split: reg.splits)

lemma [simp]: "inv_register_map (case_register hp ep (Suc 0) 0) 0 (Con 0) =
    case_reg (4 * hp) (Suc (4 * ep)) 6 3 0"
  by (auto split: reg.splits)

lemma [dest]: "unmap_mem' x = (r, y) \<Longrightarrow> x = 4 * y + register_offset r"
  by (induction x arbitrary: y rule: unmap_mem'.induct) (simp_all split: prod.splits)

lemma [simp]: "unmap_mem (case_register (\<lambda>x. (Con 0, 0)) (\<lambda>x. (Con 0, 0)) (\<lambda>x. (Con 0, 0))
  ((\<lambda>x. (Con 0, 0))(0 := (PC 0, 0), Suc 0 := (Reg Env, 0)))) = (\<lambda>x. 0)(7 := 1)"
proof (rule, unfold unmap_mem_def)
  fix x
  obtain r p where R: "unmap_mem' x = (r, p)" by fastforce
  moreover hence "x = 4 * p + register_offset r" by auto
  ultimately have "pseudoreg_map ((case r of
        Stk \<Rightarrow> (\<lambda>x. (Con 0, 0))(0 := (PC 0, 0), Suc 0 := (Reg Env, 0))
      | _ \<Rightarrow> (\<lambda>x. (Con 0, 0))) p) = ((\<lambda>x. 0)(3 := 0, 7 := 1)) x"
    by (induction r) (simp_all, presburger+)
  with R show "(case unmap_mem' x of (r, p) \<Rightarrow>
    pseudoreg_map ((case r of
      Stk \<Rightarrow> (\<lambda>x. (Con 0, 0))(0 := (PC 0, 0), Suc 0 := (Reg Env, 0)) | _ \<Rightarrow> (\<lambda>x. (Con 0, 0))) p)) =
        ((\<lambda>x. 0)(7 := 1)) x" by simp
qed

end


theory IICF_Array_Map
imports IICF_Array "../Intf/IICF_Map" "../Intf/IICF_List"
begin

  definition "am1_rel N
    \<equiv> br (\<lambda>xs k. if k<length xs then xs!k else None) (\<lambda>xs. length xs = N)"

  definition "am1_empty N \<equiv> replicate N None"
  definition "am1_update k v xs \<equiv> mop_list_set xs k (Some v)"
  definition "am1_delete k xs \<equiv> mop_list_set xs k None"
  definition "am1_lookup k xs \<equiv> mop_list_get xs k"
  definition "am1_contains_key k xs \<equiv> doN {x \<leftarrow> mop_list_get xs k; RETURN (\<not>is_None x)}"

  sepref_decl_op am_custom_empty: "\<lambda>_::nat. Map.empty::nat\<rightharpoonup>_" :: "nat_rel \<rightarrow> \<langle>nat_rel,V\<rangle>map_rel" .

  lemma fold_am_custom_empty:
    "Map.empty = op_am_custom_empty N"
    "op_map_empty = op_am_custom_empty N"
    "mop_map_empty = mop_am_custom_empty N"
    by auto

  lemma am1_empty_refine: "(am1_empty, op_am_custom_empty) \<in> nat_rel \<rightarrow>\<^sub>f\<^sub>d (\<lambda>N. am1_rel N)"
    unfolding am1_empty_def am1_rel_def
    by (auto simp: in_br_conv fun_eq_iff intro!: frefI)

  lemma am1_update_refine: "(uncurry2 am1_update, uncurry2 mop_map_update)
    \<in> (nbn_rel N \<times>\<^sub>r Id)\<times>\<^sub>ram1_rel N \<rightarrow>\<^sub>f \<langle>am1_rel N\<rangle>nres_rel"
    apply (rule frefI; clarsimp)
    unfolding am1_update_def am1_rel_def
    apply refine_vcg
    by (auto simp: in_br_conv)

  lemma am1_delete_refine: "(uncurry am1_delete, uncurry mop_map_delete)
    \<in> nbn_rel N \<times>\<^sub>r am1_rel N \<rightarrow>\<^sub>f \<langle>am1_rel N\<rangle>nres_rel"
    apply (rule frefI; clarsimp)
    unfolding am1_delete_def am1_rel_def
    apply refine_vcg
    by (auto simp: in_br_conv)

  lemma am1_lookup_refine: "(uncurry am1_lookup, uncurry mop_map_lookup)
    \<in> nbn_rel N \<times>\<^sub>r am1_rel N \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel"
    apply (rule frefI; clarsimp)
    unfolding am1_lookup_def am1_rel_def
    apply refine_vcg
    by (auto simp: in_br_conv)

  lemma am1_contains_key_refine: "(uncurry am1_contains_key, uncurry mop_map_contains_key)
    \<in> nbn_rel N \<times>\<^sub>r am1_rel N \<rightarrow>\<^sub>f \<langle>bool_rel\<rangle>nres_rel"
    apply (rule frefI; clarsimp)
    unfolding am1_contains_key_def am1_rel_def
    apply refine_vcg
    by (auto simp: in_br_conv split: option.splits)

  context dflt_pure_option begin

    definition "am2_assn \<equiv> IICF_Array.array_assn option_assn"

    definition "am_assn N \<equiv> hr_comp am2_assn (am1_rel N)"

    lemma am_assn_intf[intf_of_assn]:
      "intf_of_assn A TYPE('v) \<Longrightarrow> intf_of_assn (am_assn N) (TYPE((nat,'v)i_map))"
      by simp

    context
      fixes DUMMY :: "'l::len2 itself"
      notes [fcomp_norm_unfold] = am_assn_def[symmetric]
      notes [fcomp_norm_simps] = map_rel_Id option_rel_id_simp
        (* TODO: Declare by default! *) hrr_comp_id_conv
    begin

      private abbreviation (input) "K_assn \<equiv> snat_assn' TYPE('l)"

      sepref_definition am2_empty is "RETURN o am1_empty"
        :: "K_assn\<^sup>k \<rightarrow>\<^sub>a am2_assn"
        unfolding am1_empty_def am2_assn_def
        apply (rewrite array_fold_custom_replicate)
        by sepref

        sepref_decl_impl (no_register) am2_empty: am2_empty.refine[FCOMP am1_empty_refine]
          uses op_am_custom_empty.fref[where V=Id] .

      sepref_definition am2_lookup [llvm_inline] is "uncurry am1_lookup"
        :: "K_assn\<^sup>k *\<^sub>a am2_assn\<^sup>k \<rightarrow>\<^sub>a option_assn"
        unfolding am1_lookup_def am2_assn_def
        by sepref

      sepref_decl_impl (no_register,ismop) am2_lookup: am2_lookup.refine[FCOMP am1_lookup_refine]
        uses mop_map_lookup.fref[where K=Id and V=Id] .

      sepref_definition am2_contains_key [llvm_inline] is "uncurry am1_contains_key"
        :: "K_assn\<^sup>k *\<^sub>a am2_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
        unfolding am1_contains_key_def am2_assn_def
        by sepref

      sepref_decl_impl (no_register,ismop) am2_contains_key: am2_contains_key.refine[FCOMP am1_contains_key_refine]
        uses mop_map_contains_key.fref[where K=Id and V=Id] .

      sepref_definition am2_update [llvm_inline] is "uncurry2 am1_update"
        :: "K_assn\<^sup>k *\<^sub>a A\<^sup>k *\<^sub>a am2_assn\<^sup>d \<rightarrow>\<^sub>a am2_assn"
        unfolding am1_update_def am2_assn_def
        by sepref

      sepref_decl_impl (no_register,ismop) am2_update: am2_update.refine[FCOMP am1_update_refine]
        uses mop_map_update.fref[where K=Id and V=Id] .

      sepref_definition am2_delete [llvm_inline] is "uncurry am1_delete"
        :: "K_assn\<^sup>k *\<^sub>a am2_assn\<^sup>d \<rightarrow>\<^sub>a am2_assn"
        unfolding am1_delete_def am2_assn_def
        by sepref

      sepref_decl_impl (no_register,ismop) am2_delete: am2_delete.refine[FCOMP am1_delete_refine]
        uses mop_map_delete.fref[where K=Id and V=Id] .

      lemma am_assn_free[sepref_frame_free_rules]: "MK_FREE (am_assn N) narray_free"
        unfolding am_assn_def am2_assn_def
        by (rule sepref_frame_free_rules)+

    end
  end

  concrete_definition snat_am_empty[llvm_code,llvm_inline] is snat.am2_empty_def
  concrete_definition snat_am_lookup[llvm_code,llvm_inline] is snat.am2_lookup_def
  concrete_definition snat_am_contains_key[llvm_code,llvm_inline] is snat.am2_contains_key_def
  concrete_definition snat_am_update[llvm_code,llvm_inline] is snat.am2_update_def
  concrete_definition snat_am_delete[llvm_code,llvm_inline] is snat.am2_delete_def

  thm snat_am_empty.refine
  lemmas [unfolded snat_am_empty.refine,sepref_fr_rules] = snat.am2_empty_hnr snat.am2_empty_hnr_mop
  lemmas [unfolded snat_am_lookup.refine,sepref_fr_rules] = snat.am2_lookup_hnr snat.am2_lookup_hnr_mop
  lemmas [unfolded snat_am_contains_key.refine,sepref_fr_rules] = snat.am2_contains_key_hnr snat.am2_contains_key_hnr_mop
  lemmas [unfolded snat_am_update.refine,sepref_fr_rules] = snat.am2_update_hnr snat.am2_update_hnr_mop
  lemmas [unfolded snat_am_delete.refine,sepref_fr_rules] = snat.am2_delete_hnr snat.am2_delete_hnr_mop

  export_llvm
    "snat_am_empty :: 32 word \<Rightarrow> 32 word ptr llM"
    "snat_am_lookup :: 32 word \<Rightarrow> 32 word ptr \<Rightarrow> 32 word llM"
    "snat_am_contains_key :: 32 word \<Rightarrow> 32 word ptr \<Rightarrow> 1 word llM"
    "snat_am_update :: 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word ptr \<Rightarrow> 32 word ptr llM"
    "snat_am_delete :: 32 word \<Rightarrow> 32 word ptr \<Rightarrow> 32 word ptr llM"

  abbreviation "snat_am_assn' TYPE('l::len2) \<equiv> snat.am_assn :: nat \<Rightarrow> (nat \<Rightarrow> nat option) \<Rightarrow> 'l word ptr \<Rightarrow> llvm_amemory \<Rightarrow> bool"

(*  method frame_solve_simple =
    rule fr_round1_init,
    (determ \<open>rule fr_round1_match | rule fr_round1_nomatch\<close>)+,
    rule fr_round1_finalize,
    tactic \<open>\<close>
*)

  experiment
  begin

    sepref_definition test [llvm_code] is "\<lambda>N. doN {
      ASSERT (10 \<le>N \<and> N\<le>42);
      m \<leftarrow> mop_am_custom_empty N;
      m \<leftarrow> mop_map_update 4 2 m;
      if op_map_contains_key 4 m then doN {
        m \<leftarrow> mop_map_update 5 2 m;
        m \<leftarrow> mop_map_update 6 2 m;
        m \<leftarrow> mop_map_delete 5 m;
        RETURN (the (m 4))
      } else doN {
        RETURN (the (m 0))
      }
    }" :: "(snat_assn' TYPE(32))\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE(32)"
      apply (annot_snat_const "TYPE(32)")
      by sepref

    export_llvm test

  end

end


(*  Title:       An Example of a Cofinitary Group in Isabelle/HOL
    Author:      Bart.Kastermans at colorado.edu, 2009
    Maintainer:  Bart.Kastermans at colorado.edu
*)

theory CofGroups
imports Main "HOL-Library.Nat_Bijection"
begin

section \<open>Introduction\<close>

text \<open>Cofinitary groups have received a lot of attention in Set
Theory.  I will start by giving some references, that together give a
nice view of the area.  See also Kastermans \cite {Kques} for my view
of where the study of these groups (other than formalization) is
headed.  Starting work was done by Adeleke \cite {MR989749}, Truss
\cite {MR896533} and \cite {MR1683516}, and Koppelberg \cite
{MR709997}.  Cameron \cite {MR1367160} is a very nice survey.  There
is also work on cardinal invariants related to these groups and other
almost disjoint families, see e.g. Brendle, Spinas, and Zhang \cite
{MR1783921}, Hru{\v{s}}{\'a}k, Steprans, and Zhang \cite {MR1856740},
and Kastermans and Zhang \cite {KZ}.  Then there is also work on
constructions and descriptive complexity of these groups, see
e.g. Zhang \cite {MR1974545}, Gao and Zhang \cite {MR2370282}, and
Kastermans \cite {BK1} and \cite {BK2}.

In this note we work through formalizing a basic example of a
cofinitary group.  We want to achieve two things by working through
this example.  First how to formalize some proofs from basic
set-theoretic algebra, and secondly, to do some first steps in the
study of formalization of this area of set theory.  This is related to
the work of Paulson andGr{\polhk{a}}bczewski \cite {PG} on formalizing
set theory, our preference however is towards using Isar resulting in
a development more readable for ``normal'' mathematicians.

A \emph{cofinitary group} is a subgroup $G$ of the symmetric group on
$\mathbb{N}$ (in Isabelle @{term nat}) such that all non-identity
elements $g \in G$ have finitely many fixed points.  A simple example
of a cofinitary group is obtained by considering the group $G'$ a
subgroup of the symmetric group on $\mathbb {Z}$ (in Isabelle @{term
int} generated by the function @{term upOne} $:\mathbb {Z}
\rightarrow \mathbb {Z}$ defined by $k \mapsto k + 1$.  No element in
this group other than the identity has a fixed point.  Conjugating
this group by any bijection $\mathbb {Z} \rightarrow \N$ gives a
cofinitary group.

We will develop a workable definition of a cofinitary group (Section
\ref {sect:mainnotions}) and show that the group as described in the
previous paragraph is indeed cofinitary (this takes the whole paper,
but is all pulled together in Section \ref {sect:concl}).  Note:
formalizing the previous paragraph is all that is completed in this
note.

Since this note is also written to be read by the proverbial
``normal'' mathematician we will sometimes remark on notations as used
in Isabelle as they related to common notation.  We do expect this
proverbial mathematician to be somewhat flexible though.  He or she
will need to be flexible in reading, this is just like reading any
other article; part of reading is reconstructing.\<close>

text \<open>We end this introduction with a quick overview of the paper.
In Section \ref {sect:mainnotions} we define the notion of cofinitary
group.  In Section \ref {sect:theFunction} we define the function
@{term upOne} and give some of its basic properties.  In Section \ref
{sect:setOFunc} we define the set @{term Ex1} which is the underlying
set of the group generated by @{term upOne}, there we also derive a
normal form theorem for the elements of this set.  In Section \ref
{sect:Ex1CofBij} we show all elements in @{term Ex1} are cofinitary
bijections (cofinitary here is used in the general meaning of having
finitely many fixed points).  In Section \ref {sect:Ex1Closed} we show
this set is closed under composition and inverse, in effect showing
that it is a ``cofinitary group'' (cofinitary group here is in quotes,
since we only define it for sets of permutations on the natural
numbers).  In Section \ref {sect:moveNN} we show the general theorem that
conjugating a permutation by a bijection does the expected thing to
the set of fixed points.  In Section \ref {sect:bijN} we define the
function @{term CONJ} that is conjugation by @{term ni_bij}
(a bijection from @{typ nat} to @{typ int}), show that
is acts well with respect to the group operations, use it to define
@{term Ex2} which is the underlying set of the cofinitary group we are
construction, and show the basic properties of @{term Ex2}.  Finally
in Section \ref {sect:concl} we quickly show that all the work in the
section before it combines to show that @{term Ex2} is a cofinitary
group.\<close>

section \<open>The Main Notions\<close>

text \<open>\label {sect:mainnotions} First we define the two main notions.

We write @{term S_inf} for the symmetric group on the natural numbers
(we do not define this as a group, only as the set of bijections).\<close>

definition S_inf :: "(nat \<Rightarrow> nat) set"
where
"S_inf = {f::(nat \<Rightarrow> nat). bij f}"

text \<open>Note here that @{term bij} @{term f} is the predicate that
@{term f} is a bijection.  This is common notation in Isabelle, a
predicate applied to an object.  Related to this @{term inj} @{term f}
means @{term f} is injective, and @{term surj} @{term f} means @{term
f} is surjective.

The same notation is used for functionn application.  Next we define a
function @{term Fix}, applying it to an object is also written by
juxtaposition.\<close>

text \<open>Given any function @{term f} we define @{term Fix} @{term f}
to be the set of fixed points for this function.\<close>

definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a set)"
where
"Fix f = { n . f(n) = n }"

text \<open>We then define a locale @{term CofinitaryGroup} that
represents the notion of a cofinitary group. An interpretation is
given by giving a set of functions $nat \rightarrow nat$ and showing
that it satisfies the identities the locale assumes.  A locale is a
way to collect together some information that can then later be used
in a flexible way (we will not make a lot of use of that here).\<close>

locale CofinitaryGroup =
  fixes
    dom :: "(nat \<Rightarrow> nat) set"
  assumes
    type_dom : "dom \<subseteq> S_inf" and
    id_com : "id \<in> dom" and
    mult_closed : "f \<in> dom \<and> g \<in> dom \<Longrightarrow> f \<circ> g \<in> dom" and
    inv_closed : "f \<in> dom \<Longrightarrow> inv f \<in> dom" and
    cofinitary : "f \<in> dom \<and> f \<noteq> id \<Longrightarrow> finite (Fix f)"

section \<open>The Function @{term upOne}\<close>

text \<open>\label{sect:theFunction} Here we define the function, @{term
upOne}, translation up by 1 and proof some of its basic properties.
\<close>

definition upOne :: "int \<Rightarrow> int"
where
"upOne n = n + 1"

declare upOne_def [simp] \<comment> \<open>automated tools can use the definition\<close>

text \<open>First we show that this function is a bijection.  This is done
in the usual two parts; we show it is injective by showing from the
assumption that outputs on two numbers are equal that these two
numbers are equal.  Then we show it is surjective by finding the
number that maps to a given number.\<close>

lemma inj_upOne: "inj upOne"
by (rule Fun.injI, simp)

lemma surj_upOne: "surj upOne"
proof (unfold Fun.surj_def, rule)
  fix k::int
  show "\<exists>m. k = upOne m"
    by (rule exI[of "\<lambda>l. k = upOne l" "k - 1"], simp)
qed

theorem bij_upOne: "bij upOne"
by (unfold bij_def, rule conjI [OF inj_upOne surj_upOne])

text \<open>Now we show that the set of fixed points of @{term upOne}
is empty.  We show this in two steps, first we show that no number
is a fixed point, and then derive from this that the set of fixed
points is empty.\<close>

lemma no_fix_upOne: "upOne n \<noteq> n"
proof (rule notI)
  assume "upOne n = n"
  with upOne_def have "n+1 = n" by simp
  thus False by auto
qed

theorem "Fix upOne = {}"
proof -
  from Fix_def[of upOne]
  have "Fix upOne = {n . upOne n = n}" by auto
  with no_fix_upOne have "Fix upOne = {n . False}" by auto
  with Set.empty_def show "Fix upOne = {}" by auto
qed

text \<open>Finally we derive the equation for the inverse of @{term
upOne}.  The rule we use references \<open>Hilbert_Choice\<close> since the @{term
inv} operator, the operator that gives an inverse of a function, is
defined using Hilbert's choice operator.\<close>

lemma inv_upOne_eq: "(inv upOne) (n::int) = n - 1"
proof -
  fix "n" :: int
  have "((inv upOne) \<circ> upOne) (n - 1) = (inv upOne) n" by simp
  with inj_upOne and Hilbert_Choice.inv_o_cancel
    show "(inv upOne) n = n - 1" by auto
qed

text \<open>We can also show this quickly using Hilbert\_Choice.inv\_f\_eq
properly instantiated : @{thm Hilbert_Choice.inv_f_eq[of upOne "n - 1"
n, OF inj_upOne]}.\<close>

lemma "(inv upOne) n = n - 1"
by (rule Hilbert_Choice.inv_f_eq[of upOne "n - 1" n, OF inj_upOne], simp)

section \<open>The Set of Functions and Normal Forms\<close>

text \<open>\label {sect:setOFunc} We define the set @{term Ex1} of all
powers of @{term upOne} and study some of its properties, note that
this is the group generated by @{term upOne} (in Section \ref
{sect:Ex1Closed} we prove it closed under composition and inverse).
In Section \ref {sect:Ex1CofBij} we show that all its elements are
cofinitary and bijections (bijections with finitely many fixed
points).  Note that this is not a cofinitary group, since our
definition requires the group to be a subset of @{term S_inf}\<close>

inductive_set Ex1 :: "(int \<Rightarrow> int) set" where
base_func: "upOne \<in> Ex1" |
comp_func: "f \<in> Ex1 \<Longrightarrow> (upOne \<circ> f) \<in> Ex1" |
comp_inv : "f \<in> Ex1 \<Longrightarrow> ((inv upOne) \<circ> f) \<in> Ex1"

text \<open>We start by showing a \emph{normal form} for elements in this
set.\<close>

lemma Ex1_Normal_form_part1: "f \<in> Ex1 \<Longrightarrow> \<exists>k. \<forall> n. f(n) = n + k"
proof (rule Ex1.induct [of "f"], blast)
    \<comment> \<open>blast takes care of the first goal which is formal noise\<close>
  assume "f \<in> Ex1"
  have "\<forall>n. upOne n = n + 1" by simp
  with HOL.exI show "\<exists>k. \<forall>n. upOne n = n + k" by auto
next
  fix fa:: "int => int"
  assume fa_k: "\<exists>k. \<forall>n. fa n = n + k"
  thus "\<exists>k. \<forall>n. (upOne \<circ> fa) n = n + k" by auto
next
  fix fa :: "int \<Rightarrow> int"
  assume fa_k: "\<exists>k. \<forall>n. fa n = n + k"
  from inv_upOne_eq have "\<forall>n. (inv upOne) n = n - 1" by auto
  with fa_k show "\<exists>k. \<forall>n. (inv upOne \<circ> fa) n = n + k" by auto
qed

text \<open>Now we'll show the other direction.  Then we apply rule \<open>int_induct\<close> which allows us to do the induction by first showing it
true for $k = 1$, then showing that if true for $k = i$ it is also
true for $k = i+1$ and finally showing that if true for $k = i$ then
it is also true for $k = i - 1$.

All proofs are fairly straightforward and use extensionality for
functions.  In the base case we are just dealing with @{term upOne}.
In the other cases we define the function \<open>?h\<close> which satisfies
the induction hypothesis.  Then @{term f} is obtained from this by
adding or subtracting one pointwise.

In this proof we use some pattern matching to save on writing.  In the
statement of the theorem, we match the theorem against \<open>?P k\<close> thereby
defining the predicate \<open>?P\<close>.\<close>

lemma Ex1_Normal_form_part2:
  "(\<forall>f. ((\<forall>n. f n = n + k) \<longrightarrow> f \<in> Ex1))" (is "?P k")
proof (rule int_induct [of "?P" 1])
  show "\<forall>f. (\<forall>n. f n = n + 1) \<longrightarrow> f \<in> Ex1"
  proof
    fix f:: "int \<Rightarrow> int"
    show "(\<forall>n. f n = n + 1) \<longrightarrow> f \<in> Ex1"
    proof
      assume "\<forall>n. f n = n + 1"
      hence "\<forall>n. f n = upOne n" by auto
      with fun_eq_iff[of f upOne,THEN sym]
         have "f = upOne" by auto
      with Ex1.base_func show "f \<in> Ex1" by auto
    qed
  qed
next
  fix i::int
  assume "1 \<le> i"
  assume induct_hyp: "\<forall>f. (\<forall>n. f n = n + i) \<longrightarrow> f \<in> Ex1"
  show "\<forall>f. (\<forall>n. f n = n + (i + 1)) \<longrightarrow> f \<in> Ex1"
  proof
    fix f:: "int \<Rightarrow> int"
    show "(\<forall>n. f n = n + (i + 1)) \<longrightarrow> f \<in> Ex1"
    proof
      assume f_eq: "\<forall>n. f n = n + (i + 1)"
      let ?h = "\<lambda>n. n + i"
      from induct_hyp have h_Ex1: "?h \<in> Ex1" by auto
      from  f_eq have "\<forall>n. f n = upOne (?h n)" by (unfold upOne_def,auto)
      hence "\<forall>n. f n = (upOne \<circ> ?h) n" by auto
      with fun_eq_iff[THEN sym, of f "upOne \<circ> ?h"]
         have "f = upOne \<circ> ?h" by auto
      with h_Ex1 and Ex1.comp_func[of ?h] show "f \<in> Ex1" by auto
    qed
  qed
next
  fix i::int
  assume "i \<le> 1"
  assume induct_hyp: "\<forall>f. (\<forall>n. f n = n + i) \<longrightarrow> f \<in> Ex1"
  show "\<forall>f. (\<forall>n. f n = n + (i - 1)) \<longrightarrow> f \<in> Ex1"
  proof
    fix f:: "int \<Rightarrow> int"
    show "(\<forall>n. f n = n + (i - 1)) \<longrightarrow> f \<in> Ex1"
    proof
      assume f_eq: "\<forall>n. f n = n + (i - 1)"
      let ?h = "\<lambda>n. n + i"
      from  induct_hyp have h_Ex1: "?h \<in> Ex1" by auto
      from inv_upOne_eq and f_eq
        have "\<forall>n. f n = (inv upOne) (?h n)" by auto
      hence "\<forall>n. f n = (inv upOne \<circ> ?h) n" by auto
      with fun_eq_iff[THEN sym, of f "inv upOne \<circ> ?h"]
         have "f = inv upOne \<circ> ?h" by auto
      with h_Ex1 and Ex1.comp_inv[of ?h] show "f \<in> Ex1" by auto
    qed
  qed
qed

text \<open>Combining the two directions we get the normal form
theorem.\<close>

theorem Ex1_Normal_form: "(f \<in> Ex1) = (\<exists>k. \<forall>n. f(n) = n + k)"
proof
  assume "f \<in> Ex1"
  with Ex1_Normal_form_part1 [of f]
    show "(\<exists>k. \<forall>n. f(n) = n + k)" by auto
next
  assume "\<exists>k. \<forall>n. f(n) = n + k"
  with Ex1_Normal_form_part2
    show "f \<in> Ex1" by auto
qed

section \<open>All Elements Cofinitary Bijections.\<close>

text \<open>\label {sect:Ex1CofBij} We now show all elements in @{term
Ex1} are bijections, Theorem @{term all_bij}, and have no fixed
points, Theorem @{term no_fixed_pt}.\<close>

theorem all_bij: "f \<in> Ex1 \<Longrightarrow> bij f"
proof (unfold bij_def)
  assume "f \<in> Ex1"
  with Ex1_Normal_form
    obtain k where f_eq:"\<forall>n. f n = n + k" by auto

  show "inj f \<and> surj f"
  proof (rule conjI)
    show INJ: "inj f"
    proof (rule injI)
      fix n m
      assume "f n = f m"
      with f_eq have "n + k = m + k" by auto
      thus "n = m" by auto
    qed
  next

    show SURJ: "surj f"
    proof (unfold Fun.surj_def, rule allI)
      fix n
      from f_eq have "n = f (n - k)" by auto
      thus "\<exists>m. n = f m" by (rule exI)
    qed
  qed
qed

theorem no_fixed_pt:
  assumes f_Ex1: "f \<in> Ex1"
  and f_not_id: "f \<noteq> id"
  shows "Fix f = {}"
proof -
    \<comment> \<open>we start by proving an easy general fact\<close>
  have f_eq_then_id: "(\<forall>n. f(n) = n) \<Longrightarrow> f = id"
  proof -
    assume f_prop : "\<forall>n. f(n) = n"
    have "(f x = id x) = (f x = x)" by simp
    hence "(\<forall>x. (f x = id x)) = (\<forall>x. (f x = x))" by simp
    with fun_eq_iff[THEN sym, of f id] and f_prop show "f = id" by auto
  qed
  from f_Ex1 and Ex1_Normal_form have "\<exists>k. \<forall>n. f(n) = n + k" by auto
  then obtain k where k_prop: "\<forall>n. f(n) = n + k" ..
  hence "k = 0 \<Longrightarrow> \<forall>n. f(n) = n" by auto
  with f_eq_then_id and f_not_id have "k \<noteq> 0" by auto
  with k_prop have "\<forall>n. f(n) \<noteq> n" by auto
  moreover
  from Fix_def[of f] have "Fix f = {n . f(n) = n}" by auto
  ultimately have "Fix f = {n. False}" by auto
  with Set.empty_def show "Fix f = {}" by auto
qed

section \<open>Closed under Composition and Inverse\<close>

text \<open>\label {sect:Ex1Closed} We start by showing that this set is
closed under composition.  These facts can later be conjugated to
easily obtain the corresponding results for the group on the natural
numbers.\<close>

theorem closed_comp: "f \<in> Ex1 \<and> g \<in> Ex1 \<Longrightarrow> f \<circ> g \<in> Ex1"
proof (rule Ex1.induct [of f], blast)
  assume "f \<in> Ex1 \<and> g \<in> Ex1"
  with Ex1.comp_func[of g] show "upOne \<circ> g \<in> Ex1" by auto
next
  fix fa
  assume "fa \<circ> g \<in> Ex1"
  with Ex1.comp_func [of "fa \<circ> g"]
    and Fun.o_assoc [of "upOne" "fa" "g"]
    show "upOne \<circ> fa \<circ> g \<in> Ex1" by auto
next
  fix fa
  assume "fa \<circ> g \<in> Ex1"
  with Ex1.comp_inv [of "fa \<circ> g"]
    and Fun.o_assoc [of "inv upOne" "fa" "g"]
    show "(inv upOne) \<circ> fa \<circ> g \<in> Ex1" by auto
qed

text \<open>Now we show the set is closed under inverses.  This is
done by an induction on the definition of @{term Ex1} only using
the normal form theorem and rewriting of expressions.\<close>

theorem closed_inv: "f \<in> Ex1 \<Longrightarrow> inv f \<in> Ex1"
proof (rule Ex1.induct [of "f"], blast)
  assume "f \<in> Ex1"
  show "inv upOne \<in> Ex1" (is "?right \<in> Ex1")
  proof -
    let ?left  = "inv upOne \<circ> (inv upOne \<circ> upOne)"
    {
      from Ex1.comp_inv and Ex1.base_func have "?left \<in> Ex1" by auto
    }
    moreover
    {
      from bij_upOne and bij_is_inj have "inj upOne" by auto
      hence "inv upOne \<circ> upOne = id" by auto
      hence "?left = ?right" by auto
    }
    ultimately
    show ?thesis by auto
  qed
next
  fix f
  assume f_Ex1: "f \<in> Ex1"
  from f_Ex1 and Ex1_Normal_form
  obtain k where f_eq: "\<forall>n. f n = n + k" by auto

  show "inv (upOne \<circ> f) \<in> Ex1"
  proof -
    let ?ic = "inv (upOne \<circ> f)"
    let ?ci = "inv f \<circ> inv upOne"
    {
      \<comment> \<open>first we get an expression for @{term ?ci}\<close>
      {
        from all_bij and f_Ex1 have "bij f" by auto
        with bij_is_inj have inj_f: "inj f" by auto
        have "\<forall>n. inv f n = n - k"
        proof
          fix n
          from f_eq have "f (n - k) = n" by auto
          with inv_f_eq[of f "n-k" "n"] and inj_f
          show "inv f n = n-k" by auto
        qed
        with inv_upOne_eq
        have "\<forall>n. ?ci n = n - k - 1" by auto
        hence "\<forall>n. ?ci n = n + (-1 - k)" by arith
      }
      moreover
      \<comment> \<open>then we check that this implies @{term ?ci} is\<close>
      \<comment> \<open>a member of @{term Ex1}\<close>
      {
        from Ex1_Normal_form_part2[of "-1 - k"]
        have "(\<forall>f. ((\<forall>n. f n = n + (-1 - k)) \<longrightarrow> f \<in> Ex1))" by auto
      }
      ultimately
      have "?ci \<in> Ex1" by auto
    }
    moreover
    {
      from f_Ex1 all_bij have "bij f" by auto
      with bij_upOne and o_inv_distrib[THEN sym]
      have "?ci = ?ic" by auto
    }
    ultimately show ?thesis by auto
  qed
next
  fix f
  assume f_Ex1: "f \<in> Ex1"
  with Ex1_Normal_form
    obtain k where f_eq: "\<forall>n. f n = n + k" by auto

  show "inv (inv upOne \<circ> f) \<in> Ex1"
  proof -
    let ?ic = "inv (inv upOne \<circ> f)"
    let ?c = "inv f \<circ> upOne"
    {
      from all_bij and f_Ex1 have "bij f" by auto
      with bij_is_inj have inj_f: "inj f" by auto
      have "\<forall>n. inv f n = n - k"
      proof
        fix n
        from f_eq have "f (n - k) = n" by auto
        with inv_f_eq[of f "n-k" "n"] and inj_f
        show "inv f n = n-k" by auto
      qed
      with upOne_def
      have "\<forall>n. (inv f \<circ> upOne) n = n - k + 1" by auto
      hence "\<forall>n. (inv f \<circ> upOne) n = n + (1 - k)" by arith
      moreover
      from Ex1_Normal_form_part2[of "1 - k"]
      have "(\<forall>f. ((\<forall>n. f n = n + (1 - k)) \<longrightarrow> f \<in> Ex1))" by auto
      ultimately
      have "?c \<in> Ex1" by auto
    }
    moreover
    {
      from f_Ex1 all_bij and bij_is_inj have "bij f" by auto
      moreover
      from bij_upOne and bij_imp_bij_inv have "bij (inv upOne)" by auto
      moreover
      note o_inv_distrib[THEN sym]
      ultimately
      have "inv f \<circ> inv (inv upOne) = inv (inv upOne \<circ> f)" by auto
      moreover
      from bij_upOne and inv_inv_eq
        have "inv (inv upOne) = upOne" by auto
      ultimately
      have "?c = ?ic" by auto
    }
    ultimately
    show ?thesis by auto
  qed
qed

section \<open>Conjugation with a Bijection\<close>

text \<open>\label {sect:moveNN} An abbreviation of the bijection from the
natural numbers to the integers defined in the library.  This will be
used to coerce the functions above to be on the natural numbers.\<close>

abbreviation "ni_bij == int_decode"

lemma bij_f_o_inf_f: "bij f \<Longrightarrow> f \<circ> inv f = id"
  unfolding bij_def surj_iff by simp

text \<open>The following theorem is a key theorem in showing that the
group we are interested in is cofinitary.  It states that when you
conjugate a function with a bijection the fixed points get mapped
over.\<close>

theorem conj_fix_pt: "\<And>f::('a \<Rightarrow> 'b). \<And>g::('b \<Rightarrow> 'b). (bij f)
  \<Longrightarrow> ((inv f)`(Fix g)) = Fix ((inv f) \<circ> g \<circ> f)"
proof -
  fix f::"'a \<Rightarrow> 'b"
  assume bij_f: "bij f"
  with bij_def have inj_f: "inj f" by auto
  fix g::"'b\<Rightarrow>'b"
  show "((inv f)`(Fix g)) = Fix ((inv f) \<circ> g \<circ> f)"
  thm set_eq_subset[of "(inv f)`(Fix g)" "Fix((inv f) \<circ> g \<circ> f)"]
  proof
    show "(inv f)`(Fix g) \<subseteq> Fix ((inv f) \<circ> g \<circ> f)"
    proof
      fix x
      assume "x \<in> (inv f)`(Fix g)"
      with image_def have "\<exists>y \<in> Fix g. x = (inv f) y" by auto
      from this obtain y where y_prop: "y \<in> Fix g \<and> x = (inv f) y" by auto
      hence "x = (inv f) y" ..
      hence "f x = (f \<circ> inv f) y" by auto
      with bij_f and bij_f_o_inf_f[of f] have f_x_y: "f x = y" by auto
      from y_prop have "y \<in> Fix g" ..
      with Fix_def[of g] have "g y = y" by auto
      with f_x_y have "g (f x) = f x" by auto
      hence "(inv f) (g (f x)) = inv f (f x)" by auto
      with inv_f_f and inj_f have "(inv f) (g (f x)) = x" by auto
      hence "((inv f) \<circ> g \<circ> f) x = x" by auto
      with Fix_def[of "inv f \<circ> g \<circ> f"]
        show "x \<in> Fix ((inv f) \<circ> g \<circ> f)" by auto
    qed
  next
    show "Fix (inv f \<circ> g \<circ> f) \<subseteq> (inv f)`(Fix g)"
    proof
      fix x
      assume "x \<in> Fix (inv f \<circ> g \<circ> f)"
      with Fix_def[of "inv f \<circ> g \<circ> f"]
        have x_fix: "(inv f \<circ> g \<circ> f) x = x" by auto
      hence "(inv f) (g(f(x))) = x" by auto
      hence "\<exists>y. (inv f) y = x" by auto
      from this obtain y where x_inf_f_y: "x = (inv f) y" by auto
      with x_fix have "(inv f \<circ> g \<circ> f)((inv f) y) = (inv f) y" by auto
      hence "(f \<circ> inv f \<circ> g \<circ> f \<circ> inv f) (y) = (f \<circ> inv f)(y)" by auto
      with o_assoc
        have "((f \<circ> inv f) \<circ> g \<circ> (f \<circ> inv f)) y = (f \<circ> inv f)y" by auto
      with bij_f and bij_f_o_inf_f[of f]
        have "g y = y" by auto
      with Fix_def[of g] have "y \<in> Fix g" by auto
      with x_inf_f_y show "x \<in> (inv f)`(Fix g)" by auto
    qed
  qed
qed

section \<open>Bijections on $\mathbb{N}$\<close>

text \<open>\label {sect:bijN} In this section we define the subset @{term
Ex2} of @{term S_inf} that is the conjugate of @{term Ex1} bij @{term
ni_bij}, and show its basic properties.

@{term CONJ} is the function that will conjugate @{term Ex1} to @{term Ex2}.\<close>

definition CONJ :: "(int \<Rightarrow> int) \<Rightarrow> (nat \<Rightarrow> nat)"
where
"CONJ f = (inv ni_bij) \<circ> f \<circ> ni_bij"

declare CONJ_def [simp] \<comment> \<open>automated tools can use the definition\<close>

text \<open>We quickly check that this function is of the right type, and
then show three of its properties that are very useful in showing
@{term Ex2} is a group.\<close>

lemma type_CONJ: "f \<in> Ex1 \<Longrightarrow> (inv ni_bij) \<circ> f \<circ> ni_bij \<in> S_inf"
proof -
  assume f_Ex1: "f \<in> Ex1"
  with all_bij have "bij f" by auto
  with bij_int_decode and bij_comp
    have bij_f_nibij: "bij (f \<circ> ni_bij)" by auto
  with bij_int_decode and bij_imp_bij_inv have "bij (inv ni_bij)" by auto
  with bij_f_nibij and bij_comp[of  "f \<circ> ni_bij" "inv ni_bij"]
    and o_assoc[of "inv ni_bij" "f" "ni_bij"]
    have "bij ((inv ni_bij) \<circ> f \<circ> ni_bij)" by auto
  with S_inf_def show "((inv ni_bij) \<circ> f \<circ> ni_bij) \<in> S_inf" by auto
qed

lemma inv_CONJ:
  assumes bij_f: "bij f"
  shows "inv (CONJ f) = CONJ (inv f)" (is "?left = ?right")
proof -
  have st1: "?left = inv ((inv ni_bij) \<circ> f \<circ> ni_bij)"
    using CONJ_def by auto
  from bij_int_decode and bij_imp_bij_inv
    have inv_ni_bij_bij: "bij (inv ni_bij)" by auto
  with bij_f and bij_comp have "bij (inv ni_bij \<circ> f)" by auto
  with o_inv_distrib[of "inv ni_bij \<circ> f" ni_bij] and bij_int_decode
  have "inv ((inv ni_bij) \<circ> f \<circ>  ni_bij) =
    (inv ni_bij) \<circ> (inv ((inv ni_bij) \<circ> f))" by auto
  with st1 have st2: "?left =
    (inv ni_bij) \<circ> (inv ((inv ni_bij) \<circ> f))" by auto
  from inv_ni_bij_bij and \<open>bij f\<close> and o_inv_distrib
    have h1: "inv (inv ni_bij \<circ> f) = inv f \<circ> inv (inv (ni_bij))" by auto
  from bij_int_decode and inv_inv_eq[of ni_bij]
    have "inv (inv ni_bij) = ni_bij" by auto
  with st2 and h1 have "?left = (inv ni_bij \<circ> (inv f \<circ> ( ni_bij)))" by auto
  with o_assoc have "?left = inv ni_bij \<circ> inv f \<circ> ni_bij" by auto
  with CONJ_def[of "inv f"] show ?thesis by auto
qed

lemma comp_CONJ:
  "CONJ (f \<circ> g) = (CONJ f) \<circ> (CONJ g)" (is "?left = ?right")
proof -
  from bij_int_decode have "surj ni_bij" unfolding bij_def by auto
  then have "ni_bij \<circ> (inv ni_bij) = id" unfolding surj_iff by auto
  moreover
  have "?left = (inv ni_bij) \<circ> (f \<circ> g) \<circ> ni_bij" by simp
  hence "?left = (inv ni_bij) \<circ> ((f \<circ> id) \<circ> g) \<circ> ni_bij" by simp
  ultimately
  have "?left =
    (inv ni_bij) \<circ> ((f \<circ> (ni_bij \<circ> (inv ni_bij))) \<circ> g) \<circ> ni_bij"
    by auto
      \<comment> \<open>a simple computation using only associativity\<close>
      \<comment> \<open>completes the proof\<close>
  thus "?left = ?right" by (auto simp add: o_assoc)
qed

lemma id_CONJ: "CONJ id = id"
proof (unfold CONJ_def)
  from bij_int_decode have "inj ni_bij" using bij_def by auto
  hence "inv ni_bij \<circ> ni_bij = id" by auto
  thus "(inv ni_bij \<circ> id) \<circ> ni_bij = id" by auto
qed

text \<open>We now define the group we are interested in, and show the
basic facts that together will show this is a cofinitary group.\<close>

definition Ex2 :: "(nat \<Rightarrow> nat) set"
where
"Ex2 = CONJ`Ex1"

theorem mem_Ex2_rule: "f \<in> Ex2 = (\<exists>g. (g \<in> Ex1 \<and> f = CONJ g))"
proof
  assume "f \<in> Ex2"
  hence "f \<in> CONJ`Ex1" using Ex2_def by auto
  from this obtain "g" where "g \<in> Ex1 \<and> f = CONJ g" by blast
  thus "\<exists>g. (g \<in> Ex1 \<and> f = CONJ g)" by auto
next
  assume "\<exists>g. (g \<in> Ex1 \<and> f = CONJ g)"
  with Ex2_def show "f \<in> Ex2" by auto
qed

theorem Ex2_cofinitary:
  assumes f_Ex2: "f \<in> Ex2"
  and f_nid: "f \<noteq> id"
  shows "Fix f = {}"
proof -
  from f_Ex2 and mem_Ex2_rule
  obtain g where g_Ex1: "g \<in> Ex1" and f_cg: "f = CONJ g" by auto
  with id_CONJ and f_nid have "g \<noteq> id" by auto
  with g_Ex1 and no_fixed_pt[of g] have fg_empty: "Fix g = {}" by auto
  from conj_fix_pt[of ni_bij g] and bij_int_decode
  have "(inv ni_bij)`(Fix g) = Fix(CONJ g)" by auto
  with fg_empty have "{} = Fix (CONJ g)" by auto
  with f_cg show "Fix f = {}" by auto
qed

lemma id_Ex2: "id \<in> Ex2"
proof -
  from Ex1_Normal_form_part2[of "0"] have "id \<in> Ex1" by auto
  with id_CONJ and Ex2_def and mem_Ex2_rule show ?thesis by auto
qed

lemma inv_Ex2: "f \<in> Ex2 \<Longrightarrow> (inv f) \<in> Ex2"
proof -
  assume "f \<in> Ex2"
  with mem_Ex2_rule obtain "g" where "g \<in> Ex1" and "f = CONJ g" by auto
  with closed_inv have "inv g \<in> Ex1" by auto
  from \<open>f = CONJ g\<close> have if_iCg: "inv f = inv (CONJ g)" by auto
  from all_bij and \<open>g \<in> Ex1\<close> have "bij g" by auto
  with if_iCg and inv_CONJ have "inv f = CONJ (inv g)" by auto
  from \<open>g \<in> Ex1\<close> and "closed_inv" have "inv g \<in> Ex1" by auto
  with \<open>inv f = CONJ (inv g)\<close> and mem_Ex2_rule show "inv f \<in> Ex2" by auto
qed

lemma comp_Ex2:
  assumes f_Ex2: "f \<in> Ex2" and
  g_Ex2: "g \<in> Ex2"
  shows "f \<circ> g \<in> Ex2"
proof -
  from f_Ex2 obtain f_1
    where f_1_Ex1: "f_1 \<in> Ex1" and "f = CONJ f_1"
    using mem_Ex2_rule by auto
  moreover
  from g_Ex2 obtain g_1
    where g_1_Ex1: "g_1 \<in> Ex1" and "g = CONJ g_1"
    using mem_Ex2_rule by auto
  ultimately
  have "f \<circ> g = (CONJ f_1) \<circ> (CONJ g_1)" by auto
  hence "f \<circ> g = CONJ (f_1 \<circ> g_1)" using comp_CONJ by auto
  moreover
  have "f_1 \<circ> g_1 \<in> Ex1" using closed_comp and f_1_Ex1 and g_1_Ex1 by auto
  ultimately
  show "f \<circ> g \<in> Ex2" using mem_Ex2_rule by auto
qed

section \<open>The Conclusion\<close>

text \<open>\label{sect:concl} With all that we have shown we have already
clearly shown @{term Ex2} to be a cofinitary group.  The formalization
also shows this, we just have to refer to the correct theorems proved
above.\<close>

interpretation CofinitaryGroup Ex2
proof
  show "Ex2 \<subseteq> S_inf"
  proof
    fix f
    assume "f \<in> Ex2"
    with mem_Ex2_rule obtain g where "g \<in> Ex1" and "f = CONJ g" by auto
    with type_CONJ show "f \<in> S_inf" by auto
  qed
next
  from id_Ex2 show "id \<in> Ex2" .
next
  fix f g
  assume "f \<in> Ex2 \<and> g \<in> Ex2"
  with comp_Ex2 show "f \<circ> g \<in> Ex2" by auto
next
  fix f
  assume "f \<in> Ex2"
  with inv_Ex2 show "inv f \<in> Ex2" by auto
next
  fix f
  assume "f \<in> Ex2 \<and> f \<noteq> id"
  with Ex2_cofinitary have "Fix f = {}" by auto
  thus "finite (Fix f)" using finite_def by auto
qed

end