(*  Title:       ProductCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter ProductCategory

theory ProductCategory
imports Category EpiMonoIso
begin

  text\<open>
    This theory defines the product of two categories @{term C1} and @{term C2},
    which is the category @{term C} whose arrows are ordered pairs consisting of an
    arrow of @{term C1} and an arrow of @{term C2}, with composition defined
    componentwise.  As the ordered pair \<open>(C1.null, C2.null)\<close> is available
    to serve as \<open>C.null\<close>, we may directly identify the arrows of the product
    category @{term C} with ordered pairs, leaving the type of arrows of @{term C}
    transparent.
\<close>

  locale product_category =
    C1: category C1 +
    C2: category C2
  for C1 :: "'a1 comp"      (infixr "\<cdot>\<^sub>1" 55)
  and C2 :: "'a2 comp"      (infixr "\<cdot>\<^sub>2" 55)
  begin

    type_synonym ('aa1, 'aa2) arr = "'aa1 * 'aa2"

    notation C1.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>1 _\<guillemotright>")
    notation C2.in_hom      ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>2 _\<guillemotright>")

    abbreviation (input) Null :: "('a1, 'a2) arr"
    where "Null \<equiv> (C1.null, C2.null)"

    abbreviation (input) Arr :: "('a1, 'a2) arr \<Rightarrow> bool"
    where "Arr f \<equiv> C1.arr (fst f) \<and> C2.arr (snd f)"

    abbreviation (input) Ide :: "('a1, 'a2) arr \<Rightarrow> bool"
    where "Ide f \<equiv> C1.ide (fst f) \<and> C2.ide (snd f)"

    abbreviation (input) Dom :: "('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr"
    where "Dom f \<equiv> (if Arr f then (C1.dom (fst f), C2.dom (snd f)) else Null)"

    abbreviation (input) Cod :: "('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr"
    where "Cod f \<equiv> (if Arr f then (C1.cod (fst f), C2.cod (snd f)) else Null)"

    definition comp :: "('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr \<Rightarrow> ('a1, 'a2) arr"
    where "comp g f = (if Arr f \<and> Arr g \<and> Cod f = Dom g then
                         (C1 (fst g) (fst f), C2 (snd g) (snd f))
                       else Null)"

    notation comp      (infixr "\<cdot>" 55)

    lemma not_Arr_Null:
    shows "\<not>Arr Null"
      by simp

    interpretation partial_magma comp
    proof
      show "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
      proof
        let ?P = "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
        show 1: "?P Null" using comp_def not_Arr_Null by metis
        thus "\<And>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n \<Longrightarrow> n = Null" by metis
      qed
    qed

    notation in_hom  ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")

    lemma null_char [simp]:
    shows "null = Null"
    proof -
      let ?P = "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
      have "?P Null" using comp_def not_Arr_Null by metis
      thus ?thesis
        unfolding null_def using the1_equality [of ?P Null] ex_un_null by blast
    qed

    lemma ide_Ide:
    assumes "Ide a"
    shows "ide a"
      unfolding ide_def comp_def null_char
      using assms C1.not_arr_null C1.ide_in_hom C1.comp_arr_dom C1.comp_cod_arr
            C2.comp_arr_dom C2.comp_cod_arr
      by auto

    lemma has_domain_char:
    shows "domains f \<noteq> {} \<longleftrightarrow> Arr f"
    proof
      show "domains f \<noteq> {} \<Longrightarrow> Arr f"
        unfolding domains_def comp_def null_char by (auto; metis)
      assume f: "Arr f"
      show "domains f \<noteq> {}"
      proof -
        have "ide (Dom f) \<and> comp f (Dom f) \<noteq> null"
          using f comp_def ide_Ide C1.comp_arr_dom C1.arr_dom_iff_arr C2.arr_dom_iff_arr
          by auto
        thus ?thesis using domains_def by blast
      qed
    qed

    lemma has_codomain_char:
    shows "codomains f \<noteq> {} \<longleftrightarrow> Arr f"
    proof
      show "codomains f \<noteq> {} \<Longrightarrow> Arr f"
        unfolding codomains_def comp_def null_char by (auto; metis)
      assume f: "Arr f"
      show "codomains f \<noteq> {}"
      proof -
        have "ide (Cod f) \<and> comp (Cod f) f \<noteq> null"
          using f comp_def ide_Ide C1.comp_cod_arr C1.arr_cod_iff_arr C2.arr_cod_iff_arr
          by auto
        thus ?thesis using codomains_def by blast
      qed
    qed

    lemma arr_char [iff]:
    shows "arr f \<longleftrightarrow> Arr f"
      using has_domain_char has_codomain_char arr_def by simp

    lemma arrI [intro]:
    assumes "C1.arr f1" and "C2.arr f2"
    shows "arr (f1, f2)"
      using assms by simp

    lemma arrE:
    assumes "arr f"
    and "C1.arr (fst f) \<and> C2.arr (snd f) \<Longrightarrow> T"
    shows "T"
      using assms by auto

    lemma seqI [intro]:
    assumes "C1.seq g1 f1 \<and> C2.seq g2 f2"
    shows "seq (g1, g2) (f1, f2)"
      using assms comp_def by auto

    lemma seqE [elim]:
    assumes "seq g f"
    and "C1.seq (fst g) (fst f) \<Longrightarrow> C2.seq (snd g) (snd f) \<Longrightarrow> T"
    shows "T"
      using assms comp_def
      by (metis (no_types, lifting) C1.seqI C2.seqI Pair_inject not_arr_null null_char)

    lemma seq_char [iff]:
    shows "seq g f \<longleftrightarrow> C1.seq (fst g) (fst f) \<and> C2.seq (snd g) (snd f)"
      using comp_def by auto

    lemma Dom_comp:
    assumes "seq g f"
    shows "Dom (g \<cdot> f) = Dom f"
      using assms comp_def
      apply (cases "C1.arr (fst g)"; cases "C1.arr (fst f)";
             cases "C2.arr (snd f)"; cases "C2.arr (snd g)"; simp_all)
      by auto

    lemma Cod_comp:
    assumes "seq g f"
    shows "Cod (g \<cdot> f) = Cod g"
      using assms comp_def
      apply (cases "C1.arr (fst f)"; cases "C2.arr (snd f)";
             cases "C1.arr (fst g)"; cases "C2.arr (snd g)"; simp_all)
      by auto

    theorem is_category:
    shows "category comp"
    proof
      fix f
      show "(domains f \<noteq> {}) = (codomains f \<noteq> {})"
        using has_domain_char has_codomain_char by simp
      fix g
      show "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
        using comp_def seq_char by (metis C1.seqI C2.seqI Pair_inject null_char)
      fix h
      show "seq h g \<Longrightarrow> seq (h \<cdot> g) f \<Longrightarrow> seq g f"
        using comp_def null_char seq_char by (elim seqE C1.seqE C2.seqE, simp)
      show "seq h (g \<cdot> f) \<Longrightarrow> seq g f \<Longrightarrow> seq h g"
        using comp_def null_char seq_char by (elim seqE C1.seqE C2.seqE, simp)
      show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> seq (h \<cdot> g) f"
        using comp_def null_char seq_char by (elim seqE C1.seqE C2.seqE, simp)
      show "seq g f \<Longrightarrow> seq h g \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
        using comp_def null_char seq_char C1.comp_assoc C2.comp_assoc
        by (elim seqE C1.seqE C2.seqE, simp)
    qed

  end

  sublocale product_category \<subseteq> category comp
    using is_category comp_def by auto

  context product_category
  begin

    lemma dom_simp [simp]:
    assumes "arr f"
    shows "dom f = (C1.dom (fst f), C2.dom (snd f))"
      using assms dom_char by auto

    lemma cod_char:
    shows "cod f = Cod f"
    proof (cases "Arr f")
      show "\<not>Arr f \<Longrightarrow> cod f = Cod f"
        unfolding cod_def using has_codomain_char by auto
      show "Arr f \<Longrightarrow> cod f = Cod f"
        using ide_Ide seqI apply (intro cod_eqI, simp)
        using seq_char comp_def C1.arr_cod_iff_arr C2.arr_cod_iff_arr by auto
    qed

    lemma cod_simp [simp]:
    assumes "arr f"
    shows "cod f = (C1.cod (fst f), C2.cod (snd f))"
      using assms cod_char by auto

    lemma in_homI [intro, simp]:
    assumes "\<guillemotleft>fst f: fst a \<rightarrow>\<^sub>1 fst b\<guillemotright>" and "\<guillemotleft>snd f: snd a \<rightarrow>\<^sub>2 snd b\<guillemotright>"
    shows "\<guillemotleft>f: a \<rightarrow> b\<guillemotright>"
      using assms by fastforce

    lemma in_homE [elim]:
    assumes "\<guillemotleft>f: a \<rightarrow> b\<guillemotright>"
    and "\<guillemotleft>fst f: fst a \<rightarrow>\<^sub>1 fst b\<guillemotright> \<Longrightarrow> \<guillemotleft>snd f: snd a \<rightarrow>\<^sub>2 snd b\<guillemotright> \<Longrightarrow> T"
    shows "T"
      using assms
      by (metis C1.in_homI C2.in_homI arr_char cod_simp dom_simp fst_conv in_homE snd_conv)

    lemma ide_char [iff]:
    shows "ide f \<longleftrightarrow> Ide f"
      using ide_in_hom C1.ide_in_hom C2.ide_in_hom by blast

    lemma comp_char:
    shows "g \<cdot> f = (if C1.arr (C1 (fst g) (fst f)) \<and> C2.arr (C2 (snd g) (snd f)) then
                       (C1 (fst g) (fst f), C2 (snd g) (snd f))
                    else Null)"
      using comp_def by auto

    lemma comp_simp [simp]:
    assumes "C1.seq (fst g) (fst f)" and "C2.seq (snd g) (snd f)"
    shows "g \<cdot> f = (fst g \<cdot>\<^sub>1 fst f, snd g \<cdot>\<^sub>2 snd f)"
      using assms comp_char by simp

    lemma iso_char [iff]:
    shows "iso f \<longleftrightarrow> C1.iso (fst f) \<and> C2.iso (snd f)"
    proof
      assume f: "iso f"
      obtain g where g: "inverse_arrows f g" using f by auto
      have 1: "ide (g \<cdot> f) \<and> ide (f \<cdot> g)"
        using f g by (simp add: inverse_arrows_def)
      have "g \<cdot> f = (fst g \<cdot>\<^sub>1 fst f, snd g \<cdot>\<^sub>2 snd f) \<and> f \<cdot> g = (fst f \<cdot>\<^sub>1 fst g, snd f \<cdot>\<^sub>2 snd g)"
        using 1 comp_char arr_char by (meson ideD(1) seq_char)
      hence "C1.ide (fst g \<cdot>\<^sub>1 fst f) \<and> C2.ide (snd g \<cdot>\<^sub>2 snd f) \<and>
             C1.ide (fst f \<cdot>\<^sub>1 fst g) \<and> C2.ide (snd f \<cdot>\<^sub>2 snd g)"
        using 1 ide_char by simp
      hence "C1.inverse_arrows (fst f) (fst g) \<and> C2.inverse_arrows (snd f) (snd g)"
        by auto
      thus "C1.iso (fst f) \<and> C2.iso (snd f)" by auto
      next
      assume f: "C1.iso (fst f) \<and> C2.iso (snd f)"
      obtain g1 where g1: "C1.inverse_arrows (fst f) g1" using f by blast
      obtain g2 where g2: "C2.inverse_arrows (snd f) g2" using f by blast
      have "C1.ide (g1 \<cdot>\<^sub>1 fst f) \<and> C2.ide (g2 \<cdot>\<^sub>2 snd f) \<and>
            C1.ide (fst f \<cdot>\<^sub>1 g1) \<and> C2.ide (snd f \<cdot>\<^sub>2 g2)"
        using g1 g2 ide_char by force
      hence "inverse_arrows f (g1, g2)"
        using f g1 g2 ide_char comp_char by (intro inverse_arrowsI, auto)
      thus "iso f" by auto
    qed

    lemma isoI [intro, simp]:
    assumes "C1.iso (fst f)" and "C2.iso (snd f)"
    shows "iso f"
      using assms by simp

    lemma isoD:
    assumes "iso f"
    shows "C1.iso (fst f)" and "C2.iso (snd f)"
      using assms by auto

    lemma inv_simp [simp]:
    assumes "iso f"
    shows "inv f = (C1.inv (fst f), C2.inv (snd f))"
    proof -
      have "inverse_arrows f (C1.inv (fst f), C2.inv (snd f))"
      proof
        have 1: "C1.inverse_arrows (fst f) (C1.inv (fst f))"
          using assms iso_char C1.inv_is_inverse by simp
        have 2: "C2.inverse_arrows (snd f) (C2.inv (snd f))"
          using assms iso_char C2.inv_is_inverse by simp
        show "ide ((C1.inv (fst f), C2.inv (snd f)) \<cdot> f)"
          using 1 2 ide_char comp_char by auto
        show "ide (f \<cdot> (C1.inv (fst f), C2.inv (snd f)))"
          using 1 2 ide_char comp_char by auto
      qed
      thus ?thesis using inverse_unique by auto
    qed

  end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_BSortSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "Nat list => Nat list => Nat list" where
  "pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "Nat list => Nat list => Nat list" where
  "stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
  by pat_completeness auto

(*fun did not finish the proof*)
function bmerge :: "Nat list => Nat list => Nat list" where
  "bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: Nat list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "Nat list => Nat list" where
  "bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "ordered (bsort xs)"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_38
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
"y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
"x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun count :: "Nat => Nat list => Nat" where
"count z (nil2) = Z"
| "count z (cons2 z2 ys) =
     (if x z z2 then S (count z ys) else count z ys)"

theorem property0 :
  "((count n (y xs (cons2 n (nil2)))) = (S (count n xs)))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_StoogeSortSorts
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "Nat list => Nat list"
  and stoogesort :: "Nat list => Nat list"
  and stooge1sort1 :: "Nat list => Nat list" where
  "stooge1sort2 y =
   (case splitAt (idiv (length y) (S (S (S Z)))) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (stoogesort xs)"
  oops

end


theory Cyclic_Group_Ext imports
  CryptHOL.CryptHOL
  "HOL-Number_Theory.Cong"
  GCD
begin

context cyclic_group begin

lemma generator_pow_order: "\<^bold>g (^) order G = \<one>"
proof(cases "order G > 0")
  case True
  hence fin: "finite (carrier G)" by(simp add: order_gt_0_iff_finite)
  then have [symmetric]: "(\<lambda>x. x \<otimes> \<^bold>g) ` carrier G = carrier G"
    by(rule endo_inj_surj)(auto simp add: inj_on_multc)
  then have "carrier G = (\<lambda> n. \<^bold>g (^) Suc n) ` {..<order G}" using fin
    by(simp add: carrier_conv_generator image_image)
  then obtain n where n: "\<one> = \<^bold>g (^) Suc n" "n < order G" by auto
  have "n = order G - 1" using n inj_onD[OF inj_on_generator, of 0 "Suc n"] by fastforce
  with True n show ?thesis by auto
qed simp

lemma pow_generator_mod: "\<^bold>g (^) (k mod order G) = \<^bold>g (^) k"
proof(cases "order G > 0")
  case True
  obtain n where n: "k = n * order G + k mod order G" by (metis div_mult_mod_eq)
  have "\<^bold>g (^) k = (\<^bold>g (^) order G) (^) n \<otimes> \<^bold>g (^) (k mod order G)"
    by(subst n)(simp add: nat_pow_mult nat_pow_pow mult_ac)
  then show ?thesis by(simp add: generator_pow_order)
qed simp

lemma pow_carrier_mod: assumes "g \<in> carrier G"
  shows "g (^) (k mod order G) = g (^) k"
  using pow_generator_mod
  by (metis assms generatorE generator_closed mod_mult_right_eq nat_pow_pow)

lemma pow_generator_eq_iff_cong:
  "finite (carrier G) \<Longrightarrow> \<^bold>g (^) x = \<^bold>g (^) y \<longleftrightarrow> [x = y] (mod order G)"
by(subst (1 2) pow_generator_mod[symmetric])(auto simp add: cong_nat_def order_gt_0_iff_finite intro: inj_onD[OF inj_on_generator])

lemma inverse: assumes "gcd (nat (int m - int m')) (order \<G>) = 1" and m_ge_m': "m > m'"
  shows "[(int m - int m') * (fst (bezw (nat (int m - int m')) (order \<G>))) = 1] (mod order \<G>)"
proof-
  have 4: "int m - int m' = int (m - m')" using m_ge_m' by simp
  have 1: "fst (bezw  (nat (int m - int m')) (order \<G>)) * int (m - m') + snd (bezw (nat (int m - int m')) (order \<G>)) * int (order \<G>) = 1"
    using bezw_aux assms int_minus by presburger
  hence 2: "(fst (bezw  (nat (int m - int m')) (order \<G>)) * int (m - m') + snd (bezw (nat (int m - int m')) (order \<G>)) * int (order \<G>)) mod (order \<G>) = 1 mod (order \<G>)"
    by (simp add: zmod_int)
  hence 3: "(fst (bezw (nat (int m - int m')) (order \<G>)) * int  (m - m')) mod (order \<G>) = 1 mod (order \<G>)"
    by simp
  hence 5:  "[(fst (bezw (nat (int m - int m')) (order \<G>))) *(int m - int m')  = 1] (mod order \<G>)"
    using 1 2 4 cong_int_def by auto
  then show ?thesis by(simp add: mult.commute)
qed

end

end


(*
  File: Nat.thy
  Author: Bohua Zhan

  Axiom of infinity, construction of natural numbers. Roughly following the
  construction of natural numbers in Isabelle/ZF.
*)

theory Nat
  imports Ordinal Semiring Equipotent
begin

section \<open>Axiom of infinity\<close>

axiomatization Inf :: "i" where
  infinity: "\<emptyset> \<in> Inf \<and> (\<forall>y\<in>Inf. succ(y) \<in> Inf)"
setup {* add_forward_prfstep_cond @{thm infinity} [with_term "Inf"] *}

lemma infinityD1 [typing2]: "\<emptyset> \<in> Inf" by auto2
lemma infinityD2 [typing]: "y \<in> Inf \<Longrightarrow> succ(y) \<in> Inf" by auto2
setup {* del_prfstep_thm @{thm infinity} *}

section \<open>Definition of natural numbers\<close>

definition Zero ("0") where [rewrite]: "0 = \<emptyset>"

(* Considered only applied to nat *)
definition Suc :: "i \<Rightarrow> i" where [rewrite]:
  "Suc(n) = succ(n)"

definition nat :: i where [rewrite]:
  "nat = lfp(Inf, \<lambda>X. {0} \<union> {Suc(i). i \<in> X})"
setup {* register_wellform_data ("Suc(n)", ["n \<in> nat"]) *}

lemma nat_bnd_mono [resolve]: "bnd_mono(Inf, \<lambda>X. {0} \<union> {Suc(i). i \<in> X})" by auto2

lemma nat_induct [var_induct]:
  "n \<in> nat \<Longrightarrow> P(0) \<Longrightarrow> \<forall>x\<in>nat. P(x) \<longrightarrow> P(Suc(x)) \<Longrightarrow> P(n)"
@proof
  @induct "n \<in> lfp(Inf, \<lambda>X. {0} \<union> {Suc(i). i \<in> X})" "P(n)"
@qed

lemma nat_unfold [rewrite]: "nat = {0} \<union> {Suc(x). x \<in> nat}" by auto2
lemma nat_case_split [backward2]: "x \<in> nat \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> \<exists>m\<in>nat. x = Suc(m)" by auto2
lemma nat_0I [typing]: "0 \<in> nat" by auto2
lemma nat_SucI [typing]: "n \<in> nat \<Longrightarrow> Suc(n) \<in> nat" by auto2
lemma nat_Suc_not_zero [resolve]: "0 \<noteq> Suc(n)" by auto2
lemma nat_Suc_inj [forward]: "Suc(a) = Suc(b) \<Longrightarrow> a = b" by auto2

section \<open>Natural numbers as an ordinal\<close>

(* First infinite cardinal. *)
definition omega_ord :: i  ("\<omega>") where [rewrite]:
  "\<omega> = nat"

lemma nat_into_ordinal [resolve]:
  "n \<in> nat \<Longrightarrow> ord(n)"
@proof @var_induct "n \<in> nat" @qed

lemma nat_ordinal [forward]:
  "ord(\<omega>)"
@proof
  @have "trans_set(nat)" @with
    @have "\<forall>x\<in>nat. x \<subseteq> nat" @with
      @var_induct "x \<in> nat"
    @end
  @end
  @have "\<forall>n\<in>nat. trans_set(n)" @with
    @have "ord(n)"
  @end
@qed

lemma nat_limit_ordinal [forward]:
  "limit_ord(\<omega>)" by auto2

(* TODO: unify with proof of equipotent_nat_less_range in Finite *)
lemma equipotent_nat_less_range [backward1]:
  "m \<in> nat \<Longrightarrow> n \<in> nat \<Longrightarrow> m \<approx>\<^sub>S n \<Longrightarrow> m = n"
@proof
  @var_induct "m \<in> nat" arbitrary n @with
    @subgoal "m = Suc(m')"
      @obtain "n'\<in>nat" where "n = Suc(n')"
      @have "m' = Suc(m') \<midarrow> {m'}"
      @have "n' = Suc(n') \<midarrow> {n'}"
      @have "m' \<approx>\<^sub>S n'"
    @endgoal
  @end
@qed

lemma nat_not_equipotent [resolve]:
  "x \<in> \<omega> \<Longrightarrow> \<not> x \<approx>\<^sub>S \<omega>"
@proof
  @contradiction
  @have "Suc(x) \<lesssim>\<^sub>S \<omega>"
  @have "\<omega> \<approx>\<^sub>S x"
  @have "x \<approx>\<^sub>S Suc(x)" @with
    @have "x \<lesssim>\<^sub>S Suc(x)"
  @end
  @have "x = Suc(x)"
@qed

setup {* fold del_prfstep_thm [@{thm nat_def}, @{thm nat_bnd_mono}, @{thm nat_unfold}] *}
setup {* del_prfstep_thm @{thm omega_ord_def} *}
setup {* add_resolve_prfstep @{thm omega_ord_def} *}

abbreviation One ("1") where "1 \<equiv> Suc(0)"
abbreviation Two ("2") where "2 \<equiv> Suc(1)"
abbreviation Three ("3") where "3 \<equiv> Suc(2)"
abbreviation Four ("4") where "4 \<equiv> Suc(3)"
abbreviation Five ("5") where "5 \<equiv> Suc(4)"

section \<open>Defining functions on natural numbers\<close>

definition nat_case :: "[i, i \<Rightarrow> i, i] \<Rightarrow> i" where [rewrite]:
  "nat_case(a,b,k) = (THE y. k = 0 \<and> y = a \<or> (\<exists>x. k = Suc(x) \<and> y = b(x)))"
setup {* register_wellform_data ("nat_case(a,b,k)", ["k \<in> nat"]) *}

lemma nat_case_0 [rewrite]: "nat_case(a,b,0) = a" by auto2
lemma nat_case_Suc [rewrite]: "nat_case(a,b,Suc(m)) = b(m)" by auto2
setup {* del_prfstep_thm @{thm nat_case_def} *}

lemma nat_case_type [backward]:
  "k \<in> nat \<Longrightarrow> a \<in> T \<Longrightarrow> \<forall>m\<in>nat. b(m) \<in> T \<Longrightarrow> nat_case(a,b,k) \<in> T"
@proof
  @contradiction
  @obtain "k'\<in>nat" where "k = Suc(k')"
@qed

definition nat_rec :: "[i, i \<Rightarrow> i \<Rightarrow> i, i] \<Rightarrow> i" where [rewrite]:
  "nat_rec(a,b,k) = wfrec(mem_rel(nat), \<lambda>n f. nat_case(a, \<lambda>m. b(m, f`m), n), k)"
setup {* register_wellform_data ("nat_rec(a,b,k)", ["k \<in> nat"]) *}

lemma nat_rec_0 [rewrite]: "nat_rec(a,b,0) = a" by auto2
lemma nat_rec_Suc [rewrite]: "m \<in> nat \<Longrightarrow> nat_rec(a,b,Suc(m)) = b(m, nat_rec(a,b,m))"
  @proof @have "m \<in> ord_pred(mem_rel(nat),Suc(m))" @qed
setup {* del_prfstep_thm @{thm nat_rec_def} *}

lemma nat_rec_type [backward]:
  "k \<in> nat \<Longrightarrow> a \<in> T \<Longrightarrow> \<forall>m\<in>nat. \<forall>p\<in>T. b(m,p)\<in>T \<Longrightarrow> nat_rec(a,b,k) \<in> T"
@proof @var_induct "k \<in> nat" @qed

setup {* fold del_prfstep_thm [@{thm Zero_def}, @{thm Suc_def}] *}

section \<open>Natural numbers as an ordered semiring\<close>

(* Recursion on x:
    nat_add(0,y) = y
  | nat_add(Suc(x),y) = Suc(nat_add(x,y))
*)
definition nat_add :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "nat_add(x,y) = nat_rec(y, \<lambda>_ p. Suc(p), x)"
setup {* register_wellform_data ("nat_add(x,y)", ["x \<in> nat", "y \<in> nat"]) *}

lemma nat_add_0 [rewrite]: "nat_add(0,x) = x" by auto2
lemma nat_add_Suc [rewrite]: "x \<in> nat \<Longrightarrow> nat_add(Suc(x),y) = Suc(nat_add(x,y))" by auto2
lemma nat_add_type [typing]: "x \<in> nat \<Longrightarrow> y \<in> nat \<Longrightarrow> nat_add(x,y) \<in> nat" by auto2
setup {* del_prfstep_thm @{thm nat_add_def} *}

(* Recursion on x:
    nat_mult(0,y) = 0
  | nat_mult(Suc(x),y) = y + nat_mult(x,y)
*)
definition nat_mult :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "nat_mult(x,y) = nat_rec(0, \<lambda>_ p. nat_add(y,p), x)"
setup {* register_wellform_data ("nat_mult(x,y)", ["x \<in> nat", "y \<in> nat"]) *}

lemma nat_mult_0 [rewrite]: "nat_mult(0,x) = 0" by auto2
lemma nat_mult_Suc [rewrite]: "x \<in> nat \<Longrightarrow> nat_mult(Suc(x),y) = nat_add(y,nat_mult(x,y))" by auto2
lemma nat_mult_type [typing]: "x \<in> nat \<Longrightarrow> y \<in> nat \<Longrightarrow> nat_mult(x,y) \<in> nat" by auto2
setup {* del_prfstep_thm @{thm nat_mult_def} *}

definition nat_le :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "nat_le(x,y) \<longleftrightarrow> (\<exists>p\<in>nat. y = nat_add(x,p))"

lemma nat_leI: "x \<in> nat \<Longrightarrow> p \<in> nat \<Longrightarrow> nat_le(x,nat_add(x,p))" by auto2

definition nat_ring :: i  ("\<nat>") where [rewrite]:
  "\<nat> = OrdRing(nat, 0, \<lambda>x y. nat_add(x,y), 1, \<lambda>x y. nat_mult(x,y), \<lambda>x y. nat_le(x,y))"

lemma nat_ring_is_ord_ring_raw [forward]: "ord_ring_form(\<nat>)" by auto2
lemma nat_carrier [rewrite_bidir]: "carrier(\<nat>) = nat" by auto2
lemma nat_evals:
  "\<zero>\<^sub>\<nat> = 0"
  "\<one>\<^sub>\<nat> = 1"
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x +\<^sub>\<nat> y = nat_add(x,y)"
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x *\<^sub>\<nat> y = nat_mult(x,y)"
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x \<le>\<^sub>\<nat> y \<longleftrightarrow> nat_le(x,y)" by auto2+
setup {* fold add_rewrite_rule @{thms nat_evals(1,2)} *}
setup {* del_prfstep_thm @{thm nat_ring_def} *}
setup {* add_var_induct_data_with_prem (@{term_pat "?n \<in>. \<nat>"}, @{thm nat_induct}) *}

section \<open>Addition on natural numbers\<close>

setup {* add_rewrite_rule @{thm nat_evals(3)} *}
lemma nat_add_0_left [rewrite]: "x \<in>. \<nat> \<Longrightarrow> 0 +\<^sub>\<nat> x = x" by auto2
lemma nat_add_Suc' [rewrite]: "x \<in> nat \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> Suc(x) +\<^sub>\<nat> y = Suc(x +\<^sub>\<nat> y)" by auto2
setup {* fold del_prfstep_thm [@{thm nat_add_0}, @{thm nat_add_Suc}, @{thm nat_add_type}, @{thm nat_evals(3)}] *}

lemma nat_add_0_right [rewrite]: "x \<in>. \<nat> \<Longrightarrow> x +\<^sub>\<nat> 0 = x"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_add_assoc [rewrite_bidir]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> (x +\<^sub>\<nat> y) +\<^sub>\<nat> z = x +\<^sub>\<nat> (y +\<^sub>\<nat> z)"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_add_1 [rewrite_bidir]:
  "x \<in>. \<nat> \<Longrightarrow> Suc(x) = x +\<^sub>\<nat> 1"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_add_comm [rewrite]: "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x +\<^sub>\<nat> y = y +\<^sub>\<nat> x"
@proof @var_induct "x \<in>. \<nat>" @qed

section \<open>Multiplication on natural numbers\<close>

setup {* fold add_rewrite_rule @{thms nat_evals(3,4)} *}
lemma nat_mult_0_left [rewrite]: "x \<in>. \<nat> \<Longrightarrow> 0 *\<^sub>\<nat> x = 0" by auto2
lemma nat_mult_Suc' [rewrite]: "x \<in> nat \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> Suc(x) *\<^sub>\<nat> y = y +\<^sub>\<nat> (x *\<^sub>\<nat> y)" by auto2
setup {* fold del_prfstep_thm [@{thm nat_mult_0}, @{thm nat_mult_Suc}, @{thm nat_mult_type}] *}
setup {* fold del_prfstep_thm @{thms nat_evals(3,4)} *}

lemma nat_mult_0_right [rewrite]: "x \<in>. \<nat> \<Longrightarrow> x *\<^sub>\<nat> 0 = 0"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_mult_1 [rewrite]: "x \<in>. \<nat> \<Longrightarrow> 1 *\<^sub>\<nat> x = x" by auto2
lemma nat_mult_1_right [rewrite]: "x \<in>. \<nat> \<Longrightarrow> x *\<^sub>\<nat> 1 = x"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_distrib_l [rewrite]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> x *\<^sub>\<nat> (y +\<^sub>\<nat> z) = x *\<^sub>\<nat> y +\<^sub>\<nat> x *\<^sub>\<nat> z"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_distrib_r [rewrite]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> (x +\<^sub>\<nat> y) *\<^sub>\<nat> z = x *\<^sub>\<nat> z +\<^sub>\<nat> y *\<^sub>\<nat> z"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_mult_assoc [rewrite_bidir]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> (x *\<^sub>\<nat> y) *\<^sub>\<nat> z = x *\<^sub>\<nat> (y *\<^sub>\<nat> z)"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_mult_Suc_right [rewrite]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in> nat \<Longrightarrow> x *\<^sub>\<nat> Suc(y) = x +\<^sub>\<nat> (x *\<^sub>\<nat> y)"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_mult_comm [rewrite]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x *\<^sub>\<nat> y = y *\<^sub>\<nat> x"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_is_semiring [forward]: "is_semiring(\<nat>)" by auto2

setup {* fold del_prfstep_thm [@{thm nat_add_assoc}, @{thm nat_add_comm}] *}
setup {* fold del_prfstep_thm [@{thm nat_mult_assoc}, @{thm nat_mult_comm}] *}
setup {* fold del_prfstep_thm [@{thm nat_distrib_l}, @{thm nat_distrib_r}] *}

lemma nat_add_cancel_left [forward]:
  "a \<in>. \<nat> \<Longrightarrow> b \<in>. \<nat> \<Longrightarrow> c \<in>. \<nat> \<Longrightarrow> c +\<^sub>\<nat> a = c +\<^sub>\<nat> b \<Longrightarrow> a = b"
@proof @var_induct "c \<in>. \<nat>" @qed

lemma nat_add_cancel_right [forward]:
  "a \<in>. \<nat> \<Longrightarrow> b \<in>. \<nat> \<Longrightarrow> c \<in>. \<nat> \<Longrightarrow> a +\<^sub>\<nat> c = b +\<^sub>\<nat> c \<Longrightarrow> a = b"
@proof @have "a +\<^sub>\<nat> c = c +\<^sub>\<nat> a" @have "b +\<^sub>\<nat> c = c +\<^sub>\<nat> b" @qed

lemma nat_add_right_eq_zero [forward]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x +\<^sub>\<nat> y = x \<Longrightarrow> y = 0"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_add_left_eq_zero [forward]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x +\<^sub>\<nat> y = y \<Longrightarrow> x = 0"
@proof @have "x +\<^sub>\<nat> y = y +\<^sub>\<nat> x" @qed

lemma nat_add_is_zero [forward]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x +\<^sub>\<nat> y = 0 \<Longrightarrow> x = 0 \<and> y = 0"
@proof @var_induct "x \<in>. \<nat>" @qed

lemma nat_mult_nonzero [forward]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x *\<^sub>\<nat> y = 0 \<Longrightarrow> x = 0 \<or> y = 0"
@proof @var_induct "y \<in>. \<nat>" @qed
setup {* del_prfstep_thm @{thm nat_mult_Suc_right} *}

section \<open>Ordering on natural numbers\<close>

setup {* fold add_rewrite_rule @{thms nat_evals(3,5)} *}
lemma nat_leD [backward]: "x \<le>\<^sub>\<nat> y \<Longrightarrow> \<exists>p\<in>.\<nat>. y = x +\<^sub>\<nat> p" by auto2
lemma nat_leI_right [resolve]: "x \<in>. \<nat> \<Longrightarrow> p \<in>. \<nat> \<Longrightarrow> x \<le>\<^sub>\<nat> x +\<^sub>\<nat> p" by auto2
setup {* del_prfstep_thm @{thm nat_le_def} *}
setup {* fold del_prfstep_thm @{thms nat_evals(3,5)} *}

lemma nat_leI_left [resolve]: "x \<in>. \<nat> \<Longrightarrow> k \<in>. \<nat> \<Longrightarrow> k \<le>\<^sub>\<nat> x +\<^sub>\<nat> k"
@proof @have "x +\<^sub>\<nat> k = k +\<^sub>\<nat> x" @qed

lemma nat_le_refl [resolve]: "x \<in>. \<nat> \<Longrightarrow> x \<le>\<^sub>\<nat> x"
@proof @have "x = x +\<^sub>\<nat> 0" @qed

lemma nat_le_antisym [forward]:
  "x \<le>\<^sub>\<nat> y \<Longrightarrow> y \<le>\<^sub>\<nat> x \<Longrightarrow> x = y"
@proof
  @obtain "p\<in>nat" where "y = x +\<^sub>\<nat> p"
  @obtain "q\<in>nat" where "x = y +\<^sub>\<nat> q"
  @have "(x +\<^sub>\<nat> p) +\<^sub>\<nat> q = x +\<^sub>\<nat> (p +\<^sub>\<nat> q)"
@qed

lemma nat_le_trans [forward]:
  "x \<le>\<^sub>\<nat> y \<Longrightarrow> y \<le>\<^sub>\<nat> z \<Longrightarrow> x \<le>\<^sub>\<nat> z"
@proof
  @obtain "p\<in>nat" where "y = x +\<^sub>\<nat> p"
  @obtain "q\<in>nat" where "z = y +\<^sub>\<nat> q"
  @have "(x +\<^sub>\<nat> p) +\<^sub>\<nat> q = x +\<^sub>\<nat> (p +\<^sub>\<nat> q)"
@qed

lemma nat_is_order [forward]: "order(\<nat>)" by auto2
setup {* fold del_prfstep_thm [@{thm nat_le_refl}, @{thm nat_le_antisym}, @{thm nat_le_trans}] *}

lemma nat_less_exI [backward]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> y \<noteq> 0 \<Longrightarrow> x <\<^sub>\<nat> x +\<^sub>\<nat> y"
@proof @have "x \<noteq> x +\<^sub>\<nat> y" @qed

lemma nat_less_ex [backward]: "x <\<^sub>\<nat> y \<Longrightarrow> \<exists>p\<in>nat. p \<noteq> 0 \<and> y = x +\<^sub>\<nat> p"
@proof @obtain "p\<in>nat" where "y = x +\<^sub>\<nat> p" @qed

lemma nat_zero_le [resolve]: "x \<in>. \<nat> \<Longrightarrow> 0 \<le>\<^sub>\<nat> x"
@proof @have "x = 0 +\<^sub>\<nat> x" @qed

lemma nat_le_Suc [resolve]: "x \<in>. \<nat> \<Longrightarrow> x <\<^sub>\<nat> Suc(x)"
@proof @have "x \<noteq> Suc(x)" @with @have "x = x +\<^sub>\<nat> 0" @end @qed

lemma nat_le_to_less_Suc [resolve]: "x \<le>\<^sub>\<nat> y \<Longrightarrow> x \<le>\<^sub>\<nat> Suc(y)"
@proof @obtain "p\<in>nat" where "y = x +\<^sub>\<nat> p" @have "(x +\<^sub>\<nat> p) +\<^sub>\<nat> 1 = x +\<^sub>\<nat> (p +\<^sub>\<nat> 1)" @qed

lemma nat_less_to_Suc_le [resolve]: "x <\<^sub>\<nat> y \<Longrightarrow> Suc(x) \<le>\<^sub>\<nat> y"
@proof
  @obtain "p\<in>nat" where "p \<noteq> 0" "y = x +\<^sub>\<nat> p"
  @obtain "p'\<in>nat" where "p = Suc(p')"
  @have "x +\<^sub>\<nat> (p' +\<^sub>\<nat> 1) = (x +\<^sub>\<nat> 1) +\<^sub>\<nat> p'"
@qed

lemma nat_le_to_Suc_le [backward2]: "x \<le>\<^sub>\<nat> y \<Longrightarrow> x \<noteq> y \<Longrightarrow> Suc(x) \<le>\<^sub>\<nat> y"
@proof @have "x <\<^sub>\<nat> y" @qed

lemma nat_is_linorder [forward]: "linorder(\<nat>)"
@proof
  @have "\<forall>x\<in>.\<nat>. \<forall>y\<in>.\<nat>. \<not>x \<le>\<^sub>\<nat> y \<longrightarrow> y \<le>\<^sub>\<nat> x" @with
    @var_induct "x \<in>. \<nat>" for "x \<le>\<^sub>\<nat> y \<or> y \<le>\<^sub>\<nat> x"
  @end
@qed

lemma nat_less_Suc_to_le [forward]: "b \<in> nat \<Longrightarrow> a <\<^sub>\<nat> Suc(b) \<Longrightarrow> a \<le>\<^sub>\<nat> b" by auto2

lemma nat_le_zero [forward]: "n \<in>. \<nat> \<Longrightarrow> n \<le>\<^sub>\<nat> 0 \<Longrightarrow> n = 0" by auto2

lemma nat_less_one [forward]: "n \<in>. \<nat> \<Longrightarrow> n <\<^sub>\<nat> 1 \<Longrightarrow> n = 0" by auto2

lemma nat_add_ordered_right [rewrite_back]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> x \<le>\<^sub>\<nat> y \<longleftrightarrow> x +\<^sub>\<nat> z \<le>\<^sub>\<nat> y +\<^sub>\<nat> z"
@proof
  @case "x \<le>\<^sub>\<nat> y" @with
    @obtain "p\<in>nat" where "y = x +\<^sub>\<nat> p"
    @have "(x +\<^sub>\<nat> p) +\<^sub>\<nat> z = (x +\<^sub>\<nat> z) +\<^sub>\<nat> p" @end
  @case "x +\<^sub>\<nat> z \<le>\<^sub>\<nat> y +\<^sub>\<nat> z" @with
    @obtain "p\<in>nat" where "y +\<^sub>\<nat> z = x +\<^sub>\<nat> z +\<^sub>\<nat> p"
    @have "x +\<^sub>\<nat> z +\<^sub>\<nat> p = x +\<^sub>\<nat> p +\<^sub>\<nat> z" @end
@qed

lemma nat_add_ordered_left [rewrite_back]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> y \<le>\<^sub>\<nat> z \<longleftrightarrow> x +\<^sub>\<nat> y \<le>\<^sub>\<nat> x +\<^sub>\<nat> z"
@proof @have "x +\<^sub>\<nat> y = y +\<^sub>\<nat> x" @have "x +\<^sub>\<nat> z = z +\<^sub>\<nat> x" @qed

lemma nat_mult_ordered_left [backward]:
  "z \<in>. \<nat> \<Longrightarrow> x \<le>\<^sub>\<nat> y \<Longrightarrow> z *\<^sub>\<nat> x \<le>\<^sub>\<nat> z *\<^sub>\<nat> y"
@proof
  @obtain "p\<in>nat" where "y = x +\<^sub>\<nat> p"
  @have "z *\<^sub>\<nat> (x +\<^sub>\<nat> p) = z *\<^sub>\<nat> x +\<^sub>\<nat> z *\<^sub>\<nat> p"
@qed

lemma nat_is_ord_semiring [forward]: "is_ord_semiring(\<nat>)" by auto2

lemma nat_add_strict_ordered_right [rewrite_back]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> x <\<^sub>\<nat> y \<longleftrightarrow> x +\<^sub>\<nat> z <\<^sub>\<nat> y +\<^sub>\<nat> z" by auto2

lemma nat_add_strict_ordered_left [rewrite_back]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> y <\<^sub>\<nat> z \<longleftrightarrow> x +\<^sub>\<nat> y <\<^sub>\<nat> x +\<^sub>\<nat> z" by auto2

lemma nat_add_order_mix2 [backward1]:
  "p \<le>\<^sub>\<nat> q \<Longrightarrow> r <\<^sub>\<nat> s \<Longrightarrow> p +\<^sub>\<nat> r <\<^sub>\<nat> q +\<^sub>\<nat> s"
@proof @have "p +\<^sub>\<nat> r <\<^sub>\<nat> p +\<^sub>\<nat> s" @qed

lemma nat_add_order_mix3 [backward1]:
  "p <\<^sub>\<nat> q \<Longrightarrow> r \<le>\<^sub>\<nat> s \<Longrightarrow> p +\<^sub>\<nat> r <\<^sub>\<nat> q +\<^sub>\<nat> s"
@proof @have "p +\<^sub>\<nat> r \<le>\<^sub>\<nat> p +\<^sub>\<nat> s" @qed

lemma nat_mult_less_right [backward2]:
  "z \<in>. \<nat> \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x <\<^sub>\<nat> y \<Longrightarrow> x *\<^sub>\<nat> z <\<^sub>\<nat> y *\<^sub>\<nat> z"
@proof
  @obtain "p\<in>nat" where "p \<noteq> 0" "y = x +\<^sub>\<nat> p"
  @have "(x +\<^sub>\<nat> p) *\<^sub>\<nat> z = x *\<^sub>\<nat> z +\<^sub>\<nat> p *\<^sub>\<nat> z"
@qed

lemma nat_mult_less_left [backward2]:
  "z \<in>. \<nat> \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x <\<^sub>\<nat> y \<Longrightarrow> z *\<^sub>\<nat> x <\<^sub>\<nat> z *\<^sub>\<nat> y"
@proof @have "z *\<^sub>\<nat> x = x *\<^sub>\<nat> z" @have "z *\<^sub>\<nat> y = y *\<^sub>\<nat> z" @qed

lemma nat_mult_cancel_left [forward]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> z *\<^sub>\<nat> x = z *\<^sub>\<nat> y \<Longrightarrow> x = y"
@proof
  @case "x <\<^sub>\<nat> y" @with @have "z *\<^sub>\<nat> x <\<^sub>\<nat> z *\<^sub>\<nat> y" @end
  @case "x >\<^sub>\<nat> y" @with @have "z *\<^sub>\<nat> x >\<^sub>\<nat> z *\<^sub>\<nat> y" @end
@qed

lemma nat_mult_cancel_right [forward]:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> z \<in>. \<nat> \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x *\<^sub>\<nat> z = y *\<^sub>\<nat> z \<Longrightarrow> x = y"
@proof @have "x *\<^sub>\<nat> z = z *\<^sub>\<nat> x" @have "y *\<^sub>\<nat> z = z *\<^sub>\<nat> y" @qed

section \<open>Subtraction in natural numbers\<close>

setup {* add_backward2_prfstep @{thm minusI} *}
lemma nat_minusI [resolve]:
  "y \<in>. \<nat> \<Longrightarrow> p \<in>. \<nat> \<Longrightarrow> p +\<^sub>\<nat> y = x \<Longrightarrow> x -\<^sub>\<nat> y = p" by auto2
setup {* del_prfstep_thm @{thm minusI} *}

lemma nat_minus_prop:
  "x \<in>. \<nat> \<Longrightarrow> y \<in>. \<nat> \<Longrightarrow> x \<ge>\<^sub>\<nat> y \<Longrightarrow> x -\<^sub>\<nat> y \<in>. \<nat> \<and> (x -\<^sub>\<nat> y) +\<^sub>\<nat> y = x"
@proof
  @obtain "p\<in>.\<nat>" where "x = y +\<^sub>\<nat> p" @have "x = p +\<^sub>\<nat> y"
  @have "x -\<^sub>\<nat> y = p"
@qed
setup {* add_typing_rule (conj_left_th @{thm nat_minus_prop}) *}
setup {* add_rewrite_rule (conj_right_th @{thm nat_minus_prop}) *}

ML_file "nat_arith.ML"

section \<open>Replace lemmas about Suc(x) with x + 1\<close>

setup {* fold del_prfstep_thm [@{thm nat_Suc_inj}] *}

lemma nat_Suc_not_zero' [resolve]: "n \<in>. \<nat> \<Longrightarrow> 0 \<noteq> n +\<^sub>\<nat> 1" by auto2
lemma nat_case_split' [backward2]: "x \<in> nat \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> \<exists>m\<in>.\<nat>. x = m +\<^sub>\<nat> 1"
  @proof @obtain "m\<in>.\<nat>" where "x = Suc(m)" @qed
lemma nat_case_Suc' [rewrite]: "m \<in>. \<nat> \<Longrightarrow> nat_case(a,b,m +\<^sub>\<nat> 1) = b(m)" by auto2
lemma nat_rec_Suc' [rewrite]: "m \<in>. \<nat> \<Longrightarrow> nat_rec(a,b,m +\<^sub>\<nat> 1) = b(m, nat_rec(a,b,m))" by auto2
lemma nat_le_Suc' [resolve]: "x \<in>. \<nat> \<Longrightarrow> x <\<^sub>\<nat> x +\<^sub>\<nat> 1" by auto2
lemma nat_le_to_less_Suc' [resolve]: "x \<le>\<^sub>\<nat> y \<Longrightarrow> x \<le>\<^sub>\<nat> y +\<^sub>\<nat> 1" by auto2
lemma nat_less_to_Suc_le' [resolve]: "x <\<^sub>\<nat> y \<Longrightarrow> x +\<^sub>\<nat> 1 \<le>\<^sub>\<nat> y" by auto2
lemma nat_le_to_Suc_le' [backward2]: "x \<le>\<^sub>\<nat> y \<Longrightarrow> x \<noteq> y \<Longrightarrow> x +\<^sub>\<nat> 1 \<le>\<^sub>\<nat> y" by auto2
setup {* fold del_prfstep_thm [@{thm nat_Suc_not_zero}, @{thm nat_case_split},
  @{thm nat_case_Suc}, @{thm nat_rec_Suc}, @{thm nat_add_Suc'}, @{thm nat_mult_Suc'},
  @{thm nat_le_Suc}, @{thm nat_le_to_less_Suc},
  @{thm nat_less_to_Suc_le}, @{thm nat_le_to_Suc_le}] *}

lemma nat_induct' [var_induct]:
  "n \<in> nat \<Longrightarrow> P(0) \<Longrightarrow> \<forall>x\<in>nat. P(x) \<longrightarrow> P(x +\<^sub>\<nat> 1) \<Longrightarrow> P(n)"
@proof @var_induct "n \<in> nat" @qed
setup {* add_var_induct_data_with_prem (@{term_pat "?n \<in>. \<nat>"}, @{thm nat_induct'}) *}
setup {* del_prfstep_thm @{thm nat_add_1} *}

section \<open>Other induction principles\<close>

lemma nat_induct_k [var_induct]:
  "n \<ge>\<^sub>\<nat> k \<Longrightarrow> P(k) \<Longrightarrow> \<forall>x\<in>nat. x \<ge>\<^sub>\<nat> k \<longrightarrow> P(x) \<longrightarrow> P(x +\<^sub>\<nat> 1) \<Longrightarrow> P(n)"
@proof
  @have (@rule) "\<forall>m\<in>nat. P(m +\<^sub>\<nat> k)" @with @var_induct "m \<in> nat" @end
  @have "n = (n -\<^sub>\<nat> k) +\<^sub>\<nat> k"
@qed

lemma nat_induct_less [strong_induct]:
  "n \<in> nat \<Longrightarrow> (\<forall>n\<in>nat. (\<forall>m. m <\<^sub>\<nat> n \<longrightarrow> P(m)) \<longrightarrow> P(n)) \<Longrightarrow> P(n)"
@proof @var_induct "n \<in> nat" for "\<forall>m. m \<le>\<^sub>\<nat> n \<longrightarrow> P(m)" @qed

lemma nat_double_induct [script_induct]:
  "m \<in> nat \<and> n \<in> nat \<Longrightarrow> P(0,0) \<Longrightarrow> \<forall>x\<in>nat. \<forall>y\<in>nat. P(x,y) \<longrightarrow> P(x,y +\<^sub>\<nat> 1) \<Longrightarrow>
   \<forall>x\<in>nat. \<forall>y\<in>nat. P(x,y) \<longrightarrow> P(x +\<^sub>\<nat> 1,y) \<Longrightarrow> P(m,n)"
@proof
  @var_induct "m \<in> nat" arbitrary n @with
    @subgoal "m = 0" @var_induct "n \<in> nat" @endgoal
  @end
@qed

section \<open>Definition of power\<close>

definition power :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "power(R,b,e) = nat_rec(\<one>\<^sub>R, \<lambda>_ p. p *\<^sub>R b, e)"
setup {* register_wellform_data ("power(R,b,e)", ["b \<in>. R", "e \<in> nat"]) *}
abbreviation power_notation ("(_/ ^\<^sub>_ _)" [90,90,91] 90) where "x ^\<^sub>R y \<equiv> power(R,x,y)"

lemma power_0 [rewrite]: "b ^\<^sub>R 0 = \<one>\<^sub>R" by auto2
lemma power_Suc [rewrite]: "e \<in> nat \<Longrightarrow> b ^\<^sub>R (e +\<^sub>\<nat> 1) = (b ^\<^sub>R e) *\<^sub>R b" by auto2
lemma power_type [typing]: "is_group_raw(R) \<Longrightarrow> e \<in> nat \<Longrightarrow> b \<in>. R \<Longrightarrow> b ^\<^sub>R e \<in>. R" by auto2
setup {* del_prfstep_thm @{thm power_def} *}

section \<open>n-fold composition\<close>

(* nfold(f,0,x) = x
 | nfold(f,Suc(n),x) = f`(nfold(f,n,x))
*)
definition nfold :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "nfold(f,n,x) = nat_rec(x, \<lambda>_ p. f`p, n)"
setup {* register_wellform_data ("nfold(f,n,x)", ["n \<in> nat", "x \<in> source(f)", "source(f) = target(f)"]) *}

lemma nfold_0 [rewrite]: "nfold(f,0,x) = x" by auto2
lemma nfold_Suc [rewrite]: "n \<in> nat \<Longrightarrow> nfold(f,n +\<^sub>\<nat> 1,x) = f`(nfold(f,n,x))" by auto2
lemma nfold_type [typing]:
  "is_function(f) \<Longrightarrow> source(f) = target(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> n \<in> nat \<Longrightarrow> nfold(f,n,x) \<in> source(f)" by auto2
setup {* del_prfstep_thm @{thm nfold_def} *}

section \<open>Action of natural numbers on an abelian group\<close>

(* Recursion on n:
    nat_act(R,0,x) = 0
  | nat_act(R,n + 1,x) = nat_act(R,n,x) + x
*)
definition nat_act :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "nat_act(R,n,x) = nat_rec(\<zero>\<^sub>R, \<lambda>_ p. p +\<^sub>R x, n)"
setup {* register_wellform_data ("nat_act(R,n,x)", ["n \<in> nat", "x \<in>. R"]) *}

lemma nat_act_zero [rewrite]: "is_abgroup(R) \<Longrightarrow> nat_act(R,0,x) = \<zero>\<^sub>R" by auto2
lemma nat_act_Suc [rewrite]: "is_abgroup(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> nat_act(R,n +\<^sub>\<nat> 1,x) = nat_act(R,n,x) +\<^sub>R x" by auto2
lemma nat_act_one [rewrite]: "is_abgroup(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> nat_act(R,1,x) = x"
  @proof @have "1 = 0 +\<^sub>\<nat> 1" @qed
lemma nat_act_type [typing]: "is_abgroup(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> x \<in>. R \<Longrightarrow> nat_act(R,n,x) \<in>. R"
  @proof @var_induct "n \<in> nat" @qed

setup {* del_prfstep_thm @{thm nat_act_def} *}

lemma nat_act_add [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> m \<in> nat \<Longrightarrow> n \<in> nat \<Longrightarrow> nat_act(R,m +\<^sub>\<nat> n,x) = nat_act(R,m,x) +\<^sub>R nat_act(R,n,x)"
@proof
  @var_induct "m \<in> nat" @with
    @subgoal "m = m' +\<^sub>\<nat> 1"
      @have "nat_act(R,m',x) +\<^sub>R x +\<^sub>R nat_act(R,n,x) = nat_act(R,m',x) +\<^sub>R nat_act(R,n,x) +\<^sub>R x"
      @have "m' +\<^sub>\<nat> 1 +\<^sub>\<nat> n = m' +\<^sub>\<nat> n +\<^sub>\<nat> 1"
    @endgoal
  @end
@qed

lemma nat_act_zero_right [rewrite]:
  "is_abgroup(R) \<Longrightarrow> m \<in> nat \<Longrightarrow> nat_act(R,m,\<zero>\<^sub>R) = \<zero>\<^sub>R"
@proof @var_induct "m \<in> nat" @qed

lemma nat_act_add_right [rewrite]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> m \<in> nat \<Longrightarrow> nat_act(R,m,x +\<^sub>R y) = nat_act(R,m,x) +\<^sub>R nat_act(R,m,y)"
@proof
  @var_induct "m \<in> nat" @with
    @subgoal "m = m' +\<^sub>\<nat> 1"
      @have "(nat_act(R,m',x) +\<^sub>R nat_act(R,m',y)) +\<^sub>R (nat_act(R,1,x) +\<^sub>R nat_act(R,1,y)) =
             (nat_act(R,m',x) +\<^sub>R nat_act(R,1,x)) +\<^sub>R (nat_act(R,m',y) +\<^sub>R nat_act(R,1,y))"
    @endgoal
  @end
@qed

lemma nat_act_mult [rewrite]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> m \<in> nat \<Longrightarrow> n \<in> nat \<Longrightarrow> nat_act(R,m *\<^sub>\<nat> n,x) = nat_act(R,m,nat_act(R,n,x))"
@proof
  @var_induct "m \<in> nat" @with
    @subgoal "m = m' +\<^sub>\<nat> 1"
      @have "(m' +\<^sub>\<nat> 1) *\<^sub>\<nat> n = m' *\<^sub>\<nat> n +\<^sub>\<nat> 1 *\<^sub>\<nat> n"
    @endgoal
  @end
@qed

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Map_Extra.thy                                                        *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Map Type: extra functions and properties \<close>

theory Map_Extra
  imports
  Relation_Extra
  "HOL-Library.Countable_Set"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.AList"
begin

subsection \<open> Extensionality and Update \<close>

lemma map_eq_iff: "f = g \<longleftrightarrow> (\<forall> x \<in> dom(f) \<union> dom(g). f x = g x)"
  by (auto simp add: fun_eq_iff)

subsection \<open> Graphing Maps \<close>

definition map_graph :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b)" where
"map_graph f = {(x,y) | x y. f x = Some y}"

definition graph_map :: "('a \<leftrightarrow> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"graph_map g = (\<lambda> x. if (x \<in> fst ` g) then Some (SOME y. (x,y) \<in> g) else None)"

definition graph_map' :: "('a \<leftrightarrow> 'b) \<rightharpoonup> ('a \<rightharpoonup> 'b)" where
"graph_map' R = (if (functional R) then Some (graph_map R) else None)"

lemma map_graph_mem_equiv: "(x, y) \<in> map_graph f \<longleftrightarrow> f(x) = Some y"
  by (simp add: map_graph_def)

lemma map_graph_functional[simp]: "functional (map_graph f)"
  by (simp add:functional_def map_graph_def inj_on_def)

lemma map_graph_countable [simp]: "countable (dom f) \<Longrightarrow> countable (map_graph f)"
  apply (auto simp add:map_graph_def countable_def)
  apply (rename_tac f')
  apply (rule_tac x="f' \<circ> fst" in exI)
  apply (auto simp add:inj_on_def dom_def)
  apply fastforce
  done

lemma map_graph_inv [simp]: "graph_map (map_graph f) = f"
  by (auto intro!:ext simp add:map_graph_def graph_map_def image_def)

lemma graph_map_empty[simp]: "graph_map {} = Map.empty"
  by (simp add:graph_map_def)

lemma graph_map_insert [simp]: "\<lbrakk>functional g; g``{x} \<subseteq> {y}\<rbrakk> \<Longrightarrow> graph_map (insert (x,y) g) = (graph_map g)(x \<mapsto> y)"
  by (rule ext, auto simp add:graph_map_def)

lemma dom_map_graph: "dom f = Domain(map_graph f)"
  by (simp add: map_graph_def dom_def image_def)

lemma ran_map_graph: "ran f = Range(map_graph f)"
  by (simp add: map_graph_def ran_def image_def)

lemma graph_map_set: "functional (set xs) \<Longrightarrow> graph_map (set xs) = map_of xs"
  by (induct xs; force)

lemma rel_apply_map_graph:
  "x \<in> dom(f) \<Longrightarrow> (map_graph f)(x)\<^sub>r = the (f x)"
  by (auto simp add: rel_apply_def map_graph_def)

lemma ran_map_add_subset:
  "ran (x ++ y) \<subseteq> (ran x) \<union> (ran y)"
  by (auto simp add:ran_def)

lemma finite_dom_graph: "finite (dom f) \<Longrightarrow> finite (map_graph f)"
  by (metis dom_map_graph finite_imageD fst_eq_Domain functional_def map_graph_functional)

lemma finite_dom_ran [simp]: "finite (dom f) \<Longrightarrow> finite (ran f)"
  by (metis finite_Range finite_dom_graph ran_map_graph)

lemma functional_insert: "functional (insert a R) \<Longrightarrow> functional R"
  by (simp add: single_valued_def)

lemma Domain_insert: "Domain (insert a R) = insert (fst a) (Domain R)"
  by (simp add: Domain_fst)

lemma card_map_graph: "\<lbrakk> finite R; functional R \<rbrakk> \<Longrightarrow> card R = card (Domain R)"
  by (induct R rule: finite.induct, simp_all add: functional_insert card_insert_if Domain_insert finite_Domain)
     (metis DiffD1 Diff_insert_absorb DomainE Map_Extra.Domain_insert insertI1 insert_Diff prod.collapse single_valued_def)

lemma graph_map_inv [simp]: "functional g \<Longrightarrow> map_graph (graph_map g) = g"
  apply (auto simp add:map_graph_def graph_map_def functional_def)
    apply (metis (lifting, no_types) image_iff option.distinct(1) option.inject someI surjective_pairing)
   apply (simp add:inj_on_def)
   apply (metis fst_conv snd_conv some_equality)
  apply (metis (lifting) fst_conv image_iff)
  done

lemma graph_map_dom: "dom (graph_map R) = fst ` R"
  by (simp add: graph_map_def dom_def)

lemma graph_map_countable_dom: "countable R \<Longrightarrow> countable (dom (graph_map R))"
  by (simp add: graph_map_dom)

lemma countable_ran:
  assumes "countable (dom f)"
  shows "countable (ran f)"
proof -
  have "countable (map_graph f)"
    by (simp add: assms)
  then have "countable (Range(map_graph f))"
    by (simp add: Range_snd)
  thus ?thesis
    by (simp add: ran_map_graph)
qed

lemma map_graph_inv' [simp]:
  "graph_map' (map_graph f) = Some f"
  by (simp add: graph_map'_def)

lemma map_graph_inj:
  "inj map_graph"
  by (metis injI map_graph_inv)

lemma map_eq_graph: "f = g \<longleftrightarrow> map_graph f = map_graph g"
  by (auto simp add: inj_eq map_graph_inj)

lemma map_le_graph: "f \<subseteq>\<^sub>m g \<longleftrightarrow> map_graph f \<subseteq> map_graph g"
  by (force simp add: map_le_def map_graph_def)

lemma map_graph_comp: "map_graph (g \<circ>\<^sub>m f) = (map_graph f) O (map_graph g)"
  apply (auto simp add: map_comp_def map_graph_def relcomp_unfold)
  apply (rename_tac a b)
  apply (case_tac "f a", auto)
  done

lemma rel_comp_map: "R O map_graph f = (\<lambda> p. (fst p, the (f (snd p)))) ` (R \<rhd>\<^sub>r dom(f))"
  by (force simp add: map_graph_def relcomp_unfold rel_ranres_def image_def dom_def)

lemma map_graph_update: "map_graph (f(k \<mapsto> v)) = insert (k, v) ((- {k}) \<lhd>\<^sub>r map_graph f)"
  by (auto simp add: map_graph_def rel_domres_def, metis option.sel)

subsection \<open> Map Application \<close>

definition map_apply :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>m" [999,0] 999) where
"map_apply = (\<lambda> f x. the (f x))"

subsection \<open> Map Membership \<close>

fun map_member :: "'a \<times> 'b \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<in>\<^sub>m" 50) where
"(k, v) \<in>\<^sub>m m \<longleftrightarrow> m(k) = Some(v)"

lemma map_ext:
  "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>m A \<longleftrightarrow> (x, y) \<in>\<^sub>m B \<rbrakk> \<Longrightarrow> A = B"
  by (rule ext, auto, metis not_Some_eq)

lemma map_member_alt_def:
  "(x, y) \<in>\<^sub>m A \<longleftrightarrow> (x \<in> dom A \<and> A(x)\<^sub>m = y)"
  by (auto simp add: map_apply_def)

lemma map_le_member:
  "f \<subseteq>\<^sub>m g \<longleftrightarrow> (\<forall> x y. (x,y) \<in>\<^sub>m f \<longrightarrow> (x,y) \<in>\<^sub>m g)"
  by (force simp add: map_le_def)

subsection \<open> Preimage \<close>

definition preimage :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a set" where
"preimage f B = {x \<in> dom(f). the(f(x)) \<in> B}"

lemma preimage_range: "preimage f (ran f) = dom f"
  by (auto simp add: preimage_def ran_def)

lemma dom_preimage: "dom (m \<circ>\<^sub>m f) = preimage f (dom m)"
  apply (auto simp add: dom_def preimage_def)
   apply (meson map_comp_Some_iff)
  apply (metis map_comp_def option.case_eq_if option.distinct(1))
  done

lemma countable_preimage:
  "\<lbrakk> countable A; inj_on f (preimage f A) \<rbrakk> \<Longrightarrow> countable (preimage f A)"
  apply (auto simp add: countable_def)
  apply (rename_tac g)
  apply (rule_tac x="g \<circ> the \<circ> f" in exI)
  apply (rule inj_onI)
  apply (drule inj_onD)
     apply (auto simp add: preimage_def inj_onD)
  done

subsection \<open> Minus operation for maps \<close>

definition map_minus :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixl "--" 100)
where "map_minus f g = (\<lambda> x. if (f x = g x) then None else f x)"

lemma map_minus_apply [simp]: "y \<in> dom(f -- g) \<Longrightarrow> (f -- g)(y)\<^sub>m = f(y)\<^sub>m"
  by (auto simp add: map_minus_def dom_def map_apply_def)

lemma map_member_plus:
  "(x, y) \<in>\<^sub>m f ++ g \<longleftrightarrow> ((x \<notin> dom(g) \<and> (x, y) \<in>\<^sub>m f) \<or> (x, y) \<in>\<^sub>m g)"
  by (auto simp add: map_add_Some_iff)

lemma map_member_minus:
  "(x, y) \<in>\<^sub>m f -- g \<longleftrightarrow> (x, y) \<in>\<^sub>m f \<and> (\<not> (x, y) \<in>\<^sub>m g)"
  by (auto simp add: map_minus_def)

lemma map_minus_plus_commute:
  "dom(g) \<inter> dom(h) = {} \<Longrightarrow> (f -- g) ++ h = (f ++ h) -- g"
  apply (rule map_ext)
  apply (auto simp add: map_member_plus map_member_minus simp del: map_member.simps)
  apply (auto simp add: map_member_alt_def)
  done

lemma map_graph_minus: "map_graph (f -- g) = map_graph f - map_graph g"
  by (auto simp add: map_minus_def map_graph_def, (meson option.distinct(1))+)

lemma map_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>m f; h \<subseteq>\<^sub>m g \<rbrakk> \<Longrightarrow> (f -- h = g -- h) = (f = g)"
  by (auto simp add: map_eq_graph map_graph_minus map_le_graph)

subsection \<open> Map Bind \<close>

text \<open> Create some extra intro/elim rules to help dealing with proof about option bind. \<close>

lemma option_bindSomeE [elim!]:
  "\<lbrakk> X >>= F = Some(v); \<And> x. \<lbrakk> X = Some(x); F(x) = Some(v) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac X, auto)

lemma option_bindSomeI [intro]:
  "\<lbrakk> X = Some(x); F(x) = Some(y) \<rbrakk> \<Longrightarrow> X >>= F = Some(y)"
  by (simp)

lemma ifSomeE [elim]: "\<lbrakk> (if c then Some(x) else None) = Some(y); \<lbrakk> c; x = y \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac c, auto)

subsection \<open> Range Restriction \<close>

text \<open> A range restriction operator; only domain restriction is provided in HOL. \<close>

definition ran_restrict_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a \<rightharpoonup> 'b" ("_\<upharpoonleft>\<^bsub>_\<^esub>" [111,110] 110) where
"ran_restrict_map f B = (\<lambda>x. do { v <- f(x); if (v \<in> B) then Some(v) else None })"

lemma ran_restrict_alt_def: "f\<upharpoonleft>\<^bsub>B\<^esub> = (\<lambda> x. if x \<in> dom(f) \<and> the(f(x)) \<in> B then f x else None)"
  by (auto simp add: ran_restrict_map_def fun_eq_iff bind_eq_None_conv)

lemma ran_restrict_empty [simp]: "f\<upharpoonleft>\<^bsub>{}\<^esub> = Map.empty"
  by (simp add:ran_restrict_map_def)

lemma ran_restrict_ran [simp]: "f\<upharpoonleft>\<^bsub>ran(f) \<^esub> = f"
  apply (auto simp add:ran_restrict_map_def ran_def)
  apply (rule ext)
  apply (case_tac "f(x)", auto)
  done

lemma ran_ran_restrict [simp]: "ran(f\<upharpoonleft>\<^bsub>B\<^esub>) = ran(f) \<inter> B"
  by (auto intro!:option_bindSomeI simp add:ran_restrict_map_def ran_def)

lemma dom_ran_restrict: "dom(f\<upharpoonleft>\<^bsub>B\<^esub>) \<subseteq> dom(f)"
  by (auto simp add:ran_restrict_map_def dom_def)

lemma ran_restrict_finite_dom [intro]:
  "finite(dom(f)) \<Longrightarrow> finite(dom(f\<upharpoonleft>\<^bsub>B\<^esub>))"
  by (metis finite_subset dom_ran_restrict)

lemma dom_Some [simp]: "dom (Some \<circ> f) = UNIV"
  by (auto)

lemma map_dres_rres_commute: "f\<upharpoonleft>\<^bsub>B\<^esub> |` A = (f |` A)\<upharpoonleft>\<^bsub>B\<^esub>"
  by (auto simp add: restrict_map_def ran_restrict_map_def)

lemma ran_restrict_map_twice [simp]: "(f\<upharpoonleft>\<^bsub>A\<^esub>)\<upharpoonleft>\<^bsub>B\<^esub> = f\<upharpoonleft>\<^bsub>(A \<inter> B)\<^esub>"
  apply (auto simp add: ran_restrict_map_def fun_eq_iff option.case_eq_if)
  apply (rename_tac x)
  apply (case_tac "f x")
   apply (auto)
  done

lemma dom_left_map_add [simp]: "x \<in> dom g \<Longrightarrow> (f ++ g) x = g x"
  by (auto simp add:map_add_def dom_def)

lemma dom_right_map_add [simp]: "\<lbrakk> x \<notin> dom g; x \<in> dom f \<rbrakk> \<Longrightarrow> (f ++ g) x = f x"
  by (auto simp add:map_add_def dom_def)

lemma map_add_restrict:
  "f ++ g = (f |` (- dom g)) ++ g"
  by (rule ext, auto simp add: map_add_def restrict_map_def)

subsection \<open> Map Inverse and Identity \<close>

definition map_inv :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('b \<rightharpoonup> 'a)" where
"map_inv f \<equiv> \<lambda> y. if (y \<in> ran f) then Some (SOME x. f x = Some y) else None"

definition map_id_on :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'a)" where
"map_id_on xs \<equiv> \<lambda> x. if (x \<in> xs) then Some x else None"

lemma map_id_on_in [simp]:
  "x \<in> xs \<Longrightarrow> map_id_on xs x = Some x"
  by (simp add:map_id_on_def)

lemma map_id_on_out [simp]:
  "x \<notin> xs \<Longrightarrow> map_id_on xs x = None"
  by (simp add:map_id_on_def)

lemma map_id_dom [simp]: "dom (map_id_on xs) = xs"
  by (simp add:dom_def map_id_on_def)

lemma map_id_ran [simp]: "ran (map_id_on xs) = xs"
  by (force simp add:ran_def map_id_on_def)

lemma map_id_on_UNIV[simp]: "map_id_on UNIV = Some"
  by (simp add:map_id_on_def)

lemma map_id_on_inj [simp]:
  "inj_on (map_id_on xs) xs"
  by (simp add:inj_on_def)

lemma restrict_map_inj_on:
  "inj_on f (dom f) \<Longrightarrow> inj_on (f |` A) (dom f \<inter> A)"
  by (auto simp add:inj_on_def)

lemma map_inv_empty [simp]: "map_inv Map.empty = Map.empty"
  by (simp add:map_inv_def)

lemma map_inv_id [simp]:
  "map_inv (map_id_on xs) = map_id_on xs"
  by (force simp add:map_inv_def map_id_on_def ran_def)

lemma map_inv_Some [simp]: "map_inv Some = Some"
  by (simp add:map_inv_def ran_def)

lemma map_inv_f_f [simp]:
  "\<lbrakk> inj_on f (dom f); f x = Some y \<rbrakk> \<Longrightarrow> map_inv f y = Some x"
  apply (auto simp add: map_inv_def)
   apply (rule some_equality)
    apply (auto simp add:inj_on_def dom_def ran_def)
  done

lemma dom_map_inv [simp]:
  "dom (map_inv f) = ran f"
  by (auto simp add:map_inv_def)

lemma ran_map_inv [simp]:
  "inj_on f (dom f) \<Longrightarrow> ran (map_inv f) = dom f"
  apply (auto simp add:map_inv_def ran_def)
   apply (rename_tac a b)
   apply (rule_tac x="a" in exI)
   apply (force intro:someI)
  apply (rename_tac x y)
  apply (rule_tac x="y" in exI)
  apply (auto)
  apply (rule some_equality, simp_all)
  apply (auto simp add:inj_on_def dom_def)
  done

lemma dom_image_ran: "f ` dom f = Some ` ran f"
  by (auto simp add:dom_def ran_def image_def)

lemma inj_map_inv [intro]:
  "inj_on f (dom f) \<Longrightarrow> inj_on (map_inv f) (ran f)"
  apply (auto simp add:map_inv_def inj_on_def dom_def ran_def)
  apply (rename_tac x y u v)
  apply (frule_tac P="\<lambda> xa. f xa = Some x" in some_equality)
   apply (auto)
  apply (metis (mono_tags) option.sel someI)
  done

lemma inj_map_bij: "inj_on f (dom f) \<Longrightarrow> bij_betw f (dom f) (Some ` ran f)"
  by (auto simp add:inj_on_def dom_def ran_def image_def bij_betw_def)

lemma map_inv_map_inv [simp]:
  assumes "inj_on f (dom f)"
  shows "map_inv (map_inv f) = f"
proof -

  from assms have "inj_on (map_inv f) (ran f)"
    by auto

  thus ?thesis
    apply (rule_tac ext)
    apply (rename_tac x)
    apply (case_tac "\<exists> y. map_inv f y = Some x")
     apply (auto)[1]
     apply (simp add:map_inv_def)
     apply (rename_tac x y)
     apply (case_tac "y \<in> ran f", simp_all)
     apply (auto)
     apply (rule someI2_ex)
      apply (simp add:ran_def)
     apply (simp)
    apply (metis assms dom_image_ran dom_map_inv image_iff map_add_dom_app_simps(2) map_add_dom_app_simps(3) ran_map_inv)
    done
qed

lemma map_self_adjoin_complete [intro]:
  assumes "dom f \<inter> ran f = {}" "inj_on f (dom f)"
  shows "inj_on (map_inv f ++ f) (dom f \<union> ran f)"
  apply (rule inj_onI)
  apply (insert assms)
  apply (rename_tac x y)
  apply (case_tac "x \<in> dom f")
   apply (simp)
   apply (case_tac "y \<in> dom f")
    apply (simp add:inj_on_def)
   apply (case_tac "y \<in> ran f")
    apply (subgoal_tac "y \<in> dom (map_inv f)")
     apply (simp)
     apply (metis Int_iff domD empty_iff ranI ran_map_inv)
    apply (simp)
   apply (simp)
  apply (simp)
  apply (case_tac "y \<in> dom f")
   apply (simp)
   apply (case_tac "y \<in> ran f")
    apply (subgoal_tac "y \<in> dom (map_inv f)")
     apply (simp)
     apply (metis Int_iff empty_iff)
    apply (simp)
   apply (metis Int_iff domD empty_iff ranI ran_map_inv)
  apply (simp)
  apply (metis (lifting) inj_map_inv inj_on_contraD)
  done

lemma inj_completed_map [intro]:
  "\<lbrakk> dom f = ran f; inj_on f (dom f) \<rbrakk> \<Longrightarrow> inj (Some ++ f)"
  apply (drule inj_map_bij)
  apply (auto simp add:bij_betw_def)
  apply (auto simp add:inj_on_def)[1]
  apply (rename_tac x y)
  apply (case_tac "x \<in> dom f")
   apply (simp)
   apply (case_tac "y \<in> dom f")
    apply (simp)
   apply (simp add:ran_def)
  apply (case_tac "y \<in> dom f")
   apply (auto intro:ranI)
  done

lemma bij_completed_map [intro]:
  "\<lbrakk> dom f = ran f; inj_on f (dom f) \<rbrakk> \<Longrightarrow>
   bij_betw (Some ++ f) UNIV (range Some)"
  apply (auto simp add:bij_betw_def)
   apply (rename_tac x)
   apply (case_tac "x \<in> dom f")
    apply (simp)
    apply (metis domD rangeI)
   apply (simp)
  apply (simp add:image_def)
  apply (metis (full_types) dom_image_ran dom_left_map_add image_iff map_add_dom_app_simps(3))
  done

lemma bij_map_Some:
  "bij_betw f a (Some ` b) \<Longrightarrow> bij_betw (the \<circ> f) a b"
  apply (simp add:bij_betw_def)
  apply (safe)
    apply (metis (opaque_lifting, no_types) comp_inj_on_iff f_the_inv_into_f inj_on_inverseI option.sel)
   apply (metis (opaque_lifting, no_types) image_iff option.sel)
  apply (metis Option.these_def Some_image_these_eq image_image these_image_Some_eq)
  done

lemma ran_map_add [simp]:
  "m`(dom m \<inter> dom n) = n`(dom m \<inter> dom n) \<Longrightarrow>
   ran(m++n) = ran n \<union> ran m"
  apply (auto simp add:ran_def)
   apply (metis map_add_find_right)
  apply (rename_tac x a)
  apply (case_tac "a \<in> dom n")
   apply (subgoal_tac "\<exists> b. n b = Some x")
    apply (auto)
    apply (rename_tac x a b y)
    apply (rule_tac x="b" in exI)
    apply (simp)
   apply (metis (opaque_lifting, no_types) IntI domI image_iff)
  apply (metis (full_types) map_add_None map_add_dom_app_simps(1) map_add_dom_app_simps(3) not_None_eq)
  done

lemma ran_maplets [simp]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow> ran [xs [\<mapsto>] ys] = set ys"
    by (induct rule:list_induct2, simp_all)

lemma inj_map_add:
  "\<lbrakk> inj_on f (dom f); inj_on g (dom g); ran f \<inter> ran g = {} \<rbrakk> \<Longrightarrow>
   inj_on (f ++ g) (dom f \<union> dom g)"
  apply (auto simp add:inj_on_def)
      apply (metis (full_types) disjoint_iff_not_equal domI dom_left_map_add map_add_dom_app_simps(3) ranI)
     apply (metis domI)
    apply (metis disjoint_iff_not_equal ranI)
   apply (metis disjoint_iff_not_equal domIff map_add_Some_iff ranI)
  apply (metis domI)
  done

lemma map_inv_add':
  assumes "inj_on f (dom f)" "inj_on g (dom g)"
          "dom f \<inter> dom g = {}" "ran f \<inter> ran g = {}"
 shows "map_inv (f ++ g) = map_inv f ++ map_inv g"
proof (rule ext)

  from assms have minj: "inj_on (f ++ g) (dom (f ++ g))"
    by (simp, metis inj_map_add sup_commute)

  fix x
  have "x \<in> ran g \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
  proof -
    assume ran:"x \<in> ran g"
    then obtain y where dom:"g y = Some x" "y \<in> dom g"
      by (auto simp add:ran_def)

    hence "(f ++ g) y = Some x"
      by simp

    with assms minj ran dom show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
      by simp
  qed

  moreover have "\<lbrakk> x \<notin> ran g; x \<in> ran f \<rbrakk> \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
  proof -
    assume ran:"x \<notin> ran g" "x \<in> ran f"
    with assms obtain y where dom:"f y = Some x" "y \<in> dom f" "y \<notin> dom g"
      by (auto simp add:ran_def)

    with ran have "(f ++ g) y = Some x"
      by (simp)

    with assms minj ran dom show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
      by simp
  qed

  moreover from assms minj have "\<lbrakk> x \<notin> ran g; x \<notin> ran f \<rbrakk> \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
    apply (auto simp add:map_inv_def ran_def map_add_def)
    apply (metis dom_left_map_add map_add_def map_add_dom_app_simps(3))
    done

  ultimately show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
    apply (case_tac "x \<in> ran g")
     apply (simp)
    apply (case_tac "x \<in> ran f")
     apply (simp_all)
    done
qed

lemma map_inv_dom_res:
  assumes "inj_on f (dom f)"
  shows "map_inv (f |` A) = (map_inv f) \<upharpoonleft>\<^bsub>A\<^esub>"
  using assms
  by (auto intro!: some_equality simp add: map_inv_def restrict_map_def ran_restrict_map_def dom_def ran_def fun_eq_iff inj_on_def)
     (metis (mono_tags, lifting) option.simps(3) someI_ex)+

lemma map_inv_ran_res:
  assumes "inj_on f (dom f)"
  shows "map_inv (f \<upharpoonleft>\<^bsub>A\<^esub>) = (map_inv f) |` A"
  using assms someI_ex by (force intro!: some_equality simp add: map_inv_def restrict_map_def ran_restrict_map_def dom_def ran_def fun_eq_iff inj_on_def)

lemma map_update_as_add: "f(x \<mapsto> y) = f ++ [x \<mapsto> y]"
  by (auto simp add: map_add_def)

lemma map_add_lookup [simp]:
  "x \<notin> dom f \<Longrightarrow> ([x \<mapsto> y] ++ f) x = Some y"
  by (simp add:map_add_def dom_def)

lemma map_add_Some: "Some ++ f = map_id_on (- dom f) ++ f"
  apply (rule ext)
  apply (rename_tac x)
  apply (case_tac "x \<in> dom f")
   apply (simp_all)
  done

lemma distinct_map_dom:
  "x \<notin> set xs \<Longrightarrow> x \<notin> dom [xs [\<mapsto>] ys]"
  by (simp add:dom_def)

lemma distinct_map_ran:
  "\<lbrakk> distinct xs; y \<notin> set ys; length xs = length ys \<rbrakk> \<Longrightarrow>
   y \<notin> ran ([xs [\<mapsto>] ys])"
  apply (simp add:map_upds_def)
  apply (subgoal_tac "distinct (map fst (rev (zip xs ys)))")
  apply (simp add:ran_distinct)
  apply (metis (opaque_lifting, no_types) image_iff set_zip_rightD surjective_pairing)
  apply (simp add:zip_rev[THEN sym])
done

lemma maplets_lookup[rule_format,dest]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow>
     \<forall> y. [xs [\<mapsto>] ys] x = Some y \<longrightarrow> y \<in> set ys"
  by (induct rule:list_induct2, auto)

lemma maplets_distinct_inj [intro]:
  "\<lbrakk> length xs = length ys; distinct xs; distinct ys; set xs \<inter> set ys = {} \<rbrakk> \<Longrightarrow>
   inj_on [xs [\<mapsto>] ys] (set xs)"
  apply (induct rule:list_induct2)
   apply (simp_all)
  apply (rule conjI)
   apply (rule inj_onI)
   apply (rename_tac x xs y ys xa ya)
   apply (case_tac "xa = x")
    apply (simp)
   apply (case_tac "xa = y")
    apply (simp)
   apply (simp)
   apply (case_tac "ya = x")
    apply (simp)
   apply (simp add:inj_on_def)
  apply (auto)
  apply (rename_tac x xs y ys xa)
  apply (case_tac "xa = y")
   apply (simp)
  apply (metis maplets_lookup)
  done

lemma map_inv_maplet[simp]: "map_inv [x \<mapsto> y] = [y \<mapsto> x]"
  by (auto simp add:map_inv_def)

lemma map_inv_add:
  assumes "inj_on f (dom f)" "inj_on g (dom g)"
          "ran f \<inter> ran g = {}"
  shows "map_inv (f ++ g) = map_inv f\<upharpoonleft>\<^bsub>(- dom g)\<^esub> ++ map_inv g"
proof -
  have "map_inv (f ++ g) = map_inv (f |` (- dom(g))  ++ g)"
    by (metis map_add_restrict)
  also have "... = map_inv (f |` (- dom g)) ++ map_inv g"
    by (rule map_inv_add', auto simp add: assms restrict_map_inj_on)
       (metis assms(3) disjoint_iff ranI ran_restrictD)
  also have "... = map_inv f\<upharpoonleft>\<^bsub>(- dom g)\<^esub> ++ map_inv g"
    by (simp add: map_inv_dom_res assms)
  finally show ?thesis .
qed

lemma map_inv_upd:
  assumes "inj_on f (dom f)" "inj_on g (dom g)" "v \<notin> ran f"
  shows "map_inv (f(k \<mapsto> v)) = (map_inv (f |` (- {k})))(v \<mapsto> k)"
proof -
  have "map_inv (f(k \<mapsto> v)) = map_inv (f ++ [k \<mapsto> v])"
    by (auto)
  also have "... = map_inv f\<upharpoonleft>\<^bsub>(- dom [k \<mapsto> v])\<^esub> ++ map_inv [k \<mapsto> v]"
    by (rule map_inv_add, simp_all add: assms)
  also have "... = (map_inv f\<upharpoonleft>\<^bsub>(- {k})\<^esub>)(v \<mapsto> k)"
    by (simp)
  also have "... = (map_inv (f |` (- {k})))(v \<mapsto> k)"
    by (simp add: assms(1) map_inv_dom_res)
  finally show ?thesis .
qed

lemma map_inv_maplets [simp]:
  "\<lbrakk> length xs = length ys; distinct xs; distinct ys; set xs \<inter> set ys = {} \<rbrakk> \<Longrightarrow>
  map_inv [xs [\<mapsto>] ys] = [ys [\<mapsto>] xs]"
  apply (induct rule:list_induct2)
   apply (simp_all)
  apply (rename_tac x xs y ys)
  apply (subgoal_tac "map_inv ([xs [\<mapsto>] ys] ++ [x \<mapsto> y]) = map_inv [xs [\<mapsto>] ys] ++ map_inv [x \<mapsto> y]")
   apply (simp)
  apply (rule map_inv_add')
     apply (auto)
  done

lemma maplets_lookup_nth [rule_format,simp]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow>
   \<forall> i < length ys. [xs [\<mapsto>] ys] (xs ! i) = Some (ys ! i)"
  apply (induct rule:list_induct2)
   apply (auto)
   apply (rename_tac x xs y ys i)
   apply (case_tac i)
    apply (simp_all)
   apply (metis nth_mem)
  apply (rename_tac x xs y ys i)
  apply (case_tac i)
   apply (auto)
  done

theorem inv_map_inv:
  "\<lbrakk> inj_on f (dom f); ran f = dom f \<rbrakk>
  \<Longrightarrow> inv (the \<circ> (Some ++ f)) = the \<circ> map_inv (Some ++ f)"
  apply (rule ext)
  apply (simp add:map_add_Some map_inv_add')
  apply (simp add:inv_def)
  apply (rename_tac x)
  apply (case_tac "\<exists> y. f y = Some x")
   apply (erule exE)
   apply (rename_tac x y)
   apply (subgoal_tac "x \<in> ran f")
    apply (subgoal_tac "y \<in> dom f")
     apply (simp)
     apply (rule some_equality)
      apply (simp)
     apply (metis (opaque_lifting, mono_tags) domD domI dom_left_map_add inj_on_contraD map_add_Some map_add_dom_app_simps(3) option.sel)
    apply (simp add:dom_def)
   apply (metis ranI)
  apply (simp)
  apply (rename_tac x)
  apply (subgoal_tac "x \<notin> ran f")
   apply (simp)
   apply (rule some_equality)
    apply (simp)
   apply (metis domD dom_left_map_add map_add_Some map_add_dom_app_simps(3) option.sel)
  apply (metis dom_image_ran image_iff)
  done

lemma map_comp_dom: "dom (g \<circ>\<^sub>m f) \<subseteq> dom f"
  by (metis (lifting, full_types) Collect_mono dom_def map_comp_simps(1))

lemma map_comp_assoc: "f \<circ>\<^sub>m (g \<circ>\<^sub>m h) = f \<circ>\<^sub>m g \<circ>\<^sub>m h"
proof
  fix x
  show "(f \<circ>\<^sub>m (g \<circ>\<^sub>m h)) x = (f \<circ>\<^sub>m g \<circ>\<^sub>m h) x"
  proof (cases "h x")
    case None thus ?thesis
      by (auto simp add: map_comp_def)
  next
    case (Some y) thus ?thesis
      by (auto simp add: map_comp_def)
  qed
qed

lemma map_comp_runit [simp]: "f \<circ>\<^sub>m Some = f"
  by (simp add: map_comp_def)

lemma map_comp_lunit [simp]: "Some \<circ>\<^sub>m f = f"
proof
  fix x
  show "(Some \<circ>\<^sub>m f) x = f x"
  proof (cases "f x")
    case None thus ?thesis
      by (simp add: map_comp_def)
  next
    case (Some y) thus ?thesis
      by (simp add: map_comp_def)
  qed
qed

lemma map_comp_apply [simp]: "(f \<circ>\<^sub>m g) x = g(x) >>= f"
  by (auto simp add: map_comp_def option.case_eq_if)

lemma map_graph_map_inv: "inj_on f (dom f) \<Longrightarrow> map_graph (map_inv f) = (map_graph f)\<inverse>"
  by (auto simp add: map_graph_def, metis dom_map_inv inj_map_inv map_inv_f_f map_inv_map_inv)

subsection \<open> Merging of compatible maps \<close>

definition comp_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infixl "\<parallel>\<^sub>m" 60) where
"comp_map f g = (\<forall> x \<in> dom(f) \<inter> dom(g). the(f(x)) = the(g(x)))"

lemma comp_map_unit: "Map.empty \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

lemma comp_map_refl: "f \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

lemma comp_map_sym: "f \<parallel>\<^sub>m g \<Longrightarrow> g \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

definition merge :: "('a \<rightharpoonup> 'b) set \<Rightarrow> 'a \<rightharpoonup> 'b" where
"merge fs =
  (\<lambda> x. if (\<exists> f \<in> fs. x \<in> dom(f)) then (THE y. \<forall> f \<in> fs. x \<in> dom(f) \<longrightarrow> f(x) = y) else None)"

lemma merge_empty: "merge {} = Map.empty"
  by (simp add: merge_def)

lemma merge_singleton: "merge {f} = f"
  apply (auto intro!: ext simp add: merge_def)
  using option.collapse apply fastforce
  done

subsection \<open> Conversion between lists and maps \<close>

definition map_of_list :: "'a list \<Rightarrow> (nat \<rightharpoonup> 'a)" where
"map_of_list xs = (\<lambda> i. if (i < length xs) then Some (xs!i) else None)"

lemma map_of_list_nil [simp]: "map_of_list [] = Map.empty"
  by (simp add: map_of_list_def)

lemma dom_map_of_list [simp]: "dom (map_of_list xs) = {0..<length xs}"
  by (auto simp add: map_of_list_def dom_def)

lemma ran_map_of_list [simp]: "ran (map_of_list xs) = set xs"
  apply (simp add: ran_def map_of_list_def)
  apply (safe)
   apply (force)
  apply (meson in_set_conv_nth)
  done

definition list_of_map :: "(nat \<rightharpoonup> 'a) \<Rightarrow> 'a list" where
"list_of_map f = (if (f = Map.empty) then [] else map (the \<circ> f) [0 ..< Suc(GREATEST x. x \<in> dom f)])"

lemma list_of_map_empty [simp]: "list_of_map Map.empty = []"
  by (simp add: list_of_map_def)

definition list_of_map' :: "(nat \<rightharpoonup> 'a) \<rightharpoonup> 'a list" where
"list_of_map' f = (if (\<exists> n. dom f = {0..<n}) then Some (list_of_map f) else None)"

lemma map_of_list_inv [simp]: "list_of_map (map_of_list xs) = xs"
proof (cases "xs = []")
  case True thus ?thesis by (simp)
next
  case False
  moreover hence "(GREATEST x. x \<in> dom (map_of_list xs)) = length xs - 1"
    by (auto intro: Greatest_equality)
  moreover from False have "map_of_list xs \<noteq> Map.empty"
    by (metis ran_empty ran_map_of_list set_empty)
  ultimately show ?thesis
    by (auto intro!:nth_equalityI simp add: list_of_map_def map_of_list_def  fun_eq_iff)
qed

subsection \<open> Map Comprehension \<close>

text \<open> Map comprehension simply converts a relation built through set comprehension into a map. \<close>

syntax
  "_Mapcompr" :: "'a \<Rightarrow> 'b \<Rightarrow> idts \<Rightarrow> bool \<Rightarrow> 'a \<rightharpoonup> 'b"    ("(1[_ \<mapsto> _ |/_./ _])")

translations
  "_Mapcompr F G xs P" == "CONST graph_map {(F, G) | xs. P}"

lemma map_compr_eta:
  "[x \<mapsto> y | x y. (x, y) \<in>\<^sub>m f] = f"
  apply (rule ext)
  apply (auto simp add: graph_map_def)
  apply (metis (mono_tags, lifting) Domain.DomainI fst_eq_Domain mem_Collect_eq old.prod.case option.distinct(1) option.expand option.sel)
  done

lemma map_compr_simple:
  "[x \<mapsto> F x y | x y. (x, y) \<in>\<^sub>m f] = (\<lambda> x. do { y \<leftarrow> f(x); Some(F x y) })"
  apply (rule ext)
  apply (auto simp add: graph_map_def image_Collect)
  done

lemma map_compr_dom_simple [simp]:
  "dom [x \<mapsto> f x | x. P x] = {x. P x}"
  by (force simp add: graph_map_dom image_Collect)

lemma map_compr_ran_simple [simp]:
  "ran [x \<mapsto> f x | x. P x] = {f x | x. P x}"
  apply (auto simp add: graph_map_def ran_def)
  apply (metis (mono_tags, lifting) fst_eqD image_eqI mem_Collect_eq someI)
  done

lemma map_compr_eval_simple [simp]:
  "[x \<mapsto> f x | x. P x] x = (if (P x) then Some (f x) else None)"
  by (auto simp add: graph_map_def image_Collect)

subsection \<open> Sorted lists from maps \<close>

definition sorted_list_of_map :: "('a::linorder \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b) list" where
"sorted_list_of_map f = map (\<lambda> k. (k, the (f k))) (sorted_list_of_set(dom(f)))"

lemma sorted_list_of_map_empty [simp]:
  "sorted_list_of_map Map.empty = []"
  by (simp add: sorted_list_of_map_def)

lemma sorted_list_of_map_inv:
  assumes "finite(dom(f))"
  shows "map_of (sorted_list_of_map f) = f"
proof -
  obtain A where "finite A" "A = dom(f)"
    by (simp add: assms)
  thus ?thesis
  proof (induct A rule: finite_induct)
    case empty thus ?thesis
      by (simp add: sorted_list_of_map_def, metis dom_empty empty_iff map_le_antisym map_le_def)
  next
    case (insert x A) thus ?thesis
      by (simp add: assms sorted_list_of_map_def map_of_map_keys)
  qed
qed

declare map_member.simps [simp del]

subsection \<open> Extra map lemmas \<close>

lemma map_eqI:
  "\<lbrakk> dom f = dom g; \<forall> x\<in>dom(f). the(f x) = the(g x) \<rbrakk> \<Longrightarrow> f = g"
  by (metis domIff map_le_antisym map_le_def option.expand)

lemma map_restrict_dom [simp]: "f |` dom f = f"
  by (simp add: map_eqI)

lemma map_restrict_dom_compl: "f |` (- dom f) = Map.empty"
  by (metis dom_eq_empty_conv dom_restrict inf_compl_bot)

lemma restrict_map_neg_disj:
  "dom(f) \<inter> A = {} \<Longrightarrow> f |` (- A) = f"
  by (auto simp add: restrict_map_def, rule ext, auto, metis disjoint_iff_not_equal domIff)

lemma map_plus_restrict_dist: "(f ++ g) |` A = (f |` A) ++ (g |` A)"
  by (auto simp add: restrict_map_def map_add_def)

lemma map_plus_eq_left:
  assumes "f ++ h = g ++ h"
  shows "(f |` (- dom h)) = (g |` (- dom h))"
proof -
  have "h |` (- dom h) = Map.empty"
    by (metis Compl_disjoint dom_eq_empty_conv dom_restrict)
  then have f2: "f |` (- dom h) = (f ++ h) |` (- dom h)"
    by (simp add: map_plus_restrict_dist)
  have "h |` (- dom h) = Map.empty"
    by (metis (no_types) Compl_disjoint dom_eq_empty_conv dom_restrict)
  then show ?thesis
    using f2 assms by (simp add: map_plus_restrict_dist)
qed

lemma map_add_split:
  "dom(f) = A \<union> B \<Longrightarrow> (f |` A) ++ (f |` B) = f"
  by (rule ext, auto simp add: map_add_def restrict_map_def option.case_eq_if)

lemma map_le_via_restrict:
  "f \<subseteq>\<^sub>m g \<longleftrightarrow> g |` dom(f) = f"
  by (auto simp add: map_le_def restrict_map_def dom_def fun_eq_iff)

lemma map_add_cancel:
  "f \<subseteq>\<^sub>m g \<Longrightarrow> f ++ (g -- f) = g"
  by (auto simp add: map_le_def map_add_def map_minus_def fun_eq_iff option.case_eq_if)
     (metis domIff)

lemma map_le_iff_add: "f \<subseteq>\<^sub>m g \<longleftrightarrow> (\<exists> h. dom(f) \<inter> dom(h) = {} \<and> f ++ h = g)"
  apply (auto)
  apply (rule_tac x="g -- f" in exI)
  apply (metis (no_types, lifting) Int_emptyI domIff map_add_cancel map_le_def map_minus_def)
  apply (simp add: map_add_comm)
  done

lemma map_add_comm_weak: "(\<forall> k \<in> dom m1 \<inter> dom m2. m1(k) = m2(k)) \<Longrightarrow> m1 ++ m2 = m2 ++ m1"
  by (auto simp add: map_add_def option.case_eq_if fun_eq_iff)
     (metis IntI domI option.inject)

lemma map_add_comm_weak': "Q |` dom P = P |` dom Q \<Longrightarrow> P ++ Q = Q ++ P"
  by (metis IntD1 IntD2 map_add_comm_weak restrict_in)

lemma map_compat_add: "Q |` dom P = P |` dom Q \<Longrightarrow> R |` (dom Q \<union> dom P) = (P ++ Q) |` dom R \<Longrightarrow> R |` dom P = P |` dom R"
  by (metis Int_commute Map.restrict_restrict Un_Int_eq(2) map_add_comm_weak' map_le_iff_map_add_commute map_le_via_restrict)

abbreviation "rel_map R \<equiv> rel_fun (=) (rel_option R)"

lemma rel_map_iff:
  "rel_map R f g \<longleftrightarrow> (dom(f) = dom(g) \<and> (\<forall> x\<in>dom(f). R (the (f x)) (the (g x))))"
  apply (auto simp add: rel_fun_def)
  apply (metis not_None_eq option.rel_distinct(2))
  apply (metis not_None_eq option.rel_distinct(1))
  apply (metis option.rel_sel option.sel option.simps(3))
  apply (metis domIff option.rel_sel)
  done

end


theory Chapter3 imports Main begin

(* Exercise 3.1 *)
type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N a) s = a" |
"aval (V x) s = s x" |
"aval (Plus a b) s = aval a s + aval b s"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N a) = N a" |
"asimp_const (V x) = V x" |
"asimp_const (Plus p q) =
 (case (asimp_const p, asimp_const q) of
  (N a, N b) \<Rightarrow> N (a+b) |
  (x, y) \<Rightarrow> Plus x y)"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N a) (N b) = N (a+b)" |
"plus p (N i) = (if i = 0 then p else Plus p (N i))" |
"plus (N i) p = (if i = 0 then p else Plus (N i) p)" |
"plus p q = (Plus p q)"

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N a) = N a" |
"asimp (V x) = V x" |
"asimp (Plus p q) = plus (asimp p) (asimp q)"

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N a) = True" |
"optimal (V x) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus p q) = ((optimal p) \<and> (optimal q))"

theorem "optimal (asimp_const a) = True"
  apply(induction a)
  apply(auto split:aexp.split)
  done

(* Exercise 3.2 *)

fun collect_consts :: "aexp \<Rightarrow> int" where
"collect_consts (N a) = a" |
"collect_consts (Plus a b) = (collect_consts a) + (collect_consts b)" |
"collect_consts (V x) = 0"

fun collect_vars :: "aexp \<Rightarrow> aexp" where
"collect_vars (N a) = N 0" |
"collect_vars (Plus a b) = Plus (collect_vars a) (collect_vars b)" |
"collect_vars (V x) = V x"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp a = asimp (Plus (collect_vars a) (N (collect_consts a)))"

lemma "aval a s = collect_consts a + aval (collect_vars a) s"
  apply(induction a arbitrary: s)
  apply(auto)
  done

theorem "aval (full_asimp a) s = aval a s"
  apply(induction a rule:full_asimp.induct)
  apply(auto)
  sorry (* Couldn't figure it out *)

(* Exercise 3.3 *)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N i) = N i" |
"subst x a (V var) = (if var = x then a else (V var))" |
"subst x a (Plus e1 e2) = Plus (subst x a e1) (subst x a e2)"

lemma [simp]: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(induction e)
  apply(auto)
  done

(* Exercise 3.4 *)

datatype aexpc = Nc int | Vc vname | Plusc aexpc aexpc | Timesc aexpc aexpc

fun avalc :: "aexpc \<Rightarrow> state \<Rightarrow> val" where
"avalc (Nc a) s = a" |
"avalc (Vc x) s = s x" |
"avalc (Plusc a b) s = avalc a s + avalc b s" |
"avalc (Timesc a b) s = avalc a s * avalc b s"

fun asimpc :: "aexpc \<Rightarrow> aexpc" where
"asimpc (Nc a) = Nc a" |
"asimpc (Vc x) = Vc x" |
"asimpc (Plusc p q) =
  (case (asimpc p, asimpc q) of
    (Nc a, Nc b) \<Rightarrow> Nc (a + b) |
    (a, Nc i) \<Rightarrow> (if i = 0 then a else Plusc a (Nc i)) |
    (Nc i, b) \<Rightarrow> (if i = 0 then b else Plusc (Nc i) b) |
    (a, b) \<Rightarrow> Plusc a b)" |
"asimpc (Timesc p q) =
  (case (asimpc p, asimpc q) of
    (Nc a, Nc b) \<Rightarrow> Nc (a * b) |
    (a, Nc i) \<Rightarrow> (if i = 0 then (Nc 0) else if i = 1 then a else Timesc a (Nc i)) |
    (Nc i, b) \<Rightarrow>  (if i = 0 then (Nc 0) else if i = 1 then b else Timesc (Nc i) b) |
    (a, b) \<Rightarrow> Timesc a b)"

value "asimpc (Plusc (Nc 0) (Vc []))"

lemma [simp]: "avalc (Plusc p q) s = avalc p s + avalc q s"
  apply(induction)
  apply(auto)
  done

lemma [simp]: "avalc (Timesc p q) s = avalc p s * avalc q s"
  apply(induction)
  apply(auto)
  done

theorem "avalc (asimpc p) s = avalc p s"
  apply (induction p)
  apply(auto split:aexpc.split)
  done

(* Exercise 3.5 *)

datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | Times2 aexp2 aexp2 |  Div2 aexp2 aexp2 | Inc2 vname

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"aval2 (N2 a) s = Some (a, s)" |
"aval2 (V2 x) s = Some (s x, s)" |
"aval2 (Plus2 p q) s =
  (case (aval2 p s, aval2 q s) of
    (None, Some _) \<Rightarrow> None |
    (Some _, None) \<Rightarrow> None |
    (Some a, Some b) \<Rightarrow> Some (fst a + fst b, (\<lambda>x. ((snd a) x) + ((snd b) x) - (s x))))" |
"aval2 (Times2 p q) s =
  (case (aval2 p s, aval2 q s) of
    (None, Some _) \<Rightarrow> None |
    (Some _, None) \<Rightarrow> None |
    (Some a, Some b) \<Rightarrow> Some (fst a * fst b, (\<lambda>x. ((snd a) x) + ((snd b) x) - (s x))))" |
"aval2 (Inc2 x) s = Some (s x, s(x := 1 + (s x)))" |
"aval2 (Div2 p q) s =
  (case (aval2 p s, aval2 q s) of
    (None, Some _) \<Rightarrow> None |
    (Some _, None) \<Rightarrow> None |
    (Some a, Some b) \<Rightarrow>
      if (fst b) = 0 then
        None
      else
        Some ((fst a div fst b), (\<lambda>x. ((snd a) x) + ((snd b) x) - (s x))))"

(* Exercise 3.6 *)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl a) s = a" |
"lval (Vl x) s = s x" |
"lval (Plusl a b) s = (lval a s) + (lval b s)" |
"lval (LET x e1 e2) s = lval e2 (s(x := lval e1 s))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl a) = (N a)" |
"inline (Vl x) = (V x)" |
"inline (Plusl a b) = Plus (inline a) (inline b)" |
"inline (LET x e1 e2) = subst x (inline e1) (inline e2)"

theorem "aval (inline e) s = lval e s"
  apply(induction e arbitrary: s)
  apply(auto)
  done

(* Exercise 3.7 *)

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> (bval b s))" |
"bval (And a b) s = (bval a s \<and> bval b s)" |
"bval (Less a b) s = (aval a s < aval b s)"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n) (N m) = Bc (n < m)" |
"less a b = Less a b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and a b = And a b"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And a b) = and (bsimp a) (bsimp b)" |
"bsimp (Less a b) = less (asimp a) (asimp b)"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a b = Not (Less b a)"

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a b = And (Le a b) (Le b a)"

theorem "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply(auto)
  done

theorem "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply(auto)
  done

(* Exercise 3.8 *)

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 v) s = v" |
"ifval (Less2 a b) s = (aval a s < aval b s)" |
"ifval (If cond a b) s = (if (ifval cond s) then (ifval a s) else (ifval b s))"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc v) = (Bc2 v)" |
"b2ifexp (Less a b) = (Less2 a b)" |
"b2ifexp (Not a) = (If (b2ifexp a) (Bc2 False) (Bc2 True))" |
"b2ifexp (And a b) = (If (b2ifexp a) (b2ifexp b) (Bc2 False))"

fun or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"or a b = Not (And (Not a) (Not b))"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 v) = (Bc v)" |
"if2bexp (Less2 a b) = (Less a b)" |
"if2bexp (If c p q) =
  (case (if2bexp c, if2bexp p, if2bexp q) of
    (cond, a, b) \<Rightarrow> And (or (not cond) a) (or cond b))"

lemma "ifval ( b2ifexp b ) s = bval b s"
  apply (induction b)
  apply (auto)
done

lemma "bval ( if2bexp i ) s = ifval i s"
  apply (induction i)
  sorry (* :( *)

(* Exercise 3.9 *)

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR x) = True" |
"is_nnf (NOT (VAR x)) = True" |
"is_nnf (NOT _) = False" |
"is_nnf (AND a b) = conj (is_nnf a) (is_nnf b)" |
"is_nnf (OR a b) = disj (is_nnf a) (is_nnf b)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (OR a b) = (OR (nnf a) (nnf b))" |
"nnf (AND a b) = (AND (nnf a) (nnf b))" |
"nnf (NOT (AND a b)) = OR (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (OR a b)) = AND (nnf (NOT a)) (nnf (NOT b))" |
"nnf (NOT (NOT a)) = nnf a" |
"nnf x = x"

theorem "is_nnf (nnf b)"
  apply(induction b rule: nnf.induct)
  apply(auto)
  done

theorem "pbval (nnf b) s = pbval b s"
  apply(induction b rule:nnf.induct)
  apply(auto)
  done

fun no_or :: "pbexp \<Rightarrow> bool" where
"no_or (OR a b) = False" |
"no_or (AND a b) = conj (no_or a) (no_or b)" |
"no_or x = True"

fun is_dnf :: "pbexp \<Rightarrow> bool" where
"is_dnf (VAR _) = True" |
"is_dnf (NOT (VAR _)) = True" |
"is_dnf (NOT x) = False" |
"is_dnf (OR a b) = ((is_dnf a) \<and> (is_dnf b))" |
"is_dnf (AND a b) = ((no_or a) \<and> (no_or b) \<and> (is_nnf a) \<and> (is_nnf b))"

(* TODO: dnf_of_nnf *)

(* Exercise 3.10 *)

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk  = Some (n # stk) " |
"exec1 (LOAD x) s stk  = Some (s(x) # stk) " |
"exec1 ADD _ (i # j # stk) = Some ((i + j) # stk)" |
"exec1 ADD _ (x) = None"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk =
  (case (exec1 i s stk) of
    Some res \<Rightarrow> exec is s res |
    None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma [simp]: "exec is1 s stk = Some new_stk \<Longrightarrow> exec (is1 @ is2) s stk = exec is2 s new_stk"
  apply(induction is1 arbitrary:stk)
  apply(auto split:option.split)
  done

theorem exec_comp: "exec (comp a) s stk = Some (aval a s # stk)"
  apply(induction a arbitrary:stk)
  apply(auto)
  done

(* Exercise 3.11 *)

type_synonym reg = "nat"

datatype rinstr = LDI int reg | LD vname reg | ADD reg reg

fun rexec1 :: "rinstr \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"rexec1 (LDI i r) s rs = rs(r := i)" |
"rexec1 (LD x r) s rs = rs(r := (s x))" |
"rexec1 (ADD r1 r2) s rs = rs(r1 := (rs r1) + (rs r2))"

fun rexec :: "rinstr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"rexec [] _ rs = rs" |
"rexec (i # is) s rs = rexec is s (rexec1 i s rs)"

fun rcomp :: "aexp \<Rightarrow> reg \<Rightarrow> rinstr list" where
"rcomp (N x) r = [LDI x r]" |
"rcomp (V v) r = [LD v r]" |
"rcomp (Plus a b) r = rcomp a r @ rcomp b (r+1) @ [ADD r (r + 1)]"

lemma [simp]: "rexec (xs @ ys) s rs = rexec ys s (rexec xs s rs)"
  apply(induction xs arbitrary: rs)
  apply(auto)
  done

lemma [simp]: "r < q \<Longrightarrow> rexec (rcomp a q) s rs r = rs r"
  apply (induction a arbitrary: rs r q)
  apply (auto)
  done

theorem "rexec (rcomp a r) s rs r = aval a s"
  apply(induction a arbitrary: rs r)
  apply(auto)
  done

(* Exercise 3.12 *)

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exech0 :: "instr0 \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exech0 (LDI0 i) s rs = rs(0 := i)" |
"exech0 (LD0 v) s rs = rs(0 := s v)" |
"exech0 (ADD0 r) s rs = rs(0 := (rs 0) + (rs r))" |
"exech0 (MV0 r) s rs = rs(r := (rs 0))"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec0 [] _ rs = rs" |
"exec0 (i # is) s rs = exec0 is s (exech0 i s rs)"

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0 (N x) r = [LDI0 x]" |
"comp0 (V v) r = [LD0 v]" |
"comp0 (Plus a b) r = (comp0 a (r + 1)) @ [MV0 (r + 1)] @ (comp0 b (r + 2)) @ [ADD0 (r + 1)]"

lemma [simp]: "exec0 (xs @ ys) s rs = exec0 ys s (exec0 xs s rs)"
  apply(induction xs arbitrary: rs)
  apply(auto)
  done

lemma [simp]: "0 < r \<and> r < q \<Longrightarrow> exec0 (comp0 a q) s rs r = rs r"
  apply (induction a arbitrary: rs r q)
  apply (auto)
  done

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
  apply(induction a arbitrary: rs r)
  apply(auto)
  done

end