(*  Title:      HOL/ex/Unification.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Author:     Konrad Slind, TUM & Cambridge University Computer Laboratory
    Author:     Alexander Krauss, TUM
*)

section {* Substitution and Unification *}

theory Unification
imports Main
begin

text {*
  Implements Manna \& Waldinger's formalization, with Paulson's
  simplifications, and some new simplifications by Slind and Krauss.

  Z Manna \& R Waldinger, Deductive Synthesis of the Unification
  Algorithm.  SCP 1 (1981), 5-48

  L C Paulson, Verifying the Unification Algorithm in LCF. SCP 5
  (1985), 143-170

  K Slind, Reasoning about Terminating Functional Programs,
  Ph.D. thesis, TUM, 1999, Sect. 5.8

  A Krauss, Partial and Nested Recursive Function Definitions in
  Higher-Order Logic, JAR 44(4):303-336, 2010. Sect. 6.3
*}

subsection {* Terms *}

text {* Binary trees with leaves that are constants or variables. *}

datatype 'a trm =
  Var 'a
  | Const 'a
  | Comb "'a trm" "'a trm" (infix "\<cdot>" 60)

primrec vars_of :: "'a trm \<Rightarrow> 'a set"
where
  "vars_of (Var v) = {v}"
| "vars_of (Const c) = {}"
| "vars_of (M \<cdot> N) = vars_of M \<union> vars_of N"

fun occs :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" (infixl "\<prec>" 54)
where
  "u \<prec> Var v \<longleftrightarrow> False"
| "u \<prec> Const c \<longleftrightarrow> False"
| "u \<prec> M \<cdot> N \<longleftrightarrow> u = M \<or> u = N \<or> u \<prec> M \<or> u \<prec> N"

lemma finite_vars_of[intro]: "finite (vars_of t)"
  by (induct t) simp_all

lemma vars_iff_occseq: "x \<in> vars_of t \<longleftrightarrow> Var x \<prec> t \<or> Var x = t"
  by (induct t) auto

lemma occs_vars_subset: "M \<prec> N \<Longrightarrow> vars_of M \<subseteq> vars_of N"
  by (induct N) auto

subsection {* Substitutions *}

type_synonym 'a subst = "('a \<times> 'a trm) list"

fun assoc :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'b"
where
  "assoc x d [] = d"
| "assoc x d ((p,q)#t) = (if x = p then q else assoc x d t)"

primrec subst :: "'a trm \<Rightarrow> 'a subst \<Rightarrow> 'a trm" (infixl "\<lhd>" 55)
where
  "(Var v) \<lhd> s = assoc v (Var v) s"
| "(Const c) \<lhd> s = (Const c)"
| "(M \<cdot> N) \<lhd> s = (M \<lhd> s) \<cdot> (N \<lhd> s)"

definition subst_eq (infixr "\<doteq>" 52)
where
  "s1 \<doteq> s2 \<longleftrightarrow> (\<forall>t. t \<lhd> s1 = t \<lhd> s2)"

fun comp :: "'a subst \<Rightarrow> 'a subst \<Rightarrow> 'a subst" (infixl "\<lozenge>" 56)
where
  "[] \<lozenge> bl = bl"
| "((a,b) # al) \<lozenge> bl = (a, b \<lhd> bl) # (al \<lozenge> bl)"

lemma subst_Nil[simp]: "t \<lhd> [] = t"
by (induct t) auto

lemma subst_mono: "t \<prec> u \<Longrightarrow> t \<lhd> s \<prec> u \<lhd> s"
by (induct u) auto

lemma agreement: "(t \<lhd> r = t \<lhd> s) \<longleftrightarrow> (\<forall>v \<in> vars_of t. Var v \<lhd> r = Var v \<lhd> s)"
by (induct t) auto

lemma repl_invariance: "v \<notin> vars_of t \<Longrightarrow> t \<lhd> (v,u) # s = t \<lhd> s"
by (simp add: agreement)

lemma remove_var: "v \<notin> vars_of s \<Longrightarrow> v \<notin> vars_of (t \<lhd> [(v, s)])"
by (induct t) simp_all

lemma subst_refl[iff]: "s \<doteq> s"
  by (auto simp:subst_eq_def)

lemma subst_sym[sym]: "\<lbrakk>s1 \<doteq> s2\<rbrakk> \<Longrightarrow> s2 \<doteq> s1"
  by (auto simp:subst_eq_def)

lemma subst_trans[trans]: "\<lbrakk>s1 \<doteq> s2; s2 \<doteq> s3\<rbrakk> \<Longrightarrow> s1 \<doteq> s3"
  by (auto simp:subst_eq_def)

lemma subst_no_occs: "\<not> Var v \<prec> t \<Longrightarrow> Var v \<noteq> t
  \<Longrightarrow> t \<lhd> [(v,s)] = t"
by (induct t) auto

lemma comp_Nil[simp]: "\<sigma> \<lozenge> [] = \<sigma>"
by (induct \<sigma>) auto

lemma subst_comp[simp]: "t \<lhd> (r \<lozenge> s) = t \<lhd> r \<lhd> s"
proof (induct t)
  case (Var v) thus ?case
    by (induct r) auto
qed auto

lemma subst_eq_intro[intro]: "(\<And>t. t \<lhd> \<sigma> = t \<lhd> \<theta>) \<Longrightarrow> \<sigma> \<doteq> \<theta>"
  by (auto simp:subst_eq_def)

lemma subst_eq_dest[dest]: "s1 \<doteq> s2 \<Longrightarrow> t \<lhd> s1 = t \<lhd> s2"
  by (auto simp:subst_eq_def)

lemma comp_assoc: "(a \<lozenge> b) \<lozenge> c \<doteq> a \<lozenge> (b \<lozenge> c)"
  by auto

lemma subst_cong: "\<lbrakk>\<sigma> \<doteq> \<sigma>'; \<theta> \<doteq> \<theta>'\<rbrakk> \<Longrightarrow> (\<sigma> \<lozenge> \<theta>) \<doteq> (\<sigma>' \<lozenge> \<theta>')"
  by (auto simp: subst_eq_def)

lemma var_self: "[(v, Var v)] \<doteq> []"
proof
  fix t show "t \<lhd> [(v, Var v)] = t \<lhd> []"
    by (induct t) simp_all
qed

lemma var_same[simp]: "[(v, t)] \<doteq> [] \<longleftrightarrow> t = Var v"
by (metis assoc.simps(2) subst.simps(1) subst_eq_def var_self)

subsection {* Unifiers and Most General Unifiers *}

definition Unifier :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool"
where "Unifier \<sigma> t u \<longleftrightarrow> (t \<lhd> \<sigma> = u \<lhd> \<sigma>)"

definition MGU :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" where
  "MGU \<sigma> t u \<longleftrightarrow>
   Unifier \<sigma> t u \<and> (\<forall>\<theta>. Unifier \<theta> t u \<longrightarrow> (\<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>))"

lemma MGUI[intro]:
  "\<lbrakk>t \<lhd> \<sigma> = u \<lhd> \<sigma>; \<And>\<theta>. t \<lhd> \<theta> = u \<lhd> \<theta> \<Longrightarrow> \<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>\<rbrakk>
  \<Longrightarrow> MGU \<sigma> t u"
  by (simp only:Unifier_def MGU_def, auto)

lemma MGU_sym[sym]:
  "MGU \<sigma> s t \<Longrightarrow> MGU \<sigma> t s"
  by (auto simp:MGU_def Unifier_def)

lemma MGU_is_Unifier: "MGU \<sigma> t u \<Longrightarrow> Unifier \<sigma> t u"
unfolding MGU_def by (rule conjunct1)

lemma MGU_Var:
  assumes "\<not> Var v \<prec> t"
  shows "MGU [(v,t)] (Var v) t"
proof (intro MGUI exI)
  show "Var v \<lhd> [(v,t)] = t \<lhd> [(v,t)]" using assms
    by (metis assoc.simps(2) repl_invariance subst.simps(1) subst_Nil vars_iff_occseq)
next
  fix \<theta> assume th: "Var v \<lhd> \<theta> = t \<lhd> \<theta>"
  show "\<theta> \<doteq> [(v,t)] \<lozenge> \<theta>"
  proof
    fix s show "s \<lhd> \<theta> = s \<lhd> [(v,t)] \<lozenge> \<theta>" using th
      by (induct s) auto
  qed
qed

lemma MGU_Const: "MGU [] (Const c) (Const d) \<longleftrightarrow> c = d"
  by (auto simp: MGU_def Unifier_def)

subsection {* The unification algorithm *}

function unify :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> 'a subst option"
where
  "unify (Const c) (M \<cdot> N)   = None"
| "unify (M \<cdot> N)   (Const c) = None"
| "unify (Const c) (Var v)   = Some [(v, Const c)]"
| "unify (M \<cdot> N)   (Var v)   = (if Var v \<prec> M \<cdot> N
                                        then None
                                        else Some [(v, M \<cdot> N)])"
| "unify (Var v)   M         = (if Var v \<prec> M
                                        then None
                                        else Some [(v, M)])"
| "unify (Const c) (Const d) = (if c=d then Some [] else None)"
| "unify (M \<cdot> N) (M' \<cdot> N') = (case unify M M' of
                                    None \<Rightarrow> None |
                                    Some \<theta> \<Rightarrow> (case unify (N \<lhd> \<theta>) (N' \<lhd> \<theta>)
                                      of None \<Rightarrow> None |
                                         Some \<sigma> \<Rightarrow> Some (\<theta> \<lozenge> \<sigma>)))"
  by pat_completeness auto

subsection {* Properties used in termination proof *}

text {* Elimination of variables by a substitution: *}

definition
  "elim \<sigma> v \<equiv> \<forall>t. v \<notin> vars_of (t \<lhd> \<sigma>)"

lemma elim_intro[intro]: "(\<And>t. v \<notin> vars_of (t \<lhd> \<sigma>)) \<Longrightarrow> elim \<sigma> v"
  by (auto simp:elim_def)

lemma elim_dest[dest]: "elim \<sigma> v \<Longrightarrow> v \<notin> vars_of (t \<lhd> \<sigma>)"
  by (auto simp:elim_def)

lemma elim_eq: "\<sigma> \<doteq> \<theta> \<Longrightarrow> elim \<sigma> x = elim \<theta> x"
  by (auto simp:elim_def subst_eq_def)

lemma occs_elim: "\<not> Var v \<prec> t
  \<Longrightarrow> elim [(v,t)] v \<or> [(v,t)] \<doteq> []"
by (metis elim_intro remove_var var_same vars_iff_occseq)

text {* The result of a unification never introduces new variables: *}

declare unify.psimps[simp]

lemma unify_vars:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "vars_of (t \<lhd> \<sigma>) \<subseteq> vars_of M \<union> vars_of N \<union> vars_of t"
  (is "?P M N \<sigma> t")
using assms
proof (induct M N arbitrary:\<sigma> t)
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]" by simp
  thus ?case by (induct t) auto
next
  case (4 M N v)
  hence "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  thus ?case by (induct t) auto
next
  case (5 v M)
  hence "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  thus ?case by (induct t) auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "\<And>t. ?P M M' \<theta>1 t"
    and ih2: "\<And>t. ?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2 t"
    by (auto split:option.split_asm)

  show ?case
  proof
    fix v assume a: "v \<in> vars_of (t \<lhd> \<sigma>)"

    show "v \<in> vars_of (M \<cdot> N) \<union> vars_of (M' \<cdot> N') \<union> vars_of t"
    proof (cases "v \<notin> vars_of M \<and> v \<notin> vars_of M'
        \<and> v \<notin> vars_of N \<and> v \<notin> vars_of N'")
      case True
      with ih1 have l:"\<And>t. v \<in> vars_of (t \<lhd> \<theta>1) \<Longrightarrow> v \<in> vars_of t"
        by auto

      from a and ih2[where t="t \<lhd> \<theta>1"]
      have "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)
        \<or> v \<in> vars_of (t \<lhd> \<theta>1)" unfolding \<sigma>
        by auto
      hence "v \<in> vars_of t"
      proof
        assume "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
        with True show ?thesis by (auto dest:l)
      next
        assume "v \<in> vars_of (t \<lhd> \<theta>1)"
        thus ?thesis by (rule l)
      qed

      thus ?thesis by auto
    qed auto
  qed
qed (auto split: split_if_asm)

text {* The result of a unification is either the identity
substitution or it eliminates a variable from one of the terms: *}

lemma unify_eliminates:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "(\<exists>v\<in>vars_of M \<union> vars_of N. elim \<sigma> v) \<or> \<sigma> \<doteq> []"
  (is "?P M N \<sigma>")
using assms
proof (induct M N arbitrary:\<sigma>)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 c v)
  have no_occs: "\<not> Var v \<prec> Const c" by simp
  with 3 have "\<sigma> = [(v, Const c)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (4 M N v)
  hence no_occs: "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (5 v M)
  hence no_occs: "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (6 c d) thus ?case
    by (cases "c = d") auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "?P M M' \<theta>1"
    and ih2: "?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2"
    by (auto split:option.split_asm)

  from `unify_dom (M \<cdot> N, M' \<cdot> N')`
  have "unify_dom (M, M')"
    by (rule accp_downward) (rule unify_rel.intros)
  hence no_new_vars:
    "\<And>t. vars_of (t \<lhd> \<theta>1) \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of t"
    by (rule unify_vars) (rule `unify M M' = Some \<theta>1`)

  from ih2 show ?case
  proof
    assume "\<exists>v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1). elim \<theta>2 v"
    then obtain v
      where "v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
      and el: "elim \<theta>2 v" by auto
    with no_new_vars show ?thesis unfolding \<sigma>
      by (auto simp:elim_def)
  next
    assume empty[simp]: "\<theta>2 \<doteq> []"

    have "\<sigma> \<doteq> (\<theta>1 \<lozenge> [])" unfolding \<sigma>
      by (rule subst_cong) auto
    also have "\<dots> \<doteq> \<theta>1" by auto
    finally have "\<sigma> \<doteq> \<theta>1" .

    from ih1 show ?thesis
    proof
      assume "\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta>1 v"
      with elim_eq[OF `\<sigma> \<doteq> \<theta>1`]
      show ?thesis by auto
    next
      note `\<sigma> \<doteq> \<theta>1`
      also assume "\<theta>1 \<doteq> []"
      finally show ?thesis ..
    qed
  qed
qed

declare unify.psimps[simp del]

subsection {* Termination proof *}

termination unify
proof
  let ?R = "measures [\<lambda>(M,N). card (vars_of M \<union> vars_of N),
                           \<lambda>(M, N). size M]"
  show "wf ?R" by simp

  fix M N M' N' :: "'a trm"
  show "((M, M'), (M \<cdot> N, M' \<cdot> N')) \<in> ?R" -- "Inner call"
    by (rule measures_lesseq) (auto intro: card_mono)

  fix \<theta>                                   -- "Outer call"
  assume inner: "unify_dom (M, M')"
    "unify M M' = Some \<theta>"

  from unify_eliminates[OF inner]
  show "((N \<lhd> \<theta>, N' \<lhd> \<theta>), (M \<cdot> N, M' \<cdot> N')) \<in>?R"
  proof
    -- {* Either a variable is eliminated \ldots *}
    assume "(\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta> v)"
    then obtain v
      where "elim \<theta> v"
      and "v\<in>vars_of M \<union> vars_of M'" by auto
    with unify_vars[OF inner]
    have "vars_of (N\<lhd>\<theta>) \<union> vars_of (N'\<lhd>\<theta>)
      \<subset> vars_of (M\<cdot>N) \<union> vars_of (M'\<cdot>N')"
      by auto

    thus ?thesis
      by (auto intro!: measures_less intro: psubset_card_mono)
  next
    -- {* Or the substitution is empty *}
    assume "\<theta> \<doteq> []"
    hence "N \<lhd> \<theta> = N"
      and "N' \<lhd> \<theta> = N'" by auto
    thus ?thesis
       by (auto intro!: measures_less intro: psubset_card_mono)
  qed
qed

subsection {* Unification returns a Most General Unifier *}

lemma unify_computes_MGU:
  "unify M N = Some \<sigma> \<Longrightarrow> MGU \<sigma> M N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M N M' N' \<sigma>) -- "The interesting case"

  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and MGU_inner: "MGU \<theta>1 M M'"
    and MGU_outer: "MGU \<theta>2 (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (auto split:option.split_asm)

  show ?case
  proof
    from MGU_inner and MGU_outer
    have "M \<lhd> \<theta>1 = M' \<lhd> \<theta>1"
      and "N \<lhd> \<theta>1 \<lhd> \<theta>2 = N' \<lhd> \<theta>1 \<lhd> \<theta>2"
      unfolding MGU_def Unifier_def
      by auto
    thus "M \<cdot> N \<lhd> \<sigma> = M' \<cdot> N' \<lhd> \<sigma>" unfolding \<sigma>
      by simp
  next
    fix \<sigma>' assume "M \<cdot> N \<lhd> \<sigma>' = M' \<cdot> N' \<lhd> \<sigma>'"
    hence "M \<lhd> \<sigma>' = M' \<lhd> \<sigma>'"
      and Ns: "N \<lhd> \<sigma>' = N' \<lhd> \<sigma>'" by auto

    with MGU_inner obtain \<delta>
      where eqv: "\<sigma>' \<doteq> \<theta>1 \<lozenge> \<delta>"
      unfolding MGU_def Unifier_def
      by auto

    from Ns have "N \<lhd> \<theta>1 \<lhd> \<delta> = N' \<lhd> \<theta>1 \<lhd> \<delta>"
      by (simp add:subst_eq_dest[OF eqv])

    with MGU_outer obtain \<rho>
      where eqv2: "\<delta> \<doteq> \<theta>2 \<lozenge> \<rho>"
      unfolding MGU_def Unifier_def
      by auto

    have "\<sigma>' \<doteq> \<sigma> \<lozenge> \<rho>" unfolding \<sigma>
      by (rule subst_eq_intro, auto simp:subst_eq_dest[OF eqv] subst_eq_dest[OF eqv2])
    thus "\<exists>\<gamma>. \<sigma>' \<doteq> \<sigma> \<lozenge> \<gamma>" ..
  qed
qed (auto simp: MGU_Const intro: MGU_Var MGU_Var[symmetric] split: split_if_asm)

subsection {* Unification returns Idempotent Substitution *}

definition Idem :: "'a subst \<Rightarrow> bool"
where "Idem s \<longleftrightarrow> (s \<lozenge> s) \<doteq> s"

lemma Idem_Nil [iff]: "Idem []"
  by (simp add: Idem_def)

lemma Var_Idem:
  assumes "~ (Var v \<prec> t)" shows "Idem [(v,t)]"
  unfolding Idem_def
proof
  from assms have [simp]: "t \<lhd> [(v, t)] = t"
    by (metis assoc.simps(2) subst.simps(1) subst_no_occs)

  fix s show "s \<lhd> [(v, t)] \<lozenge> [(v, t)] = s \<lhd> [(v, t)]"
    by (induct s) auto
qed

lemma Unifier_Idem_subst:
  "Idem(r) \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
    Unifier (r \<lozenge> s) (t \<lhd> r) (u \<lhd> r)"
by (simp add: Idem_def Unifier_def subst_eq_def)

lemma Idem_comp:
  "Idem r \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
      (!!q. Unifier q (t \<lhd> r) (u \<lhd> r) \<Longrightarrow> s \<lozenge> q \<doteq> q) \<Longrightarrow>
    Idem (r \<lozenge> s)"
  apply (frule Unifier_Idem_subst, blast)
  apply (force simp add: Idem_def subst_eq_def)
  done

theorem unify_gives_Idem:
  "unify M N  = Some \<sigma> \<Longrightarrow> Idem \<sigma>"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M M' N N' \<sigma>)

  then obtain \<theta>1 \<theta>2
    where "unify M N = Some \<theta>1"
    and \<theta>2: "unify (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and "Idem \<theta>1"
    and "Idem \<theta>2"
    by (auto split: option.split_asm)

  from \<theta>2 have "Unifier \<theta>2 (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (rule unify_computes_MGU[THEN MGU_is_Unifier])

  with `Idem \<theta>1`
  show "Idem \<sigma>" unfolding \<sigma>
  proof (rule Idem_comp)
    fix \<sigma> assume "Unifier \<sigma> (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    with \<theta>2 obtain \<gamma> where \<sigma>: "\<sigma> \<doteq> \<theta>2 \<lozenge> \<gamma>"
      using unify_computes_MGU MGU_def by blast

    have "\<theta>2 \<lozenge> \<sigma> \<doteq> \<theta>2 \<lozenge> (\<theta>2 \<lozenge> \<gamma>)" by (rule subst_cong) (auto simp: \<sigma>)
    also have "... \<doteq> (\<theta>2 \<lozenge> \<theta>2) \<lozenge> \<gamma>" by (rule comp_assoc[symmetric])
    also have "... \<doteq> \<theta>2 \<lozenge> \<gamma>" by (rule subst_cong) (auto simp: `Idem \<theta>2`[unfolded Idem_def])
    also have "... \<doteq> \<sigma>" by (rule \<sigma>[symmetric])
    finally show "\<theta>2 \<lozenge> \<sigma> \<doteq> \<sigma>" .
  qed
qed (auto intro!: Var_Idem split: option.splits if_splits)

end


(*  Title       : NatStar.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 1998  University of Cambridge

Converted to Isar and polished by lcp
*)

section{*Star-transforms for the Hypernaturals*}

theory NatStar
imports Star
begin

lemma star_n_eq_starfun_whn: "star_n X = ( *f* X) whn"
by (simp add: hypnat_omega_def starfun_def star_of_def Ifun_star_n)

lemma starset_n_Un: "*sn* (%n. (A n) Un (B n)) = *sn* A Un *sn* B"
apply (simp add: starset_n_def star_n_eq_starfun_whn Un_def)
apply (rule_tac x=whn in spec, transfer, simp)
done

lemma InternalSets_Un:
     "[| X \<in> InternalSets; Y \<in> InternalSets |]
      ==> (X Un Y) \<in> InternalSets"
by (auto simp add: InternalSets_def starset_n_Un [symmetric])

lemma starset_n_Int:
      "*sn* (%n. (A n) Int (B n)) = *sn* A Int *sn* B"
apply (simp add: starset_n_def star_n_eq_starfun_whn Int_def)
apply (rule_tac x=whn in spec, transfer, simp)
done

lemma InternalSets_Int:
     "[| X \<in> InternalSets; Y \<in> InternalSets |]
      ==> (X Int Y) \<in> InternalSets"
by (auto simp add: InternalSets_def starset_n_Int [symmetric])

lemma starset_n_Compl: "*sn* ((%n. - A n)) = -( *sn* A)"
apply (simp add: starset_n_def star_n_eq_starfun_whn Compl_eq)
apply (rule_tac x=whn in spec, transfer, simp)
done

lemma InternalSets_Compl: "X \<in> InternalSets ==> -X \<in> InternalSets"
by (auto simp add: InternalSets_def starset_n_Compl [symmetric])

lemma starset_n_diff: "*sn* (%n. (A n) - (B n)) = *sn* A - *sn* B"
apply (simp add: starset_n_def star_n_eq_starfun_whn set_diff_eq)
apply (rule_tac x=whn in spec, transfer, simp)
done

lemma InternalSets_diff:
     "[| X \<in> InternalSets; Y \<in> InternalSets |]
      ==> (X - Y) \<in> InternalSets"
by (auto simp add: InternalSets_def starset_n_diff [symmetric])

lemma NatStar_SHNat_subset: "Nats \<le> *s* (UNIV:: nat set)"
by simp

lemma NatStar_hypreal_of_real_Int:
     "*s* X Int Nats = hypnat_of_nat ` X"
by (auto simp add: SHNat_eq)

lemma starset_starset_n_eq: "*s* X = *sn* (%n. X)"
by (simp add: starset_n_starset)

lemma InternalSets_starset_n [simp]: "( *s* X) \<in> InternalSets"
by (auto simp add: InternalSets_def starset_starset_n_eq)

lemma InternalSets_UNIV_diff:
     "X \<in> InternalSets ==> UNIV - X \<in> InternalSets"
apply (subgoal_tac "UNIV - X = - X")
by (auto intro: InternalSets_Compl)

subsection{*Nonstandard Extensions of Functions*}

text{* Example of transfer of a property from reals to hyperreals
    --- used for limit comparison of sequences*}

lemma starfun_le_mono:
     "\<forall>n. N \<le> n --> f n \<le> g n
      ==> \<forall>n. hypnat_of_nat N \<le> n --> ( *f* f) n \<le> ( *f* g) n"
by transfer

(*****----- and another -----*****)
lemma starfun_less_mono:
     "\<forall>n. N \<le> n --> f n < g n
      ==> \<forall>n. hypnat_of_nat N \<le> n --> ( *f* f) n < ( *f* g) n"
by transfer

text{*Nonstandard extension when we increment the argument by one*}

lemma starfun_shift_one:
     "!!N. ( *f* (%n. f (Suc n))) N = ( *f* f) (N + (1::hypnat))"
by (transfer, simp)

text{*Nonstandard extension with absolute value*}

lemma starfun_abs: "!!N. ( *f* (%n. abs (f n))) N = abs(( *f* f) N)"
by (transfer, rule refl)

text{*The hyperpow function as a nonstandard extension of realpow*}

lemma starfun_pow: "!!N. ( *f* (%n. r ^ n)) N = (hypreal_of_real r) pow N"
by (transfer, rule refl)

lemma starfun_pow2:
     "!!N. ( *f* (%n. (X n) ^ m)) N = ( *f* X) N pow hypnat_of_nat m"
by (transfer, rule refl)

lemma starfun_pow3: "!!R. ( *f* (%r. r ^ n)) R = (R) pow hypnat_of_nat n"
by (transfer, rule refl)

text{*The @{term hypreal_of_hypnat} function as a nonstandard extension of
  @{term real_of_nat} *}

lemma starfunNat_real_of_nat: "( *f* real) = hypreal_of_hypnat"
by transfer (simp add: fun_eq_iff real_of_nat_def)

lemma starfun_inverse_real_of_nat_eq:
     "N \<in> HNatInfinite
   ==> ( *f* (%x::nat. inverse(real x))) N = inverse(hypreal_of_hypnat N)"
apply (rule_tac f1 = inverse in starfun_o2 [THEN subst])
apply (subgoal_tac "hypreal_of_hypnat N ~= 0")
apply (simp_all add: zero_less_HNatInfinite starfunNat_real_of_nat starfun_inverse_inverse)
done

text{*Internal functions - some redundancy with *f* now*}

lemma starfun_n: "( *fn* f) (star_n X) = star_n (%n. f n (X n))"
by (simp add: starfun_n_def Ifun_star_n)

text{*Multiplication: @{text "( *fn) x ( *gn) = *(fn x gn)"}*}

lemma starfun_n_mult:
     "( *fn* f) z * ( *fn* g) z = ( *fn* (% i x. f i x * g i x)) z"
apply (cases z)
apply (simp add: starfun_n star_n_mult)
done

text{*Addition: @{text "( *fn) + ( *gn) = *(fn + gn)"}*}

lemma starfun_n_add:
     "( *fn* f) z + ( *fn* g) z = ( *fn* (%i x. f i x + g i x)) z"
apply (cases z)
apply (simp add: starfun_n star_n_add)
done

text{*Subtraction: @{text "( *fn) - ( *gn) = *(fn + - gn)"}*}

lemma starfun_n_add_minus:
     "( *fn* f) z + -( *fn* g) z = ( *fn* (%i x. f i x + -g i x)) z"
apply (cases z)
apply (simp add: starfun_n star_n_minus star_n_add)
done

text{*Composition: @{text "( *fn) o ( *gn) = *(fn o gn)"}*}

lemma starfun_n_const_fun [simp]:
     "( *fn* (%i x. k)) z = star_of k"
apply (cases z)
apply (simp add: starfun_n star_of_def)
done

lemma starfun_n_minus: "- ( *fn* f) x = ( *fn* (%i x. - (f i) x)) x"
apply (cases x)
apply (simp add: starfun_n star_n_minus)
done

lemma starfun_n_eq [simp]:
     "( *fn* f) (star_of n) = star_n (%i. f i n)"
by (simp add: starfun_n star_of_def)

lemma starfun_eq_iff: "(( *f* f) = ( *f* g)) = (f = g)"
by (transfer, rule refl)

lemma starfunNat_inverse_real_of_nat_Infinitesimal [simp]:
     "N \<in> HNatInfinite ==> ( *f* (%x. inverse (real x))) N \<in> Infinitesimal"
apply (rule_tac f1 = inverse in starfun_o2 [THEN subst])
apply (subgoal_tac "hypreal_of_hypnat N ~= 0")
apply (simp_all add: zero_less_HNatInfinite starfunNat_real_of_nat)
done

subsection{*Nonstandard Characterization of Induction*}

lemma hypnat_induct_obj:
    "!!n. (( *p* P) (0::hypnat) &
            (\<forall>n. ( *p* P)(n) --> ( *p* P)(n + 1)))
       --> ( *p* P)(n)"
by (transfer, induct_tac n, auto)

lemma hypnat_induct:
  "!!n. [| ( *p* P) (0::hypnat);
      !!n. ( *p* P)(n) ==> ( *p* P)(n + 1)|]
     ==> ( *p* P)(n)"
by (transfer, induct_tac n, auto)

lemma starP2_eq_iff: "( *p2* (op =)) = (op =)"
by transfer (rule refl)

lemma starP2_eq_iff2: "( *p2* (%x y. x = y)) X Y = (X = Y)"
by (simp add: starP2_eq_iff)

lemma nonempty_nat_set_Least_mem:
  "c \<in> (S :: nat set) ==> (LEAST n. n \<in> S) \<in> S"
by (erule LeastI)

lemma nonempty_set_star_has_least:
    "!!S::nat set star. Iset S \<noteq> {} ==> \<exists>n \<in> Iset S. \<forall>m \<in> Iset S. n \<le> m"
apply (transfer empty_def)
apply (rule_tac x="LEAST n. n \<in> S" in bexI)
apply (simp add: Least_le)
apply (rule LeastI_ex, auto)
done

lemma nonempty_InternalNatSet_has_least:
    "[| (S::hypnat set) \<in> InternalSets; S \<noteq> {} |] ==> \<exists>n \<in> S. \<forall>m \<in> S. n \<le> m"
apply (clarsimp simp add: InternalSets_def starset_n_def)
apply (erule nonempty_set_star_has_least)
done

text{* Goldblatt page 129 Thm 11.3.2*}
lemma internal_induct_lemma:
     "!!X::nat set star. [| (0::hypnat) \<in> Iset X; \<forall>n. n \<in> Iset X --> n + 1 \<in> Iset X |]
      ==> Iset X = (UNIV:: hypnat set)"
apply (transfer UNIV_def)
apply (rule equalityI [OF subset_UNIV subsetI])
apply (induct_tac x, auto)
done

lemma internal_induct:
     "[| X \<in> InternalSets; (0::hypnat) \<in> X; \<forall>n. n \<in> X --> n + 1 \<in> X |]
      ==> X = (UNIV:: hypnat set)"
apply (clarsimp simp add: InternalSets_def starset_n_def)
apply (erule (1) internal_induct_lemma)
done

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_nat_le_ne_lt
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((le x y) ==> ((x ~= y) ==> (lt x y)))"
  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_28
  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 elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = (if x z z2 then True else elem z xs)"

theorem property0 :
  "elem z (y xs (cons2 z (nil2)))"
  oops

end


(*  Authors:    Jeremy Avigad, David Gray, and Adam Kramer

Ported by lcp but unfinished
*)

section \<open>Gauss' Lemma\<close>

theory Gauss
imports Euler_Criterion
begin

lemma cong_prime_prod_zero_nat:
  fixes a::nat
  shows "\<lbrakk>[a * b = 0] (mod p); prime p\<rbrakk> \<Longrightarrow> [a = 0] (mod p) | [b = 0] (mod p)"
  by (auto simp add: cong_altdef_nat)

lemma cong_prime_prod_zero_int:
  fixes a::int
  shows "\<lbrakk>[a * b = 0] (mod p); prime p\<rbrakk> \<Longrightarrow> [a = 0] (mod p) | [b = 0] (mod p)"
  by (auto simp add: cong_altdef_int)

locale GAUSS =
  fixes p :: "nat"
  fixes a :: "int"

  assumes p_prime: "prime p"
  assumes p_ge_2: "2 < p"
  assumes p_a_relprime: "[a \<noteq> 0](mod p)"
  assumes a_nonzero:    "0 < a"
begin

definition "A = {0::int <.. ((int p - 1) div 2)}"
definition "B = (\<lambda>x. x * a) ` A"
definition "C = (\<lambda>x. x mod p) ` B"
definition "D = C \<inter> {.. (int p - 1) div 2}"
definition "E = C \<inter> {(int p - 1) div 2 <..}"
definition "F = (\<lambda>x. (int p - x)) ` E"

subsection \<open>Basic properties of p\<close>

lemma odd_p: "odd p"
by (metis p_prime p_ge_2 prime_odd_nat)

lemma p_minus_one_l: "(int p - 1) div 2 < p"
proof -
  have "(p - 1) div 2 \<le> (p - 1) div 1"
    by (metis div_by_1 div_le_dividend)
  also have "\<dots> = p - 1" by simp
  finally show ?thesis using p_ge_2 by arith
qed

lemma p_eq2: "int p = (2 * ((int p - 1) div 2)) + 1"
  using odd_p p_ge_2 nonzero_mult_div_cancel_left [of 2 "p - 1"]
  by simp

lemma p_odd_int: obtains z::int where "int p = 2*z+1" "0<z"
  using odd_p p_ge_2
  by (auto simp add: even_iff_mod_2_eq_zero) (metis p_eq2)

subsection \<open>Basic Properties of the Gauss Sets\<close>

lemma finite_A: "finite (A)"
by (auto simp add: A_def)

lemma finite_B: "finite (B)"
by (auto simp add: B_def finite_A)

lemma finite_C: "finite (C)"
by (auto simp add: C_def finite_B)

lemma finite_D: "finite (D)"
by (auto simp add: D_def finite_C)

lemma finite_E: "finite (E)"
by (auto simp add: E_def finite_C)

lemma finite_F: "finite (F)"
by (auto simp add: F_def finite_E)

lemma C_eq: "C = D \<union> E"
by (auto simp add: C_def D_def E_def)

lemma A_card_eq: "card A = nat ((int p - 1) div 2)"
  by (auto simp add: A_def)

lemma inj_on_xa_A: "inj_on (\<lambda>x. x * a) A"
  using a_nonzero by (simp add: A_def inj_on_def)

definition ResSet :: "int => int set => bool"
  where "ResSet m X = (\<forall>y1 y2. (y1 \<in> X & y2 \<in> X & [y1 = y2] (mod m) --> y1 = y2))"

lemma ResSet_image:
  "\<lbrakk> 0 < m; ResSet m A; \<forall>x \<in> A. \<forall>y \<in> A. ([f x = f y](mod m) --> x = y) \<rbrakk> \<Longrightarrow>
    ResSet m (f ` A)"
  by (auto simp add: ResSet_def)

lemma A_res: "ResSet p A"
  using p_ge_2
  by (auto simp add: A_def ResSet_def intro!: cong_less_imp_eq_int)

lemma B_res: "ResSet p B"
proof -
  {fix x fix y
    assume a: "[x * a = y * a] (mod p)"
    assume b: "0 < x"
    assume c: "x \<le> (int p - 1) div 2"
    assume d: "0 < y"
    assume e: "y \<le> (int p - 1) div 2"
    from p_a_relprime have "\<not>p dvd a"
      by (simp add: cong_altdef_int)
    with p_prime have "coprime a (int p)"
       by (subst gcd.commute, intro prime_imp_coprime) auto
    with a cong_mult_rcancel_int [of a "int p" x y]
      have "[x = y] (mod p)" by simp
    with cong_less_imp_eq_int [of x y p] p_minus_one_l
        order_le_less_trans [of x "(int p - 1) div 2" p]
        order_le_less_trans [of y "(int p - 1) div 2" p]
    have "x = y"
      by (metis b c cong_less_imp_eq_int d e zero_less_imp_eq_int of_nat_0_le_iff)
    } note xy = this
  show ?thesis
    apply (insert p_ge_2 p_a_relprime p_minus_one_l)
    apply (auto simp add: B_def)
    apply (rule ResSet_image)
    apply (auto simp add: A_res)
    apply (auto simp add: A_def xy)
    done
  qed

lemma SR_B_inj: "inj_on (\<lambda>x. x mod p) B"
proof -
{ fix x fix y
  assume a: "x * a mod p = y * a mod p"
  assume b: "0 < x"
  assume c: "x \<le> (int p - 1) div 2"
  assume d: "0 < y"
  assume e: "y \<le> (int p - 1) div 2"
  assume f: "x \<noteq> y"
  from a have a': "[x * a = y * a](mod p)"
    by (metis cong_int_def)
  from p_a_relprime have "\<not>p dvd a"
    by (simp add: cong_altdef_int)
  with p_prime have "coprime a (int p)"
     by (subst gcd.commute, intro prime_imp_coprime) auto
  with a' cong_mult_rcancel_int [of a "int p" x y]
    have "[x = y] (mod p)" by simp
  with cong_less_imp_eq_int [of x y p] p_minus_one_l
    order_le_less_trans [of x "(int p - 1) div 2" p]
    order_le_less_trans [of y "(int p - 1) div 2" p]
  have "x = y"
    by (metis b c cong_less_imp_eq_int d e zero_less_imp_eq_int of_nat_0_le_iff)
  then have False
    by (simp add: f)}
  then show ?thesis
    by (auto simp add: B_def inj_on_def A_def) metis
qed

lemma inj_on_pminusx_E: "inj_on (\<lambda>x. p - x) E"
  apply (auto simp add: E_def C_def B_def A_def)
  apply (rule_tac g = "(op - (int p))" in inj_on_inverseI)
  apply auto
  done

lemma nonzero_mod_p:
  fixes x::int shows "\<lbrakk>0 < x; x < int p\<rbrakk> \<Longrightarrow> [x \<noteq> 0](mod p)"
  by (simp add: cong_int_def)

lemma A_ncong_p: "x \<in> A \<Longrightarrow> [x \<noteq> 0](mod p)"
  by (rule nonzero_mod_p) (auto simp add: A_def)

lemma A_greater_zero: "x \<in> A \<Longrightarrow> 0 < x"
  by (auto simp add: A_def)

lemma B_ncong_p: "x \<in> B \<Longrightarrow> [x \<noteq> 0](mod p)"
  by (auto simp: B_def p_prime p_a_relprime A_ncong_p dest: cong_prime_prod_zero_int)

lemma B_greater_zero: "x \<in> B \<Longrightarrow> 0 < x"
  using a_nonzero by (auto simp add: B_def A_greater_zero)

lemma C_greater_zero: "y \<in> C \<Longrightarrow> 0 < y"
proof (auto simp add: C_def)
  fix x :: int
  assume a1: "x \<in> B"
  have f2: "\<And>x\<^sub>1. int x\<^sub>1 = 0 \<or> 0 < int x\<^sub>1" by linarith
  have "x mod int p \<noteq> 0" using a1 B_ncong_p cong_int_def by simp
  thus "0 < x mod int p" using a1 f2
    by (metis (no_types) B_greater_zero Divides.transfer_int_nat_functions(2) zero_less_imp_eq_int)
qed

lemma F_subset: "F \<subseteq> {x. 0 < x & x \<le> ((int p - 1) div 2)}"
  apply (auto simp add: F_def E_def C_def)
  apply (metis p_ge_2 Divides.pos_mod_bound less_diff_eq nat_int plus_int_code(2) zless_nat_conj)
  apply (auto intro: p_odd_int)
  done

lemma D_subset: "D \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
  by (auto simp add: D_def C_greater_zero)

lemma F_eq: "F = {x. \<exists>y \<in> A. ( x = p - ((y*a) mod p) & (int p - 1) div 2 < (y*a) mod p)}"
  by (auto simp add: F_def E_def D_def C_def B_def A_def)

lemma D_eq: "D = {x. \<exists>y \<in> A. ( x = (y*a) mod p & (y*a) mod p \<le> (int p - 1) div 2)}"
  by (auto simp add: D_def C_def B_def A_def)

lemma all_A_relprime: assumes "x \<in> A" shows "gcd x p = 1"
  using p_prime A_ncong_p [OF assms]
  by (auto simp: cong_altdef_int gcd.commute[of _ "int p"] intro!: prime_imp_coprime)

lemma A_prod_relprime: "gcd (prod id A) p = 1"
  by (metis id_def all_A_relprime prod_coprime)

subsection \<open>Relationships Between Gauss Sets\<close>

lemma StandardRes_inj_on_ResSet: "ResSet m X \<Longrightarrow> (inj_on (\<lambda>b. b mod m) X)"
  by (auto simp add: ResSet_def inj_on_def cong_int_def)

lemma B_card_eq_A: "card B = card A"
  using finite_A by (simp add: finite_A B_def inj_on_xa_A card_image)

lemma B_card_eq: "card B = nat ((int p - 1) div 2)"
  by (simp add: B_card_eq_A A_card_eq)

lemma F_card_eq_E: "card F = card E"
  using finite_E
  by (simp add: F_def inj_on_pminusx_E card_image)

lemma C_card_eq_B: "card C = card B"
proof -
  have "inj_on (\<lambda>x. x mod p) B"
    by (metis SR_B_inj)
  then show ?thesis
    by (metis C_def card_image)
qed

lemma D_E_disj: "D \<inter> E = {}"
  by (auto simp add: D_def E_def)

lemma C_card_eq_D_plus_E: "card C = card D + card E"
  by (auto simp add: C_eq card_Un_disjoint D_E_disj finite_D finite_E)

lemma C_prod_eq_D_times_E: "prod id E * prod id D = prod id C"
  by (metis C_eq D_E_disj finite_D finite_E inf_commute prod.union_disjoint sup_commute)

lemma C_B_zcong_prod: "[prod id C = prod id B] (mod p)"
  apply (auto simp add: C_def)
  apply (insert finite_B SR_B_inj)
  apply (drule prod.reindex [of "\<lambda>x. x mod int p" B id])
  apply auto
  apply (rule cong_prod_int)
  apply (auto simp add: cong_int_def)
  done

lemma F_Un_D_subset: "(F \<union> D) \<subseteq> A"
  apply (intro Un_least subset_trans [OF F_subset] subset_trans [OF D_subset])
  apply (auto simp add: A_def)
  done

lemma F_D_disj: "(F \<inter> D) = {}"
proof (auto simp add: F_eq D_eq)
  fix y::int and z::int
  assume "p - (y*a) mod p = (z*a) mod p"
  then have "[(y*a) mod p + (z*a) mod p = 0] (mod p)"
    by (metis add.commute diff_eq_eq dvd_refl cong_int_def dvd_eq_mod_eq_0 mod_0)
  moreover have "[y * a = (y*a) mod p] (mod p)"
    by (metis cong_int_def mod_mod_trivial)
  ultimately have "[a * (y + z) = 0] (mod p)"
    by (metis cong_int_def mod_add_left_eq mod_add_right_eq mult.commute ring_class.ring_distribs(1))
  with p_prime a_nonzero p_a_relprime
  have a: "[y + z = 0] (mod p)"
    by (auto dest!: cong_prime_prod_zero_int)
  assume b: "y \<in> A" and c: "z \<in> A"
  with A_def have "0 < y + z"
    by auto
  moreover from b c p_eq2 A_def have "y + z < p"
    by auto
  ultimately show False
    by (metis a nonzero_mod_p)
qed

lemma F_Un_D_card: "card (F \<union> D) = nat ((p - 1) div 2)"
proof -
  have "card (F \<union> D) = card E + card D"
    by (auto simp add: finite_F finite_D F_D_disj card_Un_disjoint F_card_eq_E)
  then have "card (F \<union> D) = card C"
    by (simp add: C_card_eq_D_plus_E)
  then show "card (F \<union> D) = nat ((p - 1) div 2)"
    by (simp add: C_card_eq_B B_card_eq)
qed

lemma F_Un_D_eq_A: "F \<union> D = A"
  using finite_A F_Un_D_subset A_card_eq F_Un_D_card
  by (auto simp add: card_seteq)

lemma prod_D_F_eq_prod_A: "(prod id D) * (prod id F) = prod id A"
  by (metis F_D_disj F_Un_D_eq_A Int_commute Un_commute finite_D finite_F prod.union_disjoint)

lemma prod_F_zcong: "[prod id F = ((-1) ^ (card E)) * (prod id E)] (mod p)"
proof -
  have FE: "prod id F = prod (op - p) E"
    apply (auto simp add: F_def)
    apply (insert finite_E inj_on_pminusx_E)
    apply (drule prod.reindex, auto)
    done
  then have "\<forall>x \<in> E. [(p-x) mod p = - x](mod p)"
    by (metis cong_int_def minus_mod_self1 mod_mod_trivial)
  then have "[prod ((\<lambda>x. x mod p) o (op - p)) E = prod (uminus) E](mod p)"
    using finite_E p_ge_2
          cong_prod_int [of E "(\<lambda>x. x mod p) o (op - p)" uminus p]
    by auto
  then have two: "[prod id F = prod (uminus) E](mod p)"
    by (metis FE cong_cong_mod_int cong_refl_int cong_prod_int minus_mod_self1)
  have "prod uminus E = (-1) ^ (card E) * (prod id E)"
    using finite_E by (induct set: finite) auto
  with two show ?thesis
    by simp
qed

subsection \<open>Gauss' Lemma\<close>

lemma aux: "prod id A * (- 1) ^ card E * a ^ card A * (- 1) ^ card E = prod id A * a ^ card A"
by (metis (no_types) minus_minus mult.commute mult.left_commute power_minus power_one)

theorem pre_gauss_lemma:
  "[a ^ nat((int p - 1) div 2) = (-1) ^ (card E)] (mod p)"
proof -
  have "[prod id A = prod id F * prod id D](mod p)"
    by (auto simp add: prod_D_F_eq_prod_A mult.commute cong del: prod.strong_cong)
  then have "[prod id A = ((-1)^(card E) * prod id E) * prod id D] (mod p)"
    apply (rule cong_trans_int)
    apply (metis cong_scalar_int prod_F_zcong)
    done
  then have "[prod id A = ((-1)^(card E) * prod id C)] (mod p)"
    by (metis C_prod_eq_D_times_E mult.commute mult.left_commute)
  then have "[prod id A = ((-1)^(card E) * prod id B)] (mod p)"
    by (rule cong_trans_int) (metis C_B_zcong_prod cong_scalar2_int)
  then have "[prod id A = ((-1)^(card E) *
    (prod id ((\<lambda>x. x * a) ` A)))] (mod p)"
    by (simp add: B_def)
  then have "[prod id A = ((-1)^(card E) * (prod (\<lambda>x. x * a) A))]
    (mod p)"
    by (simp add: inj_on_xa_A prod.reindex)
  moreover have "prod (\<lambda>x. x * a) A =
    prod (\<lambda>x. a) A * prod id A"
    using finite_A by (induct set: finite) auto
  ultimately have "[prod id A = ((-1)^(card E) * (prod (\<lambda>x. a) A *
    prod id A))] (mod p)"
    by simp
  then have "[prod id A = ((-1)^(card E) * a^(card A) *
      prod id A)](mod p)"
    apply (rule cong_trans_int)
    apply (simp add: cong_scalar2_int cong_scalar_int finite_A prod_constant mult.assoc)
    done
  then have a: "[prod id A * (-1)^(card E) =
      ((-1)^(card E) * a^(card A) * prod id A * (-1)^(card E))](mod p)"
    by (rule cong_scalar_int)
  then have "[prod id A * (-1)^(card E) = prod id A *
      (-1)^(card E) * a^(card A) * (-1)^(card E)](mod p)"
    apply (rule cong_trans_int)
    apply (simp add: a mult.commute mult.left_commute)
    done
  then have "[prod id A * (-1)^(card E) = prod id A * a^(card A)](mod p)"
    apply (rule cong_trans_int)
    apply (simp add: aux cong del: prod.strong_cong)
    done
  with A_prod_relprime have "[(- 1) ^ card E = a ^ card A](mod p)"
    by (metis cong_mult_lcancel_int)
  then show ?thesis
    by (simp add: A_card_eq cong_sym_int)
qed

theorem gauss_lemma: "(Legendre a p) = (-1) ^ (card E)"
proof -
  from euler_criterion p_prime p_ge_2 have
      "[(Legendre a p) = a^(nat (((p) - 1) div 2))] (mod p)"
    by auto
  moreover have "int ((p - 1) div 2) =(int p - 1) div 2" using p_eq2 by linarith
    hence "[a ^ nat (int ((p - 1) div 2)) = a ^ nat ((int p - 1) div 2)] (mod int p)" by force
  moreover note pre_gauss_lemma
  ultimately have "[(Legendre a p) = (-1) ^ (card E)] (mod p)" using cong_trans_int by blast
  moreover from p_a_relprime have "(Legendre a p) = 1 | (Legendre a p) = (-1)"
    by (auto simp add: Legendre_def)
  moreover have "(-1::int) ^ (card E) = 1 | (-1::int) ^ (card E) = -1"
    using neg_one_even_power neg_one_odd_power by blast
  moreover have "[1 \<noteq> - 1] (mod int p)"
    using cong_altdef_int nonzero_mod_p[of 2] p_odd_int by fastforce
  ultimately show ?thesis
    by (auto simp add: cong_sym_int)
qed

end

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Finite types as explicit enumerations\<close>

theory Enum
imports Map Groups_List
begin

subsection \<open>Class \<open>enum\<close>\<close>

class enum =
  fixes enum :: "'a list"
  fixes enum_all :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
  fixes enum_ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
  assumes UNIV_enum: "UNIV = set enum"
    and enum_distinct: "distinct enum"
  assumes enum_all_UNIV: "enum_all P \<longleftrightarrow> Ball UNIV P"
  assumes enum_ex_UNIV: "enum_ex P \<longleftrightarrow> Bex UNIV P"
   \<comment> \<open>tailored towards simple instantiation\<close>
begin

subclass finite proof
qed (simp add: UNIV_enum)

lemma enum_UNIV:
  "set enum = UNIV"
  by (simp only: UNIV_enum)

lemma in_enum: "x \<in> set enum"
  by (simp add: enum_UNIV)

lemma enum_eq_I:
  assumes "\<And>x. x \<in> set xs"
  shows "set enum = set xs"
proof -
  from assms UNIV_eq_I have "UNIV = set xs" by auto
  with enum_UNIV show ?thesis by simp
qed

lemma card_UNIV_length_enum:
  "card (UNIV :: 'a set) = length enum"
  by (simp add: UNIV_enum distinct_card enum_distinct)

lemma enum_all [simp]:
  "enum_all = HOL.All"
  by (simp add: fun_eq_iff enum_all_UNIV)

lemma enum_ex [simp]:
  "enum_ex = HOL.Ex"
  by (simp add: fun_eq_iff enum_ex_UNIV)

end

subsection \<open>Implementations using @{class enum}\<close>

subsubsection \<open>Unbounded operations and quantifiers\<close>

lemma Collect_code [code]:
  "Collect P = set (filter P enum)"
  by (simp add: enum_UNIV)

lemma vimage_code [code]:
  "f -` B = set (filter (%x. f x : B) enum_class.enum)"
  unfolding vimage_def Collect_code ..

definition card_UNIV :: "'a itself \<Rightarrow> nat"
where
  [code del]: "card_UNIV TYPE('a) = card (UNIV :: 'a set)"

lemma all_code [code]: "(\<forall>x. P x) \<longleftrightarrow> enum_all P"
  by simp

lemma exists_code [code]: "(\<exists>x. P x) \<longleftrightarrow> enum_ex P"
  by simp

lemma exists1_code [code]: "(\<exists>!x. P x) \<longleftrightarrow> list_ex1 P enum"
  by (auto simp add: list_ex1_iff enum_UNIV)

subsubsection \<open>An executable choice operator\<close>

definition
  [code del]: "enum_the = The"

lemma [code]:
  "The P = (case filter P enum of [x] => x | _ => enum_the P)"
proof -
  {
    fix a
    assume filter_enum: "filter P enum = [a]"
    have "The P = a"
    proof (rule the_equality)
      fix x
      assume "P x"
      show "x = a"
      proof (rule ccontr)
        assume "x \<noteq> a"
        from filter_enum obtain us vs
          where enum_eq: "enum = us @ [a] @ vs"
          and "\<forall> x \<in> set us. \<not> P x"
          and "\<forall> x \<in> set vs. \<not> P x"
          and "P a"
          by (auto simp add: filter_eq_Cons_iff) (simp only: filter_empty_conv[symmetric])
        with \<open>P x\<close> in_enum[of x, unfolded enum_eq] \<open>x \<noteq> a\<close> show "False" by auto
      qed
    next
      from filter_enum show "P a" by (auto simp add: filter_eq_Cons_iff)
    qed
  }
  from this show ?thesis
    unfolding enum_the_def by (auto split: list.split)
qed

declare [[code abort: enum_the]]

code_printing
  constant enum_the \<rightharpoonup> (Eval) "(fn '_ => raise Match)"

subsubsection \<open>Equality and order on functions\<close>

instantiation "fun" :: (enum, equal) equal
begin

definition
  "HOL.equal f g \<longleftrightarrow> (\<forall>x \<in> set enum. f x = g x)"

instance proof
qed (simp_all add: equal_fun_def fun_eq_iff enum_UNIV)

end

lemma [code]:
  "HOL.equal f g \<longleftrightarrow> enum_all (%x. f x = g x)"
  by (auto simp add: equal fun_eq_iff)

lemma [code nbe]:
  "HOL.equal (f :: _ \<Rightarrow> _) f \<longleftrightarrow> True"
  by (fact equal_refl)

lemma order_fun [code]:
  fixes f g :: "'a::enum \<Rightarrow> 'b::order"
  shows "f \<le> g \<longleftrightarrow> enum_all (\<lambda>x. f x \<le> g x)"
    and "f < g \<longleftrightarrow> f \<le> g \<and> enum_ex (\<lambda>x. f x \<noteq> g x)"
  by (simp_all add: fun_eq_iff le_fun_def order_less_le)

subsubsection \<open>Operations on relations\<close>

lemma [code]:
  "Id = image (\<lambda>x. (x, x)) (set Enum.enum)"
  by (auto intro: imageI in_enum)

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

lemma rtranclp_rtrancl_eq [code]:
  "rtranclp r x y \<longleftrightarrow> (x, y) \<in> rtrancl {(x, y). r x y}"
  by (simp add: rtrancl_def)

lemma max_ext_eq [code]:
  "max_ext R = {(X, Y). finite X \<and> finite Y \<and> Y \<noteq> {} \<and> (\<forall>x. x \<in> X \<longrightarrow> (\<exists>xa \<in> Y. (x, xa) \<in> R))}"
  by (auto simp add: max_ext.simps)

lemma max_extp_eq [code]:
  "max_extp r x y \<longleftrightarrow> (x, y) \<in> max_ext {(x, y). r x y}"
  by (simp add: max_ext_def)

lemma mlex_eq [code]:
  "f <*mlex*> R = {(x, y). f x < f y \<or> (f x \<le> f y \<and> (x, y) \<in> R)}"
  by (auto simp add: mlex_prod_def)

subsubsection \<open>Bounded accessible part\<close>

primrec bacc :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> 'a set"
where
  "bacc r 0 = {x. \<forall> y. (y, x) \<notin> r}"
| "bacc r (Suc n) = (bacc r n \<union> {x. \<forall>y. (y, x) \<in> r \<longrightarrow> y \<in> bacc r n})"

lemma bacc_subseteq_acc:
  "bacc r n \<subseteq> Wellfounded.acc r"
  by (induct n) (auto intro: acc.intros)

lemma bacc_mono:
  "n \<le> m \<Longrightarrow> bacc r n \<subseteq> bacc r m"
  by (induct rule: dec_induct) auto

lemma bacc_upper_bound:
  "bacc (r :: ('a \<times> 'a) set)  (card (UNIV :: 'a::finite set)) = (\<Union>n. bacc r n)"
proof -
  have "mono (bacc r)" unfolding mono_def by (simp add: bacc_mono)
  moreover have "\<forall>n. bacc r n = bacc r (Suc n) \<longrightarrow> bacc r (Suc n) = bacc r (Suc (Suc n))" by auto
  moreover have "finite (range (bacc r))" by auto
  ultimately show ?thesis
   by (intro finite_mono_strict_prefix_implies_finite_fixpoint)
     (auto intro: finite_mono_remains_stable_implies_strict_prefix)
qed

lemma acc_subseteq_bacc:
  assumes "finite r"
  shows "Wellfounded.acc r \<subseteq> (\<Union>n. bacc r n)"
proof
  fix x
  assume "x : Wellfounded.acc r"
  then have "\<exists> n. x : bacc r n"
  proof (induct x arbitrary: rule: acc.induct)
    case (accI x)
    then have "\<forall>y. \<exists> n. (y, x) \<in> r --> y : bacc r n" by simp
    from choice[OF this] obtain n where n: "\<forall>y. (y, x) \<in> r \<longrightarrow> y \<in> bacc r (n y)" ..
    obtain n where "\<And>y. (y, x) : r \<Longrightarrow> y : bacc r n"
    proof
      fix y assume y: "(y, x) : r"
      with n have "y : bacc r (n y)" by auto
      moreover have "n y <= Max ((%(y, x). n y) ` r)"
        using y \<open>finite r\<close> by (auto intro!: Max_ge)
      note bacc_mono[OF this, of r]
      ultimately show "y : bacc r (Max ((%(y, x). n y) ` r))" by auto
    qed
    then show ?case
      by (auto simp add: Let_def intro!: exI[of _ "Suc n"])
  qed
  then show "x : (UN n. bacc r n)" by auto
qed

lemma acc_bacc_eq:
  fixes A :: "('a :: finite \<times> 'a) set"
  assumes "finite A"
  shows "Wellfounded.acc A = bacc A (card (UNIV :: 'a set))"
  using assms by (metis acc_subseteq_bacc bacc_subseteq_acc bacc_upper_bound order_eq_iff)

lemma [code]:
  fixes xs :: "('a::finite \<times> 'a) list"
  shows "Wellfounded.acc (set xs) = bacc (set xs) (card_UNIV TYPE('a))"
  by (simp add: card_UNIV_def acc_bacc_eq)

subsection \<open>Default instances for @{class enum}\<close>

lemma map_of_zip_enum_is_Some:
  assumes "length ys = length (enum :: 'a::enum list)"
  shows "\<exists>y. map_of (zip (enum :: 'a::enum list) ys) x = Some y"
proof -
  from assms have "x \<in> set (enum :: 'a::enum list) \<longleftrightarrow>
    (\<exists>y. map_of (zip (enum :: 'a::enum list) ys) x = Some y)"
    by (auto intro!: map_of_zip_is_Some)
  then show ?thesis using enum_UNIV by auto
qed

lemma map_of_zip_enum_inject:
  fixes xs ys :: "'b::enum list"
  assumes length: "length xs = length (enum :: 'a::enum list)"
      "length ys = length (enum :: 'a::enum list)"
    and map_of: "the \<circ> map_of (zip (enum :: 'a::enum list) xs) = the \<circ> map_of (zip (enum :: 'a::enum list) ys)"
  shows "xs = ys"
proof -
  have "map_of (zip (enum :: 'a list) xs) = map_of (zip (enum :: 'a list) ys)"
  proof
    fix x :: 'a
    from length map_of_zip_enum_is_Some obtain y1 y2
      where "map_of (zip (enum :: 'a list) xs) x = Some y1"
        and "map_of (zip (enum :: 'a list) ys) x = Some y2" by blast
    moreover from map_of
      have "the (map_of (zip (enum :: 'a::enum list) xs) x) = the (map_of (zip (enum :: 'a::enum list) ys) x)"
      by (auto dest: fun_cong)
    ultimately show "map_of (zip (enum :: 'a::enum list) xs) x = map_of (zip (enum :: 'a::enum list) ys) x"
      by simp
  qed
  with length enum_distinct show "xs = ys" by (rule map_of_zip_inject)
qed

definition all_n_lists :: "(('a :: enum) list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool"
where
  "all_n_lists P n \<longleftrightarrow> (\<forall>xs \<in> set (List.n_lists n enum). P xs)"

lemma [code]:
  "all_n_lists P n \<longleftrightarrow> (if n = 0 then P [] else enum_all (%x. all_n_lists (%xs. P (x # xs)) (n - 1)))"
  unfolding all_n_lists_def enum_all
  by (cases n) (auto simp add: enum_UNIV)

definition ex_n_lists :: "(('a :: enum) list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool"
where
  "ex_n_lists P n \<longleftrightarrow> (\<exists>xs \<in> set (List.n_lists n enum). P xs)"

lemma [code]:
  "ex_n_lists P n \<longleftrightarrow> (if n = 0 then P [] else enum_ex (%x. ex_n_lists (%xs. P (x # xs)) (n - 1)))"
  unfolding ex_n_lists_def enum_ex
  by (cases n) (auto simp add: enum_UNIV)

instantiation "fun" :: (enum, enum) enum
begin

definition
  "enum = map (\<lambda>ys. the o map_of (zip (enum::'a list) ys)) (List.n_lists (length (enum::'a::enum list)) enum)"

definition
  "enum_all P = all_n_lists (\<lambda>bs. P (the o map_of (zip enum bs))) (length (enum :: 'a list))"

definition
  "enum_ex P = ex_n_lists (\<lambda>bs. P (the o map_of (zip enum bs))) (length (enum :: 'a list))"

instance proof
  show "UNIV = set (enum :: ('a \<Rightarrow> 'b) list)"
  proof (rule UNIV_eq_I)
    fix f :: "'a \<Rightarrow> 'b"
    have "f = the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum))"
      by (auto simp add: map_of_zip_map fun_eq_iff intro: in_enum)
    then show "f \<in> set enum"
      by (auto simp add: enum_fun_def set_n_lists intro: in_enum)
  qed
next
  from map_of_zip_enum_inject
  show "distinct (enum :: ('a \<Rightarrow> 'b) list)"
    by (auto intro!: inj_onI simp add: enum_fun_def
      distinct_map distinct_n_lists enum_distinct set_n_lists)
next
  fix P
  show "enum_all (P :: ('a \<Rightarrow> 'b) \<Rightarrow> bool) = Ball UNIV P"
  proof
    assume "enum_all P"
    show "Ball UNIV P"
    proof
      fix f :: "'a \<Rightarrow> 'b"
      have f: "f = the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum))"
        by (auto simp add: map_of_zip_map fun_eq_iff intro: in_enum)
      from \<open>enum_all P\<close> have "P (the \<circ> map_of (zip enum (map f enum)))"
        unfolding enum_all_fun_def all_n_lists_def
        apply (simp add: set_n_lists)
        apply (erule_tac x="map f enum" in allE)
        apply (auto intro!: in_enum)
        done
      from this f show "P f" by auto
    qed
  next
    assume "Ball UNIV P"
    from this show "enum_all P"
      unfolding enum_all_fun_def all_n_lists_def by auto
  qed
next
  fix P
  show "enum_ex (P :: ('a \<Rightarrow> 'b) \<Rightarrow> bool) = Bex UNIV P"
  proof
    assume "enum_ex P"
    from this show "Bex UNIV P"
      unfolding enum_ex_fun_def ex_n_lists_def by auto
  next
    assume "Bex UNIV P"
    from this obtain f where "P f" ..
    have f: "f = the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum))"
      by (auto simp add: map_of_zip_map fun_eq_iff intro: in_enum)
    from \<open>P f\<close> this have "P (the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum)))"
      by auto
    from  this show "enum_ex P"
      unfolding enum_ex_fun_def ex_n_lists_def
      apply (auto simp add: set_n_lists)
      apply (rule_tac x="map f enum" in exI)
      apply (auto intro!: in_enum)
      done
  qed
qed

end

lemma enum_fun_code [code]: "enum = (let enum_a = (enum :: 'a::{enum, equal} list)
  in map (\<lambda>ys. the o map_of (zip enum_a ys)) (List.n_lists (length enum_a) enum))"
  by (simp add: enum_fun_def Let_def)

lemma enum_all_fun_code [code]:
  "enum_all P = (let enum_a = (enum :: 'a::{enum, equal} list)
   in all_n_lists (\<lambda>bs. P (the o map_of (zip enum_a bs))) (length enum_a))"
  by (simp only: enum_all_fun_def Let_def)

lemma enum_ex_fun_code [code]:
  "enum_ex P = (let enum_a = (enum :: 'a::{enum, equal} list)
   in ex_n_lists (\<lambda>bs. P (the o map_of (zip enum_a bs))) (length enum_a))"
  by (simp only: enum_ex_fun_def Let_def)

instantiation set :: (enum) enum
begin

definition
  "enum = map set (sublists enum)"

definition
  "enum_all P \<longleftrightarrow> (\<forall>A\<in>set enum. P (A::'a set))"

definition
  "enum_ex P \<longleftrightarrow> (\<exists>A\<in>set enum. P (A::'a set))"

instance proof
qed (simp_all add: enum_set_def enum_all_set_def enum_ex_set_def sublists_powset distinct_set_sublists
  enum_distinct enum_UNIV)

end

instantiation unit :: enum
begin

definition
  "enum = [()]"

definition
  "enum_all P = P ()"

definition
  "enum_ex P = P ()"

instance proof
qed (auto simp add: enum_unit_def enum_all_unit_def enum_ex_unit_def)

end

instantiation bool :: enum
begin

definition
  "enum = [False, True]"

definition
  "enum_all P \<longleftrightarrow> P False \<and> P True"

definition
  "enum_ex P \<longleftrightarrow> P False \<or> P True"

instance proof
qed (simp_all only: enum_bool_def enum_all_bool_def enum_ex_bool_def UNIV_bool, simp_all)

end

instantiation prod :: (enum, enum) enum
begin

definition
  "enum = List.product enum enum"

definition
  "enum_all P = enum_all (%x. enum_all (%y. P (x, y)))"

definition
  "enum_ex P = enum_ex (%x. enum_ex (%y. P (x, y)))"

instance
  by standard
    (simp_all add: enum_prod_def distinct_product
      enum_UNIV enum_distinct enum_all_prod_def enum_ex_prod_def)

end

instantiation sum :: (enum, enum) enum
begin

definition
  "enum = map Inl enum @ map Inr enum"

definition
  "enum_all P \<longleftrightarrow> enum_all (\<lambda>x. P (Inl x)) \<and> enum_all (\<lambda>x. P (Inr x))"

definition
  "enum_ex P \<longleftrightarrow> enum_ex (\<lambda>x. P (Inl x)) \<or> enum_ex (\<lambda>x. P (Inr x))"

instance proof
qed (simp_all only: enum_sum_def enum_all_sum_def enum_ex_sum_def UNIV_sum,
  auto simp add: enum_UNIV distinct_map enum_distinct)

end

instantiation option :: (enum) enum
begin

definition
  "enum = None # map Some enum"

definition
  "enum_all P \<longleftrightarrow> P None \<and> enum_all (\<lambda>x. P (Some x))"

definition
  "enum_ex P \<longleftrightarrow> P None \<or> enum_ex (\<lambda>x. P (Some x))"

instance proof
qed (simp_all only: enum_option_def enum_all_option_def enum_ex_option_def UNIV_option_conv,
  auto simp add: distinct_map enum_UNIV enum_distinct)

end

subsection \<open>Small finite types\<close>

text \<open>We define small finite types for use in Quickcheck\<close>

datatype (plugins only: code "quickcheck" extraction) finite_1 =
  a\<^sub>1

notation (output) a\<^sub>1  ("a\<^sub>1")

lemma UNIV_finite_1:
  "UNIV = {a\<^sub>1}"
  by (auto intro: finite_1.exhaust)

instantiation finite_1 :: enum
begin

definition
  "enum = [a\<^sub>1]"

definition
  "enum_all P = P a\<^sub>1"

definition
  "enum_ex P = P a\<^sub>1"

instance proof
qed (simp_all only: enum_finite_1_def enum_all_finite_1_def enum_ex_finite_1_def UNIV_finite_1, simp_all)

end

instantiation finite_1 :: linorder
begin

definition less_finite_1 :: "finite_1 \<Rightarrow> finite_1 \<Rightarrow> bool"
where
  "x < (y :: finite_1) \<longleftrightarrow> False"

definition less_eq_finite_1 :: "finite_1 \<Rightarrow> finite_1 \<Rightarrow> bool"
where
  "x \<le> (y :: finite_1) \<longleftrightarrow> True"

instance
apply (intro_classes)
apply (auto simp add: less_finite_1_def less_eq_finite_1_def)
apply (metis finite_1.exhaust)
done

end

instance finite_1 :: "{dense_linorder, wellorder}"
by intro_classes (simp_all add: less_finite_1_def)

instantiation finite_1 :: complete_lattice
begin

definition [simp]: "Inf = (\<lambda>_. a\<^sub>1)"
definition [simp]: "Sup = (\<lambda>_. a\<^sub>1)"
definition [simp]: "bot = a\<^sub>1"
definition [simp]: "top = a\<^sub>1"
definition [simp]: "inf = (\<lambda>_ _. a\<^sub>1)"
definition [simp]: "sup = (\<lambda>_ _. a\<^sub>1)"

instance by intro_classes(simp_all add: less_eq_finite_1_def)
end

instance finite_1 :: complete_distrib_lattice
  by standard simp_all

instance finite_1 :: complete_linorder ..

lemma finite_1_eq: "x = a\<^sub>1"
by(cases x) simp

simproc_setup finite_1_eq ("x::finite_1") = \<open>
  fn _ => fn _ => fn ct =>
    (case Thm.term_of ct of
      Const (@{const_name a\<^sub>1}, _) => NONE
    | _ => SOME (mk_meta_eq @{thm finite_1_eq}))
\<close>

instantiation finite_1 :: complete_boolean_algebra
begin
definition [simp]: "op - = (\<lambda>_ _. a\<^sub>1)"
definition [simp]: "uminus = (\<lambda>_. a\<^sub>1)"
instance by intro_classes simp_all
end

instantiation finite_1 ::
  "{linordered_ring_strict, linordered_comm_semiring_strict, ordered_comm_ring,
    ordered_cancel_comm_monoid_diff, comm_monoid_mult, ordered_ring_abs,
    one, modulo, sgn, inverse}"
begin
definition [simp]: "Groups.zero = a\<^sub>1"
definition [simp]: "Groups.one = a\<^sub>1"
definition [simp]: "op + = (\<lambda>_ _. a\<^sub>1)"
definition [simp]: "op * = (\<lambda>_ _. a\<^sub>1)"
definition [simp]: "op mod = (\<lambda>_ _. a\<^sub>1)"
definition [simp]: "abs = (\<lambda>_. a\<^sub>1)"
definition [simp]: "sgn = (\<lambda>_. a\<^sub>1)"
definition [simp]: "inverse = (\<lambda>_. a\<^sub>1)"
definition [simp]: "divide = (\<lambda>_ _. a\<^sub>1)"

instance by intro_classes(simp_all add: less_finite_1_def)
end

declare [[simproc del: finite_1_eq]]
hide_const (open) a\<^sub>1

datatype (plugins only: code "quickcheck" extraction) finite_2 =
  a\<^sub>1 | a\<^sub>2

notation (output) a\<^sub>1  ("a\<^sub>1")
notation (output) a\<^sub>2  ("a\<^sub>2")

lemma UNIV_finite_2:
  "UNIV = {a\<^sub>1, a\<^sub>2}"
  by (auto intro: finite_2.exhaust)

instantiation finite_2 :: enum
begin

definition
  "enum = [a\<^sub>1, a\<^sub>2]"

definition
  "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2"

definition
  "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2"

instance proof
qed (simp_all only: enum_finite_2_def enum_all_finite_2_def enum_ex_finite_2_def UNIV_finite_2, simp_all)

end

instantiation finite_2 :: linorder
begin

definition less_finite_2 :: "finite_2 \<Rightarrow> finite_2 \<Rightarrow> bool"
where
  "x < y \<longleftrightarrow> x = a\<^sub>1 \<and> y = a\<^sub>2"

definition less_eq_finite_2 :: "finite_2 \<Rightarrow> finite_2 \<Rightarrow> bool"
where
  "x \<le> y \<longleftrightarrow> x = y \<or> x < (y :: finite_2)"

instance
apply (intro_classes)
apply (auto simp add: less_finite_2_def less_eq_finite_2_def)
apply (metis finite_2.nchotomy)+
done

end

instance finite_2 :: wellorder
by(rule wf_wellorderI)(simp add: less_finite_2_def, intro_classes)

instantiation finite_2 :: complete_lattice
begin

definition "\<Sqinter>A = (if a\<^sub>1 \<in> A then a\<^sub>1 else a\<^sub>2)"
definition "\<Squnion>A = (if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>1)"
definition [simp]: "bot = a\<^sub>1"
definition [simp]: "top = a\<^sub>2"
definition "x \<sqinter> y = (if x = a\<^sub>1 \<or> y = a\<^sub>1 then a\<^sub>1 else a\<^sub>2)"
definition "x \<squnion> y = (if x = a\<^sub>2 \<or> y = a\<^sub>2 then a\<^sub>2 else a\<^sub>1)"

lemma neq_finite_2_a\<^sub>1_iff [simp]: "x \<noteq> a\<^sub>1 \<longleftrightarrow> x = a\<^sub>2"
by(cases x) simp_all

lemma neq_finite_2_a\<^sub>1_iff' [simp]: "a\<^sub>1 \<noteq> x \<longleftrightarrow> x = a\<^sub>2"
by(cases x) simp_all

lemma neq_finite_2_a\<^sub>2_iff [simp]: "x \<noteq> a\<^sub>2 \<longleftrightarrow> x = a\<^sub>1"
by(cases x) simp_all

lemma neq_finite_2_a\<^sub>2_iff' [simp]: "a\<^sub>2 \<noteq> x \<longleftrightarrow> x = a\<^sub>1"
by(cases x) simp_all

instance
proof
  fix x :: finite_2 and A
  assume "x \<in> A"
  then show "\<Sqinter>A \<le> x" "x \<le> \<Squnion>A"
    by(case_tac [!] x)(auto simp add: less_eq_finite_2_def less_finite_2_def Inf_finite_2_def Sup_finite_2_def)
qed(auto simp add: less_eq_finite_2_def less_finite_2_def inf_finite_2_def sup_finite_2_def Inf_finite_2_def Sup_finite_2_def)
end

instance finite_2 :: complete_distrib_lattice
  by standard (auto simp add: sup_finite_2_def inf_finite_2_def Inf_finite_2_def Sup_finite_2_def)

instance finite_2 :: complete_linorder ..

instantiation finite_2 :: "{field, ring_div, idom_abs_sgn}" begin
definition [simp]: "0 = a\<^sub>1"
definition [simp]: "1 = a\<^sub>2"
definition "x + y = (case (x, y) of (a\<^sub>1, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>1 | _ \<Rightarrow> a\<^sub>2)"
definition "uminus = (\<lambda>x :: finite_2. x)"
definition "op - = (op + :: finite_2 \<Rightarrow> _)"
definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> a\<^sub>1)"
definition "inverse = (\<lambda>x :: finite_2. x)"
definition "divide = (op * :: finite_2 \<Rightarrow> _)"
definition "abs = (\<lambda>x :: finite_2. x)"
definition "x mod y = (case (x, y) of (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> a\<^sub>1)"
definition "sgn = (\<lambda>x :: finite_2. x)"
instance
by intro_classes
  (simp_all add: plus_finite_2_def uminus_finite_2_def minus_finite_2_def times_finite_2_def
       inverse_finite_2_def divide_finite_2_def abs_finite_2_def modulo_finite_2_def sgn_finite_2_def
     split: finite_2.splits)
end

lemma two_finite_2 [simp]:
  "2 = a\<^sub>1"
  by (simp add: numeral.simps plus_finite_2_def)

hide_const (open) a\<^sub>1 a\<^sub>2

datatype (plugins only: code "quickcheck" extraction) finite_3 =
  a\<^sub>1 | a\<^sub>2 | a\<^sub>3

notation (output) a\<^sub>1  ("a\<^sub>1")
notation (output) a\<^sub>2  ("a\<^sub>2")
notation (output) a\<^sub>3  ("a\<^sub>3")

lemma UNIV_finite_3:
  "UNIV = {a\<^sub>1, a\<^sub>2, a\<^sub>3}"
  by (auto intro: finite_3.exhaust)

instantiation finite_3 :: enum
begin

definition
  "enum = [a\<^sub>1, a\<^sub>2, a\<^sub>3]"

definition
  "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2 \<and> P a\<^sub>3"

definition
  "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2 \<or> P a\<^sub>3"

instance proof
qed (simp_all only: enum_finite_3_def enum_all_finite_3_def enum_ex_finite_3_def UNIV_finite_3, simp_all)

end

instantiation finite_3 :: linorder
begin

definition less_finite_3 :: "finite_3 \<Rightarrow> finite_3 \<Rightarrow> bool"
where
  "x < y = (case x of a\<^sub>1 \<Rightarrow> y \<noteq> a\<^sub>1 | a\<^sub>2 \<Rightarrow> y = a\<^sub>3 | a\<^sub>3 \<Rightarrow> False)"

definition less_eq_finite_3 :: "finite_3 \<Rightarrow> finite_3 \<Rightarrow> bool"
where
  "x \<le> y \<longleftrightarrow> x = y \<or> x < (y :: finite_3)"

instance proof (intro_classes)
qed (auto simp add: less_finite_3_def less_eq_finite_3_def split: finite_3.split_asm)

end

instance finite_3 :: wellorder
proof(rule wf_wellorderI)
  have "inv_image less_than (case_finite_3 0 1 2) = {(x, y). x < y}"
    by(auto simp add: less_finite_3_def split: finite_3.splits)
  from this[symmetric] show "wf \<dots>" by simp
qed intro_classes

instantiation finite_3 :: complete_lattice
begin

definition "\<Sqinter>A = (if a\<^sub>1 \<in> A then a\<^sub>1 else if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>3)"
definition "\<Squnion>A = (if a\<^sub>3 \<in> A then a\<^sub>3 else if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>1)"
definition [simp]: "bot = a\<^sub>1"
definition [simp]: "top = a\<^sub>3"
definition [simp]: "inf = (min :: finite_3 \<Rightarrow> _)"
definition [simp]: "sup = (max :: finite_3 \<Rightarrow> _)"

instance
proof
  fix x :: finite_3 and A
  assume "x \<in> A"
  then show "\<Sqinter>A \<le> x" "x \<le> \<Squnion>A"
    by(case_tac [!] x)(auto simp add: Inf_finite_3_def Sup_finite_3_def less_eq_finite_3_def less_finite_3_def)
next
  fix A and z :: finite_3
  assume "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  then show "z \<le> \<Sqinter>A"
    by(cases z)(auto simp add: Inf_finite_3_def less_eq_finite_3_def less_finite_3_def)
next
  fix A and z :: finite_3
  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  show "\<Squnion>A \<le> z"
    by(auto simp add: Sup_finite_3_def less_eq_finite_3_def less_finite_3_def dest: *)
qed(auto simp add: Inf_finite_3_def Sup_finite_3_def)
end

instance finite_3 :: complete_distrib_lattice
proof
  fix a :: finite_3 and B
  show "a \<squnion> \<Sqinter>B = (\<Sqinter>b\<in>B. a \<squnion> b)"
  proof(cases a "\<Sqinter>B" rule: finite_3.exhaust[case_product finite_3.exhaust])
    case a\<^sub>2_a\<^sub>3
    then have "\<And>x. x \<in> B \<Longrightarrow> x = a\<^sub>3"
      by(case_tac x)(auto simp add: Inf_finite_3_def split: if_split_asm)
    then show ?thesis using a\<^sub>2_a\<^sub>3
      by(auto simp add: Inf_finite_3_def max_def less_eq_finite_3_def less_finite_3_def split: if_split_asm)
  qed (auto simp add: Inf_finite_3_def max_def less_finite_3_def less_eq_finite_3_def split: if_split_asm)
  show "a \<sqinter> \<Squnion>B = (\<Squnion>b\<in>B. a \<sqinter> b)"
    by (cases a "\<Squnion>B" rule: finite_3.exhaust[case_product finite_3.exhaust])
      (auto simp add: Sup_finite_3_def min_def less_finite_3_def less_eq_finite_3_def split: if_split_asm)
qed

instance finite_3 :: complete_linorder ..

instantiation finite_3 :: "{field, ring_div, idom_abs_sgn}" begin
definition [simp]: "0 = a\<^sub>1"
definition [simp]: "1 = a\<^sub>2"
definition
  "x + y = (case (x, y) of
     (a\<^sub>1, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>1
   | (a\<^sub>1, a\<^sub>2) \<Rightarrow> a\<^sub>2 | (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \<Rightarrow> a\<^sub>2
   | _ \<Rightarrow> a\<^sub>3)"
definition "- x = (case x of a\<^sub>1 \<Rightarrow> a\<^sub>1 | a\<^sub>2 \<Rightarrow> a\<^sub>3 | a\<^sub>3 \<Rightarrow> a\<^sub>2)"
definition "x - y = x + (- y :: finite_3)"
definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \<Rightarrow> a\<^sub>2 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>3 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>3 | _ \<Rightarrow> a\<^sub>1)"
definition "inverse = (\<lambda>x :: finite_3. x)"
definition "x div y = x * inverse (y :: finite_3)"
definition "abs = (\<lambda>x. case x of a\<^sub>3 \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> x)"
definition "x mod y = (case (x, y) of (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>1) \<Rightarrow> a\<^sub>3 | _ \<Rightarrow> a\<^sub>1)"
definition "sgn = (\<lambda>x :: finite_3. x)"
instance
by intro_classes
  (simp_all add: plus_finite_3_def uminus_finite_3_def minus_finite_3_def times_finite_3_def
       inverse_finite_3_def divide_finite_3_def abs_finite_3_def modulo_finite_3_def sgn_finite_3_def
       less_finite_3_def
     split: finite_3.splits)
end

hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3

datatype (plugins only: code "quickcheck" extraction) finite_4 =
  a\<^sub>1 | a\<^sub>2 | a\<^sub>3 | a\<^sub>4

notation (output) a\<^sub>1  ("a\<^sub>1")
notation (output) a\<^sub>2  ("a\<^sub>2")
notation (output) a\<^sub>3  ("a\<^sub>3")
notation (output) a\<^sub>4  ("a\<^sub>4")

lemma UNIV_finite_4:
  "UNIV = {a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4}"
  by (auto intro: finite_4.exhaust)

instantiation finite_4 :: enum
begin

definition
  "enum = [a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4]"

definition
  "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2 \<and> P a\<^sub>3 \<and> P a\<^sub>4"

definition
  "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2 \<or> P a\<^sub>3 \<or> P a\<^sub>4"

instance proof
qed (simp_all only: enum_finite_4_def enum_all_finite_4_def enum_ex_finite_4_def UNIV_finite_4, simp_all)

end

instantiation finite_4 :: complete_lattice begin

text \<open>@{term a\<^sub>1} $<$ @{term a\<^sub>2},@{term a\<^sub>3} $<$ @{term a\<^sub>4},
  but @{term a\<^sub>2} and @{term a\<^sub>3} are incomparable.\<close>

definition
  "x < y \<longleftrightarrow> (case (x, y) of
     (a\<^sub>1, a\<^sub>1) \<Rightarrow> False | (a\<^sub>1, _) \<Rightarrow> True
   |  (a\<^sub>2, a\<^sub>4) \<Rightarrow> True
   |  (a\<^sub>3, a\<^sub>4) \<Rightarrow> True  | _ \<Rightarrow> False)"

definition
  "x \<le> y \<longleftrightarrow> (case (x, y) of
     (a\<^sub>1, _) \<Rightarrow> True
   | (a\<^sub>2, a\<^sub>2) \<Rightarrow> True | (a\<^sub>2, a\<^sub>4) \<Rightarrow> True
   | (a\<^sub>3, a\<^sub>3) \<Rightarrow> True | (a\<^sub>3, a\<^sub>4) \<Rightarrow> True
   | (a\<^sub>4, a\<^sub>4) \<Rightarrow> True | _ \<Rightarrow> False)"

definition
  "\<Sqinter>A = (if a\<^sub>1 \<in> A \<or> a\<^sub>2 \<in> A \<and> a\<^sub>3 \<in> A then a\<^sub>1 else if a\<^sub>2 \<in> A then a\<^sub>2 else if a\<^sub>3 \<in> A then a\<^sub>3 else a\<^sub>4)"
definition
  "\<Squnion>A = (if a\<^sub>4 \<in> A \<or> a\<^sub>2 \<in> A \<and> a\<^sub>3 \<in> A then a\<^sub>4 else if a\<^sub>2 \<in> A then a\<^sub>2 else if a\<^sub>3 \<in> A then a\<^sub>3 else a\<^sub>1)"
definition [simp]: "bot = a\<^sub>1"
definition [simp]: "top = a\<^sub>4"
definition
  "x \<sqinter> y = (case (x, y) of
     (a\<^sub>1, _) \<Rightarrow> a\<^sub>1 | (_, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>1
   | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
   | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
   | _ \<Rightarrow> a\<^sub>4)"
definition
  "x \<squnion> y = (case (x, y) of
     (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>4 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>4
  | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
  | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
  | _ \<Rightarrow> a\<^sub>1)"

instance
proof
  fix A and z :: finite_4
  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  show "\<Squnion>A \<le> z"
    by(auto simp add: Sup_finite_4_def less_eq_finite_4_def dest!: * split: finite_4.splits)
next
  fix A and z :: finite_4
  assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  show "z \<le> \<Sqinter>A"
    by(auto simp add: Inf_finite_4_def less_eq_finite_4_def dest!: * split: finite_4.splits)
qed(auto simp add: less_finite_4_def less_eq_finite_4_def Inf_finite_4_def Sup_finite_4_def inf_finite_4_def sup_finite_4_def split: finite_4.splits)

end

instance finite_4 :: complete_distrib_lattice
proof
  fix a :: finite_4 and B
  show "a \<squnion> \<Sqinter>B = (\<Sqinter>b\<in>B. a \<squnion> b)"
    by(cases a "\<Sqinter>B" rule: finite_4.exhaust[case_product finite_4.exhaust])
      (auto simp add: sup_finite_4_def Inf_finite_4_def split: finite_4.splits if_split_asm)
  show "a \<sqinter> \<Squnion>B = (\<Squnion>b\<in>B. a \<sqinter> b)"
    by(cases a "\<Squnion>B" rule: finite_4.exhaust[case_product finite_4.exhaust])
      (auto simp add: inf_finite_4_def Sup_finite_4_def split: finite_4.splits if_split_asm)
qed

instantiation finite_4 :: complete_boolean_algebra begin
definition "- x = (case x of a\<^sub>1 \<Rightarrow> a\<^sub>4 | a\<^sub>2 \<Rightarrow> a\<^sub>3 | a\<^sub>3 \<Rightarrow> a\<^sub>2 | a\<^sub>4 \<Rightarrow> a\<^sub>1)"
definition "x - y = x \<sqinter> - (y :: finite_4)"
instance
by intro_classes
  (simp_all add: inf_finite_4_def sup_finite_4_def uminus_finite_4_def minus_finite_4_def split: finite_4.splits)
end

hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3 a\<^sub>4

datatype (plugins only: code "quickcheck" extraction) finite_5 =
  a\<^sub>1 | a\<^sub>2 | a\<^sub>3 | a\<^sub>4 | a\<^sub>5

notation (output) a\<^sub>1  ("a\<^sub>1")
notation (output) a\<^sub>2  ("a\<^sub>2")
notation (output) a\<^sub>3  ("a\<^sub>3")
notation (output) a\<^sub>4  ("a\<^sub>4")
notation (output) a\<^sub>5  ("a\<^sub>5")

lemma UNIV_finite_5:
  "UNIV = {a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4, a\<^sub>5}"
  by (auto intro: finite_5.exhaust)

instantiation finite_5 :: enum
begin

definition
  "enum = [a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4, a\<^sub>5]"

definition
  "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2 \<and> P a\<^sub>3 \<and> P a\<^sub>4 \<and> P a\<^sub>5"

definition
  "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2 \<or> P a\<^sub>3 \<or> P a\<^sub>4 \<or> P a\<^sub>5"

instance proof
qed (simp_all only: enum_finite_5_def enum_all_finite_5_def enum_ex_finite_5_def UNIV_finite_5, simp_all)

end

instantiation finite_5 :: complete_lattice
begin

text \<open>The non-distributive pentagon lattice $N_5$\<close>

definition
  "x < y \<longleftrightarrow> (case (x, y) of
     (a\<^sub>1, a\<^sub>1) \<Rightarrow> False | (a\<^sub>1, _) \<Rightarrow> True
   | (a\<^sub>2, a\<^sub>3) \<Rightarrow> True  | (a\<^sub>2, a\<^sub>5) \<Rightarrow> True
   | (a\<^sub>3, a\<^sub>5) \<Rightarrow> True
   | (a\<^sub>4, a\<^sub>5) \<Rightarrow> True  | _ \<Rightarrow> False)"

definition
  "x \<le> y \<longleftrightarrow> (case (x, y) of
     (a\<^sub>1, _) \<Rightarrow> True
   | (a\<^sub>2, a\<^sub>2) \<Rightarrow> True | (a\<^sub>2, a\<^sub>3) \<Rightarrow> True | (a\<^sub>2, a\<^sub>5) \<Rightarrow> True
   | (a\<^sub>3, a\<^sub>3) \<Rightarrow> True | (a\<^sub>3, a\<^sub>5) \<Rightarrow> True
   | (a\<^sub>4, a\<^sub>4) \<Rightarrow> True | (a\<^sub>4, a\<^sub>5) \<Rightarrow> True
   | (a\<^sub>5, a\<^sub>5) \<Rightarrow> True | _ \<Rightarrow> False)"

definition
  "\<Sqinter>A =
  (if a\<^sub>1 \<in> A \<or> a\<^sub>4 \<in> A \<and> (a\<^sub>2 \<in> A \<or> a\<^sub>3 \<in> A) then a\<^sub>1
   else if a\<^sub>2 \<in> A then a\<^sub>2
   else if a\<^sub>3 \<in> A then a\<^sub>3
   else if a\<^sub>4 \<in> A then a\<^sub>4
   else a\<^sub>5)"
definition
  "\<Squnion>A =
  (if a\<^sub>5 \<in> A \<or> a\<^sub>4 \<in> A \<and> (a\<^sub>2 \<in> A \<or> a\<^sub>3 \<in> A) then a\<^sub>5
   else if a\<^sub>3 \<in> A then a\<^sub>3
   else if a\<^sub>2 \<in> A then a\<^sub>2
   else if a\<^sub>4 \<in> A then a\<^sub>4
   else a\<^sub>1)"
definition [simp]: "bot = a\<^sub>1"
definition [simp]: "top = a\<^sub>5"
definition
  "x \<sqinter> y = (case (x, y) of
     (a\<^sub>1, _) \<Rightarrow> a\<^sub>1 | (_, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>4) \<Rightarrow> a\<^sub>1 | (a\<^sub>4, a\<^sub>2) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>4) \<Rightarrow> a\<^sub>1 | (a\<^sub>4, a\<^sub>3) \<Rightarrow> a\<^sub>1
   | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
   | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
   | (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4
   | _ \<Rightarrow> a\<^sub>5)"
definition
  "x \<squnion> y = (case (x, y) of
     (a\<^sub>5, _) \<Rightarrow> a\<^sub>5 | (_, a\<^sub>5) \<Rightarrow> a\<^sub>5 | (a\<^sub>2, a\<^sub>4) \<Rightarrow> a\<^sub>5 | (a\<^sub>4, a\<^sub>2) \<Rightarrow> a\<^sub>5 | (a\<^sub>3, a\<^sub>4) \<Rightarrow> a\<^sub>5 | (a\<^sub>4, a\<^sub>3) \<Rightarrow> a\<^sub>5
   | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
   | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
   | (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4
   | _ \<Rightarrow> a\<^sub>1)"

instance
proof intro_classes
  fix A and z :: finite_5
  assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
  show "z \<le> \<Sqinter>A"
    by(auto simp add: less_eq_finite_5_def Inf_finite_5_def split: finite_5.splits if_split_asm dest!: *)
next
  fix A and z :: finite_5
  assume *: "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
  show "\<Squnion>A \<le> z"
    by(auto simp add: less_eq_finite_5_def Sup_finite_5_def split: finite_5.splits if_split_asm dest!: *)
qed(auto simp add: less_eq_finite_5_def less_finite_5_def inf_finite_5_def sup_finite_5_def Inf_finite_5_def Sup_finite_5_def split: finite_5.splits if_split_asm)

end

hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3 a\<^sub>4 a\<^sub>5

subsection \<open>Closing up\<close>

hide_type (open) finite_1 finite_2 finite_3 finite_4 finite_5
hide_const (open) enum enum_all enum_ex all_n_lists ex_n_lists ntrancl

end


theory BigStep_sseefried
imports Com
begin

(* concrete syntax (_,_) \<Rightarrow> _ is possible becasue we declared the transition arrow \<Rightarrow> as an
   infix symbol below with precendence 55 *)

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where

Skip:       "(SKIP,s) \<Rightarrow> s" |
Assign:     "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq:        "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue:     "\<lbrakk> bval b s;   (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse:    "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:  "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
              \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

(* `print_theorems` is incredibly useful for seeing what certain
   declarations bring into scope *)
print_theorems

declare big_step.intros [intro]

(* From the textbook:
"This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:"
*)
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct

schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
  apply(rule Seq)
   apply(rule Assign)
  apply simp
  apply(rule Assign)
done

(* The following command tells Isabelle to generate code for the predicate \<Rightarrow> and thus make the
predicate available in the `values` command, which is similar to `value`, but works on
inductive definitions and computes a set of possible results.  *)

code_pred big_step . (* The period is necessary at the end of this line *)

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

values "{map t [''x'', ''y'']| t. (''x'' ::= N 2;; ''y'' ::= plus (V ''x'') (N 1), \<lambda>_.0) \<Rightarrow> t}"

(* 7.2.3 Rule Inversion *)

(* Inductive definitions like above bring into scope automatically generated .induct and .cases theorems *)

(* Now we prove a bunch of rule inversions. I've decided not to use inductive_cases as in
   the official solutions and instead prove the rule inversions as they were expressed in
   the textbook.

   I must mention my indebtedness to this particular Isabelle mailing list post:
   https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2013-January/msg00118.html

*)

lemma SkipE[elim!]: "(SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
  by (erule big_step.cases, simp+)

lemma AssignE[elim!]:  "(x ::= a,s) \<Rightarrow> t \<Longrightarrow> t = s(x := aval a s)"
  by (erule big_step.cases, simp+)

lemma SeqE[elim!]: "(c1;;c2, s1) \<Rightarrow> s3 \<Longrightarrow> \<exists>s2. (c1,s1) \<Rightarrow> s2 \<and> (c2,s2) \<Rightarrow> s3"
  by (erule big_step.cases, auto)

lemma IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t \<Longrightarrow> bval b s \<and> (c1, s) \<Rightarrow> t \<or> \<not>bval b s \<and> (c2, s) \<Rightarrow> t"
  by (erule big_step.cases, simp+)

lemma WhileE[elim]:
  "(WHILE b DO c, s) \<Rightarrow> t
  \<Longrightarrow>   bval b s \<and> (\<exists>s'. (c, s) \<Rightarrow> s' \<and> (WHILE b DO c, s') \<Rightarrow> t)
      \<or> \<not>bval b s \<and> t = s"
   by  (erule big_step.cases, auto)

inductive_cases SkipE2[elim!]: "(SKIP, s) \<Rightarrow> t"
inductive_cases AssignE2[elim!]: "(x ::= a,s) \<Rightarrow> t"
inductive_cases SeqE2[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
inductive_cases IfE2[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE2[elim]: "(WHILE b DO c,s) \<Rightarrow> t"

(* Lemma 7.2 *)
lemma seq_assoc_l: "(c1;; c2;; c3, s) \<Rightarrow> s' \<Longrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
  apply clarify
  apply (rule Seq, simp)
  apply (rule Seq, simp+)
  done

lemma seq_assoc_r: "(c1;; (c2;; c3), s) \<Rightarrow> s' \<Longrightarrow> (c1;; c2;; c3, s) \<Rightarrow> s'"
  apply clarify
  apply (rule Seq, rule Seq, simp+)
  done

lemma seq_assoc: "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
  by (auto simp: seq_assoc_l seq_assoc_r)

(* Section 7.2.4 *)

abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c, s) \<Rightarrow> t = (c', s) \<Rightarrow> t)"

print_theorems

lemma while_if_equiv: "WHILE b DO c \<sim> IF b THEN (c;; WHILE b DO c) ELSE SKIP"
  by blast

lemma if_equiv: "IF b THEN c ELSE c \<sim> c"
  by blast

(* Lemma 7.6 *)
(* Uses advanced rule induction from section 5.4.6 *)

lemma
  assumes "(WHILE b DO c, s) \<Rightarrow> t"
  assumes "c \<sim> c'"
  shows "(WHILE b DO c', s) \<Rightarrow> t"
using assms
  apply (induct "(WHILE b DO c, s)" "t" arbitrary: s)
   apply blast
  apply blast
  done

  (* or you can do *)
lemma  while_equiv_aux: "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> c \<sim> c' \<Longrightarrow> (WHILE b DO c', s) \<Rightarrow> t"
  apply(induction "(WHILE b DO c)" s t arbitrary: b c rule: big_step_induct)
   apply blast
  apply blast
  done

(*
  I found the unification that was going on with the advance rule induction to be a bit
  mysterious. The following theorem is very close to what we get after:

  apply (induction "(WHILE b DO c, s)" t arbitrary: b c s rule: big_step.induct)
*)

thm big_step.induct[of "(WHILE b DO c, s)" "t" "\<lambda>(c,s1) s2. \<forall>b ca. c = WHILE b DO ca \<longrightarrow> ca \<sim> c' \<longrightarrow> (WHILE b DO c', s1) \<Rightarrow> s2"]

(* Peter Gammie showed me how to get exactly what you get after the induction step in the proofs
   above. Not the use of the `for` construct and the `rule_format` attribute (also known as a
   "directive")
*)

lemmas unified_big_step = big_step.induct[of "(WHILE b DO c, s)" "t"
  "\<lambda>(c,s1) s2. \<forall>b ca. c = WHILE b DO ca \<longrightarrow> ca \<sim> c' \<longrightarrow> (WHILE b DO c', s1) \<Rightarrow> s2", simplified,
    rule_format] for b c c' s t

(* We can now prove the lemma again with this new theorem *)
lemma  "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> c \<sim> c' \<Longrightarrow> (WHILE b DO c', s) \<Rightarrow> t"
  apply (erule unified_big_step)
  apply auto
  done

(* We now use Lemma 7.6 to prove the following *)
lemma while_equiv: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
  by (auto simp: while_equiv_aux)

(* Lemma 7.8 *)

lemma sim_refl: "c \<sim> c" by auto
lemma sim_sym: "c \<sim> c' \<Longrightarrow> c' \<sim> c" by auto
lemma sim_trans: "\<lbrakk> c \<sim> c'; c' \<sim> c'' \<rbrakk> \<Longrightarrow> c \<sim> c''" by auto

(* Lemma 7.9 IMP is deterministic*)
lemma imp_deterministic: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> t' \<rbrakk> \<Longrightarrow> t' = t"
  apply (induction t arbitrary: t' rule: big_step_induct)
  apply blast+
  done

(* Here is the "blackboard presentation" *)
theorem
  "\<lbrakk>(c,s) \<Rightarrow>t;  (c,s) \<Rightarrow> t' \<rbrakk> \<Longrightarrow> t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  -- "the only interesting case, WhileTrue:"
fix b c s s1 t t'
  -- "The assumptions of the rule:"
assume "bval b s" and "(c,s) \<Rightarrow> s1" and "(WHILE b DO c, s1) \<Rightarrow> t"
-- "Ind.Hyp; note the \<And> because of arbitrary:"
assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s1"
assume IHw: "\<And>t'. (WHILE b DO c, s1) \<Rightarrow> t' \<Longrightarrow> t' = t"
-- "Premise of implication:"
assume "(WHILE b DO c, s) \<Rightarrow> t'"
with `bval b s` obtain s1' where
  c: "(c,s) \<Rightarrow> s1'" and
  w: "(WHILE b DO c, s1') \<Rightarrow> t'" by auto
from c IHc have "s1' = s1" by blast
with w IHw show "t' =t" by blast
qed blast+
-- "prove the rest automatically"

end