theory RecursiveComplex
imports VDMToolkit
begin

section \<open>Nipkow's permutation function\<close>

definition
  pre_perm :: \<open>VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt \<Rightarrow> \<bool>\<close>
  where
  \<open>pre_perm m n r \<equiv>
      inv_VDMInt m \<and> inv_VDMInt n \<and> inv_VDMInt r \<and>
      ((0 < r \<or> 0 < n) \<longrightarrow> m+n+r > 0)\<close>

lemmas pre_perm_defs = pre_perm_def inv_VDMInt_def inv_True_def

lemma l_pre_perm_trivial[simp]: "(pre_perm m n r) = ((0 < r \<or> 0 < n) \<longrightarrow> m+n+r > 0)"
  unfolding pre_perm_def inv_VDMInt_def by simp

function (domintros)
  perm :: \<open>VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt\<close>
  where
  \<open>perm m n r =
    (if pre_perm m n r then
      (     if 0 < r then perm m (r-1) n
       else if 0 < n then perm r (n-1) m
       else m)
    else
      undefined)
  \<close>
  by (pat_completeness, auto)

definition
  perm_wf_rel :: \<open>((VDMInt \<times> VDMInt \<times> VDMInt) \<times> (VDMInt \<times> VDMInt \<times> VDMInt)) VDMSet\<close>
  where
  \<open>perm_wf_rel \<equiv>
      ({ ((m, r-1, n), (m, n, r)) | m r n . 0 < r \<and> pre_perm m n r}
      \<union>
      { ((r, n-1, m), (m, n, r)) | m r n . \<not> 0 < r \<and> 0 < n \<and> pre_perm m n r }
      )
  \<close>

lemma l_perm_wf_rel: "wf perm_wf_rel"
proof -
  text \<open>The Isabelle measure projection reflects the VDM measure: the sum of each parameter.
        ending up at zero (i.e. if negative, ignore).\<close>
  have "perm_wf_rel \<subseteq> measure (\<lambda> (m, r, n) . nat (max 0 (m+r+n)))"
    apply (intro subsetI, case_tac x)
    apply (simp add: perm_wf_rel_def case_prod_beta max_def)
    apply (elim disjE conjE, simp)
     apply (intro impI conjI, simp_all)
    text \<open>The setup with @{term perm_wf_rel} works here if the @{term pre_perm}
      specifically curbs negative sums of parameters. Yet, the termination proof fails.
      Tried various variations on gr or geq etc, no luck. Trying the @{term \<open>mlex_prod\<close>} style nest instead.\<close>
    nitpick
    done
  then show ?thesis
    by (rule wf_subset [OF wf_measure])
qed

text \<open>With the added precondition on @{term pre_perm} about case when sum has to be positive,
      and the well founded proof above, the result worked well\<close>
termination
  apply (relation \<open>perm_wf_rel\<close>)
    apply (simp add: l_perm_wf_rel)
   apply (simp_all add: perm_wf_rel_def)
  done

section \<open>Ackermann's function with @{typ VDMNat}\<close>

definition
  pre_ack :: \<open>VDMNat \<Rightarrow> VDMNat \<Rightarrow> \<bool>\<close>
  where
  \<open>pre_ack m n \<equiv> inv_VDMNat m \<and> inv_VDMNat n\<close>

lemmas pre_ack_defs = pre_ack_def inv_VDMNat_def

function (domintros)
  ack :: \<open>VDMNat \<Rightarrow> VDMNat \<Rightarrow> VDMNat\<close>
  where
  \<open>ack m n =
    (if pre_ack m n then
      (if m = 0 then
          n+1
       else
          (if n = 0 then
              ack (m-1) 1
           else
              ack (m-1) (ack m (n-1))
          )
      )
    else
      undefined
    )
  \<close>
  by (pat_completeness, auto)

termination
  apply (relation pair_less_VDMNat)
  using wf_pair_less_VDMNat apply blast
    apply (simp add: inv_VDMNat_def l_pair_less_VDMNat_I1 pre_ack_def)
   apply (simp add: inv_VDMNat_def pre_ack_def)
  by (simp add: inv_VDMNat_def pair_less_VDMNat_def pre_ack_def)

subsubsection \<open>Akermann's function with Isabelle's @{typ \<nat>}.\<close>

text \<open>This version of ackerman follows the one in the Isabelle examples. I used it to
  unpick how Sledgehammer was finding the termination proof as an attempt to try and
  mechanise the translation of such involved recursive calls. \<close>

function ack' :: "\<nat> \<Rightarrow> \<nat> \<Rightarrow> \<nat>" where
  "ack' 0 n             = Suc n"
| "ack' (Suc m) 0       = ack' m 1"
| "ack' (Suc m) (Suc n) = ack' m (ack' (Suc m) n)"
  by (pat_completeness, auto)
termination
  text \<open>Through the sledgehammer version, I unpicked the various bits and pieces needed.\<close>
(*
  using "termination" lessI pair_lessI1 pair_less_iff1 wf_pair_less by presburger
*)
  thm lessI pair_lessI1 pair_less_def pair_less_iff1 wf_pair_less
  apply (relation pair_less)
     apply (simp)
  using lessI pair_lessI1 apply presburger
  using lessI pair_less_iff1 apply presburger
  using lessI pair_lessI1 by presburger

text \<open>Show they are indeed the same function\<close>
theorem ack_correct: \<open>ack' m n = ack m n\<close>
  apply (induction m n rule: ack'.induct)
  by (simp add: pre_ack_defs)+

section \<open>Takeuchi's function (from HOL/Examples/Functions.thy)\<close>

function
  tak :: "VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt"
  where
  "tak x y z = (if x \<le> y then y else tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y))"
  by auto

lemma tak_pcorrect:
  "tak_dom (x, y, z) \<Longrightarrow> tak x y z = (if x \<le> y then y else if y \<le> z then z else x)"
  thm tak.pinduct tak.psimps
  apply (induction x y z rule: tak.pinduct)
  by (simp add: tak.psimps)

definition tak_m1 where "tak_m1 = (\<lambda>(x,y,z). if x \<le> y then 0 else 1)"
definition tak_m2 where "tak_m2 = (\<lambda>(x,y,z). nat (Max {x, y, z} - Min {x, y, z}))"
definition tak_m3 where "tak_m3 = (\<lambda>(x,y,z). nat (x - Min {x, y, z}))"

lemma "(((x1,y1,z1),(x2,y2,z2)) \<in> tak_m3 <*mlex*> {}) \<longleftrightarrow> (nat (x1 - Min {x1, y1, z1}) < nat (x2 - Min {x2, y2, z2}))"
  apply (simp add: mlex_iff)
  unfolding tak_m3_def
  (*apply (simp only: case_prod_beta fst_conv snd_conv) *)
  by simp

lemma \<open>((x1,y1,z1),(x2,y2,z2)) \<in> (tak_m2 <*mlex*> (tak_m3 <*mlex*> {}))\<close>
  apply (simp add: mlex_iff)
  unfolding tak_m3_def tak_m2_def
  apply (simp only: case_prod_beta fst_conv snd_conv, clarify)
  oops

lemma l_call1:
  \<open>x > y \<Longrightarrow> ((x-1,y,z),(x,y,z)) \<in> tak_m1 <*mlex*> (tak_m2 <*mlex*> (tak_m3 <*mlex*> {}))\<close>
  apply (simp add: mlex_iff)
  unfolding tak_m3_def tak_m2_def tak_m1_def
  apply (simp add: case_prod_beta)
  unfolding min_def max_def
  by (simp_all split:if_splits)

lemma l_call2:
  \<open>x > y \<Longrightarrow> ((y-1,z,x),(x,y,z)) \<in> tak_m1 <*mlex*> (tak_m2 <*mlex*> (tak_m3 <*mlex*> {}))\<close>
  apply (simp add: mlex_iff)
  unfolding tak_m3_def tak_m2_def tak_m1_def
  apply (simp add: case_prod_beta)
  unfolding  min_def max_def
  by simp

lemma l_call3:
  \<open>x > y \<Longrightarrow> ((z-1,x,y),(x,y,z)) \<in> tak_m1 <*mlex*> (tak_m2 <*mlex*> (tak_m3 <*mlex*> {}))\<close>
  apply (simp add: mlex_iff)
  unfolding tak_m3_def tak_m2_def tak_m1_def
  apply (simp add: case_prod_beta)
  unfolding  min_def max_def
  by simp

lemma l_call4:
  \<open>x >y \<Longrightarrow>  tak_dom (z - 1, x, y) \<Longrightarrow>
       tak_dom (y - 1, z, x) \<Longrightarrow>
       tak_dom (x - 1, y, z) \<Longrightarrow>
       ((tak (x - 1) y z, tak (y - 1) z x, tak (z - 1) x y), x, y, z)
       \<in> tak_m1 <*mlex*> tak_m2 <*mlex*> tak_m3 <*mlex*> {}\<close>
  apply (simp add: mlex_iff)
  apply (simp add: tak_pcorrect)
  unfolding tak_m3_def tak_m2_def tak_m1_def
  apply (simp add: case_prod_beta)
  unfolding  min_def max_def
  by simp

termination
  apply (relation "tak_m1 <*mlex*> tak_m2 <*mlex*> tak_m3 <*mlex*> {}")
      apply (simp add: wf_mlex)
     apply (simp add: l_call1)
     apply (simp add: l_call2)
     apply (simp add: l_call3)
  by (simp add: l_call4)
(*
     apply (auto simp: mlex_iff wf_mlex tak_pcorrect tak_m1_def tak_m2_def tak_m3_def min_def max_def)
*)

theorem tak_correct: "tak x y z = (if x \<le> y then y else if y \<le> z then z else x)"
  by (induction x y z rule: tak.induct) auto

end


(*  Title:      RSAPSS/Mod.thy

    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

header "Leammata for modular arithmetic"

theory Mod
imports Main
begin

lemma divmultassoc: "a div (b*c) * (b*c) = ((a div (b * c)) * b)*(c::nat)"
  by (rule mult.assoc [symmetric])

lemma delmod: "(a::nat) mod (b*c) mod c = a mod c"
  by (rule mod_mod_cancel [OF dvd_triv_right])

lemma timesmod1: "((x::nat)*((y::nat) mod n)) mod (n::nat) = ((x*y) mod n)"
  by (rule mod_mult_right_eq [symmetric])

lemma timesmod3: "((a mod (n::nat)) * b) mod n = (a*b) mod n"
  by (rule mod_mult_left_eq [symmetric])

lemma remainderexplemma: "(y mod (a::nat) = z mod a) \<Longrightarrow> (x*y) mod a = (x*z) mod a"
  by (rule mod_mult_cong [OF refl])

lemma remainderexp: "((a mod (n::nat))^i) mod n = (a^i) mod n"
  by (rule power_mod)

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_33
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

definition(*fun*) one :: "Nat" where
  "one = S Z"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = Z"
| "t22 (S z) y = t2 y (t22 z y)"

fun fac :: "Nat => Nat" where
  "fac (Z) = S Z"
| "fac (S y) = t22 (S y) (fac y)"

fun qfac :: "Nat => Nat => Nat" where
  "qfac (Z) y = y"
| "qfac (S z) y = qfac z (t22 (S z) y)"

theorem property0 :
  "((fac x) = (qfac x one))"
  oops

end


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

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

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

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

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function msorttd :: "int list => int list" where
  "msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = (op div) (length (cons2 y (cons2 x2 x3))) 2
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msorttd xs) xs"
  oops

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_44
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

fun intersect :: "Nat list => Nat list => Nat list" where
  "intersect (nil2) y2 = nil2"
| "intersect (cons2 z2 xs) y2 =
     (if elem z2 y2 then cons2 z2 (intersect xs y2) else
        intersect xs y2)"

theorem property0 :
  "((elem z y2) ==> ((elem z z2) ==> (elem z (intersect y2 z2))))"
  oops

end


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

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

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "int => int" where
  "nmsorttdhalf1 x =
   (if (x = 1) then 0 else
      (if (x = 0) then 0 else 1 + (nmsorttdhalf1 (x - 2))))"
  by pat_completeness auto

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function nmsorttd :: "int list => int list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun count :: "'a => 'a list => int" where
  "count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((count x (nmsorttd xs)) = (count x xs))"
  oops

end


(*  Title:      ZF/OrderType.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Order Types and Ordinal Arithmetic\<close>

theory OrderType imports OrderArith OrdQuant Nat begin

text\<open>The order type of a well-ordering is the least ordinal isomorphic to it.
Ordinal arithmetic is traditionally defined in terms of order types, as it is
here.  But a definition by transfinite recursion would be much simpler!\<close>

definition
  ordermap  :: "[i,i]\<Rightarrow>i"  where
   "ordermap(A,r) \<equiv> \<lambda>x\<in>A. wfrec[A](r, x, \<lambda>x f. f `` pred(A,x,r))"

definition
  ordertype :: "[i,i]\<Rightarrow>i"  where
   "ordertype(A,r) \<equiv> ordermap(A,r)``A"

definition
  (*alternative definition of ordinal numbers*)
  Ord_alt   :: "i \<Rightarrow> o"  where
   "Ord_alt(X) \<equiv> well_ord(X, Memrel(X)) \<and> (\<forall>u\<in>X. u=pred(X, u, Memrel(X)))"

definition
  (*coercion to ordinal: if not, just 0*)
  ordify    :: "i\<Rightarrow>i"  where
    "ordify(x) \<equiv> if Ord(x) then x else 0"

definition
  (*ordinal multiplication*)
  omult      :: "[i,i]\<Rightarrow>i"           (infixl \<open>**\<close> 70)  where
   "i ** j \<equiv> ordertype(j*i, rmult(j,Memrel(j),i,Memrel(i)))"

definition
  (*ordinal addition*)
  raw_oadd   :: "[i,i]\<Rightarrow>i"  where
    "raw_oadd(i,j) \<equiv> ordertype(i+j, radd(i,Memrel(i),j,Memrel(j)))"

definition
  oadd      :: "[i,i]\<Rightarrow>i"           (infixl \<open>++\<close> 65)  where
    "i ++ j \<equiv> raw_oadd(ordify(i),ordify(j))"

definition
  (*ordinal subtraction*)
  odiff      :: "[i,i]\<Rightarrow>i"           (infixl \<open>--\<close> 65)  where
    "i -- j \<equiv> ordertype(i-j, Memrel(i))"

subsection\<open>Proofs needing the combination of Ordinal.thy and Order.thy\<close>

lemma le_well_ord_Memrel: "j \<le> i \<Longrightarrow> well_ord(j, Memrel(i))"
apply (rule well_ordI)
apply (rule wf_Memrel [THEN wf_imp_wf_on])
apply (simp add: ltD lt_Ord linear_def
                 ltI [THEN lt_trans2 [of _ j i]])
apply (intro ballI Ord_linear)
apply (blast intro: Ord_in_Ord lt_Ord)+
done

(*"Ord(i) \<Longrightarrow> well_ord(i, Memrel(i))"*)
lemmas well_ord_Memrel = le_refl [THEN le_well_ord_Memrel]

(*Kunen's Theorem 7.3 (i), page 16;  see also Ordinal/Ord_in_Ord
  The smaller ordinal is an initial segment of the larger *)
lemma lt_pred_Memrel:
    "j<i \<Longrightarrow> pred(i, j, Memrel(i)) = j"
apply (simp add: pred_def lt_def)
apply (blast intro: Ord_trans)
done

lemma pred_Memrel:
      "x \<in> A \<Longrightarrow> pred(A, x, Memrel(A)) = A \<inter> x"
by (unfold pred_def Memrel_def, blast)

lemma Ord_iso_implies_eq_lemma:
     "\<lbrakk>j<i;  f \<in> ord_iso(i,Memrel(i),j,Memrel(j))\<rbrakk> \<Longrightarrow> R"
apply (frule lt_pred_Memrel)
apply (erule ltE)
apply (rule well_ord_Memrel [THEN well_ord_iso_predE, of i f j], auto)
  unfolding ord_iso_def
(*Combining the two simplifications causes looping*)
apply (simp (no_asm_simp))
apply (blast intro: bij_is_fun [THEN apply_type] Ord_trans)
done

(*Kunen's Theorem 7.3 (ii), page 16.  Isomorphic ordinals are equal*)
lemma Ord_iso_implies_eq:
     "\<lbrakk>Ord(i);  Ord(j);  f \<in> ord_iso(i,Memrel(i),j,Memrel(j))\<rbrakk>
      \<Longrightarrow> i=j"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: ord_iso_sym Ord_iso_implies_eq_lemma)+
done

subsection\<open>Ordermap and ordertype\<close>

lemma ordermap_type:
    "ordermap(A,r) \<in> A -> ordertype(A,r)"
  unfolding ordermap_def ordertype_def
apply (rule lam_type)
apply (rule lamI [THEN imageI], assumption+)
done

subsubsection\<open>Unfolding of ordermap\<close>

(*Useful for cardinality reasoning; see CardinalArith.ML*)
lemma ordermap_eq_image:
    "\<lbrakk>wf[A](r);  x \<in> A\<rbrakk>
     \<Longrightarrow> ordermap(A,r) ` x = ordermap(A,r) `` pred(A,x,r)"
  unfolding ordermap_def pred_def
apply (simp (no_asm_simp))
apply (erule wfrec_on [THEN trans], assumption)
apply (simp (no_asm_simp) add: subset_iff image_lam vimage_singleton_iff)
done

(*Useful for rewriting PROVIDED pred is not unfolded until later!*)
lemma ordermap_pred_unfold:
     "\<lbrakk>wf[A](r);  x \<in> A\<rbrakk>
      \<Longrightarrow> ordermap(A,r) ` x = {ordermap(A,r)`y . y \<in> pred(A,x,r)}"
by (simp add: ordermap_eq_image pred_subset ordermap_type [THEN image_fun])

(*pred-unfolded version.  NOT suitable for rewriting -- loops!*)
lemmas ordermap_unfold = ordermap_pred_unfold [simplified pred_def]

(*The theorem above is

\<lbrakk>wf[A](r); x \<in> A\<rbrakk>
\<Longrightarrow> ordermap(A,r) ` x = {ordermap(A,r) ` y . y: {y \<in> A . \<langle>y,x\<rangle> \<in> r}}

NOTE: the definition of ordermap used here delivers ordinals only if r is
transitive.  If r is the predecessor relation on the naturals then
ordermap(nat,predr) ` n equals {n-1} and not n.  A more complicated definition,
like

  ordermap(A,r) ` x = Union{succ(ordermap(A,r) ` y) . y: {y \<in> A . \<langle>y,x\<rangle> \<in> r}},

might eliminate the need for r to be transitive.
*)

subsubsection\<open>Showing that ordermap, ordertype yield ordinals\<close>

lemma Ord_ordermap:
    "\<lbrakk>well_ord(A,r);  x \<in> A\<rbrakk> \<Longrightarrow> Ord(ordermap(A,r) ` x)"
apply (unfold well_ord_def tot_ord_def part_ord_def, safe)
apply (rule_tac a=x in wf_on_induct, assumption+)
apply (simp (no_asm_simp) add: ordermap_pred_unfold)
apply (rule OrdI [OF _ Ord_is_Transset])
  unfolding pred_def Transset_def
apply (blast intro: trans_onD
             dest!: ordermap_unfold [THEN equalityD1])+
done

lemma Ord_ordertype:
    "well_ord(A,r) \<Longrightarrow> Ord(ordertype(A,r))"
  unfolding ordertype_def
apply (subst image_fun [OF ordermap_type subset_refl])
apply (rule OrdI [OF _ Ord_is_Transset])
prefer 2 apply (blast intro: Ord_ordermap)
  unfolding Transset_def well_ord_def
apply (blast intro: trans_onD
             dest!: ordermap_unfold [THEN equalityD1])
done

subsubsection\<open>ordermap preserves the orderings in both directions\<close>

lemma ordermap_mono:
     "\<lbrakk>\<langle>w,x\<rangle>: r;  wf[A](r);  w \<in> A; x \<in> A\<rbrakk>
      \<Longrightarrow> ordermap(A,r)`w \<in> ordermap(A,r)`x"
apply (erule_tac x1 = x in ordermap_unfold [THEN ssubst], assumption, blast)
done

(*linearity of r is crucial here*)
lemma converse_ordermap_mono:
    "\<lbrakk>ordermap(A,r)`w \<in> ordermap(A,r)`x;  well_ord(A,r); w \<in> A; x \<in> A\<rbrakk>
     \<Longrightarrow> \<langle>w,x\<rangle>: r"
apply (unfold well_ord_def tot_ord_def, safe)
apply (erule_tac x=w and y=x in linearE, assumption+)
apply (blast elim!: mem_not_refl [THEN notE])
apply (blast dest: ordermap_mono intro: mem_asym)
done

lemma ordermap_surj: "ordermap(A, r) \<in> surj(A, ordertype(A, r))"
  unfolding ordertype_def
  by (rule surj_image) (rule ordermap_type)

lemma ordermap_bij:
    "well_ord(A,r) \<Longrightarrow> ordermap(A,r) \<in> bij(A, ordertype(A,r))"
  unfolding well_ord_def tot_ord_def bij_def inj_def
apply (force intro!: ordermap_type ordermap_surj
             elim: linearE dest: ordermap_mono
             simp add: mem_not_refl)
done

subsubsection\<open>Isomorphisms involving ordertype\<close>

lemma ordertype_ord_iso:
 "well_ord(A,r)
  \<Longrightarrow> ordermap(A,r) \<in> ord_iso(A,r, ordertype(A,r), Memrel(ordertype(A,r)))"
  unfolding ord_iso_def
apply (safe elim!: well_ord_is_wf
            intro!: ordermap_type [THEN apply_type] ordermap_mono ordermap_bij)
apply (blast dest!: converse_ordermap_mono)
done

lemma ordertype_eq:
     "\<lbrakk>f \<in> ord_iso(A,r,B,s);  well_ord(B,s)\<rbrakk>
      \<Longrightarrow> ordertype(A,r) = ordertype(B,s)"
apply (frule well_ord_ord_iso, assumption)
apply (rule Ord_iso_implies_eq, (erule Ord_ordertype)+)
apply (blast intro: ord_iso_trans ord_iso_sym ordertype_ord_iso)
done

lemma ordertype_eq_imp_ord_iso:
     "\<lbrakk>ordertype(A,r) = ordertype(B,s); well_ord(A,r);  well_ord(B,s)\<rbrakk>
      \<Longrightarrow> \<exists>f. f \<in> ord_iso(A,r,B,s)"
apply (rule exI)
apply (rule ordertype_ord_iso [THEN ord_iso_trans], assumption)
apply (erule ssubst)
apply (erule ordertype_ord_iso [THEN ord_iso_sym])
done

subsubsection\<open>Basic equalities for ordertype\<close>

(*Ordertype of Memrel*)
lemma le_ordertype_Memrel: "j \<le> i \<Longrightarrow> ordertype(j,Memrel(i)) = j"
apply (rule Ord_iso_implies_eq [symmetric])
apply (erule ltE, assumption)
apply (blast intro: le_well_ord_Memrel Ord_ordertype)
apply (rule ord_iso_trans)
apply (erule_tac [2] le_well_ord_Memrel [THEN ordertype_ord_iso])
apply (rule id_bij [THEN ord_isoI])
apply (simp (no_asm_simp))
apply (fast elim: ltE Ord_in_Ord Ord_trans)
done

(*"Ord(i) \<Longrightarrow> ordertype(i, Memrel(i)) = i"*)
lemmas ordertype_Memrel = le_refl [THEN le_ordertype_Memrel]

lemma ordertype_0 [simp]: "ordertype(0,r) = 0"
apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq, THEN trans])
apply (erule emptyE)
apply (rule well_ord_0)
apply (rule Ord_0 [THEN ordertype_Memrel])
done

(*Ordertype of rvimage:  \<lbrakk>f \<in> bij(A,B);  well_ord(B,s)\<rbrakk> \<Longrightarrow>
                         ordertype(A, rvimage(A,f,s)) = ordertype(B,s) *)
lemmas bij_ordertype_vimage = ord_iso_rvimage [THEN ordertype_eq]

subsubsection\<open>A fundamental unfolding law for ordertype.\<close>

(*Ordermap returns the same result if applied to an initial segment*)
lemma ordermap_pred_eq_ordermap:
     "\<lbrakk>well_ord(A,r);  y \<in> A;  z \<in> pred(A,y,r)\<rbrakk>
      \<Longrightarrow> ordermap(pred(A,y,r), r) ` z = ordermap(A, r) ` z"
apply (frule wf_on_subset_A [OF well_ord_is_wf pred_subset])
apply (rule_tac a=z in wf_on_induct, assumption+)
apply (safe elim!: predE)
apply (simp (no_asm_simp) add: ordermap_pred_unfold well_ord_is_wf pred_iff)
(*combining these two simplifications LOOPS! *)
apply (simp (no_asm_simp) add: pred_pred_eq)
apply (simp add: pred_def)
apply (rule RepFun_cong [OF _ refl])
apply (drule well_ord_is_trans_on)
apply (fast elim!: trans_onD)
done

lemma ordertype_unfold:
    "ordertype(A,r) = {ordermap(A,r)`y . y \<in> A}"
  unfolding ordertype_def
apply (rule image_fun [OF ordermap_type subset_refl])
done

text\<open>Theorems by Krzysztof Grabczewski; proofs simplified by lcp\<close>

lemma ordertype_pred_subset: "\<lbrakk>well_ord(A,r);  x \<in> A\<rbrakk> \<Longrightarrow>
          ordertype(pred(A,x,r),r) \<subseteq> ordertype(A,r)"
apply (simp add: ordertype_unfold well_ord_subset [OF _ pred_subset])
apply (fast intro: ordermap_pred_eq_ordermap elim: predE)
done

lemma ordertype_pred_lt:
     "\<lbrakk>well_ord(A,r);  x \<in> A\<rbrakk>
      \<Longrightarrow> ordertype(pred(A,x,r),r) < ordertype(A,r)"
apply (rule ordertype_pred_subset [THEN subset_imp_le, THEN leE])
apply (simp_all add: Ord_ordertype well_ord_subset [OF _ pred_subset])
apply (erule sym [THEN ordertype_eq_imp_ord_iso, THEN exE])
apply (erule_tac [3] well_ord_iso_predE)
apply (simp_all add: well_ord_subset [OF _ pred_subset])
done

(*May rewrite with this -- provided no rules are supplied for proving that
        well_ord(pred(A,x,r), r) *)
lemma ordertype_pred_unfold:
     "well_ord(A,r)
      \<Longrightarrow> ordertype(A,r) = {ordertype(pred(A,x,r),r). x \<in> A}"
apply (rule equalityI)
apply (safe intro!: ordertype_pred_lt [THEN ltD])
apply (auto simp add: ordertype_def well_ord_is_wf [THEN ordermap_eq_image]
                      ordermap_type [THEN image_fun]
                      ordermap_pred_eq_ordermap pred_subset)
done

subsection\<open>Alternative definition of ordinal\<close>

(*proof by Krzysztof Grabczewski*)
lemma Ord_is_Ord_alt: "Ord(i) \<Longrightarrow> Ord_alt(i)"
  unfolding Ord_alt_def
apply (rule conjI)
apply (erule well_ord_Memrel)
apply (unfold Ord_def Transset_def pred_def Memrel_def, blast)
done

(*proof by lcp*)
lemma Ord_alt_is_Ord:
    "Ord_alt(i) \<Longrightarrow> Ord(i)"
apply (unfold Ord_alt_def Ord_def Transset_def well_ord_def
                     tot_ord_def part_ord_def trans_on_def)
apply (simp add: pred_Memrel)
apply (blast elim!: equalityE)
done

subsection\<open>Ordinal Addition\<close>

subsubsection\<open>Order Type calculations for radd\<close>

text\<open>Addition with 0\<close>

lemma bij_sum_0: "(\<lambda>z\<in>A+0. case(\<lambda>x. x, \<lambda>y. y, z)) \<in> bij(A+0, A)"
apply (rule_tac d = Inl in lam_bijective, safe)
apply (simp_all (no_asm_simp))
done

lemma ordertype_sum_0_eq:
     "well_ord(A,r) \<Longrightarrow> ordertype(A+0, radd(A,r,0,s)) = ordertype(A,r)"
apply (rule bij_sum_0 [THEN ord_isoI, THEN ordertype_eq])
prefer 2 apply assumption
apply force
done

lemma bij_0_sum: "(\<lambda>z\<in>0+A. case(\<lambda>x. x, \<lambda>y. y, z)) \<in> bij(0+A, A)"
apply (rule_tac d = Inr in lam_bijective, safe)
apply (simp_all (no_asm_simp))
done

lemma ordertype_0_sum_eq:
     "well_ord(A,r) \<Longrightarrow> ordertype(0+A, radd(0,s,A,r)) = ordertype(A,r)"
apply (rule bij_0_sum [THEN ord_isoI, THEN ordertype_eq])
prefer 2 apply assumption
apply force
done

text\<open>Initial segments of radd.  Statements by Grabczewski\<close>

(*In fact, pred(A+B, Inl(a), radd(A,r,B,s)) = pred(A,a,r)+0 *)
lemma pred_Inl_bij:
 "a \<in> A \<Longrightarrow> (\<lambda>x\<in>pred(A,a,r). Inl(x))
          \<in> bij(pred(A,a,r), pred(A+B, Inl(a), radd(A,r,B,s)))"
  unfolding pred_def
apply (rule_tac d = "case (\<lambda>x. x, \<lambda>y. y) " in lam_bijective)
apply auto
done

lemma ordertype_pred_Inl_eq:
     "\<lbrakk>a \<in> A;  well_ord(A,r)\<rbrakk>
      \<Longrightarrow> ordertype(pred(A+B, Inl(a), radd(A,r,B,s)), radd(A,r,B,s)) =
          ordertype(pred(A,a,r), r)"
apply (rule pred_Inl_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
apply (simp_all add: well_ord_subset [OF _ pred_subset])
apply (simp add: pred_def)
done

lemma pred_Inr_bij:
 "b \<in> B \<Longrightarrow>
         id(A+pred(B,b,s))
         \<in> bij(A+pred(B,b,s), pred(A+B, Inr(b), radd(A,r,B,s)))"
  unfolding pred_def id_def
apply (rule_tac d = "\<lambda>z. z" in lam_bijective, auto)
done

lemma ordertype_pred_Inr_eq:
     "\<lbrakk>b \<in> B;  well_ord(A,r);  well_ord(B,s)\<rbrakk>
      \<Longrightarrow> ordertype(pred(A+B, Inr(b), radd(A,r,B,s)), radd(A,r,B,s)) =
          ordertype(A+pred(B,b,s), radd(A,r,pred(B,b,s),s))"
apply (rule pred_Inr_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
prefer 2 apply (force simp add: pred_def id_def, assumption)
apply (blast intro: well_ord_radd well_ord_subset [OF _ pred_subset])
done

subsubsection\<open>ordify: trivial coercion to an ordinal\<close>

lemma Ord_ordify [iff, TC]: "Ord(ordify(x))"
by (simp add: ordify_def)

(*Collapsing*)
lemma ordify_idem [simp]: "ordify(ordify(x)) = ordify(x)"
by (simp add: ordify_def)

subsubsection\<open>Basic laws for ordinal addition\<close>

lemma Ord_raw_oadd: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> Ord(raw_oadd(i,j))"
by (simp add: raw_oadd_def ordify_def Ord_ordertype well_ord_radd
              well_ord_Memrel)

lemma Ord_oadd [iff,TC]: "Ord(i++j)"
by (simp add: oadd_def Ord_raw_oadd)

text\<open>Ordinal addition with zero\<close>

lemma raw_oadd_0: "Ord(i) \<Longrightarrow> raw_oadd(i,0) = i"
by (simp add: raw_oadd_def ordify_def ordertype_sum_0_eq
              ordertype_Memrel well_ord_Memrel)

lemma oadd_0 [simp]: "Ord(i) \<Longrightarrow> i++0 = i"
apply (simp (no_asm_simp) add: oadd_def raw_oadd_0 ordify_def)
done

lemma raw_oadd_0_left: "Ord(i) \<Longrightarrow> raw_oadd(0,i) = i"
by (simp add: raw_oadd_def ordify_def ordertype_0_sum_eq ordertype_Memrel
              well_ord_Memrel)

lemma oadd_0_left [simp]: "Ord(i) \<Longrightarrow> 0++i = i"
by (simp add: oadd_def raw_oadd_0_left ordify_def)

lemma oadd_eq_if_raw_oadd:
     "i++j = (if Ord(i) then (if Ord(j) then raw_oadd(i,j) else i)
              else (if Ord(j) then j else 0))"
by (simp add: oadd_def ordify_def raw_oadd_0_left raw_oadd_0)

lemma raw_oadd_eq_oadd: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> raw_oadd(i,j) = i++j"
by (simp add: oadd_def ordify_def)

(*** Further properties of ordinal addition.  Statements by Grabczewski,
    proofs by lcp. ***)

(*Surely also provable by transfinite induction on j?*)
lemma lt_oadd1: "k<i \<Longrightarrow> k < i++j"
apply (simp add: oadd_def ordify_def lt_Ord2 raw_oadd_0, clarify)
apply (simp add: raw_oadd_def)
apply (rule ltE, assumption)
apply (rule ltI)
apply (force simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel
          ordertype_pred_Inl_eq lt_pred_Memrel leI [THEN le_ordertype_Memrel])
apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)
done

(*Thus also we obtain the rule  @{term"i++j = k \<Longrightarrow> i \<le> k"} *)
lemma oadd_le_self: "Ord(i) \<Longrightarrow> i \<le> i++j"
apply (rule all_lt_imp_le)
apply (auto simp add: Ord_oadd lt_oadd1)
done

text\<open>Various other results\<close>

lemma id_ord_iso_Memrel: "A<=B \<Longrightarrow> id(A) \<in> ord_iso(A, Memrel(A), A, Memrel(B))"
apply (rule id_bij [THEN ord_isoI])
apply (simp (no_asm_simp))
apply blast
done

lemma subset_ord_iso_Memrel:
     "\<lbrakk>f \<in> ord_iso(A,Memrel(B),C,r); A<=B\<rbrakk> \<Longrightarrow> f \<in> ord_iso(A,Memrel(A),C,r)"
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN fun_is_rel])
apply (frule ord_iso_trans [OF id_ord_iso_Memrel], assumption)
apply (simp add: right_comp_id)
done

lemma restrict_ord_iso:
     "\<lbrakk>f \<in> ord_iso(i, Memrel(i), Order.pred(A,a,r), r);  a \<in> A; j < i;
       trans[A](r)\<rbrakk>
      \<Longrightarrow> restrict(f,j) \<in> ord_iso(j, Memrel(j), Order.pred(A,f`j,r), r)"
apply (frule ltD)
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
apply (frule ord_iso_restrict_pred, assumption)
apply (simp add: pred_iff trans_pred_pred_eq lt_pred_Memrel)
apply (blast intro!: subset_ord_iso_Memrel le_imp_subset [OF leI])
done

lemma restrict_ord_iso2:
     "\<lbrakk>f \<in> ord_iso(Order.pred(A,a,r), r, i, Memrel(i));  a \<in> A;
       j < i; trans[A](r)\<rbrakk>
      \<Longrightarrow> converse(restrict(converse(f), j))
          \<in> ord_iso(Order.pred(A, converse(f)`j, r), r, j, Memrel(j))"
by (blast intro: restrict_ord_iso ord_iso_sym ltI)

lemma ordertype_sum_Memrel:
     "\<lbrakk>well_ord(A,r);  k<j\<rbrakk>
      \<Longrightarrow> ordertype(A+k, radd(A, r, k, Memrel(j))) =
          ordertype(A+k, radd(A, r, k, Memrel(k)))"
apply (erule ltE)
apply (rule ord_iso_refl [THEN sum_ord_iso_cong, THEN ordertype_eq])
apply (erule OrdmemD [THEN id_ord_iso_Memrel, THEN ord_iso_sym])
apply (simp_all add: well_ord_radd well_ord_Memrel)
done

lemma oadd_lt_mono2: "k<j \<Longrightarrow> i++k < i++j"
apply (simp add: oadd_def ordify_def raw_oadd_0_left lt_Ord lt_Ord2, clarify)
apply (simp add: raw_oadd_def)
apply (rule ltE, assumption)
apply (rule ordertype_pred_unfold [THEN equalityD2, THEN subsetD, THEN ltI])
apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
apply (rule bexI)
apply (erule_tac [2] InrI)
apply (simp add: ordertype_pred_Inr_eq well_ord_Memrel lt_pred_Memrel
                 leI [THEN le_ordertype_Memrel] ordertype_sum_Memrel)
done

lemma oadd_lt_cancel2: "\<lbrakk>i++j < i++k;  Ord(j)\<rbrakk> \<Longrightarrow> j<k"
apply (simp (asm_lr) add: oadd_eq_if_raw_oadd split: split_if_asm)
 prefer 2
 apply (frule_tac i = i and j = j in oadd_le_self)
 apply (simp (asm_lr) add: oadd_def ordify_def lt_Ord not_lt_iff_le [THEN iff_sym])
apply (rule Ord_linear_lt, auto)
apply (simp_all add: raw_oadd_eq_oadd)
apply (blast dest: oadd_lt_mono2 elim: lt_irrefl lt_asym)+
done

lemma oadd_lt_iff2: "Ord(j) \<Longrightarrow> i++j < i++k \<longleftrightarrow> j<k"
by (blast intro!: oadd_lt_mono2 dest!: oadd_lt_cancel2)

lemma oadd_inject: "\<lbrakk>i++j = i++k;  Ord(j); Ord(k)\<rbrakk> \<Longrightarrow> j=k"
apply (simp add: oadd_eq_if_raw_oadd split: split_if_asm)
apply (simp add: raw_oadd_eq_oadd)
apply (rule Ord_linear_lt, auto)
apply (force dest: oadd_lt_mono2 [of concl: i] simp add: lt_not_refl)+
done

lemma lt_oadd_disj: "k < i++j \<Longrightarrow> k<i | (\<exists>l\<in>j. k = i++l )"
apply (simp add: Ord_in_Ord' [of _ j] oadd_eq_if_raw_oadd
            split: split_if_asm)
 prefer 2
 apply (simp add: Ord_in_Ord' [of _ j] lt_def)
apply (simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel raw_oadd_def)
apply (erule ltD [THEN RepFunE])
apply (force simp add: ordertype_pred_Inl_eq well_ord_Memrel ltI
                       lt_pred_Memrel le_ordertype_Memrel leI
                       ordertype_pred_Inr_eq ordertype_sum_Memrel)
done

subsubsection\<open>Ordinal addition with successor -- via associativity!\<close>

lemma oadd_assoc: "(i++j)++k = i++(j++k)"
apply (simp add: oadd_eq_if_raw_oadd Ord_raw_oadd raw_oadd_0 raw_oadd_0_left, clarify)
apply (simp add: raw_oadd_def)
apply (rule ordertype_eq [THEN trans])
apply (rule sum_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                 ord_iso_refl])
apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
apply (rule sum_assoc_ord_iso [THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] sum_ord_iso_cong [OF ord_iso_refl ordertype_ord_iso])
apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)+
done

lemma oadd_unfold: "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> i++j = i \<union> (\<Union>k\<in>j. {i++k})"
apply (rule subsetI [THEN equalityI])
apply (erule ltI [THEN lt_oadd_disj, THEN disjE])
apply (blast intro: Ord_oadd)
apply (blast elim!: ltE, blast)
apply (force intro: lt_oadd1 oadd_lt_mono2 simp add: Ord_mem_iff_lt)
done

lemma oadd_1: "Ord(i) \<Longrightarrow> i++1 = succ(i)"
apply (simp (no_asm_simp) add: oadd_unfold Ord_1 oadd_0)
apply blast
done

lemma oadd_succ [simp]: "Ord(j) \<Longrightarrow> i++succ(j) = succ(i++j)"
apply (simp add: oadd_eq_if_raw_oadd, clarify)
apply (simp add: raw_oadd_eq_oadd)
apply (simp add: oadd_1 [of j, symmetric] oadd_1 [of "i++j", symmetric]
                 oadd_assoc)
done

text\<open>Ordinal addition with limit ordinals\<close>

lemma oadd_UN:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> Ord(j(x));  a \<in> A\<rbrakk>
      \<Longrightarrow> i ++ (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i++j(x))"
by (blast intro: ltI Ord_UN Ord_oadd lt_oadd1 [THEN ltD]
                 oadd_lt_mono2 [THEN ltD]
          elim!: ltE dest!: ltI [THEN lt_oadd_disj])

lemma oadd_Limit: "Limit(j) \<Longrightarrow> i++j = (\<Union>k\<in>j. i++k)"
apply (frule Limit_has_0 [THEN ltD])
apply (simp add: Limit_is_Ord [THEN Ord_in_Ord] oadd_UN [symmetric]
                 Union_eq_UN [symmetric] Limit_Union_eq)
done

lemma oadd_eq_0_iff: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> (i ++ j) = 0 \<longleftrightarrow> i=0 \<and> j=0"
apply (erule trans_induct3 [of j])
apply (simp_all add: oadd_Limit)
apply (simp add: Union_empty_iff Limit_def lt_def, blast)
done

lemma oadd_eq_lt_iff: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> 0 < (i ++ j) \<longleftrightarrow> 0<i | 0<j"
by (simp add: Ord_0_lt_iff [symmetric] oadd_eq_0_iff)

lemma oadd_LimitI: "\<lbrakk>Ord(i); Limit(j)\<rbrakk> \<Longrightarrow> Limit(i ++ j)"
apply (simp add: oadd_Limit)
apply (frule Limit_has_1 [THEN ltD])
apply (rule increasing_LimitI)
 apply (rule Ord_0_lt)
  apply (blast intro: Ord_in_Ord [OF Limit_is_Ord])
 apply (force simp add: Union_empty_iff oadd_eq_0_iff
                        Limit_is_Ord [of j, THEN Ord_in_Ord], auto)
apply (rule_tac x="succ(y)" in bexI)
 apply (simp add: ltI Limit_is_Ord [of j, THEN Ord_in_Ord])
apply (simp add: Limit_def lt_def)
done

text\<open>Order/monotonicity properties of ordinal addition\<close>

lemma oadd_le_self2: "Ord(i) \<Longrightarrow> i \<le> j++i"
proof (induct i rule: trans_induct3)
  case 0 thus ?case by (simp add: Ord_0_le)
next
  case (succ i) thus ?case by (simp add: oadd_succ succ_leI)
next
  case (limit l)
  hence "l = (\<Union>x\<in>l. x)"
    by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
  also have "... \<le> (\<Union>x\<in>l. j++x)"
    by (rule le_implies_UN_le_UN) (rule limit.hyps)
  finally have "l \<le> (\<Union>x\<in>l. j++x)" .
  thus ?case using limit.hyps by (simp add: oadd_Limit)
qed

lemma oadd_le_mono1: "k \<le> j \<Longrightarrow> k++i \<le> j++i"
apply (frule lt_Ord)
apply (frule le_Ord2)
apply (simp add: oadd_eq_if_raw_oadd, clarify)
apply (simp add: raw_oadd_eq_oadd)
apply (erule_tac i = i in trans_induct3)
apply (simp (no_asm_simp))
apply (simp (no_asm_simp) add: oadd_succ succ_le_iff)
apply (simp (no_asm_simp) add: oadd_Limit)
apply (rule le_implies_UN_le_UN, blast)
done

lemma oadd_lt_mono: "\<lbrakk>i' \<le> i;  j'<j\<rbrakk> \<Longrightarrow> i'++j' < i++j"
by (blast intro: lt_trans1 oadd_le_mono1 oadd_lt_mono2 Ord_succD elim: ltE)

lemma oadd_le_mono: "\<lbrakk>i' \<le> i;  j' \<le> j\<rbrakk> \<Longrightarrow> i'++j' \<le> i++j"
by (simp del: oadd_succ add: oadd_succ [symmetric] le_Ord2 oadd_lt_mono)

lemma oadd_le_iff2: "\<lbrakk>Ord(j); Ord(k)\<rbrakk> \<Longrightarrow> i++j \<le> i++k \<longleftrightarrow> j \<le> k"
by (simp del: oadd_succ add: oadd_lt_iff2 oadd_succ [symmetric] Ord_succ)

lemma oadd_lt_self: "\<lbrakk>Ord(i);  0<j\<rbrakk> \<Longrightarrow> i < i++j"
apply (rule lt_trans2)
apply (erule le_refl)
apply (simp only: lt_Ord2  oadd_1 [of i, symmetric])
apply (blast intro: succ_leI oadd_le_mono)
done

text\<open>Every ordinal is exceeded by some limit ordinal.\<close>
lemma Ord_imp_greater_Limit: "Ord(i) \<Longrightarrow> \<exists>k. i<k \<and> Limit(k)"
apply (rule_tac x="i ++ nat" in exI)
apply (blast intro: oadd_LimitI  oadd_lt_self  Limit_nat [THEN Limit_has_0])
done

lemma Ord2_imp_greater_Limit: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> \<exists>k. i<k \<and> j<k \<and> Limit(k)"
apply (insert Ord_Un [of i j, THEN Ord_imp_greater_Limit])
apply (simp add: Un_least_lt_iff)
done

subsection\<open>Ordinal Subtraction\<close>

text\<open>The difference is \<^term>\<open>ordertype(j-i, Memrel(j))\<close>.
    It's probably simpler to define the difference recursively!\<close>

lemma bij_sum_Diff:
     "A<=B \<Longrightarrow> (\<lambda>y\<in>B. if(y \<in> A, Inl(y), Inr(y))) \<in> bij(B, A+(B-A))"
apply (rule_tac d = "case (\<lambda>x. x, \<lambda>y. y) " in lam_bijective)
apply (blast intro!: if_type)
apply (fast intro!: case_type)
apply (erule_tac [2] sumE)
apply (simp_all (no_asm_simp))
done

lemma ordertype_sum_Diff:
     "i \<le> j \<Longrightarrow>
            ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j))) =
            ordertype(j, Memrel(j))"
apply (safe dest!: le_subset_iff [THEN iffD1])
apply (rule bij_sum_Diff [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
apply (erule_tac [3] well_ord_Memrel, assumption)
apply (simp (no_asm_simp))
apply (frule_tac j = y in Ord_in_Ord, assumption)
apply (frule_tac j = x in Ord_in_Ord, assumption)
apply (simp (no_asm_simp) add: Ord_mem_iff_lt lt_Ord not_lt_iff_le)
apply (blast intro: lt_trans2 lt_trans)
done

lemma Ord_odiff [simp,TC]:
    "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> Ord(i--j)"
  unfolding odiff_def
apply (blast intro: Ord_ordertype Diff_subset well_ord_subset well_ord_Memrel)
done

lemma raw_oadd_ordertype_Diff:
   "i \<le> j
    \<Longrightarrow> raw_oadd(i,j--i) = ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j)))"
apply (simp add: raw_oadd_def odiff_def)
apply (safe dest!: le_subset_iff [THEN iffD1])
apply (rule sum_ord_iso_cong [THEN ordertype_eq])
apply (erule id_ord_iso_Memrel)
apply (rule ordertype_ord_iso [THEN ord_iso_sym])
apply (blast intro: well_ord_radd Diff_subset well_ord_subset well_ord_Memrel)+
done

lemma oadd_odiff_inverse: "i \<le> j \<Longrightarrow> i ++ (j--i) = j"
by (simp add: lt_Ord le_Ord2 oadd_def ordify_def raw_oadd_ordertype_Diff
              ordertype_sum_Diff ordertype_Memrel lt_Ord2 [THEN Ord_succD])

(*By oadd_inject, the difference between i and j is unique.  Note that we get
  i++j = k  \<Longrightarrow>  j = k--i.  *)
lemma odiff_oadd_inverse: "\<lbrakk>Ord(i); Ord(j)\<rbrakk> \<Longrightarrow> (i++j) -- i = j"
apply (rule oadd_inject)
apply (blast intro: oadd_odiff_inverse oadd_le_self)
apply (blast intro: Ord_ordertype Ord_oadd Ord_odiff)+
done

lemma odiff_lt_mono2: "\<lbrakk>i<j;  k \<le> i\<rbrakk> \<Longrightarrow> i--k < j--k"
apply (rule_tac i = k in oadd_lt_cancel2)
apply (simp add: oadd_odiff_inverse)
apply (subst oadd_odiff_inverse)
apply (blast intro: le_trans leI, assumption)
apply (simp (no_asm_simp) add: lt_Ord le_Ord2)
done

subsection\<open>Ordinal Multiplication\<close>

lemma Ord_omult [simp,TC]:
    "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> Ord(i**j)"
  unfolding omult_def
apply (blast intro: Ord_ordertype well_ord_rmult well_ord_Memrel)
done

subsubsection\<open>A useful unfolding law\<close>

lemma pred_Pair_eq:
 "\<lbrakk>a \<in> A;  b \<in> B\<rbrakk> \<Longrightarrow> pred(A*B, \<langle>a,b\<rangle>, rmult(A,r,B,s)) =
                      pred(A,a,r)*B \<union> ({a} * pred(B,b,s))"
apply (unfold pred_def, blast)
done

lemma ordertype_pred_Pair_eq:
     "\<lbrakk>a \<in> A;  b \<in> B;  well_ord(A,r);  well_ord(B,s)\<rbrakk> \<Longrightarrow>
         ordertype(pred(A*B, \<langle>a,b\<rangle>, rmult(A,r,B,s)), rmult(A,r,B,s)) =
         ordertype(pred(A,a,r)*B + pred(B,b,s),
                  radd(A*B, rmult(A,r,B,s), B, s))"
apply (simp (no_asm_simp) add: pred_Pair_eq)
apply (rule ordertype_eq [symmetric])
apply (rule prod_sum_singleton_ord_iso)
apply (simp_all add: pred_subset well_ord_rmult [THEN well_ord_subset])
apply (blast intro: pred_subset well_ord_rmult [THEN well_ord_subset]
             elim!: predE)
done

lemma ordertype_pred_Pair_lemma:
    "\<lbrakk>i'<i;  j'<j\<rbrakk>
     \<Longrightarrow> ordertype(pred(i*j, <i',j'>, rmult(i,Memrel(i),j,Memrel(j))),
                   rmult(i,Memrel(i),j,Memrel(j))) =
         raw_oadd (j**i', j')"
  unfolding raw_oadd_def omult_def
apply (simp add: ordertype_pred_Pair_eq lt_pred_Memrel ltD lt_Ord2
                 well_ord_Memrel)
apply (rule trans)
 apply (rule_tac [2] ordertype_ord_iso
                      [THEN sum_ord_iso_cong, THEN ordertype_eq])
  apply (rule_tac [3] ord_iso_refl)
apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq])
apply (elim SigmaE sumE ltE ssubst)
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype lt_Ord lt_Ord2)
apply (blast intro: Ord_trans)+
done

lemma lt_omult:
 "\<lbrakk>Ord(i);  Ord(j);  k<j**i\<rbrakk>
  \<Longrightarrow> \<exists>j' i'. k = j**i' ++ j' \<and> j'<j \<and> i'<i"
  unfolding omult_def
apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel)
apply (safe elim!: ltE)
apply (simp add: ordertype_pred_Pair_lemma ltI raw_oadd_eq_oadd
            omult_def [symmetric] Ord_in_Ord' [of _ i] Ord_in_Ord' [of _ j])
apply (blast intro: ltI)
done

lemma omult_oadd_lt:
     "\<lbrakk>j'<j;  i'<i\<rbrakk> \<Longrightarrow> j**i' ++ j'  <  j**i"
  unfolding omult_def
apply (rule ltI)
 prefer 2
 apply (simp add: Ord_ordertype well_ord_rmult well_ord_Memrel lt_Ord2)
apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel lt_Ord2)
apply (rule bexI [of _ i'])
apply (rule bexI [of _ j'])
apply (simp add: ordertype_pred_Pair_lemma ltI omult_def [symmetric])
apply (simp add: lt_Ord lt_Ord2 raw_oadd_eq_oadd)
apply (simp_all add: lt_def)
done

lemma omult_unfold:
     "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> j**i = (\<Union>j'\<in>j. \<Union>i'\<in>i. {j**i' ++ j'})"
apply (rule subsetI [THEN equalityI])
apply (rule lt_omult [THEN exE])
apply (erule_tac [3] ltI)
apply (simp_all add: Ord_omult)
apply (blast elim!: ltE)
apply (blast intro: omult_oadd_lt [THEN ltD] ltI)
done

subsubsection\<open>Basic laws for ordinal multiplication\<close>

text\<open>Ordinal multiplication by zero\<close>

lemma omult_0 [simp]: "i**0 = 0"
  unfolding omult_def
apply (simp (no_asm_simp))
done

lemma omult_0_left [simp]: "0**i = 0"
  unfolding omult_def
apply (simp (no_asm_simp))
done

text\<open>Ordinal multiplication by 1\<close>

lemma omult_1 [simp]: "Ord(i) \<Longrightarrow> i**1 = i"
  unfolding omult_def
apply (rule_tac s1="Memrel(i)"
       in ord_isoI [THEN ordertype_eq, THEN trans])
apply (rule_tac c = snd and d = "\<lambda>z.\<langle>0,z\<rangle>"  in lam_bijective)
apply (auto elim!: snd_type well_ord_Memrel ordertype_Memrel)
done

lemma omult_1_left [simp]: "Ord(i) \<Longrightarrow> 1**i = i"
  unfolding omult_def
apply (rule_tac s1="Memrel(i)"
       in ord_isoI [THEN ordertype_eq, THEN trans])
apply (rule_tac c = fst and d = "\<lambda>z.\<langle>z,0\<rangle>" in lam_bijective)
apply (auto elim!: fst_type well_ord_Memrel ordertype_Memrel)
done

text\<open>Distributive law for ordinal multiplication and addition\<close>

lemma oadd_omult_distrib:
     "\<lbrakk>Ord(i);  Ord(j);  Ord(k)\<rbrakk> \<Longrightarrow> i**(j++k) = (i**j)++(i**k)"
apply (simp add: oadd_eq_if_raw_oadd)
apply (simp add: omult_def raw_oadd_def)
apply (rule ordertype_eq [THEN trans])
apply (rule prod_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                  ord_iso_refl])
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype)
apply (rule sum_prod_distrib_ord_iso [THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] sum_ord_iso_cong [OF ordertype_ord_iso ordertype_ord_iso])
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype)
done

lemma omult_succ: "\<lbrakk>Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> i**succ(j) = (i**j)++i"
by (simp del: oadd_succ add: oadd_1 [of j, symmetric] oadd_omult_distrib)

text\<open>Associative law\<close>

lemma omult_assoc:
    "\<lbrakk>Ord(i);  Ord(j);  Ord(k)\<rbrakk> \<Longrightarrow> (i**j)**k = i**(j**k)"
  unfolding omult_def
apply (rule ordertype_eq [THEN trans])
apply (rule prod_ord_iso_cong [OF ord_iso_refl
                                  ordertype_ord_iso [THEN ord_iso_sym]])
apply (blast intro: well_ord_rmult well_ord_Memrel)+
apply (rule prod_assoc_ord_iso
             [THEN ord_iso_sym, THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] prod_ord_iso_cong [OF ordertype_ord_iso ord_iso_refl])
apply (blast intro: well_ord_rmult well_ord_Memrel Ord_ordertype)+
done

text\<open>Ordinal multiplication with limit ordinals\<close>

lemma omult_UN:
     "\<lbrakk>Ord(i);  \<And>x. x \<in> A \<Longrightarrow> Ord(j(x))\<rbrakk>
      \<Longrightarrow> i ** (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i**j(x))"
by (simp (no_asm_simp) add: Ord_UN omult_unfold, blast)

lemma omult_Limit: "\<lbrakk>Ord(i);  Limit(j)\<rbrakk> \<Longrightarrow> i**j = (\<Union>k\<in>j. i**k)"
by (simp add: Limit_is_Ord [THEN Ord_in_Ord] omult_UN [symmetric]
              Union_eq_UN [symmetric] Limit_Union_eq)

subsubsection\<open>Ordering/monotonicity properties of ordinal multiplication\<close>

(*As a special case we have "\<lbrakk>0<i;  0<j\<rbrakk> \<Longrightarrow> 0 < i**j" *)
lemma lt_omult1: "\<lbrakk>k<i;  0<j\<rbrakk> \<Longrightarrow> k < i**j"
apply (safe elim!: ltE intro!: ltI Ord_omult)
apply (force simp add: omult_unfold)
done

lemma omult_le_self: "\<lbrakk>Ord(i);  0<j\<rbrakk> \<Longrightarrow> i \<le> i**j"
by (blast intro: all_lt_imp_le Ord_omult lt_omult1 lt_Ord2)

lemma omult_le_mono1:
  assumes kj: "k \<le> j" and i: "Ord(i)" shows "k**i \<le> j**i"
proof -
  have o: "Ord(k)" "Ord(j)" by (rule lt_Ord [OF kj] le_Ord2 [OF kj])+
  show ?thesis using i
  proof (induct i rule: trans_induct3)
    case 0 thus ?case
      by simp
  next
    case (succ i) thus ?case
      by (simp add: o kj omult_succ oadd_le_mono)
  next
    case (limit l)
    thus ?case
      by (auto simp add: o kj omult_Limit le_implies_UN_le_UN)
  qed
qed

lemma omult_lt_mono2: "\<lbrakk>k<j;  0<i\<rbrakk> \<Longrightarrow> i**k < i**j"
apply (rule ltI)
apply (simp (no_asm_simp) add: omult_unfold lt_Ord2)
apply (safe elim!: ltE intro!: Ord_omult)
apply (force simp add: Ord_omult)
done

lemma omult_le_mono2: "\<lbrakk>k \<le> j;  Ord(i)\<rbrakk> \<Longrightarrow> i**k \<le> i**j"
apply (rule subset_imp_le)
apply (safe elim!: ltE dest!: Ord_succD intro!: Ord_omult)
apply (simp add: omult_unfold)
apply (blast intro: Ord_trans)
done

lemma omult_le_mono: "\<lbrakk>i' \<le> i;  j' \<le> j\<rbrakk> \<Longrightarrow> i'**j' \<le> i**j"
by (blast intro: le_trans omult_le_mono1 omult_le_mono2 Ord_succD elim: ltE)

lemma omult_lt_mono: "\<lbrakk>i' \<le> i;  j'<j;  0<i\<rbrakk> \<Longrightarrow> i'**j' < i**j"
by (blast intro: lt_trans1 omult_le_mono1 omult_lt_mono2 Ord_succD elim: ltE)

lemma omult_le_self2:
  assumes i: "Ord(i)" and j: "0<j" shows "i \<le> j**i"
proof -
  have oj: "Ord(j)" by (rule lt_Ord2 [OF j])
  show ?thesis using i
  proof (induct i rule: trans_induct3)
    case 0 thus ?case
      by simp
  next
    case (succ i)
    have "j ** i ++ 0 < j ** i ++ j"
      by (rule oadd_lt_mono2 [OF j])
    with succ.hyps show ?case
      by (simp add: oj j omult_succ ) (rule lt_trans1)
  next
    case (limit l)
    hence "l = (\<Union>x\<in>l. x)"
      by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
    also have "... \<le> (\<Union>x\<in>l. j**x)"
      by (rule le_implies_UN_le_UN) (rule limit.hyps)
    finally have "l \<le> (\<Union>x\<in>l. j**x)" .
    thus ?case using limit.hyps by (simp add: oj omult_Limit)
  qed
qed

text\<open>Further properties of ordinal multiplication\<close>

lemma omult_inject: "\<lbrakk>i**j = i**k;  0<i;  Ord(j);  Ord(k)\<rbrakk> \<Longrightarrow> j=k"
apply (rule Ord_linear_lt)
prefer 4 apply assumption
apply auto
apply (force dest: omult_lt_mono2 simp add: lt_not_refl)+
done

subsection\<open>The Relation \<^term>\<open>Lt\<close>\<close>

lemma wf_Lt: "wf(Lt)"
apply (rule wf_subset)
apply (rule wf_Memrel)
apply (auto simp add: Lt_def Memrel_def lt_def)
done

lemma irrefl_Lt: "irrefl(A,Lt)"
by (auto simp add: Lt_def irrefl_def)

lemma trans_Lt: "trans[A](Lt)"
apply (simp add: Lt_def trans_on_def)
apply (blast intro: lt_trans)
done

lemma part_ord_Lt: "part_ord(A,Lt)"
by (simp add: part_ord_def irrefl_Lt trans_Lt)

lemma linear_Lt: "linear(nat,Lt)"
apply (auto dest!: not_lt_imp_le simp add: Lt_def linear_def le_iff)
apply (drule lt_asym, auto)
done

lemma tot_ord_Lt: "tot_ord(nat,Lt)"
by (simp add: tot_ord_def linear_Lt part_ord_Lt)

lemma well_ord_Lt: "well_ord(nat,Lt)"
by (simp add: well_ord_def wf_Lt wf_imp_wf_on tot_ord_Lt)

end


(*  Title:      FOL/ex/Quantifiers_Int.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section {* First-Order Logic: quantifier examples (intuitionistic version) *}

theory Quantifiers_Int
imports IFOL
begin

lemma "(ALL x y. P(x,y))  -->  (ALL y x. P(x,y))"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(EX x y. P(x,y)) --> (EX y x. P(x,y))"
  by (tactic "IntPr.fast_tac @{context} 1")

-- {* Converse is false *}
lemma "(ALL x. P(x)) | (ALL x. Q(x)) --> (ALL x. P(x) | Q(x))"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(ALL x. P-->Q(x))  <->  (P--> (ALL x. Q(x)))"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(ALL x. P(x)-->Q)  <->  ((EX x. P(x)) --> Q)"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* Some harder ones *}

lemma "(EX x. P(x) | Q(x)) <-> (EX x. P(x)) | (EX x. Q(x))"
  by (tactic "IntPr.fast_tac @{context} 1")

-- {* Converse is false *}
lemma "(EX x. P(x)&Q(x)) --> (EX x. P(x))  &  (EX x. Q(x))"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* Basic test of quantifier reasoning *}

-- {* TRUE *}
lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(ALL x. Q(x))  -->  (EX x. Q(x))"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* The following should fail, as they are false! *}

lemma "(ALL x. EX y. Q(x,y))  -->  (EX y. ALL x. Q(x,y))"
  apply (tactic "IntPr.fast_tac @{context} 1")?
  oops

lemma "(EX x. Q(x))  -->  (ALL x. Q(x))"
  apply (tactic "IntPr.fast_tac @{context} 1")?
  oops

schematic_lemma "P(?a) --> (ALL x. P(x))"
  apply (tactic "IntPr.fast_tac @{context} 1")?
  oops

schematic_lemma "(P(?a) --> (ALL x. Q(x))) --> (ALL x. P(x) --> Q(x))"
  apply (tactic "IntPr.fast_tac @{context} 1")?
  oops

text {* Back to things that are provable \dots *}

lemma "(ALL x. P(x)-->Q(x)) & (EX x. P(x)) --> (EX x. Q(x))"
  by (tactic "IntPr.fast_tac @{context} 1")

-- {* An example of why exI should be delayed as long as possible *}
lemma "(P --> (EX x. Q(x))) & P --> (EX x. Q(x))"
  by (tactic "IntPr.fast_tac @{context} 1")

schematic_lemma "(ALL x. P(x)-->Q(f(x))) & (ALL x. Q(x)-->R(g(x))) & P(d) --> R(?a)"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "(ALL x. Q(x))  -->  (EX x. Q(x))"
  by (tactic "IntPr.fast_tac @{context} 1")

text {* Some slow ones *}

-- {* Principia Mathematica *11.53 *}
lemma "(ALL x y. P(x) --> Q(y)) <-> ((EX x. P(x)) --> (ALL y. Q(y)))"
  by (tactic "IntPr.fast_tac @{context} 1")

(*Principia Mathematica *11.55  *)
lemma "(EX x y. P(x) & Q(x,y)) <-> (EX x. P(x) & (EX y. Q(x,y)))"
  by (tactic "IntPr.fast_tac @{context} 1")

(*Principia Mathematica *11.61  *)
lemma "(EX y. ALL x. P(x) --> Q(x,y)) --> (ALL x. P(x) --> (EX y. Q(x,y)))"
  by (tactic "IntPr.fast_tac @{context} 1")

end


section\<open>CNF Sat to Clique\<close>

theory CNF_SAT_To_Clique
  imports Main "../Three_Sat_To_Set_Cover"
begin

subsection \<open>Preliminaries\<close>

definition
  "ugraph_nodes E V \<equiv> ugraph E \<and>  \<Union> E \<subseteq> V \<and> finite V"

definition cnf_sat where
  "cnf_sat \<equiv> {F. sat F \<and> (\<forall>c \<in> set F. finite c)}"

definition
  "is_clique E C \<equiv> \<forall>u \<in> C. \<forall>v \<in> C. v=u \<or> {u, v} \<in> E"

definition
  "clique \<equiv> {(E, V , k). \<exists>C. ugraph_nodes E V \<and> C \<subseteq> V \<and> card C \<ge> k \<and> is_clique E C}"

definition
  "cnf_sat_to_clique F \<equiv> (if finite (\<Union> (set F)) then (
    {{(l1, i), (l2, j)} | l1 l2 i j. i < length F \<and> j < length F \<and> i\<noteq> j \<and> \<not> conflict l1 l2 \<and>
         l1 \<in> F ! i \<and> l2 \<in> F ! j},
    {(l1, i) | l1 i. i < length F \<and>   l1 \<in> F ! i},
    length F) else ({}, {}, 1))"

subsection \<open>F \<in> cnf_sat \<Longrightarrow> cnf_sat_to_clique F \<in> clique\<close>

definition get_some_true where
  "get_some_true F \<sigma> i \<equiv> SOME l. lift \<sigma> l \<and> l \<in> F ! i"

lemma models_smaller: "models \<sigma> (a#F) \<Longrightarrow> models \<sigma> F"
  by(auto simp add: models_def)

context
  fixes F E V k assumes triple: "cnf_sat_to_clique F = (E, V, k)"
  fixes \<sigma> assumes sigma_def: "models \<sigma> F"
  fixes C assumes C_def: "C \<equiv> {(get_some_true F \<sigma> i, i) |i. i < length F}"
  assumes F_wf: "F \<in> cnf_sat"
begin

lemma fin_1:"finite (\<Union> (set F))"
  using \<open>F \<in> cnf_sat\<close>
  unfolding cnf_sat_def
  by (auto 4 3 intro: card_ge_0_finite)

lemma V_def: "V = {(l1, i) | l1 i. i < length F \<and>   l1 \<in> F ! i}"
  using cnf_sat_to_clique_def fin_1 triple
  by (metis (mono_tags, lifting) fst_conv old.prod.exhaust snd_conv)

lemma E_def: "E = {{(l1, i), (l2, j)} | l1 l2 i j. i < length F
         \<and> j < length F \<and> i\<noteq> j \<and> \<not> conflict l1 l2 \<and>
         l1 \<in> F ! i \<and> l2 \<in> F ! j} " using cnf_sat_to_clique_def triple fin_1
  by (metis (mono_tags, lifting) fst_eqD)

text\<open>Similar to the proof in Three_Sat_To_Set_Cover\<close>
lemma cnf_sat_to_clique_ugraph: "ugraph E"
proof -
  let ?S = "((\<Union> (set F)) \<times> {0..<length F}) \<times> ((\<Union> (set F)) \<times> {0..<length F})"
  show ?thesis
    using triple fin_1
    unfolding cnf_sat_to_clique_def is_clique_def ugraph_def
    by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma edges_between_nodes:
  assumes "X \<in> E"
  shows " X \<subseteq> V"
  using assms triple E_def V_def
  by(auto)

lemma finite_V:
  shows "finite V"
proof -
  let ?S = "((\<Union> (set F)) \<times> {0..<length F})"
  show ?thesis
    using triple fin_1
    unfolding cnf_sat_to_clique_def is_clique_def ugraph_def
    by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma cnf_sat_to_clique_ugraph_nodes:
  shows "ugraph_nodes E V"
  apply(auto simp add: cnf_sat_to_clique_ugraph ugraph_nodes_def F_wf finite_V)
  using edges_between_nodes F_wf
  by blast

lemma get_some_true_aux:
  assumes "i < length F"
  shows "(\<sigma>\<up>) (get_some_true F \<sigma> i) \<and> (get_some_true F \<sigma> i) \<in> F ! i"
  using assms sigma_def
  unfolding models_def get_some_true_def
  by - (rule someI_ex, auto)

lemmas
  get_some_true_sat = get_some_true_aux[THEN conjunct1]
  and
  get_some_true_index = get_some_true_aux[THEN conjunct2]

lemma get_some_true_yields_clique:
  assumes "u\<in>C" "v\<in>C"
  shows "{u, v} \<in> E \<or> u = v"
  using assms triple E_def V_def C_def conflict_models_ccontr
    get_some_true_index get_some_true_sat by blast+

lemma is_clique:
  shows "is_clique E  C"
  unfolding is_clique_def
  using get_some_true_yields_clique F_wf sigma_def
  by(fastforce)

lemma cnf_sat_has_pos: "F \<noteq> []  \<Longrightarrow> \<exists>p. lift \<sigma> p"
  by(auto simp add: models_def lift_def cnf_sat_def split: lit.split)

lemma all_clauses_have_pos: "\<forall>i < (length F). \<exists>p \<in> F!i. lift \<sigma> p"
  using F_wf sigma_def
  by(auto simp add: models_def lift_def cnf_sat_def split: lit.split)

lemma card_clique:
  shows "card C \<ge> length F"
  unfolding F_wf C_def setcompr_eq_image
  by (subst card_image) (auto intro: inj_onI)

lemma in_clique_implies_in_nodes:
  assumes "v \<in> C"
  shows "v \<in> V"
  using assms V_def C_def triple assms get_some_true_index
  by force

lemma clique_in_graph:
  shows "C\<subseteq> V"
  using in_clique_implies_in_nodes
  by blast

lemma in_clique: "cnf_sat_to_clique F \<in> clique"
proof -
  have is_c: "is_clique E C"
    using is_clique
    by auto
  then have card_C_length: "card C \<ge> (length F)"
    using card_clique
    by auto
  then have card_C: "card C \<ge> k"
    using cnf_sat_to_clique_def triple
    by (simp add: cnf_sat_to_clique_def fin_1)
  have clique_contained: "C \<subseteq> V"
    using clique_in_graph
    by blast
  have ug: "ugraph_nodes E V"
    using  cnf_sat_to_clique_ugraph_nodes
    by(auto)
  then have "\<exists> C'. ugraph_nodes (fst (cnf_sat_to_clique F)) (fst (snd( cnf_sat_to_clique F)))
      \<and> C' \<subseteq> fst(snd (cnf_sat_to_clique F)) \<and> card C' \<ge> (snd (snd(cnf_sat_to_clique F)))
      \<and> is_clique (fst (cnf_sat_to_clique F)) C'"
    using card_C is_c clique_contained ug triple
    by(auto)
  then have "cnf_sat_to_clique F \<in>
    {(E, V, k). \<exists>C. ugraph_nodes E V \<and> C \<subseteq> V \<and> card C \<ge> k \<and> is_clique E C}"
    by (simp add: case_prod_beta')
  then show ?thesis
    using clique_def
    by(auto simp add: clique_def)
qed

end

subsection\<open>cnf_sat_to_clique F \<in> clique \<Longrightarrow> F \<in> cnf_sat\<close>

context
  fixes F E V k assumes triple: "cnf_sat_to_clique F = (E, V, k)"
  assumes in_clique: "(E, V, k) \<in> clique"
begin

lemma not_finite_implies_not_finite:
  assumes "\<not> (\<forall>c \<in> set F. finite c)"
  shows "V = {}"
  using assms triple cnf_sat_to_clique_def
  by (metis (no_types, lifting) Pair_inject Union_upper finite_subset)

lemma else_not_in_clique: "({}, {}, 1) \<notin> clique"
  by(auto simp add: clique_def)

lemma aux_for_finite_F:
  assumes "X \<in> set F"
  shows "finite X"
  using assms else_not_in_clique in_clique triple
  unfolding cnf_sat_to_clique_def
  by (auto split: if_split_asm) (meson Sup_upper finite_subset)

lemma aux1: "finite (\<Union> (set F)) \<Longrightarrow>
  E = {{(l1, i), (l2, j)} |l1 l2 i j. i < length F \<and> j < length F
    \<and> i \<noteq> j \<and> \<not> conflict l1 l2 \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j}"
  using triple
  by(auto simp add: cnf_sat_to_clique_def)

lemma finite_F_1:
  assumes "E\<noteq> {} \<or> V \<noteq> {}"
  shows "finite (\<Union> (set F))"
  using cnf_sat_to_clique_def triple
  apply(auto simp add: cnf_sat_to_clique_def)
  by (metis (no_types, lifting) else_not_in_clique local.in_clique)

lemma E_def_C:
  assumes "E \<noteq> {}"
  shows "E= {{(l1, i), (l2, j)} | l1 l2 i j. i < length F \<and> j < length F
        \<and> i\<noteq> j \<and> \<not> conflict l1 l2 \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j}"
  using triple finite_F_1 aux1 assms
  by auto

lemma finite_F:
  shows  "finite (\<Union> (set F))"
  using else_not_in_clique cnf_sat_to_clique_def E_def_C triple finite_F_1 in_clique
  by (simp add: aux_for_finite_F)

lemma no_edges_between_clause:
  assumes "{(l1, i), (l2, i)} \<in> E"
  shows False
proof -
  have "E \<noteq> {}"
    using assms
    by auto
  then have "i \<noteq> i"
    using assms triple E_def_C by simp (metis (lifting) Pair_inject doubleton_eq_iff)
  then show ?thesis
    by auto
qed

lemma conflict_commutative: "conflict l1 l2 = conflict l2 l1"
  by(auto simp add: conflict_def)

lemma edge_conflict_aux:
  assumes "{(l1, i), (l2, j)} \<in>E"
  shows "\<not> conflict l1 l2"
proof (rule ccontr)
  assume "\<not> \<not> conflict l1 l2"
  then have "conflict l1 l2 \<and> conflict l2 l1"
    by (auto simp add: conflict_commutative)
  have "\<not>conflict l1 l2 \<or> \<not> conflict l2 l1"
    using assms triple E_def_C
    apply(auto)
    by (smt Pair_inject doubleton_eq_iff empty_iff mem_Collect_eq)
  then have "\<not> conflict l1 l2"
    using conflict_commutative
    by(auto)
  then show False
    using assms \<open>\<not> \<not> conflict l1 l2\<close>
    by auto
qed

lemma aux5: "v\<in> C \<and> u \<in> C \<and> card C \<le> 1 \<and> finite C\<Longrightarrow> u = v"
  by(auto simp add: card_le_Suc0_iff_eq)

lemma no_conflicts_in_edges_empty_E:
  assumes "is_clique E C" "(l1, i) \<in> C" "(l2, j) \<in> C" "conflict l1 l2" "E = {}" "finite C"
  shows "False"
proof -
  have "card C \<le> 1"
    using assms is_clique_def
    apply(auto)
    by (metis assms(1, 6) card_le_Suc0_iff_eq emptyE is_clique_def)
  then have "(l1, i) = (l2, j)"
    using \<open>(l1, i) \<in> C\<close> \<open>(l2, j) \<in> C\<close> aux5  assms
    by fastforce
  then have "\<not> conflict l1 l2"
    by auto
  then show ?thesis
    using assms
    by(auto)
qed

lemma no_conflicts_in_edges:
  assumes "is_clique E C" "(l1, i) \<in> C" "(l2, j) \<in> C" "conflict l1 l2" "E \<noteq> {}"
  shows "False"
proof -
  have in_E: "{(l1, i), (l2, j)} \<in> E"
    using assms is_clique_def
    by (metis Pair_inject conflict_same)
  then have "\<not> conflict l1 l2"
    using E_def_C edge_conflict_aux
    by auto
  then show ?thesis
    using assms
    by(auto)
qed

lemma f_sat:
  shows "sat F"
proof -
  from triple in_clique have "length F = k"
    unfolding cnf_sat_to_clique_def else_not_in_clique
    by (metis (no_types, lifting) else_not_in_clique old.prod.inject)
  have fin_2: "finite V"
    using in_clique clique_def ugraph_nodes_def
    apply(auto)
    by fastforce
  from in_clique obtain C where C:
    "ugraph_nodes E V" "C \<subseteq> V" "card C \<ge> k" "is_clique E C"
    using cnf_sat_to_clique_def \<open>cnf_sat_to_clique _ = _\<close> in_clique clique_def
    by (smt case_prodD mem_Collect_eq)
  define \<sigma> where "\<sigma> \<equiv> \<lambda>x. (\<exists>i. (Pos x, i) \<in> C)"
  have V_inj: "l = l'" if "(l, i) \<in> C" "(l', i) \<in> C" for l l' i
  proof (rule ccontr)
    from that C(2) have "i < length F"
      using \<open>cnf_sat_to_clique _ = _\<close>
      unfolding cnf_sat_to_clique_def
      by(auto simp add: finite_F)
    from that C(2) have "l \<in> F ! i" "l' \<in> F ! i"
      using \<open>cnf_sat_to_clique _ = _\<close>
      unfolding cnf_sat_to_clique_def
      by(auto simp add: finite_F)
    assume "l \<noteq> l'"
    with \<open>l \<in> _\<close> \<open>l' \<in> _\<close> \<open>i < _\<close> have "{(l, i), (l', i)} \<notin> E"
      using \<open>cnf_sat_to_clique _ = _\<close>
      unfolding cnf_sat_to_clique_def
      by (metis (no_types, lifting)no_edges_between_clause)
    with C(4) that \<open>l \<noteq> l'\<close> show False
      unfolding is_clique_def
      by auto
  qed
  have fin_3: "finite C"
    using C fin_2 finite_subset
    by auto
  have 1: "i < length F \<and> l \<in> F ! i" if "(l, i) \<in> C" for l i
    using that C(2) using \<open>cnf_sat_to_clique _ = _\<close>
    unfolding cnf_sat_to_clique_def by (auto simp add: finite_F)
  then have C_sub: "C \<subseteq> (\<lambda>i. (SOME l. (l, i) \<in> C, i)) ` {0..<length F}"
    by (auto 4 3 intro: someI V_inj)
  have 2: "\<exists>l. (l, i) \<in> C" if "i < length F" for i
  proof (rule ccontr)
    assume "\<nexists>l. (l, i) \<in> C"
    with that C_sub have "C \<subset> (\<lambda>i. (SOME l. (l, i) \<in> C, i)) ` {0..<length F}"
      by fastforce
    then have "card C < length F"
      apply -
      apply (drule psubset_card_mono[rotated])
      using card_image_le[of "{0..<length F}" "\<lambda>i. (SOME l. (l, i) \<in> C, i)"]
      by auto
    with \<open>card C \<ge> _\<close> \<open>length F = _\<close> show False
      by simp
  qed
  have no_conflict: False if "(l, i) \<in> C" "(l', j) \<in> C" "conflict l l'" for l l' i j
    using triple that no_conflicts_in_edges C finite_F cnf_sat_to_clique_def E_def_C fin_3
    apply(auto simp add: finite_F no_conflicts_in_edges no_conflicts_in_edges_empty_E)
    using no_conflicts_in_edges_empty_E
    by smt
  have "\<exists>l\<in>cls. (\<sigma>\<up>) l" if "cls \<in> set F" for cls
  proof -
    from that obtain i where "F ! i = cls" "i < length F"
      by (meson in_set_conv_nth)
    then obtain l where "(l, i) \<in> C"
      by (blast dest: 2)
    then have "(\<sigma>\<up>) l"
      unfolding \<sigma>_def lift_def
      by (cases l) (auto simp: conflict_def dest: no_conflict)
    moreover from \<open>_ \<in> C\<close> have "l \<in> cls"
      using \<open>F ! i = _\<close>
      by (auto dest: 1)
    ultimately show ?thesis
      by auto
  qed
  then have "\<sigma> \<Turnstile> F"
    unfolding models_def
    by auto
  then show ?thesis
    by(auto simp add: sat_def)
qed

end

subsection\<open> Main theorem \<close>

(*Just some help for Isabelle, since she was not able to figure that out herself*)
lemma cnf_sat_impl_clique: "F \<in> cnf_sat \<Longrightarrow> cnf_sat_to_clique F \<in> clique"
proof -
  assume f_cnf_sat: "F\<in> cnf_sat"
  then obtain \<sigma>  where "\<sigma> \<Turnstile> F"
    unfolding cnf_sat_def sat_def
    by auto
  then have models_sigma: "models \<sigma> F"
    by auto
  obtain E V k where "cnf_sat_to_clique F = (E, V, k)"
    using cnf_sat_to_clique_def prod_cases3
    by blast
  then show ?thesis
    using in_clique f_cnf_sat models_sigma prod_cases3
    by blast
qed

lemma in_clique_implies_in_cnf_sat:
  assumes "cnf_sat_to_clique F \<in> clique"
  shows "F \<in> cnf_sat"
proof - (*found by sledgehammer*)
  have "\<forall>p Ls. cnf_sat_to_clique (Ls::'a lit set list) \<noteq> p \<or> p \<notin> clique \<or> sat Ls"
    by (simp add: f_sat)
  then have "sat F \<and> (\<forall>L. L \<in> set F \<longrightarrow> finite L)"
    by (metis (no_types) assms aux_for_finite_F old.prod.exhaust)
  then show ?thesis
    using cnf_sat_def
    by auto
qed

theorem is_reduction_cnf_sat_to_clique:
  "is_reduction cnf_sat_to_clique cnf_sat clique"
  unfolding is_reduction_def
  using cnf_sat_impl_clique in_clique_implies_in_cnf_sat
  by auto

end