(*  Title:       aodvmech/aodv/Loop_Freedom.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Routing graphs and loop freedom"

theory C_Loop_Freedom
imports C_Aodv_Predicates C_Fresher
begin

text \<open>Define the central theorem that relates an invariant over network states to the absence
      of loops in the associate routing graph.\<close>

definition
  rt_graph :: "(ip \<Rightarrow> state) \<Rightarrow> ip \<Rightarrow> ip rel"
where
  "rt_graph \<sigma> = (\<lambda>dip.
     {(ip, ip') | ip ip' dsn dsk hops.
        ip \<noteq> dip \<and> rt (\<sigma> ip) dip = Some (dsn, dsk, val, hops, ip')})"

text \<open>Given the state of a network @{term \<sigma>}, a routing graph for a given destination
      ip address @{term dip} abstracts the details of routing tables into nodes
      (ip addresses) and vertices (valid routes between ip addresses).\<close>

lemma rt_graphE [elim]:
    fixes n dip ip ip'
  assumes "(ip, ip') \<in> rt_graph \<sigma> dip"
    shows "ip \<noteq> dip \<and> (\<exists>r. rt (\<sigma> ip) = r
                            \<and> (\<exists>dsn dsk hops. r dip = Some (dsn, dsk, val, hops, ip')))"
  using assms unfolding rt_graph_def by auto

lemma rt_graph_vD [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> dip \<in> vD(rt (\<sigma> ip))"
  unfolding rt_graph_def vD_def by auto

lemma rt_graph_vD_trans [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+ \<Longrightarrow> dip \<in> vD(rt (\<sigma> ip))"
  by (erule converse_tranclE) auto

lemma rt_graph_not_dip [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> ip \<noteq> dip"
  unfolding rt_graph_def by auto

lemma rt_graph_not_dip_trans [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+ \<Longrightarrow> ip \<noteq> dip"
  by (erule converse_tranclE) auto

text "NB: the property below cannot be lifted to the transitive closure"

lemma rt_graph_nhip_is_nhop [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> ip' = the (nhop (rt (\<sigma> ip)) dip)"
  unfolding rt_graph_def by auto

theorem inv_to_loop_freedom:
  assumes "\<forall>i dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                   in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                      \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip))"
    shows "\<forall>dip. irrefl ((rt_graph \<sigma> dip)\<^sup>+)"
  using assms proof (intro allI)
    fix \<sigma> :: "ip \<Rightarrow> state" and dip
    assume inv: "\<forall>ip dip.
                  let nhip = the (nhop (rt (\<sigma> ip)) dip)
                  in dip \<in> vD(rt (\<sigma> ip)) \<inter> vD(rt (\<sigma> nhip)) \<and>
                     nhip \<noteq> dip \<longrightarrow> rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
    { fix ip ip'
      assume "(ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+"
         and "dip \<in> vD(rt (\<sigma> ip'))"
         and "ip' \<noteq> dip"
       hence "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> ip')"
         proof induction
           fix nhip
           assume "(ip, nhip) \<in> rt_graph \<sigma> dip"
              and "dip \<in> vD(rt (\<sigma> nhip))"
              and "nhip \<noteq> dip"
           from \<open>(ip, nhip) \<in> rt_graph \<sigma> dip\<close> have "dip \<in> vD(rt (\<sigma> ip))"
                                               and "nhip = the (nhop (rt (\<sigma> ip)) dip)"
             by auto
           from \<open>dip \<in> vD(rt (\<sigma> ip))\<close> and \<open>dip \<in> vD(rt (\<sigma> nhip))\<close>
             have "dip \<in> vD(rt (\<sigma> ip)) \<inter> vD(rt (\<sigma> nhip))" ..
           with \<open>nhip = the (nhop (rt (\<sigma> ip)) dip)\<close>
                and \<open>nhip \<noteq> dip\<close>
                and inv
             show "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
             by (clarsimp simp: Let_def)
         next
           fix nhip nhip'
           assume "(ip, nhip) \<in> (rt_graph \<sigma> dip)\<^sup>+"
              and "(nhip, nhip') \<in> rt_graph \<sigma> dip"
              and IH: "\<lbrakk> dip \<in> vD(rt (\<sigma> nhip)); nhip \<noteq> dip \<rbrakk> \<Longrightarrow> rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
              and "dip \<in> vD(rt (\<sigma> nhip'))"
              and "nhip' \<noteq> dip"
           from \<open>(nhip, nhip') \<in> rt_graph \<sigma> dip\<close> have 1: "dip \<in> vD(rt (\<sigma> nhip))"
                                                  and 2: "nhip \<noteq> dip"
                                                  and "nhip' = the (nhop (rt (\<sigma> nhip)) dip)"
             by auto
           from 1 2 have "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)" by (rule IH)
           also have "rt (\<sigma> nhip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')"
             proof -
               from \<open>dip \<in> vD(rt (\<sigma> nhip))\<close> and \<open>dip \<in> vD(rt (\<sigma> nhip'))\<close>
                 have "dip \<in> vD(rt (\<sigma> nhip)) \<inter> vD(rt (\<sigma> nhip'))" ..
               with \<open>nhip' \<noteq> dip\<close>
                    and \<open>nhip' = the (nhop (rt (\<sigma> nhip)) dip)\<close>
                    and inv
                 show "rt (\<sigma> nhip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')"
                   by (clarsimp simp: Let_def)
             qed
           finally show "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')" .
         qed } note fresher = this

    show "irrefl ((rt_graph \<sigma> dip)\<^sup>+)"
    unfolding irrefl_def proof (intro allI notI)
      fix ip
      assume "(ip, ip) \<in> (rt_graph \<sigma> dip)\<^sup>+"
      moreover then have "dip \<in> vD(rt (\<sigma> ip))"
                     and "ip \<noteq> dip"
        by auto
      ultimately have "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> ip)" by (rule fresher)
      thus False by simp
    qed
  qed

end


theory mOrd
  imports Ordinal_Model_Base
begin

context Ordinal_Model begin

lemma mordI :
  assumes i:"i : Ord"
  shows "<ord, i> : mOrd"
  unfolding mOrd_def
proof (rule intI)
  show "<ord, i> : M"
    using mI[OF i ord_tierI_eq[OF i]] .
  thus "<ord, i> :\<^enum> ord"
    using partI_pair[OF m_pair] by auto
qed

lemma mord_m :
  "i : mOrd \<Longrightarrow> i : M"
  unfolding mOrd_def by unfold_typs

lemma ord_m :
  "i : Ord \<Longrightarrow> <ord, i> : M"
  using mord_m[OF mordI] .

lemma ord_snd_eq' :
  "i : Ord \<Longrightarrow> snd <ord, i> = i"
  using mpair_snd_eq[OF ord_m] .

lemma ord_snd_eq :
  "i' : Ord \<Longrightarrow> i = <ord, i'> \<Longrightarrow> snd i = i'"
  using ord_snd_eq' by auto

lemma mordE :
  assumes i:"i : mOrd"
  obtains i' where "i' : Ord" "i = <ord, i'>"
proof -
  have "i : M" "i :\<^enum> ord"
    using i unfolding mOrd_def
    by (auto dest: intE)
  then obtain i' where i':"i = <ord, i'>"
    using partE by metis
  then obtain j x where "j : Ord"
     "i' \<in> Variants ord j x"
    using m_cases_pair \<open>i : M\<close>
      zero_ord succ_ord limit_ord
    by metis
  hence "i' : Ord" "i = <ord, i'>"
    using variants_ord_mem i' by auto
  thus ?thesis ..
qed

lemma mord_snd_ord :
  "i : mOrd \<Longrightarrow> snd i : Ord"
  using mordE ord_snd_eq by metis

lemma mordD :
  assumes "<ord, i> : mOrd"
  shows "i : Ord"
  using mord_snd_ord[OF assms]
  unfolding mpair_snd_eq[OF mord_m[OF assms]] .

lemma mord_snd_eq :
  "<ord, i'> : mOrd \<Longrightarrow> snd <ord,i'> = i'"
  using ord_snd_eq[OF mordD] by auto

lemmas mord_pair_inject =
  mpair_inject(2)[OF mord_m[OF mordI] mord_m[OF mordI]]

end
end


(*  Author:     Tobias Nipkow, 2007  *)

theory QEdlo_fr
imports DLO
begin

subsection "Interior Point Method"

text\<open>This section formalizes a new quantifier elimination procedure
based on the idea of Ferrante and Rackoff~\cite{FerranteR-SIAM75} (see
also \S\ref{sec:FRE}) of taking a point between each lower and upper
bound as a test point. For dense linear orders it is not obvious how
to realize this because we cannot name any intermediate point
directly.\<close>

fun asubst\<^sub>2 :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom fm" where
"asubst\<^sub>2 l u (Less 0 0) = FalseF" |
"asubst\<^sub>2 l u (Less 0 (Suc j)) = Or (Atom(Less u j)) (Atom(Eq u j))" |
"asubst\<^sub>2 l u (Less (Suc i) 0) = Or (Atom(Less i l)) (Atom(Eq i l))" |
"asubst\<^sub>2 l u (Less (Suc i) (Suc j)) = Atom(Less i j)" |
"asubst\<^sub>2 l u (Eq 0 0) = TrueF" |
"asubst\<^sub>2 l u (Eq 0 _) = FalseF" |
"asubst\<^sub>2 l u (Eq _ 0) = FalseF" |
"asubst\<^sub>2 l u (Eq (Suc i) (Suc j)) = Atom(Eq i j)"

abbreviation "subst\<^sub>2 l u \<equiv> amap\<^sub>f\<^sub>m (asubst\<^sub>2 l u)"

lemma I_subst\<^sub>21:
 "nqfree f \<Longrightarrow> xs!l < xs!u \<Longrightarrow> DLO.I (subst\<^sub>2 l u f) xs
 \<Longrightarrow> xs!l < x \<Longrightarrow> x < xs!u \<Longrightarrow> DLO.I f (x#xs)"
proof(induct f arbitrary: x)
  case (Atom a) thus ?case
    by (cases "(l,u,a)" rule: asubst\<^sub>2.cases) auto
qed auto

definition
"nolub f xs l x u \<longleftrightarrow> (\<forall>y\<in>{l<..<x}. y \<notin> LB f xs) \<and> (\<forall>y\<in>{x<..<u}. y \<notin> UB f xs)"

lemma nolub_And[simp]:
  "nolub (And f g) xs l x u = (nolub f xs l x u \<and> nolub g xs l x u)"
by(auto simp:nolub_def)

lemma nolub_Or[simp]:
  "nolub (Or f g) xs l x u = (nolub f xs l x u \<and> nolub g xs l x u)"
by(auto simp:nolub_def)

context notes [[simp_depth_limit=3]]
begin

lemma I_subst\<^sub>22:
 "nqfree f \<Longrightarrow> xs!l < x \<and> x < xs!u \<Longrightarrow> nolub f xs (xs!l) x (xs!u)
 \<Longrightarrow> \<forall>x\<in>{xs!l <..< xs!u}. DLO.I f (x#xs) \<and> x \<notin> EQ f xs
 \<Longrightarrow> DLO.I (subst\<^sub>2 l u f) xs"
proof (induct f)
  case (Atom a) show ?case
    apply (cases "(l,u,a)" rule: asubst\<^sub>2.cases)
    apply(insert Atom, auto simp: EQ_def nolub_def split:if_split_asm)
    done
next
  case Or thus ?case by (simp add: Ball_def)(metis innermost_intvl)
qed auto

end

definition
"qe_interior\<^sub>1 \<phi> =
(let as = DLO.atoms\<^sub>0 \<phi>; lbs = lbounds as; ubs = ubounds as; ebs = ebounds as;
     intrs = [And (Atom(Less l u)) (subst\<^sub>2 l u \<phi>). l\<leftarrow>lbs, u\<leftarrow>ubs]
 in list_disj (inf\<^sub>- \<phi> # inf\<^sub>+ \<phi> # intrs @ map (subst \<phi>) ebs))"

theorem I_interior1:
assumes "nqfree \<phi>" shows "DLO.I (qe_interior\<^sub>1 \<phi>) xs = (\<exists>x. DLO.I \<phi> (x#xs))"
  (is "?QE = ?EX")
proof
  assume ?QE
  { assume "DLO.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using \<open>?QE\<close> min_inf[of \<phi> xs] \<open>nqfree \<phi>\<close>
      by(auto simp add:qe_interior\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume  "DLO.I (inf\<^sub>+ \<phi>) xs"
    hence ?EX using \<open>?QE\<close> plus_inf[of \<phi> xs] \<open>nqfree \<phi>\<close>
      by(auto simp add:qe_interior\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume "\<not>DLO.I (inf\<^sub>- \<phi>) xs \<and> \<not>DLO.I (inf\<^sub>+ \<phi>) xs \<and>
            (\<forall>x\<in>EQ \<phi> xs. \<not>DLO.I \<phi> (x#xs))"
    with \<open>?QE\<close> \<open>nqfree \<phi>\<close> obtain l u
      where "DLO.I (subst\<^sub>2 l u \<phi>) xs" and "xs!l < xs!u"
      by(fastforce simp: qe_interior\<^sub>1_def set_lbounds set_ubounds I_subst EQ_conv_set_ebounds)
    moreover then obtain x where "xs!l < x \<and> x < xs!u" by(metis dense)
    ultimately have "DLO.I \<phi> (x # xs)"
      using \<open>nqfree \<phi>\<close> I_subst\<^sub>21[OF \<open>nqfree \<phi>\<close> \<open>xs!l < xs!u\<close>] by simp
    hence ?EX .. }
  ultimately show ?EX by blast
next
  let ?as = "DLO.atoms\<^sub>0 \<phi>" let ?E = "set(ebounds ?as)"
  assume ?EX
  then obtain x where x: "DLO.I \<phi> (x#xs)" ..
  { assume "DLO.I (inf\<^sub>- \<phi>) xs \<or> DLO.I (inf\<^sub>+ \<phi>) xs"
    hence ?QE using \<open>nqfree \<phi>\<close> by(auto simp:qe_interior\<^sub>1_def)
  } moreover
  { assume "\<exists>k \<in> ?E. DLO.I (subst \<phi> k) xs"
    hence ?QE by(force simp:qe_interior\<^sub>1_def) } moreover
  { assume "\<not> DLO.I (inf\<^sub>- \<phi>) xs" and "\<not> DLO.I (inf\<^sub>+ \<phi>) xs"
    and "\<forall>k \<in> ?E. \<not> DLO.I (subst \<phi> k) xs"
    hence noE: "\<forall>e \<in> EQ \<phi> xs. \<not> DLO.I \<phi> (e#xs)"
      using \<open>nqfree \<phi>\<close> by (force simp:set_ebounds EQ_def I_subst)
    hence "x \<notin> EQ \<phi> xs" using x by fastforce
    obtain l where "l \<in> LB \<phi> xs" "l < x"
      using LBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> DLO.I(inf\<^sub>- \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    obtain u where "u \<in> UB \<phi> xs" "x < u"
      using UBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> DLO.I(inf\<^sub>+ \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    have "\<exists>l\<in>LB \<phi> xs. \<exists>u\<in>UB \<phi> xs. l<x \<and> x<u \<and> nolub \<phi> xs l x u \<and> (\<forall>y. l < y \<and> y < u \<longrightarrow> DLO.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. DLO.I \<phi> (x#xs)", OF finite_LB finite_UB \<open>l:LB \<phi> xs\<close> \<open>u:UB \<phi> xs\<close> \<open>l<x\<close> \<open>x<u\<close> x] x innermost_intvl[OF \<open>nqfree \<phi>\<close> _ _ _ \<open>x \<notin> EQ \<phi> xs\<close>]
      by (simp add:nolub_def)
    then obtain m n where
      "Less (Suc m) 0 \<in> set ?as" "Less 0 (Suc n) \<in> set ?as"
      "xs!m < x \<and> x < xs!n"
      "nolub \<phi> xs (xs!m) x (xs!n)"
      "\<forall>y. xs!m < y \<and> y < xs!n \<longrightarrow> DLO.I \<phi> (y#xs)"
      by blast
    moreover
    hence "DLO.I (subst\<^sub>2 m n \<phi>) xs" using noE
      by(force intro!: I_subst\<^sub>22[OF \<open>nqfree \<phi>\<close>])
    ultimately have ?QE
      by(fastforce simp add:qe_interior\<^sub>1_def bex_Un set_lbounds set_ubounds)
  } ultimately show ?QE by blast
qed

lemma qfree_asubst\<^sub>2: "qfree (asubst\<^sub>2 l u a)"
by(cases "(l,u,a)" rule:asubst\<^sub>2.cases) simp_all

lemma qfree_subst\<^sub>2: "nqfree \<phi> \<Longrightarrow> qfree (subst\<^sub>2 l u \<phi>)"
by(induct \<phi>) (simp_all add:qfree_asubst\<^sub>2)

lemma qfree_interior1: "nqfree \<phi> \<Longrightarrow> qfree(qe_interior\<^sub>1 \<phi>)"
apply(simp add:qe_interior\<^sub>1_def)
apply(rule qfree_list_disj)
apply (auto simp:qfree_min_inf qfree_plus_inf qfree_subst\<^sub>2 qfree_map_fm)
done

definition "qe_interior = DLO.lift_nnf_qe qe_interior\<^sub>1"

lemma qfree_qe_interior: "qfree(qe_interior \<phi>)"
by(simp add: qe_interior_def DLO.qfree_lift_nnf_qe qfree_interior1)

end


(*  Title:      HOL/HOLCF/Cpodef.thy
    Author:     Brian Huffman
*)

section {* Subtypes of pcpos *}

theory Cpodef
imports Adm
keywords "pcpodef" "cpodef" :: thy_goal
begin

subsection {* Proving a subtype is a partial order *}

text {*
  A subtype of a partial order is itself a partial order,
  if the ordering is defined in the standard way.
*}

setup {* Sign.add_const_constraint (@{const_name Porder.below}, NONE) *}

theorem typedef_po:
  fixes Abs :: "'a::po \<Rightarrow> 'b::type"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "OFCLASS('b, po_class)"
 apply (intro_classes, unfold below)
   apply (rule below_refl)
  apply (erule (1) below_trans)
 apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
 apply (erule (1) below_antisym)
done

setup {* Sign.add_const_constraint (@{const_name Porder.below},
  SOME @{typ "'a::below \<Rightarrow> 'a::below \<Rightarrow> bool"}) *}

subsection {* Proving a subtype is finite *}

lemma typedef_finite_UNIV:
  fixes Abs :: "'a::type \<Rightarrow> 'b::type"
  assumes type: "type_definition Rep Abs A"
  shows "finite A \<Longrightarrow> finite (UNIV :: 'b set)"
proof -
  assume "finite A"
  hence "finite (Abs ` A)" by (rule finite_imageI)
  thus "finite (UNIV :: 'b set)"
    by (simp only: type_definition.Abs_image [OF type])
qed

subsection {* Proving a subtype is chain-finite *}

lemma ch2ch_Rep:
  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "chain S \<Longrightarrow> chain (\<lambda>i. Rep (S i))"
unfolding chain_def below .

theorem typedef_chfin:
  fixes Abs :: "'a::chfin \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "OFCLASS('b, chfin_class)"
 apply intro_classes
 apply (drule ch2ch_Rep [OF below])
 apply (drule chfin)
 apply (unfold max_in_chain_def)
 apply (simp add: type_definition.Rep_inject [OF type])
done

subsection {* Proving a subtype is complete *}

text {*
  A subtype of a cpo is itself a cpo if the ordering is
  defined in the standard way, and the defining subset
  is closed with respect to limits of chains.  A set is
  closed if and only if membership in the set is an
  admissible predicate.
*}

lemma typedef_is_lubI:
  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "range (\<lambda>i. Rep (S i)) <<| Rep x \<Longrightarrow> range S <<| x"
unfolding is_lub_def is_ub_def below by simp

lemma Abs_inverse_lub_Rep:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm:  "adm (\<lambda>x. x \<in> A)"
  shows "chain S \<Longrightarrow> Rep (Abs (\<Squnion>i. Rep (S i))) = (\<Squnion>i. Rep (S i))"
 apply (rule type_definition.Abs_inverse [OF type])
 apply (erule admD [OF adm ch2ch_Rep [OF below]])
 apply (rule type_definition.Rep [OF type])
done

theorem typedef_is_lub:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "chain S \<Longrightarrow> range S <<| Abs (\<Squnion>i. Rep (S i))"
proof -
  assume S: "chain S"
  hence "chain (\<lambda>i. Rep (S i))" by (rule ch2ch_Rep [OF below])
  hence "range (\<lambda>i. Rep (S i)) <<| (\<Squnion>i. Rep (S i))" by (rule cpo_lubI)
  hence "range (\<lambda>i. Rep (S i)) <<| Rep (Abs (\<Squnion>i. Rep (S i)))"
    by (simp only: Abs_inverse_lub_Rep [OF type below adm S])
  thus "range S <<| Abs (\<Squnion>i. Rep (S i))"
    by (rule typedef_is_lubI [OF below])
qed

lemmas typedef_lub = typedef_is_lub [THEN lub_eqI]

theorem typedef_cpo:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "OFCLASS('b, cpo_class)"
proof
  fix S::"nat \<Rightarrow> 'b" assume "chain S"
  hence "range S <<| Abs (\<Squnion>i. Rep (S i))"
    by (rule typedef_is_lub [OF type below adm])
  thus "\<exists>x. range S <<| x" ..
qed

subsubsection {* Continuity of \emph{Rep} and \emph{Abs} *}

text {* For any sub-cpo, the @{term Rep} function is continuous. *}

theorem typedef_cont_Rep:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "cont (\<lambda>x. f x) \<Longrightarrow> cont (\<lambda>x. Rep (f x))"
 apply (erule cont_apply [OF _ _ cont_const])
 apply (rule contI)
 apply (simp only: typedef_lub [OF type below adm])
 apply (simp only: Abs_inverse_lub_Rep [OF type below adm])
 apply (rule cpo_lubI)
 apply (erule ch2ch_Rep [OF below])
done

text {*
  For a sub-cpo, we can make the @{term Abs} function continuous
  only if we restrict its domain to the defining subset by
  composing it with another continuous function.
*}

theorem typedef_cont_Abs:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  fixes f :: "'c::cpo \<Rightarrow> 'a::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)" (* not used *)
    and f_in_A: "\<And>x. f x \<in> A"
  shows "cont f \<Longrightarrow> cont (\<lambda>x. Abs (f x))"
unfolding cont_def is_lub_def is_ub_def ball_simps below
by (simp add: type_definition.Abs_inverse [OF type f_in_A])

subsection {* Proving subtype elements are compact *}

theorem typedef_compact:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "compact (Rep k) \<Longrightarrow> compact k"
proof (unfold compact_def)
  have cont_Rep: "cont Rep"
    by (rule typedef_cont_Rep [OF type below adm cont_id])
  assume "adm (\<lambda>x. Rep k \<notsqsubseteq> x)"
  with cont_Rep have "adm (\<lambda>x. Rep k \<notsqsubseteq> Rep x)" by (rule adm_subst)
  thus "adm (\<lambda>x. k \<notsqsubseteq> x)" by (unfold below)
qed

subsection {* Proving a subtype is pointed *}

text {*
  A subtype of a cpo has a least element if and only if
  the defining subset has a least element.
*}

theorem typedef_pcpo_generic:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and z_in_A: "z \<in> A"
    and z_least: "\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x"
  shows "OFCLASS('b, pcpo_class)"
 apply (intro_classes)
 apply (rule_tac x="Abs z" in exI, rule allI)
 apply (unfold below)
 apply (subst type_definition.Abs_inverse [OF type z_in_A])
 apply (rule z_least [OF type_definition.Rep [OF type]])
done

text {*
  As a special case, a subtype of a pcpo has a least element
  if the defining subset contains @{term \<bottom>}.
*}

theorem typedef_pcpo:
  fixes Abs :: "'a::pcpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "OFCLASS('b, pcpo_class)"
by (rule typedef_pcpo_generic [OF type below bottom_in_A], rule minimal)

subsubsection {* Strictness of \emph{Rep} and \emph{Abs} *}

text {*
  For a sub-pcpo where @{term \<bottom>} is a member of the defining
  subset, @{term Rep} and @{term Abs} are both strict.
*}

theorem typedef_Abs_strict:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "Abs \<bottom> = \<bottom>"
 apply (rule bottomI, unfold below)
 apply (simp add: type_definition.Abs_inverse [OF type bottom_in_A])
done

theorem typedef_Rep_strict:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "Rep \<bottom> = \<bottom>"
 apply (rule typedef_Abs_strict [OF type below bottom_in_A, THEN subst])
 apply (rule type_definition.Abs_inverse [OF type bottom_in_A])
done

theorem typedef_Abs_bottom_iff:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "x \<in> A \<Longrightarrow> (Abs x = \<bottom>) = (x = \<bottom>)"
 apply (rule typedef_Abs_strict [OF type below bottom_in_A, THEN subst])
 apply (simp add: type_definition.Abs_inject [OF type] bottom_in_A)
done

theorem typedef_Rep_bottom_iff:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "(Rep x = \<bottom>) = (x = \<bottom>)"
 apply (rule typedef_Rep_strict [OF type below bottom_in_A, THEN subst])
 apply (simp add: type_definition.Rep_inject [OF type])
done

subsection {* Proving a subtype is flat *}

theorem typedef_flat:
  fixes Abs :: "'a::flat \<Rightarrow> 'b::pcpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "OFCLASS('b, flat_class)"
 apply (intro_classes)
 apply (unfold below)
 apply (simp add: type_definition.Rep_inject [OF type, symmetric])
 apply (simp add: typedef_Rep_strict [OF type below bottom_in_A])
 apply (simp add: ax_flat)
done

subsection {* HOLCF type definition package *}

ML_file "Tools/cpodef.ML"

end


section \<open>Data: Integers\<close>

theory Data_Integer
  imports
    Numeral_Cpo
    Data_Bool
begin

domain Integer = MkI (lazy int)

instance Integer :: flat
proof
  fix x y :: Integer
  assume "x \<sqsubseteq> y" then show "x = \<bottom> \<or> x = y"
    by (cases x; cases y) simp_all
qed

instantiation Integer :: "{plus,times,minus,uminus,zero,one}"
begin

definition "0 = MkI\<cdot>0"
definition "1 = MkI\<cdot>1"
definition "a + b = (\<Lambda> (MkI\<cdot>x) (MkI\<cdot>y). MkI\<cdot>(x + y))\<cdot>a\<cdot>b"
definition "a - b = (\<Lambda> (MkI\<cdot>x) (MkI\<cdot>y). MkI\<cdot>(x - y))\<cdot>a\<cdot>b"
definition "a * b = (\<Lambda> (MkI\<cdot>x) (MkI\<cdot>y). MkI\<cdot>(x * y))\<cdot>a\<cdot>b"
definition "- a = (\<Lambda> (MkI\<cdot>x). MkI\<cdot>(uminus x))\<cdot>a"

instance ..

end

lemma Integer_arith_strict [simp]:
  fixes x :: Integer
  shows "\<bottom> + x = \<bottom>" and "x + \<bottom> = \<bottom>"
    and "\<bottom> * x = \<bottom>" and "x * \<bottom> = \<bottom>"
    and "\<bottom> - x = \<bottom>" and "x - \<bottom> = \<bottom>"
    and "- \<bottom> = (\<bottom>::Integer)"
  unfolding plus_Integer_def times_Integer_def
  unfolding minus_Integer_def uminus_Integer_def
  by (cases x, simp, simp)+

lemma Integer_arith_simps [simp]:
  "MkI\<cdot>a + MkI\<cdot>b = MkI\<cdot>(a + b)"
  "MkI\<cdot>a * MkI\<cdot>b = MkI\<cdot>(a * b)"
  "MkI\<cdot>a - MkI\<cdot>b = MkI\<cdot>(a - b)"
  "- MkI\<cdot>a = MkI\<cdot>(uminus a)"
  unfolding plus_Integer_def times_Integer_def
  unfolding minus_Integer_def uminus_Integer_def
  by simp_all

lemma plus_MkI_MkI:
  "MkI\<cdot>x + MkI\<cdot>y = MkI\<cdot>(x + y)"
  unfolding plus_Integer_def by simp

instance Integer :: "{plus_cpo,minus_cpo,times_cpo}"
  by standard (simp_all add: flatdom_strict2cont)

instance Integer :: comm_monoid_add
proof
  fix a b c :: Integer
  show "(a + b) + c = a + (b + c)"
    by (cases a; cases b; cases c) simp_all
  show "a + b = b + a"
    by (cases a; cases b) simp_all
  show "0 + a = a"
    unfolding zero_Integer_def
    by (cases a) simp_all
qed

instance Integer :: comm_monoid_mult
proof
  fix a b c :: Integer
  show "(a * b) * c = a * (b * c)"
    by (cases a; cases b; cases c) simp_all
  show "a * b = b * a"
    by (cases a; cases b) simp_all
  show "1 * a = a"
    unfolding one_Integer_def
    by (cases a) simp_all
qed

instance Integer :: comm_semiring
proof
  fix a b c :: Integer
  show "(a + b) * c = a * c + b * c"
    by (cases a; cases b; cases c) (simp_all add: distrib_right)
qed

instance Integer :: semiring_numeral ..

lemma Integer_add_diff_cancel [simp]:
  "b \<noteq> \<bottom> \<Longrightarrow> (a::Integer) + b - b = a"
  by (cases a; cases b) simp_all

lemma zero_Integer_neq_bottom [simp]: "(0::Integer) \<noteq> \<bottom>"
  by (simp add: zero_Integer_def)

lemma one_Integer_neq_bottom [simp]: "(1::Integer) \<noteq> \<bottom>"
  by (simp add: one_Integer_def)

lemma plus_Integer_eq_bottom_iff [simp]:
  fixes x y :: Integer shows "x + y = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (cases x, simp, cases y, simp, simp)

lemma diff_Integer_eq_bottom_iff [simp]:
  fixes x y :: Integer shows "x - y = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (cases x, simp, cases y, simp, simp)

lemma mult_Integer_eq_bottom_iff [simp]:
  fixes x y :: Integer shows "x * y = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (cases x, simp, cases y, simp, simp)

lemma numeral_Integer_eq: "numeral k = MkI\<cdot>(numeral k)"
  by (induct k, simp_all only: numeral.simps one_Integer_def plus_MkI_MkI)

lemma numeral_Integer_neq_bottom [simp]: "(numeral k::Integer) \<noteq> \<bottom>"
  unfolding numeral_Integer_eq by simp

text \<open>Symmetric versions are also needed, because the reorient
  simproc does not apply to these comparisons.\<close>

lemma bottom_neq_zero_Integer [simp]: "(\<bottom>::Integer) \<noteq> 0"
  by (simp add: zero_Integer_def)

lemma bottom_neq_one_Integer [simp]: "(\<bottom>::Integer) \<noteq> 1"
  by (simp add: one_Integer_def)

lemma bottom_neq_numeral_Integer [simp]: "(\<bottom>::Integer) \<noteq> numeral k"
  unfolding numeral_Integer_eq by simp

instantiation Integer :: Ord_linear
begin

definition
  "eq = (\<Lambda> (MkI\<cdot>x) (MkI\<cdot>y). if x = y then TT else FF)"

definition
  "compare = (\<Lambda> (MkI\<cdot>x) (MkI\<cdot>y).
    if x < y then LT else if x > y then GT else EQ)"

instance proof
  fix x y z :: Integer
  show "compare\<cdot>\<bottom>\<cdot>y = \<bottom>"
    unfolding compare_Integer_def by simp
  show "compare\<cdot>x\<cdot>\<bottom> = \<bottom>"
    unfolding compare_Integer_def by (cases x, simp_all)
  show "oppOrdering\<cdot>(compare\<cdot>x\<cdot>y) = compare\<cdot>y\<cdot>x"
    unfolding compare_Integer_def
    by (cases x, cases y, simp, simp,
        cases y, simp, simp add: not_less less_imp_le)
  { assume "compare\<cdot>x\<cdot>y = EQ" then show "x = y"
      unfolding compare_Integer_def
      by (cases x, cases y, simp, simp,
          cases y, simp, simp split: if_splits) }
  { assume "compare\<cdot>x\<cdot>y = LT" and "compare\<cdot>y\<cdot>z = LT" then show "compare\<cdot>x\<cdot>z = LT"
      unfolding compare_Integer_def
      by (cases x, simp, cases y, simp, cases z, simp,
          auto split: if_splits) }
  show "eq\<cdot>x\<cdot>y = is_EQ\<cdot>(compare\<cdot>x\<cdot>y)"
    unfolding eq_Integer_def compare_Integer_def
    by (cases x, simp, cases y, simp, auto)
  show "compare\<cdot>x\<cdot>x \<sqsubseteq> EQ"
    unfolding compare_Integer_def
    by (cases x, simp_all)
qed

end

lemma compare_MkI_MkI [simp]:
  "compare\<cdot>(MkI\<cdot>x)\<cdot>(MkI\<cdot>y) = (if x < y then LT else if x > y then GT else EQ)"
  unfolding compare_Integer_def by simp

lemma lt_MkI_MkI [simp]:
  "lt\<cdot>(MkI\<cdot>x)\<cdot>(MkI\<cdot>y) = (if x < y then TT else FF)"
  unfolding lt_def by simp

lemma le_MkI_MkI [simp]:
  "le\<cdot>(MkI\<cdot>x)\<cdot>(MkI\<cdot>y) = (if x \<le> y then TT else FF)"
  unfolding le_def by simp

lemma eq_Integer_bottom_iff [simp]:
  fixes x y :: Integer shows "eq\<cdot>x\<cdot>y = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (cases x, simp, cases y, simp, simp)

lemma compare_Integer_bottom_iff [simp]:
  fixes x y :: Integer shows "compare\<cdot>x\<cdot>y = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (cases x, simp, cases y, simp, simp)

lemma lt_Integer_bottom_iff [simp]:
  fixes x y :: Integer shows "lt\<cdot>x\<cdot>y = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (cases x, simp, cases y, simp, simp)

lemma le_Integer_bottom_iff [simp]:
  fixes x y :: Integer shows "le\<cdot>x\<cdot>y = \<bottom> \<longleftrightarrow> x = \<bottom> \<or> y = \<bottom>"
  by (cases x, simp, cases y, simp, simp)

lemma compare_refl_Integer [simp]:
  "(x::Integer) \<noteq> \<bottom> \<Longrightarrow> compare\<cdot>x\<cdot>x = EQ"
  by (cases x) simp_all

lemma eq_refl_Integer [simp]:
  "(x::Integer) \<noteq> \<bottom> \<Longrightarrow> eq\<cdot>x\<cdot>x = TT"
  by (cases x) simp_all

lemma lt_refl_Integer [simp]:
  "(x::Integer) \<noteq> \<bottom> \<Longrightarrow> lt\<cdot>x\<cdot>x = FF"
  by (cases x) simp_all

lemma le_refl_Integer [simp]:
  "(x::Integer) \<noteq> \<bottom> \<Longrightarrow> le\<cdot>x\<cdot>x = TT"
  by (cases x) simp_all

lemma eq_Integer_numeral_simps [simp]:
  "eq\<cdot>(0::Integer)\<cdot>0 = TT"
  "eq\<cdot>(0::Integer)\<cdot>1 = FF"
  "eq\<cdot>(1::Integer)\<cdot>0 = FF"
  "eq\<cdot>(1::Integer)\<cdot>1 = TT"
  "eq\<cdot>(0::Integer)\<cdot>(numeral k) = FF"
  "eq\<cdot>(numeral k)\<cdot>(0::Integer) = FF"
  "k \<noteq> Num.One \<Longrightarrow> eq\<cdot>(1::Integer)\<cdot>(numeral k) = FF"
  "k \<noteq> Num.One \<Longrightarrow> eq\<cdot>(numeral k)\<cdot>(1::Integer) = FF"
  "eq\<cdot>(numeral k::Integer)\<cdot>(numeral l) = (if k = l then TT else FF)"
  unfolding zero_Integer_def one_Integer_def numeral_Integer_eq
  by simp_all

lemma compare_Integer_numeral_simps [simp]:
  "compare\<cdot>(0::Integer)\<cdot>0 = EQ"
  "compare\<cdot>(0::Integer)\<cdot>1 = LT"
  "compare\<cdot>(1::Integer)\<cdot>0 = GT"
  "compare\<cdot>(1::Integer)\<cdot>1 = EQ"
  "compare\<cdot>(0::Integer)\<cdot>(numeral k) = LT"
  "compare\<cdot>(numeral k)\<cdot>(0::Integer) = GT"
  "Num.One < k \<Longrightarrow> compare\<cdot>(1::Integer)\<cdot>(numeral k) = LT"
  "Num.One < k \<Longrightarrow> compare\<cdot>(numeral k)\<cdot>(1::Integer) = GT"
  "compare\<cdot>(numeral k::Integer)\<cdot>(numeral l) =
    (if k < l then LT else if k > l then GT else EQ)"
  unfolding zero_Integer_def one_Integer_def numeral_Integer_eq
  by simp_all

lemma lt_Integer_numeral_simps [simp]:
  "lt\<cdot>(0::Integer)\<cdot>0 = FF"
  "lt\<cdot>(0::Integer)\<cdot>1 = TT"
  "lt\<cdot>(1::Integer)\<cdot>0 = FF"
  "lt\<cdot>(1::Integer)\<cdot>1 = FF"
  "lt\<cdot>(0::Integer)\<cdot>(numeral k) = TT"
  "lt\<cdot>(numeral k)\<cdot>(0::Integer) = FF"
  "Num.One < k \<Longrightarrow> lt\<cdot>(1::Integer)\<cdot>(numeral k) = TT"
  "lt\<cdot>(numeral k)\<cdot>(1::Integer) = FF"
  "lt\<cdot>(numeral k::Integer)\<cdot>(numeral l) = (if k < l then TT else FF)"
  unfolding zero_Integer_def one_Integer_def numeral_Integer_eq
  by simp_all

lemma le_Integer_numeral_simps [simp]:
  "le\<cdot>(0::Integer)\<cdot>0 = TT"
  "le\<cdot>(0::Integer)\<cdot>1 = TT"
  "le\<cdot>(1::Integer)\<cdot>0 = FF"
  "le\<cdot>(1::Integer)\<cdot>1 = TT"
  "le\<cdot>(0::Integer)\<cdot>(numeral k) = TT"
  "le\<cdot>(numeral k)\<cdot>(0::Integer) = FF"
  "le\<cdot>(1::Integer)\<cdot>(numeral k) = TT"
  "Num.One < k \<Longrightarrow> le\<cdot>(numeral k)\<cdot>(1::Integer) = FF"
  "le\<cdot>(numeral k::Integer)\<cdot>(numeral l) = (if k \<le> l then TT else FF)"
  unfolding zero_Integer_def one_Integer_def numeral_Integer_eq
  by simp_all

lemma MkI_eq_0_iff [simp]: "MkI\<cdot>n = 0 \<longleftrightarrow> n = 0"
  unfolding zero_Integer_def by simp

lemma MkI_eq_1_iff [simp]: "MkI\<cdot>n = 1 \<longleftrightarrow> n = 1"
  unfolding one_Integer_def by simp

lemma MkI_eq_numeral_iff [simp]: "MkI\<cdot>n = numeral k \<longleftrightarrow> n = numeral k"
  unfolding numeral_Integer_eq by simp

lemma MkI_0: "MkI\<cdot>0 = 0"
  by simp

lemma MkI_1: "MkI\<cdot>1 = 1"
  by simp

lemma le_plus_1:
  fixes m :: "Integer"
  assumes "le\<cdot>m\<cdot>n = TT"
  shows "le\<cdot>m\<cdot>(n + 1) = TT"
proof -
  from assms have "n \<noteq> \<bottom>" by auto
  then have "le\<cdot>n\<cdot>(n + 1) = TT"
    by (cases n) (auto, metis le_MkI_MkI less_add_one less_le_not_le one_Integer_def plus_MkI_MkI)
  with assms show ?thesis by (auto dest: le_trans)
qed

subsection \<open>Induction rules that do not break the abstraction\<close>

lemma nonneg_Integer_induct [consumes 1, case_names 0 step]:
  fixes i :: Integer
  assumes i_nonneg: "le\<cdot>0\<cdot>i = TT"
    and zero: "P 0"
    and step: "\<And>i. le\<cdot>1\<cdot>i = TT \<Longrightarrow> P (i - 1) \<Longrightarrow> P i"
  shows "P i"
proof (cases i)
  case bottom
  then have False using i_nonneg by simp
  then show ?thesis ..
next
  case (MkI integer)
  show ?thesis
  proof (cases integer)
    case neg
    then have False using i_nonneg MkI by (auto simp add: zero_Integer_def one_Integer_def)
    then show ?thesis ..
  next
    case (nonneg nat)
    have "P (MkI\<cdot>(int nat))"
    proof(induct nat)
      case 0
      show ?case using zero by (simp add: zero_Integer_def)
    next
      case (Suc nat)
      have "le\<cdot>1\<cdot>(MkI\<cdot>(int (Suc nat))) = TT"
        by (simp add: one_Integer_def)
      moreover
      have "P (MkI\<cdot>(int (Suc nat)) - 1)"
        using Suc
        by (simp add: one_Integer_def)
      ultimately
      show ?case
        by (rule step)
    qed
    then show ?thesis using nonneg MkI by simp
  qed
qed

end


theory week06A_demo imports Main begin

-- -----------------------------------------------------------------------

-- {* a recursive data type: *}
datatype ('a,'b) tree = Tip | Node "('a,'b) tree" 'b "('a,'b) tree"

term Tip
term Node

print_theorems

-- {* distinctness of constructors automatic: *}
lemma "Tip ~= Node l x r" by simp

-- {* case syntax, case distinction manual *}
lemma "(1::nat) \<le> (case t of Tip \<Rightarrow> 1 | Node l x r \<Rightarrow> x+1)"
  apply(case_tac t)
  apply auto
  done

-- {* partial cases and dummy patterns: *}
term "case t of Node _ b _ => b"

-- {* partial case maps to 'undefined': *}
lemma "(case Tip of Node _ _ _ => 0) = undefined" by simp

-- {* nested case and default pattern: *}
term "case t of Node (Node _ _ _) x Tip => 0 | _ => 1"

-- {* inifinitely branching: *}
datatype 'a inftree = Tp | Nd 'a "nat \<Rightarrow> 'a inftree"

-- {* mutually recursive *}
datatype
  ty = Integer | Real | RefT ref
  and
  ref = Class | Array ty

-- -----------------------------------------------------------------

-- {* primitive recursion *}

primrec
  app :: "'a list => 'a list => 'a list"
where
  "app Nil ys = ys" |
  "app (Cons x xs) ys = Cons x (app xs ys)"

print_theorems

primrec
  rv :: "'a list => 'a list"
where
  "rv [] = []" |
  "rv (x#xs) = app (rv xs) [x]"

-- {* on trees *}
primrec
  mirror :: "('a,'b) tree => ('a,'b) tree"
where
  "mirror Tip = Tip" |
  "mirror (Node l x r) = Node (mirror r) x (mirror l)"

print_theorems

-- {* mutual recursion *}
primrec
  has_int :: "ty \<Rightarrow> bool" and
  has_int_ref :: "ref \<Rightarrow> bool"
where
  "has_int Integer       = True" |
  "has_int Real          = False" |
  "has_int (RefT T)      = has_int_ref T" |

  "has_int_ref Class     = False" |
  "has_int_ref (Array T) = has_int T"

-- ------------------------------------------------------------------

-- {* structural induction *}

-- {* discovering lemmas needed to prove a theorem *}

term app

lemma rv_Nil: "app xs Nil = xs"
  apply (induction xs)
   apply simp
  apply simp
  done

lemma app_assoc: "app (app xs ys) zs = app xs (app ys zs)"
  apply (induct xs)
   apply auto
  done

lemma rv_app: "rv (app xs ys) = app (rv ys) (rv xs)"
  apply (induction xs)
   apply simp
   apply (simp add:rv_Nil)
  apply simp
  apply (simp add:app_assoc)
  done

theorem rv_rv: "rv (rv xs) = xs"
  apply (induction xs)
   apply simp
  apply simp
  apply (simp add: rv_app)
  done

-- {* induction heuristics *}

primrec
  itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "itrev [] ys = ys" |
  "itrev (x#xs) ys = itrev xs (x#ys)"

lemma itrev_cons: "app (app xs (Cons a Nil)) ys = app xs (Cons a ys)"
  apply (induction xs)
   apply auto
  done

lemma itrev_app: "\<forall>ys. itrev xs ys = app (rv xs) ys"
  apply (induction xs)
   apply simp+
  apply clarsimp
  apply (simp only: itrev_cons)
  done

lemma "itrev xs [] = rv xs"
  apply (induct xs)
   apply simp+
  apply (simp add: itrev_app)
  done

lemma de_morgans_law: "\<not>(A \<or> B) \<longrightarrow> \<not>A \<and> \<not>B"
  using [[simp_trace]]
  apply (rule impI)
  apply (rule conjI)
   apply (rule classical)
   apply (erule notE)
  apply (rule disjI1)
   apply (rule classical)
   apply (erule notE)
   apply assumption
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI2)
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

-- ------------------------------------------------------------------

primrec
  lsum :: "nat list \<Rightarrow> nat"
where
  "lsum [] = 0" |
  "lsum (x#xs) = x + lsum xs"

lemma
  "2 * lsum [0 ..< Suc n] = n * (n + 1)"

  apply (induction n)
  apply simp
  apply simp
  apply ()
  oops

lemma
  "lsum (replicate n a) = n * a"
  oops

-- {* tail recursive version: *}

primrec
  lsumT :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
where
  "lsumT [] s = ?"

lemma lsum_correct:
  "lsumT xs 0 = lsum xs"
  oops

end


(*  Title:      FOL/IFOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section \<open>Intuitionistic first-order logic\<close>

theory IFOL
imports Pure
begin

ML_file "~~/src/Tools/misc_legacy.ML"
ML_file "~~/src/Provers/splitter.ML"
ML_file "~~/src/Provers/hypsubst.ML"
ML_file "~~/src/Tools/IsaPlanner/zipper.ML"
ML_file "~~/src/Tools/IsaPlanner/isand.ML"
ML_file "~~/src/Tools/IsaPlanner/rw_inst.ML"
ML_file "~~/src/Provers/quantifier1.ML"
ML_file "~~/src/Tools/intuitionistic.ML"
ML_file "~~/src/Tools/project_rule.ML"
ML_file "~~/src/Tools/atomize_elim.ML"

subsection \<open>Syntax and axiomatic basis\<close>

setup Pure_Thy.old_appl_syntax_setup

class "term"
default_sort "term"

typedecl o

judgment
  Trueprop :: "o \<Rightarrow> prop"  ("(_)" 5)

subsubsection \<open>Equality\<close>

axiomatization
  eq :: "['a, 'a] \<Rightarrow> o"  (infixl "=" 50)
where
  refl: "a = a" and
  subst: "a = b \<Longrightarrow> P(a) \<Longrightarrow> P(b)"

subsubsection \<open>Propositional logic\<close>

axiomatization
  False :: o and
  conj :: "[o, o] => o"  (infixr "\<and>" 35) and
  disj :: "[o, o] => o"  (infixr "\<or>" 30) and
  imp :: "[o, o] => o"  (infixr "\<longrightarrow>" 25)
where
  conjI: "\<lbrakk>P;  Q\<rbrakk> \<Longrightarrow> P \<and> Q" and
  conjunct1: "P \<and> Q \<Longrightarrow> P" and
  conjunct2: "P \<and> Q \<Longrightarrow> Q" and

  disjI1: "P \<Longrightarrow> P \<or> Q" and
  disjI2: "Q \<Longrightarrow> P \<or> Q" and
  disjE: "\<lbrakk>P \<or> Q; P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R" and

  impI: "(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q" and
  mp: "\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q" and

  FalseE: "False \<Longrightarrow> P"

subsubsection \<open>Quantifiers\<close>

axiomatization
  All :: "('a \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10) and
  Ex :: "('a \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
where
  allI: "(\<And>x. P(x)) \<Longrightarrow> (\<forall>x. P(x))" and
  spec: "(\<forall>x. P(x)) \<Longrightarrow> P(x)" and
  exI: "P(x) \<Longrightarrow> (\<exists>x. P(x))" and
  exE: "\<lbrakk>\<exists>x. P(x); \<And>x. P(x) \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"

subsubsection \<open>Definitions\<close>

definition "True \<equiv> False \<longrightarrow> False"

definition Not ("\<not> _" [40] 40)
  where not_def: "\<not> P \<equiv> P \<longrightarrow> False"

definition iff  (infixr "\<longleftrightarrow>" 25)
  where "P \<longleftrightarrow> Q \<equiv> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)"

definition Ex1 :: "('a \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>!" 10)
  where ex1_def: "\<exists>!x. P(x) \<equiv> \<exists>x. P(x) \<and> (\<forall>y. P(y) \<longrightarrow> y = x)"

axiomatization where  \<comment> \<open>Reflection, admissible\<close>
  eq_reflection: "(x = y) \<Longrightarrow> (x \<equiv> y)" and
  iff_reflection: "(P \<longleftrightarrow> Q) \<Longrightarrow> (P \<equiv> Q)"

abbreviation not_equal :: "['a, 'a] \<Rightarrow> o"  (infixl "\<noteq>" 50)
  where "x \<noteq> y \<equiv> \<not> (x = y)"

subsubsection \<open>Old-style ASCII syntax\<close>

notation (ASCII)
  not_equal  (infixl "~=" 50) and
  Not  ("~ _" [40] 40) and
  conj  (infixr "&" 35) and
  disj  (infixr "|" 30) and
  All  (binder "ALL " 10) and
  Ex  (binder "EX " 10) and
  Ex1  (binder "EX! " 10) and
  imp  (infixr "-->" 25) and
  iff  (infixr "<->" 25)

subsection \<open>Lemmas and proof tools\<close>

lemmas strip = impI allI

lemma TrueI: True
  unfolding True_def by (rule impI)

subsubsection \<open>Sequent-style elimination rules for \<open>\<and>\<close> \<open>\<longrightarrow>\<close> and \<open>\<forall>\<close>\<close>

lemma conjE:
  assumes major: "P \<and> Q"
    and r: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R"
  shows R
  apply (rule r)
   apply (rule major [THEN conjunct1])
  apply (rule major [THEN conjunct2])
  done

lemma impE:
  assumes major: "P \<longrightarrow> Q"
    and P
  and r: "Q \<Longrightarrow> R"
  shows R
  apply (rule r)
  apply (rule major [THEN mp])
  apply (rule \<open>P\<close>)
  done

lemma allE:
  assumes major: "\<forall>x. P(x)"
    and r: "P(x) \<Longrightarrow> R"
  shows R
  apply (rule r)
  apply (rule major [THEN spec])
  done

text \<open>Duplicates the quantifier; for use with @{ML eresolve_tac}.\<close>
lemma all_dupE:
  assumes major: "\<forall>x. P(x)"
    and r: "\<lbrakk>P(x); \<forall>x. P(x)\<rbrakk> \<Longrightarrow> R"
  shows R
  apply (rule r)
   apply (rule major [THEN spec])
  apply (rule major)
  done

subsubsection \<open>Negation rules, which translate between \<open>\<not> P\<close> and \<open>P \<longrightarrow> False\<close>\<close>

lemma notI: "(P \<Longrightarrow> False) \<Longrightarrow> \<not> P"
  unfolding not_def by (erule impI)

lemma notE: "\<lbrakk>\<not> P; P\<rbrakk> \<Longrightarrow> R"
  unfolding not_def by (erule mp [THEN FalseE])

lemma rev_notE: "\<lbrakk>P; \<not> P\<rbrakk> \<Longrightarrow> R"
  by (erule notE)

text \<open>This is useful with the special implication rules for each kind of \<open>P\<close>.\<close>
lemma not_to_imp:
  assumes "\<not> P"
    and r: "P \<longrightarrow> False \<Longrightarrow> Q"
  shows Q
  apply (rule r)
  apply (rule impI)
  apply (erule notE [OF \<open>\<not> P\<close>])
  done

text \<open>
  For substitution into an assumption \<open>P\<close>, reduce \<open>Q\<close> to \<open>P \<longrightarrow> Q\<close>, substitute into this implication, then apply \<open>impI\<close> to
  move \<open>P\<close> back into the assumptions.
\<close>
lemma rev_mp: "\<lbrakk>P; P \<longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (erule mp)

text \<open>Contrapositive of an inference rule.\<close>
lemma contrapos:
  assumes major: "\<not> Q"
    and minor: "P \<Longrightarrow> Q"
  shows "\<not> P"
  apply (rule major [THEN notE, THEN notI])
  apply (erule minor)
  done

subsubsection \<open>Modus Ponens Tactics\<close>

text \<open>
  Finds \<open>P \<longrightarrow> Q\<close> and P in the assumptions, replaces implication by
  \<open>Q\<close>.
\<close>
ML \<open>
  fun mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN assume_tac ctxt i;
  fun eq_mp_tac ctxt i =
    eresolve_tac ctxt @{thms notE impE} i THEN eq_assume_tac i;
\<close>

subsection \<open>If-and-only-if\<close>

lemma iffI: "\<lbrakk>P \<Longrightarrow> Q; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q"
  apply (unfold iff_def)
  apply (rule conjI)
   apply (erule impI)
  apply (erule impI)
  done

lemma iffE:
  assumes major: "P \<longleftrightarrow> Q"
    and r: "P \<longrightarrow> Q \<Longrightarrow> Q \<longrightarrow> P \<Longrightarrow> R"
  shows R
  apply (insert major, unfold iff_def)
  apply (erule conjE)
  apply (erule r)
  apply assumption
  done

subsubsection \<open>Destruct rules for \<open>\<longleftrightarrow>\<close> similar to Modus Ponens\<close>

lemma iffD1: "\<lbrakk>P \<longleftrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q"
  apply (unfold iff_def)
  apply (erule conjunct1 [THEN mp])
  apply assumption
  done

lemma iffD2: "\<lbrakk>P \<longleftrightarrow> Q; Q\<rbrakk> \<Longrightarrow> P"
  apply (unfold iff_def)
  apply (erule conjunct2 [THEN mp])
  apply assumption
  done

lemma rev_iffD1: "\<lbrakk>P; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  apply (erule iffD1)
  apply assumption
  done

lemma rev_iffD2: "\<lbrakk>Q; P \<longleftrightarrow> Q\<rbrakk> \<Longrightarrow> P"
  apply (erule iffD2)
  apply assumption
  done

lemma iff_refl: "P \<longleftrightarrow> P"
  by (rule iffI)

lemma iff_sym: "Q \<longleftrightarrow> P \<Longrightarrow> P \<longleftrightarrow> Q"
  apply (erule iffE)
  apply (rule iffI)
  apply (assumption | erule mp)+
  done

lemma iff_trans: "\<lbrakk>P \<longleftrightarrow> Q; Q \<longleftrightarrow> R\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> R"
  apply (rule iffI)
  apply (assumption | erule iffE | erule (1) notE impE)+
  done

subsection \<open>Unique existence\<close>

text \<open>
  NOTE THAT the following 2 quantifications:

    \<^item> \<open>\<exists>!x\<close> such that [\<open>\<exists>!y\<close> such that P(x,y)]   (sequential)
    \<^item> \<open>\<exists>!x,y\<close> such that P(x,y)                   (simultaneous)

  do NOT mean the same thing. The parser treats \<open>\<exists>!x y.P(x,y)\<close> as sequential.
\<close>

lemma ex1I: "P(a) \<Longrightarrow> (\<And>x. P(x) \<Longrightarrow> x = a) \<Longrightarrow> \<exists>!x. P(x)"
  apply (unfold ex1_def)
  apply (assumption | rule exI conjI allI impI)+
  done

text \<open>Sometimes easier to use: the premises have no shared variables. Safe!\<close>
lemma ex_ex1I: "\<exists>x. P(x) \<Longrightarrow> (\<And>x y. \<lbrakk>P(x); P(y)\<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> \<exists>!x. P(x)"
  apply (erule exE)
  apply (rule ex1I)
   apply assumption
  apply assumption
  done

lemma ex1E: "\<exists>! x. P(x) \<Longrightarrow> (\<And>x. \<lbrakk>P(x); \<forall>y. P(y) \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
  apply (unfold ex1_def)
  apply (assumption | erule exE conjE)+
  done

subsubsection \<open>\<open>\<longleftrightarrow>\<close> congruence rules for simplification\<close>

text \<open>Use \<open>iffE\<close> on a premise. For \<open>conj_cong\<close>, \<open>imp_cong\<close>, \<open>all_cong\<close>, \<open>ex_cong\<close>.\<close>
ML \<open>
  fun iff_tac ctxt prems i =
    resolve_tac ctxt (prems RL @{thms iffE}) i THEN
    REPEAT1 (eresolve_tac ctxt @{thms asm_rl mp} i);
\<close>

method_setup iff =
  \<open>Attrib.thms >>
    (fn prems => fn ctxt => SIMPLE_METHOD' (iff_tac ctxt prems))\<close>

lemma conj_cong:
  assumes "P \<longleftrightarrow> P'"
    and "P' \<Longrightarrow> Q \<longleftrightarrow> Q'"
  shows "(P \<and> Q) \<longleftrightarrow> (P' \<and> Q')"
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

text \<open>Reversed congruence rule!  Used in ZF/Order.\<close>
lemma conj_cong2:
  assumes "P \<longleftrightarrow> P'"
    and "P' \<Longrightarrow> Q \<longleftrightarrow> Q'"
  shows "(Q \<and> P) \<longleftrightarrow> (Q' \<and> P')"
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

lemma disj_cong:
  assumes "P \<longleftrightarrow> P'" and "Q \<longleftrightarrow> Q'"
  shows "(P \<or> Q) \<longleftrightarrow> (P' \<or> Q')"
  apply (insert assms)
  apply (erule iffE disjE disjI1 disjI2 |
    assumption | rule iffI | erule (1) notE impE)+
  done

lemma imp_cong:
  assumes "P \<longleftrightarrow> P'"
    and "P' \<Longrightarrow> Q \<longleftrightarrow> Q'"
  shows "(P \<longrightarrow> Q) \<longleftrightarrow> (P' \<longrightarrow> Q')"
  apply (insert assms)
  apply (assumption | rule iffI impI | erule iffE | erule (1) notE impE | iff assms)+
  done

lemma iff_cong: "\<lbrakk>P \<longleftrightarrow> P'; Q \<longleftrightarrow> Q'\<rbrakk> \<Longrightarrow> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P' \<longleftrightarrow> Q')"
  apply (erule iffE | assumption | rule iffI | erule (1) notE impE)+
  done

lemma not_cong: "P \<longleftrightarrow> P' \<Longrightarrow> \<not> P \<longleftrightarrow> \<not> P'"
  apply (assumption | rule iffI notI | erule (1) notE impE | erule iffE notE)+
  done

lemma all_cong:
  assumes "\<And>x. P(x) \<longleftrightarrow> Q(x)"
  shows "(\<forall>x. P(x)) \<longleftrightarrow> (\<forall>x. Q(x))"
  apply (assumption | rule iffI allI | erule (1) notE impE | erule allE | iff assms)+
  done

lemma ex_cong:
  assumes "\<And>x. P(x) \<longleftrightarrow> Q(x)"
  shows "(\<exists>x. P(x)) \<longleftrightarrow> (\<exists>x. Q(x))"
  apply (erule exE | assumption | rule iffI exI | erule (1) notE impE | iff assms)+
  done

lemma ex1_cong:
  assumes "\<And>x. P(x) \<longleftrightarrow> Q(x)"
  shows "(\<exists>!x. P(x)) \<longleftrightarrow> (\<exists>!x. Q(x))"
  apply (erule ex1E spec [THEN mp] | assumption | rule iffI ex1I | erule (1) notE impE | iff assms)+
  done

subsection \<open>Equality rules\<close>

lemma sym: "a = b \<Longrightarrow> b = a"
  apply (erule subst)
  apply (rule refl)
  done

lemma trans: "\<lbrakk>a = b; b = c\<rbrakk> \<Longrightarrow> a = c"
  apply (erule subst, assumption)
  done

lemma not_sym: "b \<noteq> a \<Longrightarrow> a \<noteq> b"
  apply (erule contrapos)
  apply (erule sym)
  done

text \<open>
  Two theorems for rewriting only one instance of a definition:
  the first for definitions of formulae and the second for terms.
\<close>

lemma def_imp_iff: "(A \<equiv> B) \<Longrightarrow> A \<longleftrightarrow> B"
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: "(A \<equiv> B) \<Longrightarrow> A = B"
  apply unfold
  apply (rule refl)
  done

lemma meta_eq_to_iff: "x \<equiv> y \<Longrightarrow> x \<longleftrightarrow> y"
  by unfold (rule iff_refl)

text \<open>Substitution.\<close>
lemma ssubst: "\<lbrakk>b = a; P(a)\<rbrakk> \<Longrightarrow> P(b)"
  apply (drule sym)
  apply (erule (1) subst)
  done

text \<open>A special case of \<open>ex1E\<close> that would otherwise need quantifier
  expansion.\<close>
lemma ex1_equalsE: "\<lbrakk>\<exists>!x. P(x); P(a); P(b)\<rbrakk> \<Longrightarrow> a = b"
  apply (erule ex1E)
  apply (rule trans)
   apply (rule_tac [2] sym)
   apply (assumption | erule spec [THEN mp])+
  done

subsubsection \<open>Polymorphic congruence rules\<close>

lemma subst_context: "a = b \<Longrightarrow> t(a) = t(b)"
  apply (erule ssubst)
  apply (rule refl)
  done

lemma subst_context2: "\<lbrakk>a = b; c = d\<rbrakk> \<Longrightarrow> t(a,c) = t(b,d)"
  apply (erule ssubst)+
  apply (rule refl)
  done

lemma subst_context3: "\<lbrakk>a = b; c = d; e = f\<rbrakk> \<Longrightarrow> t(a,c,e) = t(b,d,f)"
  apply (erule ssubst)+
  apply (rule refl)
  done

text \<open>
  Useful with @{ML eresolve_tac} for proving equalities from known
  equalities.

        a = b
        |   |
        c = d
\<close>
lemma box_equals: "\<lbrakk>a = b; a = c; b = d\<rbrakk> \<Longrightarrow> c = d"
  apply (rule trans)
   apply (rule trans)
    apply (rule sym)
    apply assumption+
  done

text \<open>Dual of \<open>box_equals\<close>: for proving equalities backwards.\<close>
lemma simp_equals: "\<lbrakk>a = c; b = d; c = d\<rbrakk> \<Longrightarrow> a = b"
  apply (rule trans)
   apply (rule trans)
    apply assumption+
  apply (erule sym)
  done

subsubsection \<open>Congruence rules for predicate letters\<close>

lemma pred1_cong: "a = a' \<Longrightarrow> P(a) \<longleftrightarrow> P(a')"
  apply (rule iffI)
   apply (erule (1) subst)
  apply (erule (1) ssubst)
  done

lemma pred2_cong: "\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> P(a,b) \<longleftrightarrow> P(a',b')"
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

lemma pred3_cong: "\<lbrakk>a = a'; b = b'; c = c'\<rbrakk> \<Longrightarrow> P(a,b,c) \<longleftrightarrow> P(a',b',c')"
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

text \<open>Special case for the equality predicate!\<close>
lemma eq_cong: "\<lbrakk>a = a'; b = b'\<rbrakk> \<Longrightarrow> a = b \<longleftrightarrow> a' = b'"
  apply (erule (1) pred2_cong)
  done

subsection \<open>Simplifications of assumed implications\<close>

text \<open>
  Roy Dyckhoff has proved that \<open>conj_impE\<close>, \<open>disj_impE\<close>, and
  \<open>imp_impE\<close> used with @{ML mp_tac} (restricted to atomic formulae) is
  COMPLETE for intuitionistic propositional logic.

  See R. Dyckhoff, Contraction-free sequent calculi for intuitionistic logic
  (preprint, University of St Andrews, 1991).
\<close>

lemma conj_impE:
  assumes major: "(P \<and> Q) \<longrightarrow> S"
    and r: "P \<longrightarrow> (Q \<longrightarrow> S) \<Longrightarrow> R"
  shows R
  by (assumption | rule conjI impI major [THEN mp] r)+

lemma disj_impE:
  assumes major: "(P \<or> Q) \<longrightarrow> S"
    and r: "\<lbrakk>P \<longrightarrow> S; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> R"
  shows R
  by (assumption | rule disjI1 disjI2 impI major [THEN mp] r)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since Q must be provable -- backtracking needed.\<close>
lemma imp_impE:
  assumes major: "(P \<longrightarrow> Q) \<longrightarrow> S"
    and r1: "\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q"
    and r2: "S \<Longrightarrow> R"
  shows R
  by (assumption | rule impI major [THEN mp] r1 r2)+

text \<open>Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since ~P must be provable -- backtracking needed.\<close>
lemma not_impE: "\<not> P \<longrightarrow> S \<Longrightarrow> (P \<Longrightarrow> False) \<Longrightarrow> (S \<Longrightarrow> R) \<Longrightarrow> R"
  apply (drule mp)
   apply (rule notI)
   apply assumption
  apply assumption
  done

text \<open>Simplifies the implication. UNSAFE.\<close>
lemma iff_impE:
  assumes major: "(P \<longleftrightarrow> Q) \<longrightarrow> S"
    and r1: "\<lbrakk>P; Q \<longrightarrow> S\<rbrakk> \<Longrightarrow> Q"
    and r2: "\<lbrakk>Q; P \<longrightarrow> S\<rbrakk> \<Longrightarrow> P"
    and r3: "S \<Longrightarrow> R"
  shows R
  apply (assumption | rule iffI impI major [THEN mp] r1 r2 r3)+
  done

text \<open>What if \<open>(\<forall>x. \<not> \<not> P(x)) \<longrightarrow> \<not> \<not> (\<forall>x. P(x))\<close> is an assumption?
  UNSAFE.\<close>
lemma all_impE:
  assumes major: "(\<forall>x. P(x)) \<longrightarrow> S"
    and r1: "\<And>x. P(x)"
    and r2: "S \<Longrightarrow> R"
  shows R
  apply (rule allI impI major [THEN mp] r1 r2)+
  done

text \<open>
  Unsafe: \<open>\<exists>x. P(x)) \<longrightarrow> S\<close> is equivalent
  to \<open>\<forall>x. P(x) \<longrightarrow> S\<close>.\<close>
lemma ex_impE:
  assumes major: "(\<exists>x. P(x)) \<longrightarrow> S"
    and r: "P(x) \<longrightarrow> S \<Longrightarrow> R"
  shows R
  apply (assumption | rule exI impI major [THEN mp] r)+
  done

text \<open>Courtesy of Krzysztof Grabczewski.\<close>
lemma disj_imp_disj: "P \<or> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> S) \<Longrightarrow> R \<or> S"
  apply (erule disjE)
  apply (rule disjI1) apply assumption
  apply (rule disjI2) apply assumption
  done

ML \<open>
structure Project_Rule = Project_Rule
(
  val conjunct1 = @{thm conjunct1}
  val conjunct2 = @{thm conjunct2}
  val mp = @{thm mp}
)
\<close>

ML_file "fologic.ML"

lemma thin_refl: "\<lbrakk>x = x; PROP W\<rbrakk> \<Longrightarrow> PROP W" .

ML \<open>
structure Hypsubst = Hypsubst
(
  val dest_eq = FOLogic.dest_eq
  val dest_Trueprop = FOLogic.dest_Trueprop
  val dest_imp = FOLogic.dest_imp
  val eq_reflection = @{thm eq_reflection}
  val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
  val imp_intr = @{thm impI}
  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl}
);
open Hypsubst;
\<close>

ML_file "intprover.ML"

subsection \<open>Intuitionistic Reasoning\<close>

setup \<open>Intuitionistic.method_setup @{binding iprover}\<close>

lemma impE':
  assumes 1: "P \<longrightarrow> Q"
    and 2: "Q \<Longrightarrow> R"
    and 3: "P \<longrightarrow> Q \<Longrightarrow> P"
  shows R
proof -
  from 3 and 1 have P .
  with 1 have Q by (rule impE)
  with 2 show R .
qed

lemma allE':
  assumes 1: "\<forall>x. P(x)"
    and 2: "P(x) \<Longrightarrow> \<forall>x. P(x) \<Longrightarrow> Q"
  shows Q
proof -
  from 1 have "P(x)" by (rule spec)
  from this and 1 show Q by (rule 2)
qed

lemma notE':
  assumes 1: "\<not> P"
    and 2: "\<not> P \<Longrightarrow> P"
  shows R
proof -
  from 2 and 1 have P .
  with 1 show R by (rule notE)
qed

lemmas [Pure.elim!] = disjE iffE FalseE conjE exE
  and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
  and [Pure.elim 2] = allE notE' impE'
  and [Pure.intro] = exI disjI2 disjI1

setup \<open>
  Context_Rules.addSWrapper
    (fn ctxt => fn tac => hyp_subst_tac ctxt ORELSE' tac)
\<close>

lemma iff_not_sym: "\<not> (Q \<longleftrightarrow> P) \<Longrightarrow> \<not> (P \<longleftrightarrow> Q)"
  by iprover

lemmas [sym] = sym iff_sym not_sym iff_not_sym
  and [Pure.elim?] = iffD1 iffD2 impE

lemma eq_commute: "a = b \<longleftrightarrow> b = a"
  apply (rule iffI)
  apply (erule sym)+
  done

subsection \<open>Atomizing meta-level rules\<close>

lemma atomize_all [atomize]: "(\<And>x. P(x)) \<equiv> Trueprop (\<forall>x. P(x))"
proof
  assume "\<And>x. P(x)"
  then show "\<forall>x. P(x)" ..
next
  assume "\<forall>x. P(x)"
  then show "\<And>x. P(x)" ..
qed

lemma atomize_imp [atomize]: "(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)"
proof
  assume "A \<Longrightarrow> B"
  then show "A \<longrightarrow> B" ..
next
  assume "A \<longrightarrow> B" and A
  then show B by (rule mp)
qed

lemma atomize_eq [atomize]: "(x \<equiv> y) \<equiv> Trueprop (x = y)"
proof
  assume "x \<equiv> y"
  show "x = y" unfolding \<open>x \<equiv> y\<close> by (rule refl)
next
  assume "x = y"
  then show "x \<equiv> y" by (rule eq_reflection)
qed

lemma atomize_iff [atomize]: "(A \<equiv> B) \<equiv> Trueprop (A \<longleftrightarrow> B)"
proof
  assume "A \<equiv> B"
  show "A \<longleftrightarrow> B" unfolding \<open>A \<equiv> B\<close> by (rule iff_refl)
next
  assume "A \<longleftrightarrow> B"
  then show "A \<equiv> B" by (rule iff_reflection)
qed

lemma atomize_conj [atomize]: "(A &&& B) \<equiv> Trueprop (A \<and> B)"
proof
  assume conj: "A &&& B"
  show "A \<and> B"
  proof (rule conjI)
    from conj show A by (rule conjunctionD1)
    from conj show B by (rule conjunctionD2)
  qed
next
  assume conj: "A \<and> B"
  show "A &&& B"
  proof -
    from conj show A ..
    from conj show B ..
  qed
qed

lemmas [symmetric, rulify] = atomize_all atomize_imp
  and [symmetric, defn] = atomize_all atomize_imp atomize_eq atomize_iff

subsection \<open>Atomizing elimination rules\<close>

lemma atomize_exL[atomize_elim]: "(\<And>x. P(x) \<Longrightarrow> Q) \<equiv> ((\<exists>x. P(x)) \<Longrightarrow> Q)"
  by rule iprover+

lemma atomize_conjL[atomize_elim]: "(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (A \<and> B \<Longrightarrow> C)"
  by rule iprover+

lemma atomize_disjL[atomize_elim]: "((A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C) \<equiv> ((A \<or> B \<Longrightarrow> C) \<Longrightarrow> C)"
  by rule iprover+

lemma atomize_elimL[atomize_elim]: "(\<And>B. (A \<Longrightarrow> B) \<Longrightarrow> B) \<equiv> Trueprop(A)" ..

subsection \<open>Calculational rules\<close>

lemma forw_subst: "a = b \<Longrightarrow> P(b) \<Longrightarrow> P(a)"
  by (rule ssubst)

lemma back_subst: "P(a) \<Longrightarrow> a = b \<Longrightarrow> P(b)"
  by (rule subst)

text \<open>
  Note that this list of rules is in reverse order of priorities.
\<close>

lemmas basic_trans_rules [trans] =
  forw_subst
  back_subst
  rev_mp
  mp
  trans

subsection \<open>``Let'' declarations\<close>

nonterminal letbinds and letbind

definition Let :: "['a::{}, 'a => 'b] \<Rightarrow> ('b::{})"
  where "Let(s, f) \<equiv> f(s)"

syntax
  "_bind"       :: "[pttrn, 'a] => letbind"           ("(2_ =/ _)" 10)
  ""            :: "letbind => letbinds"              ("_")
  "_binds"      :: "[letbind, letbinds] => letbinds"  ("_;/ _")
  "_Let"        :: "[letbinds, 'a] => 'a"             ("(let (_)/ in (_))" 10)

translations
  "_Let(_binds(b, bs), e)"  == "_Let(b, _Let(bs, e))"
  "let x = a in e"          == "CONST Let(a, \<lambda>x. e)"

lemma LetI:
  assumes "\<And>x. x = t \<Longrightarrow> P(u(x))"
  shows "P(let x = t in u(x))"
  apply (unfold Let_def)
  apply (rule refl [THEN assms])
  done

subsection \<open>Intuitionistic simplification rules\<close>

lemma conj_simps:
  "P \<and> True \<longleftrightarrow> P"
  "True \<and> P \<longleftrightarrow> P"
  "P \<and> False \<longleftrightarrow> False"
  "False \<and> P \<longleftrightarrow> False"
  "P \<and> P \<longleftrightarrow> P"
  "P \<and> P \<and> Q \<longleftrightarrow> P \<and> Q"
  "P \<and> \<not> P \<longleftrightarrow> False"
  "\<not> P \<and> P \<longleftrightarrow> False"
  "(P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)"
  by iprover+

lemma disj_simps:
  "P \<or> True \<longleftrightarrow> True"
  "True \<or> P \<longleftrightarrow> True"
  "P \<or> False \<longleftrightarrow> P"
  "False \<or> P \<longleftrightarrow> P"
  "P \<or> P \<longleftrightarrow> P"
  "P \<or> P \<or> Q \<longleftrightarrow> P \<or> Q"
  "(P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)"
  by iprover+

lemma not_simps:
  "\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q"
  "\<not> False \<longleftrightarrow> True"
  "\<not> True \<longleftrightarrow> False"
  by iprover+

lemma imp_simps:
  "(P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
  "(P \<longrightarrow> True) \<longleftrightarrow> True"
  "(False \<longrightarrow> P) \<longleftrightarrow> True"
  "(True \<longrightarrow> P) \<longleftrightarrow> P"
  "(P \<longrightarrow> P) \<longleftrightarrow> True"
  "(P \<longrightarrow> \<not> P) \<longleftrightarrow> \<not> P"
  by iprover+

lemma iff_simps:
  "(True \<longleftrightarrow> P) \<longleftrightarrow> P"
  "(P \<longleftrightarrow> True) \<longleftrightarrow> P"
  "(P \<longleftrightarrow> P) \<longleftrightarrow> True"
  "(False \<longleftrightarrow> P) \<longleftrightarrow> \<not> P"
  "(P \<longleftrightarrow> False) \<longleftrightarrow> \<not> P"
  by iprover+

text \<open>The \<open>x = t\<close> versions are needed for the simplification
  procedures.\<close>
lemma quant_simps:
  "\<And>P. (\<forall>x. P) \<longleftrightarrow> P"
  "(\<forall>x. x = t \<longrightarrow> P(x)) \<longleftrightarrow> P(t)"
  "(\<forall>x. t = x \<longrightarrow> P(x)) \<longleftrightarrow> P(t)"
  "\<And>P. (\<exists>x. P) \<longleftrightarrow> P"
  "\<exists>x. x = t"
  "\<exists>x. t = x"
  "(\<exists>x. x = t \<and> P(x)) \<longleftrightarrow> P(t)"
  "(\<exists>x. t = x \<and> P(x)) \<longleftrightarrow> P(t)"
  by iprover+

text \<open>These are NOT supplied by default!\<close>
lemma distrib_simps:
  "P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R"
  "(Q \<or> R) \<and> P \<longleftrightarrow> Q \<and> P \<or> R \<and> P"
  "(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)"
  by iprover+

subsubsection \<open>Conversion into rewrite rules\<close>

lemma P_iff_F: "\<not> P \<Longrightarrow> (P \<longleftrightarrow> False)"
  by iprover
lemma iff_reflection_F: "\<not> P \<Longrightarrow> (P \<equiv> False)"
  by (rule P_iff_F [THEN iff_reflection])

lemma P_iff_T: "P \<Longrightarrow> (P \<longleftrightarrow> True)"
  by iprover
lemma iff_reflection_T: "P \<Longrightarrow> (P \<equiv> True)"
  by (rule P_iff_T [THEN iff_reflection])

subsubsection \<open>More rewrite rules\<close>

lemma conj_commute: "P \<and> Q \<longleftrightarrow> Q \<and> P" by iprover
lemma conj_left_commute: "P \<and> (Q \<and> R) \<longleftrightarrow> Q \<and> (P \<and> R)" by iprover
lemmas conj_comms = conj_commute conj_left_commute

lemma disj_commute: "P \<or> Q \<longleftrightarrow> Q \<or> P" by iprover
lemma disj_left_commute: "P \<or> (Q \<or> R) \<longleftrightarrow> Q \<or> (P \<or> R)" by iprover
lemmas disj_comms = disj_commute disj_left_commute

lemma conj_disj_distribL: "P \<and> (Q \<or> R) \<longleftrightarrow> (P \<and> Q \<or> P \<and> R)" by iprover
lemma conj_disj_distribR: "(P \<or> Q) \<and> R \<longleftrightarrow> (P \<and> R \<or> Q \<and> R)" by iprover

lemma disj_conj_distribL: "P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)" by iprover
lemma disj_conj_distribR: "(P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)" by iprover

lemma imp_conj_distrib: "(P \<longrightarrow> (Q \<and> R)) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)" by iprover
lemma imp_conj: "((P \<and> Q) \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))" by iprover
lemma imp_disj: "(P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)" by iprover

lemma de_Morgan_disj: "(\<not> (P \<or> Q)) \<longleftrightarrow> (\<not> P \<and> \<not> Q)" by iprover

lemma not_ex: "(\<not> (\<exists>x. P(x))) \<longleftrightarrow> (\<forall>x. \<not> P(x))" by iprover
lemma imp_ex: "((\<exists>x. P(x)) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x) \<longrightarrow> Q)" by iprover

lemma ex_disj_distrib: "(\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> ((\<exists>x. P(x)) \<or> (\<exists>x. Q(x)))"
  by iprover

lemma all_conj_distrib: "(\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> ((\<forall>x. P(x)) \<and> (\<forall>x. Q(x)))"
  by iprover

end