theory Chapter12_3_Typechecking
imports Chapter12_2_PatternMatching
begin

inductive typecheck_patn :: "patn => type => type env => bool"
where tc_vpat [simp]: "typecheck_patn VarPat t (extend empty_env t)"
    | tc_wpat [simp]: "typecheck_patn WildPat t empty_env"
    | tc_tpat [simp]: "typecheck_patn TrivPat Unit empty_env"
    | tc_ppat [simp]: "typecheck_patn p1 t1 e1 ==> typecheck_patn p2 t2 e2 ==>
          typecheck_patn (PairPat p1 p2) (Prod t1 t2) (e1 +++ e2)"
    | tc_lpat [simp]: "typecheck_patn p t e ==> typecheck_patn (InLPat p) (Sum t t2) e"
    | tc_rpat [simp]: "typecheck_patn p t e ==> typecheck_patn (InRPat p) (Sum t2 t) e"

inductive_cases [elim!]: "typecheck_patn VarPat t gam"
inductive_cases [elim!]: "typecheck_patn WildPat t gam"
inductive_cases [elim!]: "typecheck_patn TrivPat t gam"
inductive_cases [elim!]: "typecheck_patn (PairPat p1 p2) t gam"
inductive_cases [elim!]: "typecheck_patn (InLPat p) t gam"
inductive_cases [elim!]: "typecheck_patn (InRPat p) t gam"

inductive typecheck :: "type env => expr => type => bool"
      and typecheck_rules :: "type env => type => rule list => type => bool"
      and typecheck_rule :: "type env => type => rule => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck gam (Var x) t"
    | tc_zero [simp]: "typecheck gam Zero Nat"
    | tc_suc [simp]: "typecheck gam e Nat ==> typecheck gam (Suc e) Nat"
    | tc_rec [simp]: "typecheck gam et Nat ==> typecheck gam e0 t ==>
                typecheck (extend (extend gam t) Nat) es t ==> typecheck gam (Rec et e0 es) t"
    | tc_lam [simp]: "typecheck (extend gam t1) e t2 ==> typecheck gam (Lam t1 e) (Arrow t1 t2)"
    | tc_appl [simp]: "typecheck gam e1 (Arrow t2 t) ==> typecheck gam e2 t2 ==>
                typecheck gam (Appl e1 e2) t"
    | tc_triv [simp]: "typecheck gam Triv Unit"
    | tc_pair [simp]: "typecheck gam e1 t1 ==> typecheck gam e2 t2 ==>
                typecheck gam (Pair e1 e2) (Prod t1 t2)"
    | tc_projl [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjL e) t1"
    | tc_projr [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjR e) t2"
    | tc_abort [simp]: "typecheck gam e Void ==> typecheck gam (Abort t e) t"
    | tc_case [simp]: "typecheck gam et (Sum t1 t2) ==> typecheck (extend gam t1) el t ==>
                typecheck (extend gam t2) er t ==> typecheck gam (Case et el er) t"
    | tc_inl [simp]: "typecheck gam e t1 ==> typecheck gam (InL t1 t2 e) (Sum t1 t2)"
    | tc_inr [simp]: "typecheck gam e t2 ==> typecheck gam (InR t1 t2 e) (Sum t1 t2)"
    | tc_match [simp]: "typecheck gam e t1 ==> typecheck_rules gam t1 rs t ==>
                satisfies_all (rules_constraint rs) ==> typecheck gam (Match e rs) t"
    | tc_rules_nil [simp]: "typecheck_rules gam t1 [] t"
    | tc_rules_cons [simp]: "typecheck_rule gam t1 r t ==> typecheck_rules gam t1 rs t ==>
                typecheck_rules gam t1 (r # rs) t"
    | tc_rule [simp]: "typecheck_patn p t1 gam1 ==> typecheck (gam1 +++ gam) e t ==>
                typecheck_rule gam t1 (Rule p e) t"

inductive_cases [elim!]: "typecheck gam (Var x) t"
inductive_cases [elim!]: "typecheck gam Zero t"
inductive_cases [elim!]: "typecheck gam (Suc e) t"
inductive_cases [elim!]: "typecheck gam (Rec et e0 es) t"
inductive_cases [elim!]: "typecheck gam (Lam t1 e) t"
inductive_cases [elim!]: "typecheck gam (Appl e1 e2) t"
inductive_cases [elim!]: "typecheck gam Triv t"
inductive_cases [elim!]: "typecheck gam (Pair e1 e2) t"
inductive_cases [elim!]: "typecheck gam (ProjL e) t"
inductive_cases [elim!]: "typecheck gam (ProjR e) t"
inductive_cases [elim!]: "typecheck gam (Abort t1 e) t"
inductive_cases [elim!]: "typecheck gam (Case et el er) t"
inductive_cases [elim!]: "typecheck gam (InL t1 t2 e) t"
inductive_cases [elim!]: "typecheck gam (InR t1 t2 e) t"
inductive_cases [elim!]: "typecheck gam (Match e rs) t"
inductive_cases [elim!]: "typecheck_rules gam t1 [] t"
inductive_cases [elim!]: "typecheck_rules gam t1 (r # rs) t"
inductive_cases [elim!]: "typecheck_rule gam t1 (Rule p e) t"

inductive typecheck_subst :: "type env => substitution => type env => bool"
where tc_sub_nil [simp]: "typecheck_subst gam [] empty_env"
    | tc_sub_cons [simp]: "typecheck gam e t ==> typecheck_subst gam es sig ==>
          typecheck_subst gam (e # es) (extend sig t)"

inductive_cases [elim!]: "typecheck_subst g [] sig"
inductive_cases [elim!]: "typecheck_subst g (e # es) sig"

lemma [simp]: "typecheck gam e t ==> n in gam ==> typecheck (extend_at n gam t') (insert n e) t"
  and [simp]: "typecheck_rules gam tt rs t ==> n in gam ==>
         typecheck_rules (extend_at n gam t') tt (insert_rules n rs) t"
  and [simp]: "typecheck_rule gam tt r t ==> n in gam ==>
         typecheck_rule (extend_at n gam t') tt (insert_rule n r) t"
proof (induction gam e t and gam tt rs t and gam tt r t arbitrary: n and n and n
       rule: typecheck_typecheck_rules_typecheck_rule.inducts, fastforce+)
case (tc_rule p t1 sig gam e t)
  hence "(next_by (env_size sig) n) in (sig +++ gam)" by simp
  with tc_rule show ?case by fastforce
qed

lemma [simp]: "typecheck gam e t ==> typecheck (sig +++ gam) (mult_insert (env_size sig) e) t"
proof (induction "env_size sig" arbitrary: sig)
case 0
  hence "sig = empty_env" by auto
  with 0 show ?case by simp
next case (Suc n)
  from Suc have "env_size sig = Nat.Suc n" by simp
  hence "EX sig' s. sig = extend sig' s & env_size sig' = n" by fast
  then obtain sig' s where SDEF: "sig = extend sig' s & env_size sig' = n" by fast
  with Suc have "typecheck (sig' +++ gam) (mult_insert n e) t" by fast
  hence "typecheck (extend sig' s +++ gam) (insert first (mult_insert n e)) t" by simp
  with Suc SDEF show ?case by (metis mult_insert.simps(2))
qed

lemma [simp]: "typecheck (extend_at n gam t') e t ==> n in gam ==> typecheck gam e' t' ==>
                  typecheck gam (subst e' n e) t"
  and [simp]: "typecheck_rules (extend_at n gam t') tt rs t ==> n in gam ==>
                  typecheck gam e' t' ==> typecheck_rules gam tt (subst_rules e' n rs) t"
  and [simp]: "typecheck_rule (extend_at n gam t') tt r t ==> n in gam ==> typecheck gam e' t' ==>
                  typecheck_rule gam tt (subst_rule e' n r) t"
by (induction "extend_at n gam t'" e t and "extend_at n gam t'" tt rs t
          and "extend_at n gam t'" tt r t
    arbitrary: n gam t' e' and n gam t' e' and n gam t' e'
    rule: typecheck_typecheck_rules_typecheck_rule.inducts, fastforce+)

lemma [simp]: "typecheck_subst gam s sig ==> length s = env_size sig"
by (induction gam s sig rule: typecheck_subst.induct, simp_all)

lemma [simp]: "typecheck_subst gg s g ==> typecheck_subst gg s' g' ==>
        typecheck_subst gg (s @ s') (g +++ g')"
by (induction s g rule: typecheck_subst.induct, simp_all)

lemma [simp]: "typecheck_subst gam s sig ==> typecheck (sig +++ gam) e t ==>
        typecheck gam (apply_subst s e) t"
by (induction gam s sig arbitrary: e rule: typecheck_subst.induct, simp_all)

lemma [simp]: "matches p e s ==> typecheck gam e t1 ==> typecheck_patn p t1 sig ==>
        typecheck_subst gam s sig"
by (induction p e s arbitrary: gam t1 sig rule: matches.induct, auto)

end


theory T25
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=7,timeout=86400]
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_ZF 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]=>i"  where
   "ordermap(A,r) == \<lambda>x\<in>A. wfrec[A](r, x, %x f. f `` pred(A,x,r))"

definition
  ordertype :: "[i,i]=>i"  where
   "ordertype(A,r) == ordermap(A,r)``A"

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

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

definition
  (*ordinal multiplication*)
  omult      :: "[i,i]=>i"           (infixl "**" 70)  where
   "i ** j == ordertype(j*i, rmult(j,Memrel(j),i,Memrel(i)))"

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

definition
  oadd      :: "[i,i]=>i"           (infixl "++" 65)  where
    "i ++ j == raw_oadd(ordify(i),ordify(j))"

definition
  (*ordinal subtraction*)
  odiff      :: "[i,i]=>i"           (infixl "--" 65)  where
    "i -- j == 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 ==> 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) ==> 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 ==> 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 ==> pred(A, x, Memrel(A)) = A \<inter> x"
by (unfold pred_def Memrel_def, blast)

lemma Ord_iso_implies_eq_lemma:
     "[| j<i;  f \<in> ord_iso(i,Memrel(i),j,Memrel(j)) |] ==> R"
apply (frule lt_pred_Memrel)
apply (erule ltE)
apply (rule well_ord_Memrel [THEN well_ord_iso_predE, of i f j], auto)
apply (unfold 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:
     "[| Ord(i);  Ord(j);  f \<in> ord_iso(i,Memrel(i),j,Memrel(j)) |]
      ==> 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)"
apply (unfold 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:
    "[| wf[A](r);  x \<in> A |]
     ==> ordermap(A,r) ` x = ordermap(A,r) `` pred(A,x,r)"
apply (unfold 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:
     "[| wf[A](r);  x \<in> A |]
      ==> 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

[| wf[A](r); x \<in> A |]
==> ordermap(A,r) ` x = {ordermap(A,r) ` y . y: {y \<in> A . <y,x> \<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 . <y,x> \<in> r}},

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

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

lemma Ord_ordermap:
    "[| well_ord(A,r);  x \<in> A |] ==> 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])
apply (unfold pred_def Transset_def)
apply (blast intro: trans_onD
             dest!: ordermap_unfold [THEN equalityD1])+
done

lemma Ord_ordertype:
    "well_ord(A,r) ==> Ord(ordertype(A,r))"
apply (unfold 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)
apply (unfold 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:
     "[| <w,x>: r;  wf[A](r);  w \<in> A; x \<in> A |]
      ==> 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:
    "[| ordermap(A,r)`w \<in> ordermap(A,r)`x;  well_ord(A,r); w \<in> A; x \<in> A |]
     ==> <w,x>: 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) ==> ordermap(A,r) \<in> bij(A, ordertype(A,r))"
apply (unfold 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)
  ==> ordermap(A,r) \<in> ord_iso(A,r, ordertype(A,r), Memrel(ordertype(A,r)))"
apply (unfold 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:
     "[| f \<in> ord_iso(A,r,B,s);  well_ord(B,s) |]
      ==> 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:
     "[| ordertype(A,r) = ordertype(B,s); well_ord(A,r);  well_ord(B,s) |]
      ==> \<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 ==> 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) ==> 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:  [| f \<in> bij(A,B);  well_ord(B,s) |] ==>
                         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:
     "[| well_ord(A,r);  y \<in> A;  z \<in> pred(A,y,r) |]
      ==> 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}"
apply (unfold 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: "[| well_ord(A,r);  x \<in> A |] ==>
          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:
     "[| well_ord(A,r);  x \<in> A |]
      ==> 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)
      ==> 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) ==> Ord_alt(i)"
apply (unfold 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) ==> 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(%x. x, %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) ==> 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(%x. x, %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) ==> 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 ==> (\<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)))"
apply (unfold pred_def)
apply (rule_tac d = "case (%x. x, %y. y) " in lam_bijective)
apply auto
done

lemma ordertype_pred_Inl_eq:
     "[| a \<in> A;  well_ord(A,r) |]
      ==> 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 ==>
         id(A+pred(B,b,s))
         \<in> bij(A+pred(B,b,s), pred(A+B, Inr(b), radd(A,r,B,s)))"
apply (unfold pred_def id_def)
apply (rule_tac d = "%z. z" in lam_bijective, auto)
done

lemma ordertype_pred_Inr_eq:
     "[| b \<in> B;  well_ord(A,r);  well_ord(B,s) |]
      ==> 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: "[|Ord(i); Ord(j)|] ==> 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) ==> 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) ==> i++0 = i"
apply (simp (no_asm_simp) add: oadd_def raw_oadd_0 ordify_def)
done

lemma raw_oadd_0_left: "Ord(i) ==> 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) ==> 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: "[|Ord(i); Ord(j)|] ==> 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 ==> 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 ==> i \<le> k"} *)
lemma oadd_le_self: "Ord(i) ==> 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 ==> 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:
     "[| f \<in> ord_iso(A,Memrel(B),C,r); A<=B |] ==> 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:
     "[| f \<in> ord_iso(i, Memrel(i), Order.pred(A,a,r), r);  a \<in> A; j < i;
       trans[A](r) |]
      ==> 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:
     "[| f \<in> ord_iso(Order.pred(A,a,r), r, i, Memrel(i));  a \<in> A;
       j < i; trans[A](r) |]
      ==> 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:
     "[| well_ord(A,r);  k<j |]
      ==> 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 ==> 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: "[| i++j < i++k;  Ord(j) |] ==> 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) ==> i++j < i++k \<longleftrightarrow> j<k"
by (blast intro!: oadd_lt_mono2 dest!: oadd_lt_cancel2)

lemma oadd_inject: "[| i++j = i++k;  Ord(j); Ord(k) |] ==> 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 ==> 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: "[| Ord(i);  Ord(j) |] ==> 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) ==> 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) ==> 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:
     "[| !!x. x \<in> A ==> Ord(j(x));  a \<in> A |]
      ==> 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) ==> 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: "[| Ord(i); Ord(j) |] ==> (i ++ j) = 0 \<longleftrightarrow> i=0 & 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: "[| Ord(i); Ord(j) |] ==> 0 < (i ++ j) \<longleftrightarrow> 0<i | 0<j"
by (simp add: Ord_0_lt_iff [symmetric] oadd_eq_0_iff)

lemma oadd_LimitI: "[| Ord(i); Limit(j) |] ==> 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) ==> 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 ==> 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: "[| i' \<le> i;  j'<j |] ==> i'++j' < i++j"
by (blast intro: lt_trans1 oadd_le_mono1 oadd_lt_mono2 Ord_succD elim: ltE)

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

lemma oadd_le_iff2: "[| Ord(j); Ord(k) |] ==> 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: "[| Ord(i);  0<j |] ==> 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) ==> \<exists>k. i<k & 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: "[|Ord(i); Ord(j)|] ==> \<exists>k. i<k & j<k & 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 "ordertype(j-i, Memrel(j))"}.
    It's probably simpler to define the difference recursively!\<close>

lemma bij_sum_Diff:
     "A<=B ==> (\<lambda>y\<in>B. if(y \<in> A, Inl(y), Inr(y))) \<in> bij(B, A+(B-A))"
apply (rule_tac d = "case (%x. x, %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 ==>
            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]:
    "[| Ord(i);  Ord(j) |] ==> Ord(i--j)"
apply (unfold odiff_def)
apply (blast intro: Ord_ordertype Diff_subset well_ord_subset well_ord_Memrel)
done

lemma raw_oadd_ordertype_Diff:
   "i \<le> j
    ==> 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 ==> 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  ==>  j = k--i.  *)
lemma odiff_oadd_inverse: "[| Ord(i); Ord(j) |] ==> (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: "[| i<j;  k \<le> i |] ==> 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]:
    "[| Ord(i);  Ord(j) |] ==> Ord(i**j)"
apply (unfold 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:
 "[| a \<in> A;  b \<in> B |] ==> pred(A*B, <a,b>, 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:
     "[| a \<in> A;  b \<in> B;  well_ord(A,r);  well_ord(B,s) |] ==>
         ordertype(pred(A*B, <a,b>, 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:
    "[| i'<i;  j'<j |]
     ==> 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')"
apply (unfold 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:
 "[| Ord(i);  Ord(j);  k<j**i |]
  ==> \<exists>j' i'. k = j**i' ++ j' & j'<j & i'<i"
apply (unfold 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:
     "[| j'<j;  i'<i |] ==> j**i' ++ j'  <  j**i"
apply (unfold 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:
     "[| Ord(i);  Ord(j) |] ==> 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"
apply (unfold omult_def)
apply (simp (no_asm_simp))
done

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

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

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

lemma omult_1_left [simp]: "Ord(i) ==> 1**i = i"
apply (unfold omult_def)
apply (rule_tac s1="Memrel(i)"
       in ord_isoI [THEN ordertype_eq, THEN trans])
apply (rule_tac c = fst and d = "%z.<z,0>" 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:
     "[| Ord(i);  Ord(j);  Ord(k) |] ==> 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: "[| Ord(i);  Ord(j) |] ==> 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:
    "[| Ord(i);  Ord(j);  Ord(k) |] ==> (i**j)**k = i**(j**k)"
apply (unfold 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:
     "[| Ord(i);  !!x. x \<in> A ==> Ord(j(x)) |]
      ==> 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: "[| Ord(i);  Limit(j) |] ==> 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 "[| 0<i;  0<j |] ==> 0 < i**j" *)
lemma lt_omult1: "[| k<i;  0<j |] ==> k < i**j"
apply (safe elim!: ltE intro!: ltI Ord_omult)
apply (force simp add: omult_unfold)
done

lemma omult_le_self: "[| Ord(i);  0<j |] ==> 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: "[| k<j;  0<i |] ==> 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: "[| k \<le> j;  Ord(i) |] ==> 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: "[| i' \<le> i;  j' \<le> j |] ==> i'**j' \<le> i**j"
by (blast intro: le_trans omult_le_mono1 omult_le_mono2 Ord_succD elim: ltE)

lemma omult_lt_mono: "[| i' \<le> i;  j'<j;  0<i |] ==> 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: "[| i**j = i**k;  0<i;  Ord(j);  Ord(k) |] ==> 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 Lt}\<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


theory better imports FOL
begin

subsection \<open>Signature\<close>

declare [[eta_contract = false]]

typedecl i
instance i :: "term" ..

axiomatization mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<in>\<close> 50)  \<comment> \<open>membership relation\<close>
abbreviation not_mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<notin>\<close> 50)  \<comment> \<open>negated membership relation\<close>
  where "x \<notin> y \<equiv> \<not> (x \<in> y)"

definition Subset :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<subseteq>\<close> 50)  \<comment> \<open>subset relation\<close>
  where subset_def: "A \<subseteq> B \<equiv> \<forall>x. (x\<in>A \<longrightarrow> x\<in>B)"

lemma subsetI [intro!]:
    "(!!x. x\<in>A ==> x\<in>B) ==> A \<subseteq> B"
by (simp add: subset_def)

axiomatization
where
  axext:     "A \<subseteq> B \<and> B \<subseteq> A \<longrightarrow> A = B"

definition One :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close> (binder \<open>!\<close> 10)
  where one_def: \<open>(!m. P(m)) \<equiv> (\<forall>x1.\<forall>x2.(P(x1)\<and>P(x2)\<longrightarrow>x1=x2))\<close>

definition Eno :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close> (binder \<open>my?\<close> 10)
  where Eno_def: \<open>(my?m. P(m)) \<equiv> (\<exists>x1.\<exists>x2.(\<not>P(x1)\<and>\<not>P(x2)\<and>x1\<noteq>x2))\<close>

definition ExOne :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close> (binder \<open>my\<exists>!\<close> 10)
  where exone_def: \<open>(my\<exists>!m. P(m)) \<equiv> (\<exists>m. P(m))\<and>(!m. P(m))\<close>

definition AllEno :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close> (binder \<open>\<forall>?\<close> 10)
  where alleno_def: \<open>(\<forall>?m. P(m)) \<equiv> (\<forall>m. P(m))\<or>(my?m. P(m))\<close>

(*
axiomatization
  One :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>!\<close> 10)(* and
  Ex :: \<open>('a \<Rightarrow> o) \<Rightarrow> o\<close>  (binder \<open>\<exists>\<close> 10)*)
where
  oneI: \<open>(\<forall>x1.\<forall>x2.(P(x1)\<and>P(x2)\<longrightarrow>x1=x2)) \<Longrightarrow> (!m. P(m))\<close>
*)
axiomatization
where
  axpair: \<open>\<forall>x.\<forall>y.\<exists>p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close>

theorem pairone : \<open>\<forall>x.\<forall>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close>
  apply(rule allI)
  apply(rule allI)
  apply(rule ex1I)
   apply(rule exE)

    apply(rule spec)
    apply(rule spec)
    apply(rule axpair)
(*  apply assumption

   apply(rule allI)
   apply(rule iffI)
*)
  oops

(*theorem t000 : \<open>\<And>x.\<And>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close>*)
theorem t000 : \<open>\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close>
proof (rule rev_mp)
(*  fix x
  fix y*)
  have \<open>\<forall>xa. \<forall>ya. \<exists>p. \<forall>z. z \<in> p \<longleftrightarrow> z = xa \<or> z = ya\<close> by (rule axpair)
  then have \<open>\<forall>ya. \<exists>p. \<forall>z. z \<in> p \<longleftrightarrow> z = x \<or> z = ya\<close> by (rule spec)
  then show \<open>\<exists>p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close> by (rule spec)
next
(*  fix x
  fix y *)
  show \<open>(\<exists>p. \<forall>z. z \<in> p \<longleftrightarrow> z = x \<or> z = y)\<longrightarrow>(\<exists>!p. \<forall>z. z \<in> p \<longleftrightarrow> z = x \<or> z = y)\<close>
  proof(rule impI)
    show \<open> \<exists>p. \<forall>z. z \<in> p \<longleftrightarrow>
            z = x \<or> z = y \<Longrightarrow>
    \<exists>!p. \<forall>z. z \<in> p \<longleftrightarrow> z = x \<or> z = y\<close>
    proof(erule exE)
      show\<open>\<And>p. \<forall>z. z \<in> p \<longleftrightarrow>
             z = x \<or> z = y \<Longrightarrow>
         \<exists>!p. \<forall>z. z \<in> p \<longleftrightarrow>
                  z = x \<or> z = y\<close>
      proof(rule ex1I)
        fix p
        assume \<open>\<forall>z. z \<in> p \<longleftrightarrow> z = x \<or> z = y\<close>
        then show \<open>\<forall>z. z \<in> p \<longleftrightarrow> z = x \<or> z = y\<close> by assumption
      next
        fix p1 p2
        assume H1:\<open>\<forall>z. z \<in> p1 \<longleftrightarrow> z = x \<or> z = y\<close>
        assume H2:\<open>\<forall>z. z \<in> p2 \<longleftrightarrow> z = x \<or> z = y\<close>
        show \<open>p1=p2\<close>
        proof(rule mp[OF axext])
          show \<open>p1 \<subseteq> p2 \<and> p2 \<subseteq> p1\<close>
          proof(rule conjI)
            show \<open>p1 \<subseteq> p2\<close>
            proof(rule subsetI)
              fix q
              assume aq:\<open>q \<in> p1\<close>
              from H1 have h1: \<open>q \<in> p1 \<longleftrightarrow> q = x \<or> q = y\<close> by (rule spec)
              from H2 have h2: \<open>q \<in> p2 \<longleftrightarrow> q = x \<or> q = y\<close> by (rule spec)
              from h1 and aq have bq:\<open>q = x \<or> q = y\<close> by (rule iffD1)
              from h2 and bq show \<open>q \<in> p2\<close> by (rule iffD2)
            qed
          next
            show \<open>p2 \<subseteq> p1\<close>
            proof(rule subsetI)
              fix q
              assume aq:\<open>q \<in> p2\<close>
              from H1 have h1: \<open>q \<in> p1 \<longleftrightarrow> q = x \<or> q = y\<close> by (rule spec)
              from H2 have h2: \<open>q \<in> p2 \<longleftrightarrow> q = x \<or> q = y\<close> by (rule spec)
              from h2 and aq have bq:\<open>q = x \<or> q = y\<close> by (rule iffD1)
              from h1 and bq show \<open>q \<in> p1\<close> by (rule iffD2)
            qed
          qed
        qed
      qed
    qed
  qed
qed

theorem pairone : \<open>\<forall>x.\<forall>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close>
proof -
  have c:\<open>\<And>x.\<And>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close> by (rule t000)
  from c have c:\<open>\<And>x.\<forall>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close> by (rule allI)
  from c have c:\<open>\<forall>x.\<forall>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close> by (rule allI)
  show \<open>\<forall>x.\<forall>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close> by (rule c)
qed

definition df_pair :: "[i, i, i] \<Rightarrow> o"
  where "df_pair \<equiv> \<lambda>p.\<lambda>a.\<lambda>b.(\<forall>z.(z\<in>p\<longleftrightarrow>(z=a\<or>z=b)))"

theorem pairone2 : \<open>\<forall>x.\<forall>y.\<exists>!p. df_pair(p,x,y)\<close>
  by (unfold df_pair_def, rule pairone)

(* Extension by definition: we can introduce new functional symbol because
the theorem "pairone" was proved. *)
axiomatization
  Pair :: "[i, i] \<Rightarrow> i"  (\<open>{_,_}\<close> [90] 90)
  where Pair_def : "x \<in> {a, b} \<equiv> ((x=a)\<or>(x=b))"

axiomatization
  Union :: "i \<Rightarrow> i"  (\<open>\<Union>_\<close> [90] 90)

(* preliminaries *)
definition Ind :: \<open>i\<Rightarrow>o\<close>
  where Ind_def : \<open>Ind(x) == 0 \<in> x \<and> (\<forall>y\<in>x. succ(y) \<in> x)\<close>
(*
proof -
  show q:\<open>\<forall>x.\<forall>y.\<exists>!p. df_pair(p,x,y)\<close>
  proof (unfold df_pair_def, rule pairone)
  qed
qed

  (*have w:\<open>\<forall>x.\<forall>y.\<exists>!p.\<forall>z.(z\<in>p\<longleftrightarrow>(z=x\<or>z=y))\<close> by (rule pairone) *)
(*  have \<open>df_pair(x)\<longleftrightarrow>\<close>*)

  show \<open>\<forall>x.\<forall>y.\<exists>!p. df_pair(p,x,y)\<close>
  proof
    by assumption
(*  where "df_pair \<equiv> \<lambda>x.\<lambda>a.\<lambda>b.(x=a\<or>x=b)" *)
*)

end


section {* \isaheader{Hashable Interface} *}
theory Intf_Hash
imports
    Main
    "../../Lib/HashCode"
    "../../../Automatic_Refinement/Automatic_Refinement"
begin

type_synonym 'a eq = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'k bhc = "nat \<Rightarrow> 'k \<Rightarrow> nat"

subsection {* Abstract and concrete hash functions *}

definition is_bounded_hashcode :: "('c\<times>'a) set \<Rightarrow> 'c eq \<Rightarrow> 'c bhc \<Rightarrow> bool"
  where "is_bounded_hashcode R eq bhc \<equiv>
             ((eq,op =) \<in> R \<rightarrow> R \<rightarrow> bool_rel) \<and>
             (\<forall>n x y. eq x y \<longrightarrow> bhc n x = bhc n y) \<and>
             (\<forall>n x. 1 < n \<longrightarrow> bhc n x < n)"
definition abstract_bounded_hashcode :: "('c\<times>'a) set \<Rightarrow> 'c bhc \<Rightarrow> 'a bhc"
  where "abstract_bounded_hashcode Rk bhc n x' \<equiv>
             if x' \<in> Range Rk
                 then THE c. \<exists>x. (x,x') \<in> Rk \<and> bhc n x = c
                 else 0"

lemma is_bounded_hashcodeI[intro]:
  "((eq,op =) \<in> R \<rightarrow> R \<rightarrow> bool_rel) \<Longrightarrow>
   (\<And>x y n. eq x y \<Longrightarrow> bhc n x = bhc n y) \<Longrightarrow>
   (\<And>x n. 1 < n \<Longrightarrow> bhc n x < n) \<Longrightarrow> is_bounded_hashcode R eq bhc"
  unfolding is_bounded_hashcode_def by force

lemma is_bounded_hashcodeD[dest]:
  assumes "is_bounded_hashcode R eq bhc"
  shows "(eq,op =) \<in> R \<rightarrow> R \<rightarrow> bool_rel" and
        "\<And>n x y. eq x y \<Longrightarrow> bhc n x = bhc n y" and
        "\<And>n x. 1 < n \<Longrightarrow> bhc n x < n"
  using assms unfolding is_bounded_hashcode_def by simp_all

lemma bounded_hashcode_welldefined:
  assumes BHC: "is_bounded_hashcode Rk eq bhc" and
          R1: "(x1,x') \<in> Rk" and R2: "(x2,x') \<in> Rk"
  shows "bhc n x1 = bhc n x2"
proof-
  from is_bounded_hashcodeD[OF BHC] have "(eq,op =) \<in> Rk \<rightarrow> Rk \<rightarrow> bool_rel" by simp
  with R1 R2 have "eq x1 x2" by (force dest: fun_relD)
  thus ?thesis using BHC by blast
qed

lemma abstract_bhc_correct[intro]:
  assumes "is_bounded_hashcode Rk eq bhc"
  shows "(bhc, abstract_bounded_hashcode Rk bhc) \<in>
      nat_rel \<rightarrow> Rk \<rightarrow> nat_rel" (is "(bhc, ?bhc') \<in> _")
proof (intro fun_relI)
  fix n n' x x'
  assume A: "(n,n') \<in> nat_rel" and B: "(x,x') \<in> Rk"
  hence C: "n = n'" and D: "x' \<in> Range Rk" by auto
  have "?bhc' n' x' = bhc n x"
      unfolding abstract_bounded_hashcode_def
      apply (simp add: C D, rule)
      apply (intro exI conjI, fact B, rule refl)
      apply (elim exE conjE, hypsubst,
          erule bounded_hashcode_welldefined[OF assms _ B])
      done
  thus "(bhc n x, ?bhc' n' x') \<in> nat_rel" by simp
qed

lemma abstract_bhc_is_bhc[intro]:
  fixes Rk :: "('c\<times>'a) set"
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  shows "is_bounded_hashcode Id op= (abstract_bounded_hashcode Rk bhc)"
      (is "is_bounded_hashcode _ op= ?bhc'")
proof
  fix x'::'a and y'::'a and n'::nat assume "x' = y'"
  thus "?bhc' n' x' = ?bhc' n' y'" by simp
next
  fix x'::'a and n'::nat assume "1 < n'"
  from abstract_bhc_correct[OF bhc] show "?bhc' n' x' < n'"
  proof (cases "x' \<in> Range Rk")
    case False
      with `1 < n'` show ?thesis
          unfolding abstract_bounded_hashcode_def by simp
  next
    case True
      then obtain x where "(x,x') \<in> Rk" ..
      have "(n',n') \<in> nat_rel" ..
      from abstract_bhc_correct[OF assms] have "?bhc' n' x' = bhc n' x"
        apply -
        apply (drule fun_relD[OF _ `(n',n') \<in> nat_rel`],
               drule fun_relD[OF _ `(x,x') \<in> Rk`], simp)
        done
      also from `1 < n'` and bhc have "... < n'" by blast
      finally show "?bhc' n' x' < n'" .
  qed
qed simp

(*lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "\<lbrakk>STRUCT_EQ_tag eq op=; REL_IS_ID R\<rbrakk> \<Longrightarrow> is_bounded_hashcode R eq bounded_hashcode"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_bounds)*)

(* TODO: This is a hack that causes the relation to be instantiated to Id, if it is not
    yet fixed! *)
lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "\<lbrakk>STRUCT_EQ_tag eq op=; REL_FORCE_ID R\<rbrakk> \<Longrightarrow> is_bounded_hashcode R eq bounded_hashcode_nat"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_nat_bounds)

subsection {* Default hash map size *}

definition is_valid_def_hm_size :: "'k itself \<Rightarrow> nat \<Rightarrow> bool"
    where "is_valid_def_hm_size type n \<equiv> n > 1"

lemma hashable_def_size_is_def_size[autoref_ga_rules]:
  shows "is_valid_def_hm_size TYPE('k::hashable) (def_hashmap_size TYPE('k))"
    unfolding is_valid_def_hm_size_def by (fact def_hashmap_size)

end


(* Positive paradox of material implication*)

theory Week1

imports Main

begin

(*If-Introduction*)

print_statement impI (*thm impI*)

lemma "A \<longrightarrow> A"
proof (rule impI)
  assume A (*assuming the antecedent*)
  then show A.
qed

(*Paradox of Material Implication*)

lemma positive_paradox : "A \<longrightarrow> (B \<longrightarrow> A)"
proof (rule impI)
  assume A
  show "B \<longrightarrow> A"
  proof (rule impI)
    assume B (*irrelevant*)
    from `A` show A. (* 'from `A`' can be abb. as 'then' *)
  qed
qed

(*2.1 Exercise*)

lemma "A \<longrightarrow> B \<longrightarrow> B"
proof(rule impI)
  assume A (*irrelevant*)
  show "B \<longrightarrow> B"
  proof (rule impI)
    assume B
    then show B.(* 'thus' is an abb. for 'then show' *)
  qed
qed

(*Modus Ponens*)

lemma "A \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> B"
proof(rule impI)
  assume A
  show "(A \<longrightarrow> B) \<longrightarrow> B"
  proof
    assume "(A \<longrightarrow> B)"
    then show  B using `A` by (rule mp)
  qed
qed

(*3.1 Exercise*)

print_statement mp

lemma contraction: "(A \<longrightarrow> A \<longrightarrow> B) \<longrightarrow> (A \<longrightarrow> B)"
proof (rule impI)
  assume "(A \<longrightarrow> A \<longrightarrow> B)"
  show  "(A \<longrightarrow> B)"
  proof (rule impI)
    assume A
    with `A \<longrightarrow> A \<longrightarrow> B` have "(A \<longrightarrow> B)" by (rule mp) (*get the consequent () for further use*)
    thus B using `A` by (rule mp)
    qed
  qed

(* EXERCISES *)

(*1*)
lemma mingle: "A \<longrightarrow> A \<longrightarrow> A"

proof (rule impI)
  assume A
  show "A \<longrightarrow> A"
  proof
    assume A
    from `A` show A. (*A from line 2 used.*)
(* To use A from line 5, type `thus A.`
In either case, one of the A's will be unused, hence not sound.*)
    qed
  qed

(*2*)
lemma prefixing: "(A \<longrightarrow> B) \<longrightarrow> (C \<longrightarrow> A) \<longrightarrow> (C \<longrightarrow> B)"
proof (rule impI)
  assume "(A \<longrightarrow> B)"
  show "(C \<longrightarrow> A) \<longrightarrow> (C \<longrightarrow> B)"
  proof (rule impI)
    assume "(C \<longrightarrow> A)"
    show "C \<longrightarrow> B"
    proof
      assume C
      with `(A \<longrightarrow> B)` and `(C \<longrightarrow> A)` have "(C \<longrightarrow> B)" by blast
      thus B using `C` by blast
    qed
  qed
qed

(*3*)
(*NOTE: Solution can be implemented using the method above as well*)
lemma suffixing: "(A \<longrightarrow> B) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C)"
proof (rule impI)
  assume "(A \<longrightarrow> B)"
  show "(B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C)"
  proof (rule impI)
    assume "(B \<longrightarrow> C)"
    show "A \<longrightarrow> C"
    proof
      assume A
      with `(A \<longrightarrow> B)` have B by (rule mp)
      with `(B \<longrightarrow> C)` show C by (rule mp)
    qed
  qed
qed

(*4*)
lemma "(A\<longrightarrow> B\<longrightarrow> C)\<longrightarrow> (B\<longrightarrow> A\<longrightarrow> C)"
proof
  assume "(A\<longrightarrow> B\<longrightarrow> C)"
  show "(B\<longrightarrow> A\<longrightarrow> C)"
  proof
    assume B
    show "(A\<longrightarrow> C)"
      proof
        assume A
        with `(A\<longrightarrow> B\<longrightarrow> C)` have "(B\<longrightarrow> C)" by blast (*rule mp*)
        then show C using `B` by blast (*rule mp*)
      qed
    qed
  qed

(*5*)
lemma hypothetical_syllogism: "(A \<longrightarrow> B) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> C)"
proof (rule Week1.suffixing)
qed

(*Not mentioned*)
lemma "(A\<longrightarrow> B)\<longrightarrow> A\<longrightarrow> C\<longrightarrow> B"
proof(rule impI)
  assume "A \<longrightarrow> B"
  show "A\<longrightarrow> C\<longrightarrow> B"
  proof (rule impI)
    assume A
    show "C\<longrightarrow> B"
    proof (rule impI)
      assume C
      from `A \<longrightarrow> B` have B using `A` by (rule mp)
      from `B` show B.
    qed
  qed
qed

lemma "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> (A \<longrightarrow> C)"
proof (rule impI)
  assume "A\<longrightarrow> B \<longrightarrow> C"
  show "(A \<longrightarrow> B) \<longrightarrow> (A \<longrightarrow> C)"
  proof (rule impI)
    assume "A \<longrightarrow> B"
    show "A \<longrightarrow> C"
    proof (rule impI)
      assume A
      from `A \<longrightarrow> B` have B using `A` by (rule mp)
      from `A\<longrightarrow> B \<longrightarrow>C` have "B\<longrightarrow> C" using `A` by (rule mp)
      thus C using `B` by (rule mp)
    qed
  qed
qed

end


(*  File:       Elimination_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Elimination Module\<close>

theory Elimination_Module
  imports Evaluation_Function
          Electoral_Module
begin

text \<open>
  This is the elimination module. It rejects a set of alternatives only if
  these are not all alternatives. The alternatives potentially to be rejected
  are put in a so-called elimination set. These are all alternatives that score
  below a preset threshold value that depends on the specific voting rule.
\<close>

subsection \<open>Definition\<close>

type_synonym Threshold_Value = nat

type_synonym Threshold_Relation = "nat \<Rightarrow> nat \<Rightarrow> bool"

type_synonym 'a Electoral_Set = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set"

fun elimination_set :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Set" where
 "elimination_set e t r A p = {a \<in> A . r (e a A p) t }"

fun elimination_module :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Module" where
  "elimination_module e t r A p =
      (if (elimination_set e t r A p) \<noteq> A
        then ({}, (elimination_set e t r A p), A - (elimination_set e t r A p))
        else ({},{},A))"

subsection \<open>Common Eliminators\<close>

fun has_majority :: "'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "has_majority p a = (win_count p a > ( length p div 2))"

fun less_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "less_eliminator e t A p = elimination_module e t (<) A p"

fun max_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "max_eliminator e A p =
    less_eliminator e (Max {e x A p | x. x \<in> A}) A p"

fun leq_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "leq_eliminator e t A p = elimination_module e t (\<le>) A p"

fun min_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "min_eliminator e A p =
    leq_eliminator e (Min {e x A p | x. x \<in> A}) A p"

fun average :: "'a Evaluation_Function \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                    Threshold_Value" where
  "average e A p = (\<Sum> x \<in> A. e x A p) div (card A)"

fun less_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "less_average_eliminator e A p = less_eliminator e (average e A p) A p"

fun leq_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "leq_average_eliminator e A p = leq_eliminator e (average e A p) A p"

subsection \<open>Soundness\<close>

lemma elim_mod_sound[simp]: "electoral_module (elimination_module e t r)"
proof (unfold electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  have "set_equals_partition A (elimination_module e t r A p)"
    by auto
  thus "well_formed A (elimination_module e t r A p)"
    by simp
qed

lemma less_elim_sound[simp]: "electoral_module (less_eliminator e t)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < t} \<union> A = A"
    by safe
qed

lemma leq_elim_sound[simp]: "electoral_module (leq_eliminator e t)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> t} \<union> A = A"
    by safe
qed

lemma max_elim_sound[simp]: "electoral_module (max_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < Max {e x A p |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < Max {e x A p |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma min_elim_sound[simp]: "electoral_module (min_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> Min {e x A p |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> Min {e x A p |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma less_avg_elim_sound[simp]: "electoral_module (less_average_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < (\<Sum>x\<in>A. e x A p) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < (\<Sum>x\<in>A. e x A p) div card A} \<union> A = A"
    by safe
qed

lemma leq_avg_elim_sound[simp]: "electoral_module (leq_average_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> (\<Sum>x\<in>A. e x A p) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> (\<Sum>x\<in>A. e x A p) div card A} \<union> A = A"
    by safe
qed

subsection \<open>Non-Electing\<close>

lemma elim_mod_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (elimination_module e t r )"
  unfolding non_electing_def
  by simp

lemma less_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (less_eliminator e t)"
  using elim_mod_non_electing profile less_elim_sound
  unfolding non_electing_def
  by simp

lemma leq_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (leq_eliminator e t)"
  unfolding non_electing_def
  by simp

lemma max_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (max_eliminator e)"
  unfolding non_electing_def
  by simp

lemma min_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (min_eliminator e)"
  unfolding non_electing_def
  by simp

lemma less_avg_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (less_average_eliminator e)"
proof (unfold non_electing_def, safe)
  show "electoral_module (less_average_eliminator e)"
    by simp
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    x :: "'b"
  assume
    fin_A: "finite A" and
    prof_p: "profile A p" and
    elect_x: "x \<in> elect (less_average_eliminator e) A p"
  hence fin_prof: "finite_profile A p"
    by metis
  have "non_electing (less_average_eliminator e)"
    unfolding non_electing_def
    by simp
  hence "{} = elect (less_average_eliminator e) A p"
    using fin_prof
    unfolding non_electing_def
    by metis
  thus "x \<in> {}"
    using elect_x
    by metis
qed

lemma leq_avg_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (leq_average_eliminator e)"
proof (unfold non_electing_def, safe)
  show "electoral_module (leq_average_eliminator e)"
    by simp
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    x :: "'b"
  assume
    fin_A: "finite A" and
    prof_p: "profile A p" and
    elect_x: "x \<in> elect (leq_average_eliminator e) A p"
  hence fin_prof: "finite_profile A p"
    by metis
  have "non_electing (leq_average_eliminator e)"
    unfolding non_electing_def
    by simp
  hence "{} = elect (leq_average_eliminator e) A p"
    using fin_prof
    unfolding non_electing_def
    by metis
  thus "x \<in> {}"
    using elect_x
    by metis
qed

subsection \<open>Inference Rules\<close>

text \<open>
  If the used evaluation function is Condorcet rating,
    max-eliminator is Condorcet compatible.
\<close>

theorem cr_eval_imp_ccomp_max_elim[simp]:
  assumes
    profile: "finite_profile A p" and
    rating: "condorcet_rating e"
  shows "condorcet_compatibility (max_eliminator e)"
proof (unfold condorcet_compatibility_def, safe)
  show "electoral_module (max_eliminator e)"
    by simp
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    w :: "'b"
  assume
    c_win: "condorcet_winner A p w" and
    rej_w: "w \<in> reject (max_eliminator e) A p"
  have "e w A p = Max {e a A p | a. a \<in> A}"
    using c_win cond_winner_imp_max_eval_val rating
    by fastforce
  hence "w \<notin> reject (max_eliminator e) A p"
    by simp
  thus "False"
    using rej_w
    by linarith
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    l :: "'b"
  assume elect_l: "l \<in> elect (max_eliminator e) A p"
  have "l \<notin> elect (max_eliminator e) A p"
    by simp
  thus False
    using elect_l
    by linarith
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    w :: "'b" and
    l :: "'b"
  assume
    "condorcet_winner A p w" and
    "w \<in> elect (max_eliminator e) A p"
  thus "l \<in> reject (max_eliminator e) A p"
    using profile rating condorcet_winner.elims(2)
          empty_iff max_elim_non_electing
    unfolding non_electing_def
    by metis
qed

lemma cr_eval_imp_dcc_max_elim_helper1:
  assumes
    f_prof: "finite_profile A p" and
    rating: "condorcet_rating e" and
    winner: "condorcet_winner A p w"
  shows "elimination_set e (Max {e x A p | x. x \<in> A}) (<) A p = A - {w}"
proof (safe, simp_all, safe)
  assume
    "e w A p < Max {e x A p |x. x \<in> A}"
  thus False
    using cond_winner_imp_max_eval_val
          rating winner f_prof
    by fastforce
next
  fix x :: "'a"
  assume
    x_in_A: "x \<in> A" and
    not_max: "\<not> e x A p < Max {e y A p |y. y \<in> A}"
  show "x = w"
    using non_cond_winner_not_max_eval x_in_A
          rating winner f_prof not_max
    by (metis (mono_tags, lifting))
qed

text \<open>
  If the used evaluation function is Condorcet rating, max-eliminator
  is defer-Condorcet-consistent.
\<close>

theorem cr_eval_imp_dcc_max_elim[simp]:
  assumes rating: "condorcet_rating e"
  shows "defer_condorcet_consistency (max_eliminator e)"
proof (unfold defer_condorcet_consistency_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    finite: "finite A"
  hence profile: "finite_profile A p"
    by simp
  let ?trsh = "(Max {e y A p | y. y \<in> A})"
  show
    "max_eliminator e A p =
      ({},
        A - defer (max_eliminator e) A p,
        {a \<in> A. condorcet_winner A p a})"
  proof (cases "elimination_set e (?trsh) (<) A p \<noteq> A")
    case True
    from profile rating winner
    have 0: "(elimination_set e ?trsh (<) A p) = A - {w}"
      using cr_eval_imp_dcc_max_elim_helper1
      by (metis (mono_tags, lifting))
    have
      "max_eliminator e A p =
        ({},
          (elimination_set e ?trsh (<) A p),
          A - (elimination_set e ?trsh (<) A p))"
      using True
      by simp
    also have "... = ({}, A - {w}, {w})"
      using 0 winner
      by auto
    also have "... = ({},A - defer (max_eliminator e) A p, {w})"
      using calculation
      by simp
    also have
      "... =
        ({},
          A - defer (max_eliminator e) A p,
          {d \<in> A. condorcet_winner A p d})"
      using cond_winner_unique3 winner Collect_cong
      by (metis (no_types, lifting))
    finally show ?thesis
      using finite winner
      by metis
  next
    case False
    have "?trsh = e w A p"
      using rating winner
      by (simp add: cond_winner_imp_max_eval_val)
    thus ?thesis
      using winner False
      by auto
  qed
qed

end


theory Div imports Main
begin

fun div2 :: "nat \<Rightarrow> nat" where
"div2 0 = 0" |
"div2 (Suc 0) = 0" |
"div2 (Suc(Suc n)) = Suc(div2 n)"

lemma "div2(n) = n div 2"
apply(induction n rule: div2.induct)

end


(*  Title:      HOL/Nitpick_Examples/Typedef_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to typedefs.
*)

section \<open>Examples Featuring Nitpick Applied to Typedefs\<close>

theory Typedef_Nits
imports Complex_Main
begin

nitpick_params [verbose, card = 1-4, sat_solver = MiniSat_JNI, max_threads = 1,
                timeout = 240]

definition "three = {0::nat, 1, 2}"
typedef three = three
unfolding three_def by blast

definition A :: three where "A \<equiv> Abs_three 0"
definition B :: three where "B \<equiv> Abs_three 1"
definition C :: three where "C \<equiv> Abs_three 2"

lemma "x = (y::three)"
nitpick [expect = genuine]
oops

definition "one_or_two = {undefined False::'a, undefined True}"

typedef 'a one_or_two = "one_or_two :: 'a set"
unfolding one_or_two_def by auto

lemma "x = (y::unit one_or_two)"
nitpick [expect = none]
sorry

lemma "x = (y::bool one_or_two)"
nitpick [expect = genuine]
oops

lemma "undefined False \<longleftrightarrow> undefined True \<Longrightarrow> x = (y::bool one_or_two)"
nitpick [expect = none]
sorry

lemma "undefined False \<longleftrightarrow> undefined True \<Longrightarrow> \<exists>x (y::bool one_or_two). x \<noteq> y"
nitpick [card = 1, expect = potential] (* unfortunate *)
oops

lemma "\<exists>x (y::bool one_or_two). x \<noteq> y"
nitpick [card = 1, expect = potential] (* unfortunate *)
nitpick [card = 2, expect = none]
oops

definition "bounded = {n::nat. finite (UNIV :: 'a set) \<longrightarrow> n < card (UNIV :: 'a set)}"

typedef 'a bounded = "bounded(TYPE('a))"
unfolding bounded_def
apply (rule_tac x = 0 in exI)
apply (case_tac "card UNIV = 0")
by auto

lemma "x = (y::unit bounded)"
nitpick [expect = none]
sorry

lemma "x = (y::bool bounded)"
nitpick [expect = genuine]
oops

lemma "x \<noteq> (y::bool bounded) \<Longrightarrow> z = x \<or> z = y"
nitpick [expect = potential] (* unfortunate *)
sorry

lemma "x \<noteq> (y::(bool \<times> bool) bounded) \<Longrightarrow> z = x \<or> z = y"
nitpick [card = 1-5, expect = genuine]
oops

lemma "True \<equiv> ((\<lambda>x::bool. x) = (\<lambda>x. x))"
nitpick [expect = none]
by (rule True_def)

lemma "False \<equiv> \<forall>P. P"
nitpick [expect = none]
by (rule False_def)

lemma "() = Abs_unit True"
nitpick [expect = none]
by (rule Unity_def)

lemma "() = Abs_unit False"
nitpick [expect = none]
by simp

lemma "Rep_unit () = True"
nitpick [expect = none]
by (insert Rep_unit) simp

lemma "Rep_unit () = False"
nitpick [expect = genuine]
oops

lemma "Pair a b = Abs_prod (Pair_Rep a b)"
nitpick [card = 1-2, expect = none]
by (rule Pair_def)

lemma "Pair a b = Abs_prod (Pair_Rep b a)"
nitpick [card = 1-2, expect = none]
nitpick [dont_box, expect = genuine]
oops

lemma "fst (Abs_prod (Pair_Rep a b)) = a"
nitpick [card = 2, expect = none]
by (simp add: Pair_def [THEN sym])

lemma "fst (Abs_prod (Pair_Rep a b)) = b"
nitpick [card = 1-2, expect = none]
nitpick [dont_box, expect = genuine]
oops

lemma "a \<noteq> a' \<Longrightarrow> Pair_Rep a b \<noteq> Pair_Rep a' b"
nitpick [expect = none]
apply (rule ccontr)
apply simp
apply (drule subst [where P = "\<lambda>r. Abs_prod r = Abs_prod (Pair_Rep a b)"])
 apply (rule refl)
by (simp add: Pair_def [THEN sym])

lemma "Abs_prod (Rep_prod a) = a"
nitpick [card = 2, expect = none]
by (rule Rep_prod_inverse)

lemma "Inl \<equiv> \<lambda>a. Abs_sum (Inl_Rep a)"
nitpick [card = 1, expect = none]
by (simp add: Inl_def o_def)

lemma "Inl \<equiv> \<lambda>a. Abs_sum (Inr_Rep a)"
nitpick [card = 1, card "'a + 'a" = 2, expect = genuine]
oops

lemma "Inl_Rep a \<noteq> Inr_Rep a"
nitpick [expect = none]
by (rule Inl_Rep_not_Inr_Rep)

lemma "Abs_sum (Rep_sum a) = a"
nitpick [card = 1, expect = none]
nitpick [card = 2, expect = none]
by (rule Rep_sum_inverse)

lemma "0::nat \<equiv> Abs_Nat Zero_Rep"
nitpick [expect = none]
by (rule Zero_nat_def [abs_def])

lemma "Suc n = Abs_Nat (Suc_Rep (Rep_Nat n))"
nitpick [expect = none]
by (rule Nat.Suc_def)

lemma "Suc n = Abs_Nat (Suc_Rep (Suc_Rep (Rep_Nat n)))"
nitpick [expect = genuine]
oops

lemma "Abs_Nat (Rep_Nat a) = a"
nitpick [expect = none]
by (rule Rep_Nat_inverse)

lemma "Abs_list (Rep_list a) = a"
(* nitpick [card = 1-2, expect = none] FIXME *)
by (rule Rep_list_inverse)

record point =
  Xcoord :: int
  Ycoord :: int

lemma "Abs_point_ext (Rep_point_ext a) = a"
nitpick [expect = none]
by (fact Rep_point_ext_inverse)

lemma "Fract a b = of_int a / of_int b"
nitpick [card = 1, expect = none]
by (rule Fract_of_int_quotient)

lemma "Abs_rat (Rep_rat a) = a"
nitpick [card = 1, expect = none]
by (rule Rep_rat_inverse)

typedef check = "{x::nat. x < 2}" by (rule exI[of _ 0], auto)

lemma "Rep_check (Abs_check n) = n \<Longrightarrow> n < 2"
nitpick [card = 1-3, expect = none]
using Rep_check[of "Abs_check n"] by auto

lemma "Rep_check (Abs_check n) = n \<Longrightarrow> n < 1"
nitpick [card = 1-3, expect = genuine]
oops

end