(*  Title:      HOL/Orderings.thy
    Author:     Tobias Nipkow, Markus Wenzel, and Larry Paulson
*)

section {* Abstract orderings *}

theory Orderings
imports HOL
keywords "print_orders" :: diag
begin

ML_file "~~/src/Provers/order.ML"
ML_file "~~/src/Provers/quasi.ML"  (* FIXME unused? *)

subsection {* Abstract ordering *}

locale ordering =
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
   and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<prec>" 50)
  assumes strict_iff_order: "a \<prec> b \<longleftrightarrow> a \<preceq> b \<and> a \<noteq> b"
  assumes refl: "a \<preceq> a" -- {* not @{text iff}: makes problems due to multiple (dual) interpretations *}
    and antisym: "a \<preceq> b \<Longrightarrow> b \<preceq> a \<Longrightarrow> a = b"
    and trans: "a \<preceq> b \<Longrightarrow> b \<preceq> c \<Longrightarrow> a \<preceq> c"
begin

lemma strict_implies_order:
  "a \<prec> b \<Longrightarrow> a \<preceq> b"
  by (simp add: strict_iff_order)

lemma strict_implies_not_eq:
  "a \<prec> b \<Longrightarrow> a \<noteq> b"
  by (simp add: strict_iff_order)

lemma not_eq_order_implies_strict:
  "a \<noteq> b \<Longrightarrow> a \<preceq> b \<Longrightarrow> a \<prec> b"
  by (simp add: strict_iff_order)

lemma order_iff_strict:
  "a \<preceq> b \<longleftrightarrow> a \<prec> b \<or> a = b"
  by (auto simp add: strict_iff_order refl)

lemma irrefl: -- {* not @{text iff}: makes problems due to multiple (dual) interpretations *}
  "\<not> a \<prec> a"
  by (simp add: strict_iff_order)

lemma asym:
  "a \<prec> b \<Longrightarrow> b \<prec> a \<Longrightarrow> False"
  by (auto simp add: strict_iff_order intro: antisym)

lemma strict_trans1:
  "a \<preceq> b \<Longrightarrow> b \<prec> c \<Longrightarrow> a \<prec> c"
  by (auto simp add: strict_iff_order intro: trans antisym)

lemma strict_trans2:
  "a \<prec> b \<Longrightarrow> b \<preceq> c \<Longrightarrow> a \<prec> c"
  by (auto simp add: strict_iff_order intro: trans antisym)

lemma strict_trans:
  "a \<prec> b \<Longrightarrow> b \<prec> c \<Longrightarrow> a \<prec> c"
  by (auto intro: strict_trans1 strict_implies_order)

end

locale ordering_top = ordering +
  fixes top :: "'a"
  assumes extremum [simp]: "a \<preceq> top"
begin

lemma extremum_uniqueI:
  "top \<preceq> a \<Longrightarrow> a = top"
  by (rule antisym) auto

lemma extremum_unique:
  "top \<preceq> a \<longleftrightarrow> a = top"
  by (auto intro: antisym)

lemma extremum_strict [simp]:
  "\<not> (top \<prec> a)"
  using extremum [of a] by (auto simp add: order_iff_strict intro: asym irrefl)

lemma not_eq_extremum:
  "a \<noteq> top \<longleftrightarrow> a \<prec> top"
  by (auto simp add: order_iff_strict intro: not_eq_order_implies_strict extremum)

end

subsection {* Syntactic orders *}

class ord =
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

notation
  less_eq  ("op <=") and
  less_eq  ("(_/ <= _)" [51, 51] 50) and
  less  ("op <") and
  less  ("(_/ < _)"  [51, 51] 50)

notation (xsymbols)
  less_eq  ("op \<le>") and
  less_eq  ("(_/ \<le> _)"  [51, 51] 50)

notation (HTML output)
  less_eq  ("op \<le>") and
  less_eq  ("(_/ \<le> _)"  [51, 51] 50)

abbreviation (input)
  greater_eq  (infix ">=" 50) where
  "x >= y \<equiv> y <= x"

notation (input)
  greater_eq  (infix "\<ge>" 50)

abbreviation (input)
  greater  (infix ">" 50) where
  "x > y \<equiv> y < x"

end

subsection {* Quasi orders *}

class preorder = ord +
  assumes less_le_not_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"
  and order_refl [iff]: "x \<le> x"
  and order_trans: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
begin

text {* Reflexivity. *}

lemma eq_refl: "x = y \<Longrightarrow> x \<le> y"
    -- {* This form is useful with the classical reasoner. *}
by (erule ssubst) (rule order_refl)

lemma less_irrefl [iff]: "\<not> x < x"
by (simp add: less_le_not_le)

lemma less_imp_le: "x < y \<Longrightarrow> x \<le> y"
unfolding less_le_not_le by blast

text {* Asymmetry. *}

lemma less_not_sym: "x < y \<Longrightarrow> \<not> (y < x)"
by (simp add: less_le_not_le)

lemma less_asym: "x < y \<Longrightarrow> (\<not> P \<Longrightarrow> y < x) \<Longrightarrow> P"
by (drule less_not_sym, erule contrapos_np) simp

text {* Transitivity. *}

lemma less_trans: "x < y \<Longrightarrow> y < z \<Longrightarrow> x < z"
by (auto simp add: less_le_not_le intro: order_trans)

lemma le_less_trans: "x \<le> y \<Longrightarrow> y < z \<Longrightarrow> x < z"
by (auto simp add: less_le_not_le intro: order_trans)

lemma less_le_trans: "x < y \<Longrightarrow> y \<le> z \<Longrightarrow> x < z"
by (auto simp add: less_le_not_le intro: order_trans)

text {* Useful for simplification, but too risky to include by default. *}

lemma less_imp_not_less: "x < y \<Longrightarrow> (\<not> y < x) \<longleftrightarrow> True"
by (blast elim: less_asym)

lemma less_imp_triv: "x < y \<Longrightarrow> (y < x \<longrightarrow> P) \<longleftrightarrow> True"
by (blast elim: less_asym)

text {* Transitivity rules for calculational reasoning *}

lemma less_asym': "a < b \<Longrightarrow> b < a \<Longrightarrow> P"
by (rule less_asym)

text {* Dual order *}

lemma dual_preorder:
  "class.preorder (op \<ge>) (op >)"
proof qed (auto simp add: less_le_not_le intro: order_trans)

end

subsection {* Partial orders *}

class order = preorder +
  assumes antisym: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
begin

lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
  by (auto simp add: less_le_not_le intro: antisym)

sublocale order!: ordering less_eq less +  dual_order!: ordering greater_eq greater
  by default (auto intro: antisym order_trans simp add: less_le)

text {* Reflexivity. *}

lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x = y"
    -- {* NOT suitable for iff, since it can cause PROOF FAILED. *}
by (fact order.order_iff_strict)

lemma le_imp_less_or_eq: "x \<le> y \<Longrightarrow> x < y \<or> x = y"
unfolding less_le by blast

text {* Useful for simplification, but too risky to include by default. *}

lemma less_imp_not_eq: "x < y \<Longrightarrow> (x = y) \<longleftrightarrow> False"
by auto

lemma less_imp_not_eq2: "x < y \<Longrightarrow> (y = x) \<longleftrightarrow> False"
by auto

text {* Transitivity rules for calculational reasoning *}

lemma neq_le_trans: "a \<noteq> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
by (fact order.not_eq_order_implies_strict)

lemma le_neq_trans: "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a < b"
by (rule order.not_eq_order_implies_strict)

text {* Asymmetry. *}

lemma eq_iff: "x = y \<longleftrightarrow> x \<le> y \<and> y \<le> x"
by (blast intro: antisym)

lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x = y"
by (blast intro: antisym)

lemma less_imp_neq: "x < y \<Longrightarrow> x \<noteq> y"
by (fact order.strict_implies_not_eq)

text {* Least value operator *}

definition (in ord)
  Least :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" (binder "LEAST " 10) where
  "Least P = (THE x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<le> y))"

lemma Least_equality:
  assumes "P x"
    and "\<And>y. P y \<Longrightarrow> x \<le> y"
  shows "Least P = x"
unfolding Least_def by (rule the_equality)
  (blast intro: assms antisym)+

lemma LeastI2_order:
  assumes "P x"
    and "\<And>y. P y \<Longrightarrow> x \<le> y"
    and "\<And>x. P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le> y \<Longrightarrow> Q x"
  shows "Q (Least P)"
unfolding Least_def by (rule theI2)
  (blast intro: assms antisym)+

text {* Dual order *}

lemma dual_order:
  "class.order (op \<ge>) (op >)"
by (intro_locales, rule dual_preorder) (unfold_locales, rule antisym)

end

text {* Alternative introduction rule with bias towards strict order *}

lemma order_strictI:
  fixes less (infix "\<sqsubset>" 50)
    and less_eq (infix "\<sqsubseteq>" 50)
  assumes less_eq_less: "\<And>a b. a \<sqsubseteq> b \<longleftrightarrow> a \<sqsubset> b \<or> a = b"
    assumes asym: "\<And>a b. a \<sqsubset> b \<Longrightarrow> \<not> b \<sqsubset> a"
  assumes irrefl: "\<And>a. \<not> a \<sqsubset> a"
  assumes trans: "\<And>a b c. a \<sqsubset> b \<Longrightarrow> b \<sqsubset> c \<Longrightarrow> a \<sqsubset> c"
  shows "class.order less_eq less"
proof
  fix a b
  show "a \<sqsubset> b \<longleftrightarrow> a \<sqsubseteq> b \<and> \<not> b \<sqsubseteq> a"
    by (auto simp add: less_eq_less asym irrefl)
next
  fix a
  show "a \<sqsubseteq> a"
    by (auto simp add: less_eq_less)
next
  fix a b c
  assume "a \<sqsubseteq> b" and "b \<sqsubseteq> c" then show "a \<sqsubseteq> c"
    by (auto simp add: less_eq_less intro: trans)
next
  fix a b
  assume "a \<sqsubseteq> b" and "b \<sqsubseteq> a" then show "a = b"
    by (auto simp add: less_eq_less asym)
qed

subsection {* Linear (total) orders *}

class linorder = order +
  assumes linear: "x \<le> y \<or> y \<le> x"
begin

lemma less_linear: "x < y \<or> x = y \<or> y < x"
unfolding less_le using less_le linear by blast

lemma le_less_linear: "x \<le> y \<or> y < x"
by (simp add: le_less less_linear)

lemma le_cases [case_names le ge]:
  "(x \<le> y \<Longrightarrow> P) \<Longrightarrow> (y \<le> x \<Longrightarrow> P) \<Longrightarrow> P"
using linear by blast

lemma linorder_cases [case_names less equal greater]:
  "(x < y \<Longrightarrow> P) \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> (y < x \<Longrightarrow> P) \<Longrightarrow> P"
using less_linear by blast

lemma linorder_wlog[case_names le sym]:
  "(\<And>a b. a \<le> b \<Longrightarrow> P a b) \<Longrightarrow> (\<And>a b. P b a \<Longrightarrow> P a b) \<Longrightarrow> P a b"
  by (cases rule: le_cases[of a b]) blast+

lemma not_less: "\<not> x < y \<longleftrightarrow> y \<le> x"
apply (simp add: less_le)
using linear apply (blast intro: antisym)
done

lemma not_less_iff_gr_or_eq:
 "\<not>(x < y) \<longleftrightarrow> (x > y | x = y)"
apply(simp add:not_less le_less)
apply blast
done

lemma not_le: "\<not> x \<le> y \<longleftrightarrow> y < x"
apply (simp add: less_le)
using linear apply (blast intro: antisym)
done

lemma neq_iff: "x \<noteq> y \<longleftrightarrow> x < y \<or> y < x"
by (cut_tac x = x and y = y in less_linear, auto)

lemma neqE: "x \<noteq> y \<Longrightarrow> (x < y \<Longrightarrow> R) \<Longrightarrow> (y < x \<Longrightarrow> R) \<Longrightarrow> R"
by (simp add: neq_iff) blast

lemma antisym_conv1: "\<not> x < y \<Longrightarrow> x \<le> y \<longleftrightarrow> x = y"
by (blast intro: antisym dest: not_less [THEN iffD1])

lemma antisym_conv2: "x \<le> y \<Longrightarrow> \<not> x < y \<longleftrightarrow> x = y"
by (blast intro: antisym dest: not_less [THEN iffD1])

lemma antisym_conv3: "\<not> y < x \<Longrightarrow> \<not> x < y \<longleftrightarrow> x = y"
by (blast intro: antisym dest: not_less [THEN iffD1])

lemma leI: "\<not> x < y \<Longrightarrow> y \<le> x"
unfolding not_less .

lemma leD: "y \<le> x \<Longrightarrow> \<not> x < y"
unfolding not_less .

(*FIXME inappropriate name (or delete altogether)*)
lemma not_leE: "\<not> y \<le> x \<Longrightarrow> x < y"
unfolding not_le .

text {* Dual order *}

lemma dual_linorder:
  "class.linorder (op \<ge>) (op >)"
by (rule class.linorder.intro, rule dual_order) (unfold_locales, rule linear)

end

text {* Alternative introduction rule with bias towards strict order *}

lemma linorder_strictI:
  fixes less (infix "\<sqsubset>" 50)
    and less_eq (infix "\<sqsubseteq>" 50)
  assumes "class.order less_eq less"
  assumes trichotomy: "\<And>a b. a \<sqsubset> b \<or> a = b \<or> b \<sqsubset> a"
  shows "class.linorder less_eq less"
proof -
  interpret order less_eq less
    by (fact `class.order less_eq less`)
  show ?thesis
  proof
    fix a b
    show "a \<sqsubseteq> b \<or> b \<sqsubseteq> a"
      using trichotomy by (auto simp add: le_less)
  qed
qed

subsection {* Reasoning tools setup *}

ML {*
signature ORDERS =
sig
  val print_structures: Proof.context -> unit
  val order_tac: Proof.context -> thm list -> int -> tactic
  val add_struct: string * term list -> string -> attribute
  val del_struct: string * term list -> attribute
end;

structure Orders: ORDERS =
struct

(* context data *)

fun struct_eq ((s1: string, ts1), (s2, ts2)) =
  s1 = s2 andalso eq_list (op aconv) (ts1, ts2);

structure Data = Generic_Data
(
  type T = ((string * term list) * Order_Tac.less_arith) list;
    (* Order structures:
       identifier of the structure, list of operations and record of theorems
       needed to set up the transitivity reasoner,
       identifier and operations identify the structure uniquely. *)
  val empty = [];
  val extend = I;
  fun merge data = AList.join struct_eq (K fst) data;
);

fun print_structures ctxt =
  let
    val structs = Data.get (Context.Proof ctxt);
    fun pretty_term t = Pretty.block
      [Pretty.quote (Syntax.pretty_term ctxt t), Pretty.brk 1,
        Pretty.str "::", Pretty.brk 1,
        Pretty.quote (Syntax.pretty_typ ctxt (type_of t))];
    fun pretty_struct ((s, ts), _) = Pretty.block
      [Pretty.str s, Pretty.str ":", Pretty.brk 1,
       Pretty.enclose "(" ")" (Pretty.breaks (map pretty_term ts))];
  in
    Pretty.writeln (Pretty.big_list "order structures:" (map pretty_struct structs))
  end;

val _ =
  Outer_Syntax.command @{command_spec "print_orders"}
    "print order structures available to transitivity reasoner"
    (Scan.succeed (Toplevel.unknown_context o
      Toplevel.keep (print_structures o Toplevel.context_of)));

(* tactics *)

fun struct_tac ((s, ops), thms) ctxt facts =
  let
    val [eq, le, less] = ops;
    fun decomp thy (@{const Trueprop} $ t) =
          let
            fun excluded t =
              (* exclude numeric types: linear arithmetic subsumes transitivity *)
              let val T = type_of t
              in
                T = HOLogic.natT orelse T = HOLogic.intT orelse T = HOLogic.realT
              end;
            fun rel (bin_op $ t1 $ t2) =
                  if excluded t1 then NONE
                  else if Pattern.matches thy (eq, bin_op) then SOME (t1, "=", t2)
                  else if Pattern.matches thy (le, bin_op) then SOME (t1, "<=", t2)
                  else if Pattern.matches thy (less, bin_op) then SOME (t1, "<", t2)
                  else NONE
              | rel _ = NONE;
            fun dec (Const (@{const_name Not}, _) $ t) =
                  (case rel t of NONE =>
                    NONE
                  | SOME (t1, rel, t2) => SOME (t1, "~" ^ rel, t2))
              | dec x = rel x;
          in dec t end
      | decomp _ _ = NONE;
  in
    (case s of
      "order" => Order_Tac.partial_tac decomp thms ctxt facts
    | "linorder" => Order_Tac.linear_tac decomp thms ctxt facts
    | _ => error ("Unknown order kind " ^ quote s ^ " encountered in transitivity reasoner"))
  end

fun order_tac ctxt facts =
  FIRST' (map (fn s => CHANGED o struct_tac s ctxt facts) (Data.get (Context.Proof ctxt)));

(* attributes *)

fun add_struct s tag =
  Thm.declaration_attribute
    (fn thm => Data.map (AList.map_default struct_eq (s, Order_Tac.empty TrueI) (Order_Tac.update tag thm)));
fun del_struct s =
  Thm.declaration_attribute
    (fn _ => Data.map (AList.delete struct_eq s));

end;
*}

attribute_setup order = {*
  Scan.lift ((Args.add -- Args.name >> (fn (_, s) => SOME s) || Args.del >> K NONE) --|
    Args.colon (* FIXME || Scan.succeed true *) ) -- Scan.lift Args.name --
    Scan.repeat Args.term
    >> (fn ((SOME tag, n), ts) => Orders.add_struct (n, ts) tag
         | ((NONE, n), ts) => Orders.del_struct (n, ts))
*} "theorems controlling transitivity reasoner"

method_setup order = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (Orders.order_tac ctxt []))
*} "transitivity reasoner"

text {* Declarations to set up transitivity reasoner of partial and linear orders. *}

context order
begin

(* The type constraint on @{term op =} below is necessary since the operation
   is not a parameter of the locale. *)

declare less_irrefl [THEN notE, order add less_reflE: order "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool" "op <=" "op <"]

declare order_refl  [order add le_refl: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_imp_le [order add less_imp_le: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare antisym [order add eqI: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare eq_refl [order add eqD1: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare sym [THEN eq_refl, order add eqD2: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_trans [order add less_trans: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_le_trans [order add less_le_trans: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare le_less_trans [order add le_less_trans: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare order_trans [order add le_trans: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare le_neq_trans [order add le_neq_trans: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare neq_le_trans [order add neq_le_trans: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_imp_neq [order add less_imp_neq: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare eq_neq_eq_imp_neq [order add eq_neq_eq_imp_neq: order "op = :: 'a => 'a => bool" "op <=" "op <"]

declare not_sym [order add not_sym: order "op = :: 'a => 'a => bool" "op <=" "op <"]

end

context linorder
begin

declare [[order del: order "op = :: 'a => 'a => bool" "op <=" "op <"]]

declare less_irrefl [THEN notE, order add less_reflE: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare order_refl [order add le_refl: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_imp_le [order add less_imp_le: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare not_less [THEN iffD2, order add not_lessI: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare not_le [THEN iffD2, order add not_leI: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare not_less [THEN iffD1, order add not_lessD: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare not_le [THEN iffD1, order add not_leD: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare antisym [order add eqI: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare eq_refl [order add eqD1: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare sym [THEN eq_refl, order add eqD2: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_trans [order add less_trans: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_le_trans [order add less_le_trans: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare le_less_trans [order add le_less_trans: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare order_trans [order add le_trans: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare le_neq_trans [order add le_neq_trans: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare neq_le_trans [order add neq_le_trans: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare less_imp_neq [order add less_imp_neq: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare eq_neq_eq_imp_neq [order add eq_neq_eq_imp_neq: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

declare not_sym [order add not_sym: linorder "op = :: 'a => 'a => bool" "op <=" "op <"]

end

setup {*
  map_theory_simpset (fn ctxt0 => ctxt0 addSolver
    mk_solver "Transitivity" (fn ctxt => Orders.order_tac ctxt (Simplifier.prems_of ctxt)))
  (*Adding the transitivity reasoners also as safe solvers showed a slight
    speed up, but the reasoning strength appears to be not higher (at least
    no breaking of additional proofs in the entire HOL distribution, as
    of 5 March 2004, was observed).*)
*}

ML {*
local
  fun prp t thm = Thm.prop_of thm = t;  (* FIXME proper aconv!? *)
in

fun antisym_le_simproc ctxt ct =
  (case term_of ct of
    (le as Const (_, T)) $ r $ s =>
     (let
        val prems = Simplifier.prems_of ctxt;
        val less = Const (@{const_name less}, T);
        val t = HOLogic.mk_Trueprop(le $ s $ r);
      in
        (case find_first (prp t) prems of
          NONE =>
            let val t = HOLogic.mk_Trueprop(HOLogic.Not $ (less $ r $ s)) in
              (case find_first (prp t) prems of
                NONE => NONE
              | SOME thm => SOME(mk_meta_eq(thm RS @{thm linorder_class.antisym_conv1})))
             end
         | SOME thm => SOME (mk_meta_eq (thm RS @{thm order_class.antisym_conv})))
      end handle THM _ => NONE)
  | _ => NONE);

fun antisym_less_simproc ctxt ct =
  (case term_of ct of
    NotC $ ((less as Const(_,T)) $ r $ s) =>
     (let
       val prems = Simplifier.prems_of ctxt;
       val le = Const (@{const_name less_eq}, T);
       val t = HOLogic.mk_Trueprop(le $ r $ s);
      in
        (case find_first (prp t) prems of
          NONE =>
            let val t = HOLogic.mk_Trueprop (NotC $ (less $ s $ r)) in
              (case find_first (prp t) prems of
                NONE => NONE
              | SOME thm => SOME (mk_meta_eq(thm RS @{thm linorder_class.antisym_conv3})))
            end
        | SOME thm => SOME (mk_meta_eq (thm RS @{thm linorder_class.antisym_conv2})))
      end handle THM _ => NONE)
  | _ => NONE);

end;
*}

simproc_setup antisym_le ("(x::'a::order) \<le> y") = "K antisym_le_simproc"
simproc_setup antisym_less ("\<not> (x::'a::linorder) < y") = "K antisym_less_simproc"

subsection {* Bounded quantifiers *}

syntax
  "_All_less" :: "[idt, 'a, bool] => bool"    ("(3ALL _<_./ _)"  [0, 0, 10] 10)
  "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3EX _<_./ _)"  [0, 0, 10] 10)
  "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3ALL _<=_./ _)" [0, 0, 10] 10)
  "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3EX _<=_./ _)" [0, 0, 10] 10)

  "_All_greater" :: "[idt, 'a, bool] => bool"    ("(3ALL _>_./ _)"  [0, 0, 10] 10)
  "_Ex_greater" :: "[idt, 'a, bool] => bool"    ("(3EX _>_./ _)"  [0, 0, 10] 10)
  "_All_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3ALL _>=_./ _)" [0, 0, 10] 10)
  "_Ex_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3EX _>=_./ _)" [0, 0, 10] 10)

syntax (xsymbols)
  "_All_less" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_<_./ _)"  [0, 0, 10] 10)
  "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_<_./ _)"  [0, 0, 10] 10)
  "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<le>_./ _)" [0, 0, 10] 10)
  "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<le>_./ _)" [0, 0, 10] 10)

  "_All_greater" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_>_./ _)"  [0, 0, 10] 10)
  "_Ex_greater" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_>_./ _)"  [0, 0, 10] 10)
  "_All_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<ge>_./ _)" [0, 0, 10] 10)
  "_Ex_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<ge>_./ _)" [0, 0, 10] 10)

syntax (HOL)
  "_All_less" :: "[idt, 'a, bool] => bool"    ("(3! _<_./ _)"  [0, 0, 10] 10)
  "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3? _<_./ _)"  [0, 0, 10] 10)
  "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3! _<=_./ _)" [0, 0, 10] 10)
  "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3? _<=_./ _)" [0, 0, 10] 10)

syntax (HTML output)
  "_All_less" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_<_./ _)"  [0, 0, 10] 10)
  "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_<_./ _)"  [0, 0, 10] 10)
  "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<le>_./ _)" [0, 0, 10] 10)
  "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<le>_./ _)" [0, 0, 10] 10)

  "_All_greater" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_>_./ _)"  [0, 0, 10] 10)
  "_Ex_greater" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_>_./ _)"  [0, 0, 10] 10)
  "_All_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<ge>_./ _)" [0, 0, 10] 10)
  "_Ex_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<ge>_./ _)" [0, 0, 10] 10)

translations
  "ALL x<y. P"   =>  "ALL x. x < y \<longrightarrow> P"
  "EX x<y. P"    =>  "EX x. x < y \<and> P"
  "ALL x<=y. P"  =>  "ALL x. x <= y \<longrightarrow> P"
  "EX x<=y. P"   =>  "EX x. x <= y \<and> P"
  "ALL x>y. P"   =>  "ALL x. x > y \<longrightarrow> P"
  "EX x>y. P"    =>  "EX x. x > y \<and> P"
  "ALL x>=y. P"  =>  "ALL x. x >= y \<longrightarrow> P"
  "EX x>=y. P"   =>  "EX x. x >= y \<and> P"

print_translation {*
let
  val All_binder = Mixfix.binder_name @{const_syntax All};
  val Ex_binder = Mixfix.binder_name @{const_syntax Ex};
  val impl = @{const_syntax HOL.implies};
  val conj = @{const_syntax HOL.conj};
  val less = @{const_syntax less};
  val less_eq = @{const_syntax less_eq};

  val trans =
   [((All_binder, impl, less),
    (@{syntax_const "_All_less"}, @{syntax_const "_All_greater"})),
    ((All_binder, impl, less_eq),
    (@{syntax_const "_All_less_eq"}, @{syntax_const "_All_greater_eq"})),
    ((Ex_binder, conj, less),
    (@{syntax_const "_Ex_less"}, @{syntax_const "_Ex_greater"})),
    ((Ex_binder, conj, less_eq),
    (@{syntax_const "_Ex_less_eq"}, @{syntax_const "_Ex_greater_eq"}))];

  fun matches_bound v t =
    (case t of
      Const (@{syntax_const "_bound"}, _) $ Free (v', _) => v = v'
    | _ => false);
  fun contains_var v = Term.exists_subterm (fn Free (x, _) => x = v | _ => false);
  fun mk x c n P = Syntax.const c $ Syntax_Trans.mark_bound_body x $ n $ P;

  fun tr' q = (q, fn _ =>
    (fn [Const (@{syntax_const "_bound"}, _) $ Free (v, T),
        Const (c, _) $ (Const (d, _) $ t $ u) $ P] =>
        (case AList.lookup (op =) trans (q, c, d) of
          NONE => raise Match
        | SOME (l, g) =>
            if matches_bound v t andalso not (contains_var v u) then mk (v, T) l u P
            else if matches_bound v u andalso not (contains_var v t) then mk (v, T) g t P
            else raise Match)
      | _ => raise Match));
in [tr' All_binder, tr' Ex_binder] end
*}

subsection {* Transitivity reasoning *}

context ord
begin

lemma ord_le_eq_trans: "a \<le> b \<Longrightarrow> b = c \<Longrightarrow> a \<le> c"
  by (rule subst)

lemma ord_eq_le_trans: "a = b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
  by (rule ssubst)

lemma ord_less_eq_trans: "a < b \<Longrightarrow> b = c \<Longrightarrow> a < c"
  by (rule subst)

lemma ord_eq_less_trans: "a = b \<Longrightarrow> b < c \<Longrightarrow> a < c"
  by (rule ssubst)

end

lemma order_less_subst2: "(a::'a::order) < b ==> f b < (c::'c::order) ==>
  (!!x y. x < y ==> f x < f y) ==> f a < c"
proof -
  assume r: "!!x y. x < y ==> f x < f y"
  assume "a < b" hence "f a < f b" by (rule r)
  also assume "f b < c"
  finally (less_trans) show ?thesis .
qed

lemma order_less_subst1: "(a::'a::order) < f b ==> (b::'b::order) < c ==>
  (!!x y. x < y ==> f x < f y) ==> a < f c"
proof -
  assume r: "!!x y. x < y ==> f x < f y"
  assume "a < f b"
  also assume "b < c" hence "f b < f c" by (rule r)
  finally (less_trans) show ?thesis .
qed

lemma order_le_less_subst2: "(a::'a::order) <= b ==> f b < (c::'c::order) ==>
  (!!x y. x <= y ==> f x <= f y) ==> f a < c"
proof -
  assume r: "!!x y. x <= y ==> f x <= f y"
  assume "a <= b" hence "f a <= f b" by (rule r)
  also assume "f b < c"
  finally (le_less_trans) show ?thesis .
qed

lemma order_le_less_subst1: "(a::'a::order) <= f b ==> (b::'b::order) < c ==>
  (!!x y. x < y ==> f x < f y) ==> a < f c"
proof -
  assume r: "!!x y. x < y ==> f x < f y"
  assume "a <= f b"
  also assume "b < c" hence "f b < f c" by (rule r)
  finally (le_less_trans) show ?thesis .
qed

lemma order_less_le_subst2: "(a::'a::order) < b ==> f b <= (c::'c::order) ==>
  (!!x y. x < y ==> f x < f y) ==> f a < c"
proof -
  assume r: "!!x y. x < y ==> f x < f y"
  assume "a < b" hence "f a < f b" by (rule r)
  also assume "f b <= c"
  finally (less_le_trans) show ?thesis .
qed

lemma order_less_le_subst1: "(a::'a::order) < f b ==> (b::'b::order) <= c ==>
  (!!x y. x <= y ==> f x <= f y) ==> a < f c"
proof -
  assume r: "!!x y. x <= y ==> f x <= f y"
  assume "a < f b"
  also assume "b <= c" hence "f b <= f c" by (rule r)
  finally (less_le_trans) show ?thesis .
qed

lemma order_subst1: "(a::'a::order) <= f b ==> (b::'b::order) <= c ==>
  (!!x y. x <= y ==> f x <= f y) ==> a <= f c"
proof -
  assume r: "!!x y. x <= y ==> f x <= f y"
  assume "a <= f b"
  also assume "b <= c" hence "f b <= f c" by (rule r)
  finally (order_trans) show ?thesis .
qed

lemma order_subst2: "(a::'a::order) <= b ==> f b <= (c::'c::order) ==>
  (!!x y. x <= y ==> f x <= f y) ==> f a <= c"
proof -
  assume r: "!!x y. x <= y ==> f x <= f y"
  assume "a <= b" hence "f a <= f b" by (rule r)
  also assume "f b <= c"
  finally (order_trans) show ?thesis .
qed

lemma ord_le_eq_subst: "a <= b ==> f b = c ==>
  (!!x y. x <= y ==> f x <= f y) ==> f a <= c"
proof -
  assume r: "!!x y. x <= y ==> f x <= f y"
  assume "a <= b" hence "f a <= f b" by (rule r)
  also assume "f b = c"
  finally (ord_le_eq_trans) show ?thesis .
qed

lemma ord_eq_le_subst: "a = f b ==> b <= c ==>
  (!!x y. x <= y ==> f x <= f y) ==> a <= f c"
proof -
  assume r: "!!x y. x <= y ==> f x <= f y"
  assume "a = f b"
  also assume "b <= c" hence "f b <= f c" by (rule r)
  finally (ord_eq_le_trans) show ?thesis .
qed

lemma ord_less_eq_subst: "a < b ==> f b = c ==>
  (!!x y. x < y ==> f x < f y) ==> f a < c"
proof -
  assume r: "!!x y. x < y ==> f x < f y"
  assume "a < b" hence "f a < f b" by (rule r)
  also assume "f b = c"
  finally (ord_less_eq_trans) show ?thesis .
qed

lemma ord_eq_less_subst: "a = f b ==> b < c ==>
  (!!x y. x < y ==> f x < f y) ==> a < f c"
proof -
  assume r: "!!x y. x < y ==> f x < f y"
  assume "a = f b"
  also assume "b < c" hence "f b < f c" by (rule r)
  finally (ord_eq_less_trans) show ?thesis .
qed

text {*
  Note that this list of rules is in reverse order of priorities.
*}

lemmas [trans] =
  order_less_subst2
  order_less_subst1
  order_le_less_subst2
  order_le_less_subst1
  order_less_le_subst2
  order_less_le_subst1
  order_subst2
  order_subst1
  ord_le_eq_subst
  ord_eq_le_subst
  ord_less_eq_subst
  ord_eq_less_subst
  forw_subst
  back_subst
  rev_mp
  mp

lemmas (in order) [trans] =
  neq_le_trans
  le_neq_trans

lemmas (in preorder) [trans] =
  less_trans
  less_asym'
  le_less_trans
  less_le_trans
  order_trans

lemmas (in order) [trans] =
  antisym

lemmas (in ord) [trans] =
  ord_le_eq_trans
  ord_eq_le_trans
  ord_less_eq_trans
  ord_eq_less_trans

lemmas [trans] =
  trans

lemmas order_trans_rules =
  order_less_subst2
  order_less_subst1
  order_le_less_subst2
  order_le_less_subst1
  order_less_le_subst2
  order_less_le_subst1
  order_subst2
  order_subst1
  ord_le_eq_subst
  ord_eq_le_subst
  ord_less_eq_subst
  ord_eq_less_subst
  forw_subst
  back_subst
  rev_mp
  mp
  neq_le_trans
  le_neq_trans
  less_trans
  less_asym'
  le_less_trans
  less_le_trans
  order_trans
  antisym
  ord_le_eq_trans
  ord_eq_le_trans
  ord_less_eq_trans
  ord_eq_less_trans
  trans

text {* These support proving chains of decreasing inequalities
    a >= b >= c ... in Isar proofs. *}

lemma xt1 [no_atp]:
  "a = b ==> b > c ==> a > c"
  "a > b ==> b = c ==> a > c"
  "a = b ==> b >= c ==> a >= c"
  "a >= b ==> b = c ==> a >= c"
  "(x::'a::order) >= y ==> y >= x ==> x = y"
  "(x::'a::order) >= y ==> y >= z ==> x >= z"
  "(x::'a::order) > y ==> y >= z ==> x > z"
  "(x::'a::order) >= y ==> y > z ==> x > z"
  "(a::'a::order) > b ==> b > a ==> P"
  "(x::'a::order) > y ==> y > z ==> x > z"
  "(a::'a::order) >= b ==> a ~= b ==> a > b"
  "(a::'a::order) ~= b ==> a >= b ==> a > b"
  "a = f b ==> b > c ==> (!!x y. x > y ==> f x > f y) ==> a > f c"
  "a > b ==> f b = c ==> (!!x y. x > y ==> f x > f y) ==> f a > c"
  "a = f b ==> b >= c ==> (!!x y. x >= y ==> f x >= f y) ==> a >= f c"
  "a >= b ==> f b = c ==> (!! x y. x >= y ==> f x >= f y) ==> f a >= c"
  by auto

lemma xt2 [no_atp]:
  "(a::'a::order) >= f b ==> b >= c ==> (!!x y. x >= y ==> f x >= f y) ==> a >= f c"
by (subgoal_tac "f b >= f c", force, force)

lemma xt3 [no_atp]: "(a::'a::order) >= b ==> (f b::'b::order) >= c ==>
    (!!x y. x >= y ==> f x >= f y) ==> f a >= c"
by (subgoal_tac "f a >= f b", force, force)

lemma xt4 [no_atp]: "(a::'a::order) > f b ==> (b::'b::order) >= c ==>
  (!!x y. x >= y ==> f x >= f y) ==> a > f c"
by (subgoal_tac "f b >= f c", force, force)

lemma xt5 [no_atp]: "(a::'a::order) > b ==> (f b::'b::order) >= c==>
    (!!x y. x > y ==> f x > f y) ==> f a > c"
by (subgoal_tac "f a > f b", force, force)

lemma xt6 [no_atp]: "(a::'a::order) >= f b ==> b > c ==>
    (!!x y. x > y ==> f x > f y) ==> a > f c"
by (subgoal_tac "f b > f c", force, force)

lemma xt7 [no_atp]: "(a::'a::order) >= b ==> (f b::'b::order) > c ==>
    (!!x y. x >= y ==> f x >= f y) ==> f a > c"
by (subgoal_tac "f a >= f b", force, force)

lemma xt8 [no_atp]: "(a::'a::order) > f b ==> (b::'b::order) > c ==>
    (!!x y. x > y ==> f x > f y) ==> a > f c"
by (subgoal_tac "f b > f c", force, force)

lemma xt9 [no_atp]: "(a::'a::order) > b ==> (f b::'b::order) > c ==>
    (!!x y. x > y ==> f x > f y) ==> f a > c"
by (subgoal_tac "f a > f b", force, force)

lemmas xtrans = xt1 xt2 xt3 xt4 xt5 xt6 xt7 xt8 xt9

(*
  Since "a >= b" abbreviates "b <= a", the abbreviation "..." stands
  for the wrong thing in an Isar proof.

  The extra transitivity rules can be used as follows:

lemma "(a::'a::order) > z"
proof -
  have "a >= b" (is "_ >= ?rhs")
    sorry
  also have "?rhs >= c" (is "_ >= ?rhs")
    sorry
  also (xtrans) have "?rhs = d" (is "_ = ?rhs")
    sorry
  also (xtrans) have "?rhs >= e" (is "_ >= ?rhs")
    sorry
  also (xtrans) have "?rhs > f" (is "_ > ?rhs")
    sorry
  also (xtrans) have "?rhs > z"
    sorry
  finally (xtrans) show ?thesis .
qed

  Alternatively, one can use "declare xtrans [trans]" and then
  leave out the "(xtrans)" above.
*)

subsection {* Monotonicity *}

context order
begin

definition mono :: "('a \<Rightarrow> 'b\<Colon>order) \<Rightarrow> bool" where
  "mono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"

lemma monoI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  shows "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> mono f"
  unfolding mono_def by iprover

lemma monoD [dest?]:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  shows "mono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  unfolding mono_def by iprover

lemma monoE:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  assumes "mono f"
  assumes "x \<le> y"
  obtains "f x \<le> f y"
proof
  from assms show "f x \<le> f y" by (simp add: mono_def)
qed

definition antimono :: "('a \<Rightarrow> 'b\<Colon>order) \<Rightarrow> bool" where
  "antimono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<ge> f y)"

lemma antimonoI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  shows "(\<And>x y. x \<le> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> antimono f"
  unfolding antimono_def by iprover

lemma antimonoD [dest?]:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  shows "antimono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
  unfolding antimono_def by iprover

lemma antimonoE:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  assumes "antimono f"
  assumes "x \<le> y"
  obtains "f x \<ge> f y"
proof
  from assms show "f x \<ge> f y" by (simp add: antimono_def)
qed

definition strict_mono :: "('a \<Rightarrow> 'b\<Colon>order) \<Rightarrow> bool" where
  "strict_mono f \<longleftrightarrow> (\<forall>x y. x < y \<longrightarrow> f x < f y)"

lemma strict_monoI [intro?]:
  assumes "\<And>x y. x < y \<Longrightarrow> f x < f y"
  shows "strict_mono f"
  using assms unfolding strict_mono_def by auto

lemma strict_monoD [dest?]:
  "strict_mono f \<Longrightarrow> x < y \<Longrightarrow> f x < f y"
  unfolding strict_mono_def by auto

lemma strict_mono_mono [dest?]:
  assumes "strict_mono f"
  shows "mono f"
proof (rule monoI)
  fix x y
  assume "x \<le> y"
  show "f x \<le> f y"
  proof (cases "x = y")
    case True then show ?thesis by simp
  next
    case False with `x \<le> y` have "x < y" by simp
    with assms strict_monoD have "f x < f y" by auto
    then show ?thesis by simp
  qed
qed

end

context linorder
begin

lemma mono_invE:
  fixes f :: "'a \<Rightarrow> 'b\<Colon>order"
  assumes "mono f"
  assumes "f x < f y"
  obtains "x \<le> y"
proof
  show "x \<le> y"
  proof (rule ccontr)
    assume "\<not> x \<le> y"
    then have "y \<le> x" by simp
    with `mono f` obtain "f y \<le> f x" by (rule monoE)
    with `f x < f y` show False by simp
  qed
qed

lemma strict_mono_eq:
  assumes "strict_mono f"
  shows "f x = f y \<longleftrightarrow> x = y"
proof
  assume "f x = f y"
  show "x = y" proof (cases x y rule: linorder_cases)
    case less with assms strict_monoD have "f x < f y" by auto
    with `f x = f y` show ?thesis by simp
  next
    case equal then show ?thesis .
  next
    case greater with assms strict_monoD have "f y < f x" by auto
    with `f x = f y` show ?thesis by simp
  qed
qed simp

lemma strict_mono_less_eq:
  assumes "strict_mono f"
  shows "f x \<le> f y \<longleftrightarrow> x \<le> y"
proof
  assume "x \<le> y"
  with assms strict_mono_mono monoD show "f x \<le> f y" by auto
next
  assume "f x \<le> f y"
  show "x \<le> y" proof (rule ccontr)
    assume "\<not> x \<le> y" then have "y < x" by simp
    with assms strict_monoD have "f y < f x" by auto
    with `f x \<le> f y` show False by simp
  qed
qed

lemma strict_mono_less:
  assumes "strict_mono f"
  shows "f x < f y \<longleftrightarrow> x < y"
  using assms
    by (auto simp add: less_le Orderings.less_le strict_mono_eq strict_mono_less_eq)

end

subsection {* min and max -- fundamental *}

definition (in ord) min :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "min a b = (if a \<le> b then a else b)"

definition (in ord) max :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "max a b = (if a \<le> b then b else a)"

lemma min_absorb1: "x \<le> y \<Longrightarrow> min x y = x"
  by (simp add: min_def)

lemma max_absorb2: "x \<le> y \<Longrightarrow> max x y = y"
  by (simp add: max_def)

lemma min_absorb2: "(y\<Colon>'a\<Colon>order) \<le> x \<Longrightarrow> min x y = y"
  by (simp add:min_def)

lemma max_absorb1: "(y\<Colon>'a\<Colon>order) \<le> x \<Longrightarrow> max x y = x"
  by (simp add: max_def)

subsection {* (Unique) top and bottom elements *}

class bot =
  fixes bot :: 'a ("\<bottom>")

class order_bot = order + bot +
  assumes bot_least: "\<bottom> \<le> a"
begin

sublocale bot!: ordering_top greater_eq greater bot
  by default (fact bot_least)

lemma le_bot:
  "a \<le> \<bottom> \<Longrightarrow> a = \<bottom>"
  by (fact bot.extremum_uniqueI)

lemma bot_unique:
  "a \<le> \<bottom> \<longleftrightarrow> a = \<bottom>"
  by (fact bot.extremum_unique)

lemma not_less_bot:
  "\<not> a < \<bottom>"
  by (fact bot.extremum_strict)

lemma bot_less:
  "a \<noteq> \<bottom> \<longleftrightarrow> \<bottom> < a"
  by (fact bot.not_eq_extremum)

end

class top =
  fixes top :: 'a ("\<top>")

class order_top = order + top +
  assumes top_greatest: "a \<le> \<top>"
begin

sublocale top!: ordering_top less_eq less top
  by default (fact top_greatest)

lemma top_le:
  "\<top> \<le> a \<Longrightarrow> a = \<top>"
  by (fact top.extremum_uniqueI)

lemma top_unique:
  "\<top> \<le> a \<longleftrightarrow> a = \<top>"
  by (fact top.extremum_unique)

lemma not_top_less:
  "\<not> \<top> < a"
  by (fact top.extremum_strict)

lemma less_top:
  "a \<noteq> \<top> \<longleftrightarrow> a < \<top>"
  by (fact top.not_eq_extremum)

end

subsection {* Dense orders *}

class dense_order = order +
  assumes dense: "x < y \<Longrightarrow> (\<exists>z. x < z \<and> z < y)"

class dense_linorder = linorder + dense_order
begin

lemma dense_le:
  fixes y z :: 'a
  assumes "\<And>x. x < y \<Longrightarrow> x \<le> z"
  shows "y \<le> z"
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence "z < y" by simp
  from dense[OF this]
  obtain x where "x < y" and "z < x" by safe
  moreover have "x \<le> z" using assms[OF `x < y`] .
  ultimately show False by auto
qed

lemma dense_le_bounded:
  fixes x y z :: 'a
  assumes "x < y"
  assumes *: "\<And>w. \<lbrakk> x < w ; w < y \<rbrakk> \<Longrightarrow> w \<le> z"
  shows "y \<le> z"
proof (rule dense_le)
  fix w assume "w < y"
  from dense[OF `x < y`] obtain u where "x < u" "u < y" by safe
  from linear[of u w]
  show "w \<le> z"
  proof (rule disjE)
    assume "u \<le> w"
    from less_le_trans[OF `x < u` `u \<le> w`] `w < y`
    show "w \<le> z" by (rule *)
  next
    assume "w \<le> u"
    from `w \<le> u` *[OF `x < u` `u < y`]
    show "w \<le> z" by (rule order_trans)
  qed
qed

lemma dense_ge:
  fixes y z :: 'a
  assumes "\<And>x. z < x \<Longrightarrow> y \<le> x"
  shows "y \<le> z"
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence "z < y" by simp
  from dense[OF this]
  obtain x where "x < y" and "z < x" by safe
  moreover have "y \<le> x" using assms[OF `z < x`] .
  ultimately show False by auto
qed

lemma dense_ge_bounded:
  fixes x y z :: 'a
  assumes "z < x"
  assumes *: "\<And>w. \<lbrakk> z < w ; w < x \<rbrakk> \<Longrightarrow> y \<le> w"
  shows "y \<le> z"
proof (rule dense_ge)
  fix w assume "z < w"
  from dense[OF `z < x`] obtain u where "z < u" "u < x" by safe
  from linear[of u w]
  show "y \<le> w"
  proof (rule disjE)
    assume "w \<le> u"
    from `z < w` le_less_trans[OF `w \<le> u` `u < x`]
    show "y \<le> w" by (rule *)
  next
    assume "u \<le> w"
    from *[OF `z < u` `u < x`] `u \<le> w`
    show "y \<le> w" by (rule order_trans)
  qed
qed

end

class no_top = order +
  assumes gt_ex: "\<exists>y. x < y"

class no_bot = order +
  assumes lt_ex: "\<exists>y. y < x"

class unbounded_dense_linorder = dense_linorder + no_top + no_bot

subsection {* Wellorders *}

class wellorder = linorder +
  assumes less_induct [case_names less]: "(\<And>x. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x) \<Longrightarrow> P a"
begin

lemma wellorder_Least_lemma:
  fixes k :: 'a
  assumes "P k"
  shows LeastI: "P (LEAST x. P x)" and Least_le: "(LEAST x. P x) \<le> k"
proof -
  have "P (LEAST x. P x) \<and> (LEAST x. P x) \<le> k"
  using assms proof (induct k rule: less_induct)
    case (less x) then have "P x" by simp
    show ?case proof (rule classical)
      assume assm: "\<not> (P (LEAST a. P a) \<and> (LEAST a. P a) \<le> x)"
      have "\<And>y. P y \<Longrightarrow> x \<le> y"
      proof (rule classical)
        fix y
        assume "P y" and "\<not> x \<le> y"
        with less have "P (LEAST a. P a)" and "(LEAST a. P a) \<le> y"
          by (auto simp add: not_le)
        with assm have "x < (LEAST a. P a)" and "(LEAST a. P a) \<le> y"
          by auto
        then show "x \<le> y" by auto
      qed
      with `P x` have Least: "(LEAST a. P a) = x"
        by (rule Least_equality)
      with `P x` show ?thesis by simp
    qed
  qed
  then show "P (LEAST x. P x)" and "(LEAST x. P x) \<le> k" by auto
qed

-- "The following 3 lemmas are due to Brian Huffman"
lemma LeastI_ex: "\<exists>x. P x \<Longrightarrow> P (Least P)"
  by (erule exE) (erule LeastI)

lemma LeastI2:
  "P a \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> Q (Least P)"
  by (blast intro: LeastI)

lemma LeastI2_ex:
  "\<exists>a. P a \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> Q (Least P)"
  by (blast intro: LeastI_ex)

lemma LeastI2_wellorder:
  assumes "P a"
  and "\<And>a. \<lbrakk> P a; \<forall>b. P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
  shows "Q (Least P)"
proof (rule LeastI2_order)
  show "P (Least P)" using `P a` by (rule LeastI)
next
  fix y assume "P y" thus "Least P \<le> y" by (rule Least_le)
next
  fix x assume "P x" "\<forall>y. P y \<longrightarrow> x \<le> y" thus "Q x" by (rule assms(2))
qed

lemma not_less_Least: "k < (LEAST x. P x) \<Longrightarrow> \<not> P k"
apply (simp (no_asm_use) add: not_le [symmetric])
apply (erule contrapos_nn)
apply (erule Least_le)
done

end

subsection {* Order on @{typ bool} *}

instantiation bool :: "{order_bot, order_top, linorder}"
begin

definition
  le_bool_def [simp]: "P \<le> Q \<longleftrightarrow> P \<longrightarrow> Q"

definition
  [simp]: "(P\<Colon>bool) < Q \<longleftrightarrow> \<not> P \<and> Q"

definition
  [simp]: "\<bottom> \<longleftrightarrow> False"

definition
  [simp]: "\<top> \<longleftrightarrow> True"

instance proof
qed auto

end

lemma le_boolI: "(P \<Longrightarrow> Q) \<Longrightarrow> P \<le> Q"
  by simp

lemma le_boolI': "P \<longrightarrow> Q \<Longrightarrow> P \<le> Q"
  by simp

lemma le_boolE: "P \<le> Q \<Longrightarrow> P \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
  by simp

lemma le_boolD: "P \<le> Q \<Longrightarrow> P \<longrightarrow> Q"
  by simp

lemma bot_boolE: "\<bottom> \<Longrightarrow> P"
  by simp

lemma top_boolI: \<top>
  by simp

subsection {* Order on @{typ "_ \<Rightarrow> _"} *}

instantiation "fun" :: (type, ord) ord
begin

definition
  le_fun_def: "f \<le> g \<longleftrightarrow> (\<forall>x. f x \<le> g x)"

definition
  "(f\<Colon>'a \<Rightarrow> 'b) < g \<longleftrightarrow> f \<le> g \<and> \<not> (g \<le> f)"

instance ..

end

instance "fun" :: (type, preorder) preorder proof
qed (auto simp add: le_fun_def less_fun_def
  intro: order_trans antisym)

instance "fun" :: (type, order) order proof
qed (auto simp add: le_fun_def intro: antisym)

instantiation "fun" :: (type, bot) bot
begin

definition
  "\<bottom> = (\<lambda>x. \<bottom>)"

instance ..

end

instantiation "fun" :: (type, order_bot) order_bot
begin

lemma bot_apply [simp, code]:
  "\<bottom> x = \<bottom>"
  by (simp add: bot_fun_def)

instance proof
qed (simp add: le_fun_def)

end

instantiation "fun" :: (type, top) top
begin

definition
  [no_atp]: "\<top> = (\<lambda>x. \<top>)"

instance ..

end

instantiation "fun" :: (type, order_top) order_top
begin

lemma top_apply [simp, code]:
  "\<top> x = \<top>"
  by (simp add: top_fun_def)

instance proof
qed (simp add: le_fun_def)

end

lemma le_funI: "(\<And>x. f x \<le> g x) \<Longrightarrow> f \<le> g"
  unfolding le_fun_def by simp

lemma le_funE: "f \<le> g \<Longrightarrow> (f x \<le> g x \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding le_fun_def by simp

lemma le_funD: "f \<le> g \<Longrightarrow> f x \<le> g x"
  by (rule le_funE)

lemma mono_compose: "mono Q \<Longrightarrow> mono (\<lambda>i x. Q i (f x))"
  unfolding mono_def le_fun_def by auto

subsection {* Order on unary and binary predicates *}

lemma predicate1I:
  assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
  shows "P \<le> Q"
  apply (rule le_funI)
  apply (rule le_boolI)
  apply (rule PQ)
  apply assumption
  done

lemma predicate1D:
  "P \<le> Q \<Longrightarrow> P x \<Longrightarrow> Q x"
  apply (erule le_funE)
  apply (erule le_boolE)
  apply assumption+
  done

lemma rev_predicate1D:
  "P x \<Longrightarrow> P \<le> Q \<Longrightarrow> Q x"
  by (rule predicate1D)

lemma predicate2I:
  assumes PQ: "\<And>x y. P x y \<Longrightarrow> Q x y"
  shows "P \<le> Q"
  apply (rule le_funI)+
  apply (rule le_boolI)
  apply (rule PQ)
  apply assumption
  done

lemma predicate2D:
  "P \<le> Q \<Longrightarrow> P x y \<Longrightarrow> Q x y"
  apply (erule le_funE)+
  apply (erule le_boolE)
  apply assumption+
  done

lemma rev_predicate2D:
  "P x y \<Longrightarrow> P \<le> Q \<Longrightarrow> Q x y"
  by (rule predicate2D)

lemma bot1E [no_atp]: "\<bottom> x \<Longrightarrow> P"
  by (simp add: bot_fun_def)

lemma bot2E: "\<bottom> x y \<Longrightarrow> P"
  by (simp add: bot_fun_def)

lemma top1I: "\<top> x"
  by (simp add: top_fun_def)

lemma top2I: "\<top> x y"
  by (simp add: top_fun_def)

subsection {* Name duplicates *}

lemmas order_eq_refl = preorder_class.eq_refl
lemmas order_less_irrefl = preorder_class.less_irrefl
lemmas order_less_imp_le = preorder_class.less_imp_le
lemmas order_less_not_sym = preorder_class.less_not_sym
lemmas order_less_asym = preorder_class.less_asym
lemmas order_less_trans = preorder_class.less_trans
lemmas order_le_less_trans = preorder_class.le_less_trans
lemmas order_less_le_trans = preorder_class.less_le_trans
lemmas order_less_imp_not_less = preorder_class.less_imp_not_less
lemmas order_less_imp_triv = preorder_class.less_imp_triv
lemmas order_less_asym' = preorder_class.less_asym'

lemmas order_less_le = order_class.less_le
lemmas order_le_less = order_class.le_less
lemmas order_le_imp_less_or_eq = order_class.le_imp_less_or_eq
lemmas order_less_imp_not_eq = order_class.less_imp_not_eq
lemmas order_less_imp_not_eq2 = order_class.less_imp_not_eq2
lemmas order_neq_le_trans = order_class.neq_le_trans
lemmas order_le_neq_trans = order_class.le_neq_trans
lemmas order_antisym = order_class.antisym
lemmas order_eq_iff = order_class.eq_iff
lemmas order_antisym_conv = order_class.antisym_conv

lemmas linorder_linear = linorder_class.linear
lemmas linorder_less_linear = linorder_class.less_linear
lemmas linorder_le_less_linear = linorder_class.le_less_linear
lemmas linorder_le_cases = linorder_class.le_cases
lemmas linorder_not_less = linorder_class.not_less
lemmas linorder_not_le = linorder_class.not_le
lemmas linorder_neq_iff = linorder_class.neq_iff
lemmas linorder_neqE = linorder_class.neqE
lemmas linorder_antisym_conv1 = linorder_class.antisym_conv1
lemmas linorder_antisym_conv2 = linorder_class.antisym_conv2
lemmas linorder_antisym_conv3 = linorder_class.antisym_conv3

end


theory Submission
imports Defs
begin

(* The append lemma - gives 30% of the points.
   Note: While this lemma gives less points, it's actually harder to prove! *)

lemma rle_append: "xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys \<Longrightarrow> rle (xs @ ys) = rle xs @ rle ys"
  apply (induction xs rule: rle.induct)
  apply (auto split: if_splits)
  subgoal by (metis (mono_tags, lifting) hd_Cons_tl takeWhile.simps(1) takeWhile.simps(2))
  subgoal
    by (metis (full_types) dropWhile.simps(1) dropWhile.simps(2) hd_Cons_tl)
  subgoal
    apply (cases ys)
    apply auto
    by (smt append_Nil2 last_in_set list.sel(1) rle.elims takeWhile.simps(2) takeWhile_append1 takeWhile_append2 takeWhile_eq_all_conv)
  subgoal
    apply (cases ys)
    apply auto
    by (smt append_Nil2 dropWhile_append1 dropWhile_append3 dropWhile_eq_Nil_conv last_appendR last_in_set list.sel(1) rle.elims takeWhile_dropWhile_id)
  done
(* Given the append lemma show the reverse lemma - gives 70% of the points.
   Note: While this lemma gives more points, it might actually be easier to prove *)

lemma TKS: "set (takeWhile (\<lambda>y. y = x) xs) \<subseteq> {x}"
  apply (induction xs)
  apply simp
  by (metis (mono_tags, lifting) set_takeWhileD singleton_iff subsetI)

lemma 1: "rle (rev xs) = rev (rle xs)"
proof (induction xs rule: rle.induct)
  case 1
  then show ?case by auto
next
  case (2 x xs)

  have 1: "[(x, Suc (length (takeWhile (\<lambda>y. y = x) xs)))] = rle (takeWhile (\<lambda>y. y = x) (x#xs))"
    apply (cases xs)
    apply auto
    by (metis rle.simps(1) self_append_conv takeWhile_dropWhile_id takeWhile_idem)

  have x1: "rev (takeWhile (\<lambda>y. y = x) xs) = takeWhile (\<lambda>y. y = x) xs"
    by (simp add: SR[OF TKS])

  have x2: "rev (dropWhile (\<lambda>y. y = x) xs) @ takeWhile (\<lambda>y. y = x) (x # xs) = rev (x#xs)"
    apply simp
    apply (subst (3) takeWhile_dropWhile_id[of "(\<lambda>y. y = x)" xs, symmetric])
    apply (simp del: takeWhile_dropWhile_id)
    apply (subst x1)
    by (simp add: TKS)

  have "rev (rle (dropWhile (\<lambda>y. y = x) xs)) @ [(x, Suc (length (takeWhile (\<lambda>y. y = x) xs)))]
    = (rle (rev (x#xs)))
  "
    apply (simp only: 1 2[symmetric])
    apply (subst rle_append[symmetric])
    apply auto []
    apply (metis (full_types) append_Nil2 empty_iff filter_id_conv hd_dropWhile last_rev list.set(1) takeWhile_dropWhile_id takeWhile_eq_filter)
    apply (simp only: x2)
    done

  then show ?case
    by simp

qed

lemma rle_rev_if_rle_append: "(xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys \<Longrightarrow> rle (xs @ ys) = rle xs @ rle ys)
       \<Longrightarrow> rle (rev xs) = rev (rle xs)"
  using 1 by blast

end


theory ex301
  imports Main
begin
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

value "Node Tip True Tip"

fun set::"'a tree \<Rightarrow> 'a set" where
  "set Tip = {}"|
  "set (Node l v r) = (set l) \<union> {v} \<union> (set r)"

value "set (Node (Node (Node Tip 4 Tip) 1 (Node Tip 5 Tip)) (2::int) (Node Tip 3 Tip))"

fun get::"int tree \<Rightarrow> int" where
  "get Tip = 0"|
  "get (Node l v r) = v"

value "get (Node Tip 7 Tip)"

fun ord::"int tree \<Rightarrow> bool" where
  "ord Tip = True"|
  "ord (Node Tip v Tip) = True"|
  "ord (Node l v Tip) = (if (ord l)\<and>((get l) < v) then True else False)"|
  "ord (Node Tip v r) = (if (ord r)\<and>(v < (get r)) then True else False)"|
  "ord (Node l v r) = (if (ord l)\<and>(ord r)\<and>((get l)<v)\<and>(v<(get r)) then True else False)"

value "ord (Node (Node Tip 2 Tip) 4 Tip)"
value "ord (Node (Node (Node Tip 1 Tip) 2 (Node Tip 6 Tip)) 5 (Node Tip 6 Tip))"

fun ins::"int \<Rightarrow> int tree \<Rightarrow> int tree" where
  "ins x Tip = Node Tip x Tip"|
  "ins x (Node l v r) = (if (x=v) then (Node l v r) else (if (x<v) then (Node (ins x l) v r) else (Node l v (ins x r))))"

value "ins 3 (Node (Node Tip 2 Tip) 4 Tip)"

lemma ex301a: "set (ins x t) = {x} \<union> set t"
  apply(induction t arbitrary: x)
   apply(auto simp add:algebra_simps)
  done

lemma ex301b: "ord t \<Longrightarrow> ord (ins i t)"
  apply(induction t arbitrary: i)
   apply(auto simp add:algebra_simps)
  sorry

end


(*  Author:  Gertrud Bauer, Tobias Nipkow  *)

section \<open>Transitive Closure of Successor List Function\<close>

theory RTranCl
imports Main
begin

text\<open>The reflexive transitive closure of a relation induced by a
function of type @{typ"'a \<Rightarrow> 'a list"}. Instead of defining the closure
again it would have been simpler to take @{term"{(x,y) . y \<in> set(f x)}\<^sup>*"}.\<close>

abbreviation (input)
  in_set :: "'a \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b \<Rightarrow> bool" ("_ [_]\<rightarrow> _" [55,0,55] 50) where
  "g [succs]\<rightarrow> g' == g' \<in> set (succs g)"

inductive_set
  RTranCl :: "('a \<Rightarrow> 'a list) \<Rightarrow> ('a * 'a) set"
  and in_RTranCl :: "'a \<Rightarrow> ('a \<Rightarrow> 'a list) \<Rightarrow> 'a \<Rightarrow> bool"
    ("_ [_]\<rightarrow>* _" [55,0,55] 50)
  for succs :: "'a \<Rightarrow> 'a list"
where
  "g [succs]\<rightarrow>* g' \<equiv> (g,g') \<in> RTranCl succs"
| refl: "g [succs]\<rightarrow>* g"
| succs: "g [succs]\<rightarrow> g' \<Longrightarrow> g' [succs]\<rightarrow>* g'' \<Longrightarrow> g [succs]\<rightarrow>* g''"

inductive_cases RTranCl_elim: "(h,h') : RTranCl succs"

lemma RTranCl_induct(*<*) [induct set: RTranCl, consumes 1, case_names refl succs] (*>*):
 "(h, h') \<in> RTranCl succs \<Longrightarrow>
  P h \<Longrightarrow>
  (\<And>g g'. g' \<in> set (succs g) \<Longrightarrow> P g \<Longrightarrow> P g') \<Longrightarrow>
  P h'"
proof -
  assume s: "\<And>g g'. g' \<in> set (succs g) \<Longrightarrow> P g \<Longrightarrow> P g'"
  assume "(h, h') \<in> RTranCl succs" "P h"
  then show "P h'"
  proof (induct rule: RTranCl.induct)
    fix g assume "P g" then show "P g" .
  next
    fix g g' g''
    assume IH: "P g' \<Longrightarrow> P g''"
    assume "g' \<in> set(succs g)" "P g"
    then have "P g'" by (rule s)
    then show "P g''" by (rule IH)
  qed
qed

definition invariant :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a list) \<Rightarrow> bool" where
"invariant P succs \<equiv> \<forall>g g'. g' \<in> set(succs g) \<longrightarrow> P g \<longrightarrow> P g'"

lemma invariantE:
  "invariant P succs  \<Longrightarrow> g [succs]\<rightarrow> g' \<Longrightarrow> P g \<Longrightarrow> P g'"
by(simp add:invariant_def)

lemma inv_subset:
 "invariant P f \<Longrightarrow> (\<And>g. P g \<Longrightarrow> set(f' g) \<subseteq> set(f g)) \<Longrightarrow> invariant P f'"
by(auto simp:invariant_def)

lemma RTranCl_inv:
  "invariant P succs \<Longrightarrow> (g,g') \<in> RTranCl succs \<Longrightarrow> P g \<Longrightarrow> P g'"
by (erule RTranCl_induct)(auto simp:invariant_def)

lemma RTranCl_subset2:
assumes a: "(s,g) : RTranCl f"
shows "(\<And>g. (s,g) \<in> RTranCl f \<Longrightarrow> set(f g) \<subseteq> set(h g)) \<Longrightarrow> (s,g) : RTranCl h"
using a
proof (induct rule: RTranCl.induct)
  case refl show ?case by(rule RTranCl.intros)
next
  case succs thus ?case by(blast intro: RTranCl.intros)
qed

end


(*  Title:      HOL/Induct/QuoNestedDataType.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2004  University of Cambridge
*)

section\<open>Quotienting a Free Algebra Involving Nested Recursion\<close>

text \<open>This is the development promised in Lawrence Paulson's paper ``Defining functions on equivalence classes''
\emph{ACM Transactions on Computational Logic} \textbf{7}:40 (2006), 658--675,
illustrating bare-bones quotient constructions. Any comparison using lifting and transfer
should be done in a separate theory.\<close>

theory QuoNestedDataType imports Main begin

subsection\<open>Defining the Free Algebra\<close>

text\<open>Messages with encryption and decryption as free constructors.\<close>
datatype
     freeExp = VAR  nat
             | PLUS  freeExp freeExp
             | FNCALL  nat "freeExp list"

datatype_compat freeExp

text\<open>The equivalence relation, which makes PLUS associative.\<close>

text\<open>The first rule is the desired equation. The next three rules
make the equations applicable to subterms. The last two rules are symmetry
and transitivity.\<close>
inductive_set
  exprel :: "(freeExp * freeExp) set"
  and exp_rel :: "[freeExp, freeExp] => bool"  (infixl "\<sim>" 50)
  where
    "X \<sim> Y \<equiv> (X,Y) \<in> exprel"
  | ASSOC: "PLUS X (PLUS Y Z) \<sim> PLUS (PLUS X Y) Z"
  | VAR: "VAR N \<sim> VAR N"
  | PLUS: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> PLUS X Y \<sim> PLUS X' Y'"
  | FNCALL: "(Xs,Xs') \<in> listrel exprel \<Longrightarrow> FNCALL F Xs \<sim> FNCALL F Xs'"
  | SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
  | TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"
  monos listrel_mono

text\<open>Proving that it is an equivalence relation\<close>

lemma exprel_refl: "X \<sim> X"
  and list_exprel_refl: "(Xs,Xs) \<in> listrel(exprel)"
  by (induct X and Xs rule: compat_freeExp.induct compat_freeExp_list.induct)
    (blast intro: exprel.intros listrel.intros)+

theorem equiv_exprel: "equiv UNIV exprel"
proof -
  have "refl exprel" by (simp add: refl_on_def exprel_refl)
  moreover have "sym exprel" by (simp add: sym_def, blast intro: exprel.SYM)
  moreover have "trans exprel" by (simp add: trans_def, blast intro: exprel.TRANS)
  ultimately show ?thesis by (simp add: equiv_def)
qed

theorem equiv_list_exprel: "equiv UNIV (listrel exprel)"
  using equiv_listrel [OF equiv_exprel] by simp

lemma FNCALL_Cons:
  "\<lbrakk>X \<sim> X'; (Xs,Xs') \<in> listrel(exprel)\<rbrakk> \<Longrightarrow> FNCALL F (X#Xs) \<sim> FNCALL F (X'#Xs')"
  by (blast intro: exprel.intros listrel.intros)

subsection\<open>Some Functions on the Free Algebra\<close>

subsubsection\<open>The Set of Variables\<close>

text\<open>A function to return the set of variables present in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.
Note that the "free" refers to the free datatype rather than to the concept
of a free variable.\<close>
primrec freevars :: "freeExp \<Rightarrow> nat set" and freevars_list :: "freeExp list \<Rightarrow> nat set"
  where
  "freevars (VAR N) = {N}"
| "freevars (PLUS X Y) = freevars X \<union> freevars Y"
| "freevars (FNCALL F Xs) = freevars_list Xs"

| "freevars_list [] = {}"
| "freevars_list (X # Xs) = freevars X \<union> freevars_list Xs"

text\<open>This theorem lets us prove that the vars function respects the
equivalence relation.  It also helps us prove that Variable
  (the abstract constructor) is injective\<close>
theorem exprel_imp_eq_freevars: "U \<sim> V \<Longrightarrow> freevars U = freevars V"
proof (induct set: exprel)
  case (FNCALL Xs Xs' F)
  then show ?case
    by (induct rule: listrel.induct) auto
qed (simp_all add: Un_assoc)

subsubsection\<open>Functions for Freeness\<close>

text\<open>A discriminator function to distinguish vars, sums and function calls\<close>
primrec freediscrim :: "freeExp \<Rightarrow> int" where
  "freediscrim (VAR N) = 0"
| "freediscrim (PLUS X Y) = 1"
| "freediscrim (FNCALL F Xs) = 2"

theorem exprel_imp_eq_freediscrim:
     "U \<sim> V \<Longrightarrow> freediscrim U = freediscrim V"
  by (induct set: exprel) auto

text\<open>This function, which returns the function name, is used to
prove part of the injectivity property for FnCall.\<close>
primrec freefun :: "freeExp \<Rightarrow> nat" where
  "freefun (VAR N) = 0"
| "freefun (PLUS X Y) = 0"
| "freefun (FNCALL F Xs) = F"

theorem exprel_imp_eq_freefun:
     "U \<sim> V \<Longrightarrow> freefun U = freefun V"
  by (induct set: exprel) (simp_all add: listrel.intros)

text\<open>This function, which returns the list of function arguments, is used to
prove part of the injectivity property for FnCall.\<close>
primrec freeargs :: "freeExp \<Rightarrow> freeExp list" where
  "freeargs (VAR N) = []"
| "freeargs (PLUS X Y) = []"
| "freeargs (FNCALL F Xs) = Xs"

theorem exprel_imp_eqv_freeargs:
  assumes "U \<sim> V"
  shows "(freeargs U, freeargs V) \<in> listrel exprel"
  using assms
proof induction
  case (FNCALL Xs Xs' F)
  then show ?case
    by (simp add: listrel_iff_nth)
next
  case (SYM X Y)
  then show ?case
    by (meson equivE equiv_list_exprel symD)
next
  case (TRANS X Y Z)
  then show ?case
    by (meson equivE equiv_list_exprel transD)
qed (use listrel.simps in auto)

subsection\<open>The Initial Algebra: A Quotiented Message Type\<close>

definition "Exp = UNIV//exprel"

typedef exp = Exp
  morphisms Rep_Exp Abs_Exp
  unfolding Exp_def by (auto simp add: quotient_def)

text\<open>The abstract message constructors\<close>

definition
  Var :: "nat \<Rightarrow> exp" where
  "Var N = Abs_Exp(exprel``{VAR N})"

definition
  Plus :: "[exp,exp] \<Rightarrow> exp" where
   "Plus X Y =
       Abs_Exp (\<Union>U \<in> Rep_Exp X. \<Union>V \<in> Rep_Exp Y. exprel``{PLUS U V})"

definition
  FnCall :: "[nat, exp list] \<Rightarrow> exp" where
   "FnCall F Xs =
       Abs_Exp (\<Union>Us \<in> listset (map Rep_Exp Xs). exprel``{FNCALL F Us})"

text\<open>Reduces equality of equivalence classes to the \<^term>\<open>exprel\<close> relation:
  \<^term>\<open>(exprel``{x} = exprel``{y}) = ((x,y) \<in> exprel)\<close>\<close>
lemmas equiv_exprel_iff = eq_equiv_class_iff [OF equiv_exprel UNIV_I UNIV_I]

declare equiv_exprel_iff [simp]

text\<open>All equivalence classes belong to set of representatives\<close>
lemma exprel_in_Exp [simp]: "exprel``{U} \<in> Exp"
  by (simp add: Exp_def quotientI)

lemma inj_on_Abs_Exp: "inj_on Abs_Exp Exp"
  by (meson Abs_Exp_inject inj_onI)

text\<open>Reduces equality on abstractions to equality on representatives\<close>
declare inj_on_Abs_Exp [THEN inj_on_eq_iff, simp]

declare Abs_Exp_inverse [simp]

text\<open>Case analysis on the representation of a exp as an equivalence class.\<close>
lemma eq_Abs_Exp [case_names Abs_Exp, cases type: exp]:
     "(\<And>U. z = Abs_Exp (exprel``{U}) \<Longrightarrow> P) \<Longrightarrow> P"
  by (metis Abs_Exp_cases Exp_def quotientE)

subsection\<open>Every list of abstract expressions can be expressed in terms of a
  list of concrete expressions\<close>

definition
  Abs_ExpList :: "freeExp list => exp list" where
  "Abs_ExpList Xs \<equiv> map (\<lambda>U. Abs_Exp(exprel``{U})) Xs"

lemma Abs_ExpList_Nil [simp]: "Abs_ExpList [] = []"
  by (simp add: Abs_ExpList_def)

lemma Abs_ExpList_Cons [simp]:
  "Abs_ExpList (X#Xs) = Abs_Exp (exprel``{X}) # Abs_ExpList Xs"
  by (simp add: Abs_ExpList_def)

lemma ExpList_rep: "\<exists>Us. z = Abs_ExpList Us"
  by (smt (verit, del_insts) Abs_ExpList_def eq_Abs_Exp ex_map_conv)

subsubsection\<open>Characteristic Equations for the Abstract Constructors\<close>

lemma Plus: "Plus (Abs_Exp(exprel``{U})) (Abs_Exp(exprel``{V})) =
             Abs_Exp (exprel``{PLUS U V})"
proof -
  have "(\<lambda>U V. exprel``{PLUS U V}) respects2 exprel"
    by (auto simp add: congruent2_def exprel.PLUS)
  thus ?thesis
    by (simp add: Plus_def UN_equiv_class2 [OF equiv_exprel equiv_exprel])
qed

text\<open>It is not clear what to do with FnCall: it's argument is an abstraction
of an \<^typ>\<open>exp list\<close>. Is it just Nil or Cons? What seems to work best is to
regard an \<^typ>\<open>exp list\<close> as a \<^term>\<open>listrel exprel\<close> equivalence class\<close>

text\<open>This theorem is easily proved but never used. There's no obvious way
even to state the analogous result, \<open>FnCall_Cons\<close>.\<close>
lemma FnCall_Nil: "FnCall F [] = Abs_Exp (exprel``{FNCALL F []})"
  by (simp add: FnCall_def)

lemma FnCall_respects:
     "(\<lambda>Us. exprel``{FNCALL F Us}) respects (listrel exprel)"
  by (auto simp add: congruent_def exprel.FNCALL)

lemma FnCall_sing:
     "FnCall F [Abs_Exp(exprel``{U})] = Abs_Exp (exprel``{FNCALL F [U]})"
proof -
  have "(\<lambda>U. exprel``{FNCALL F [U]}) respects exprel"
    by (auto simp add: congruent_def FNCALL_Cons listrel.intros)
  thus ?thesis
    by (simp add: FnCall_def UN_equiv_class [OF equiv_exprel])
qed

lemma listset_Rep_Exp_Abs_Exp:
     "listset (map Rep_Exp (Abs_ExpList Us)) = listrel exprel``{Us}"
  by (induct Us) (simp_all add: listrel_Cons Abs_ExpList_def)

lemma FnCall:
     "FnCall F (Abs_ExpList Us) = Abs_Exp (exprel``{FNCALL F Us})"
proof -
  have "(\<lambda>Us. exprel``{FNCALL F Us}) respects (listrel exprel)"
    by (auto simp add: congruent_def exprel.FNCALL)
  thus ?thesis
    by (simp add: FnCall_def UN_equiv_class [OF equiv_list_exprel]
                  listset_Rep_Exp_Abs_Exp)
qed

text\<open>Establishing this equation is the point of the whole exercise\<close>

subsection\<open>The Abstract Function to Return the Set of Variables\<close>

definition
  vars :: "exp \<Rightarrow> nat set" where "vars X \<equiv> (\<Union>U \<in> Rep_Exp X. freevars U)"

lemma vars_respects: "freevars respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freevars)

text\<open>The extension of the function \<^term>\<open>vars\<close> to lists\<close>
primrec vars_list :: "exp list \<Rightarrow> nat set" where
  "vars_list []    = {}"
| "vars_list(E#Es) = vars E \<union> vars_list Es"

text\<open>Now prove the three equations for \<^term>\<open>vars\<close>\<close>

lemma vars_Variable [simp]: "vars (Var N) = {N}"
by (simp add: vars_def Var_def
              UN_equiv_class [OF equiv_exprel vars_respects])

lemma vars_Plus [simp]: "vars (Plus X Y) = vars X \<union> vars Y"
proof -
  have "\<And>U V. \<lbrakk>X = Abs_Exp (exprel``{U}); Y = Abs_Exp (exprel``{V})\<rbrakk>
               \<Longrightarrow> vars (Plus X Y) = vars X \<union> vars Y"
    by (simp add: vars_def Plus UN_equiv_class [OF equiv_exprel vars_respects])
  then show ?thesis
    by (meson eq_Abs_Exp)
qed

lemma vars_FnCall [simp]: "vars (FnCall F Xs) = vars_list Xs"
proof -
  have "vars (Abs_Exp (exprel``{FNCALL F Us})) = vars_list (Abs_ExpList Us)" for Us
    by (induct Us) (auto simp: vars_def UN_equiv_class [OF equiv_exprel vars_respects])
  then show ?thesis
    by (metis ExpList_rep FnCall)
qed

lemma vars_FnCall_Nil: "vars (FnCall F Nil) = {}"
  by simp

lemma vars_FnCall_Cons: "vars (FnCall F (X#Xs)) = vars X \<union> vars_list Xs"
  by simp

subsection\<open>Injectivity Properties of Some Constructors\<close>

lemma VAR_imp_eq: "VAR m \<sim> VAR n \<Longrightarrow> m = n"
  by (drule exprel_imp_eq_freevars, simp)

text\<open>Can also be proved using the function \<^term>\<open>vars\<close>\<close>
lemma Var_Var_eq [iff]: "(Var m = Var n) = (m = n)"
  by (auto simp add: Var_def exprel_refl dest: VAR_imp_eq)

lemma VAR_neqv_PLUS: "VAR m \<sim> PLUS X Y \<Longrightarrow> False"
  using exprel_imp_eq_freediscrim by force

theorem Var_neq_Plus [iff]: "Var N \<noteq> Plus X Y"
proof -
  have "\<And>U V. \<lbrakk>X = Abs_Exp (exprel``{U}); Y = Abs_Exp (exprel``{V})\<rbrakk> \<Longrightarrow> Var N \<noteq> Plus X Y"
    using Plus VAR_neqv_PLUS Var_def by force
  then show ?thesis
    by (meson eq_Abs_Exp)
qed

theorem Var_neq_FnCall [iff]: "Var N \<noteq> FnCall F Xs"
proof -
  have "\<And>Us. Var N \<noteq> FnCall F (Abs_ExpList Us)"
    using FnCall Var_def exprel_imp_eq_freediscrim by fastforce
  then show ?thesis
    by (metis ExpList_rep)
qed

subsection\<open>Injectivity of \<^term>\<open>FnCall\<close>\<close>

definition
  "fun" :: "exp \<Rightarrow> nat"
  where "fun X \<equiv> the_elem (\<Union>U \<in> Rep_Exp X. {freefun U})"

lemma fun_respects: "(\<lambda>U. {freefun U}) respects exprel"
  by (auto simp add: congruent_def exprel_imp_eq_freefun)

lemma fun_FnCall [simp]: "fun (FnCall F Xs) = F"
proof -
  have "\<And>Us. fun (FnCall F (Abs_ExpList Us)) = F"
    using FnCall UN_equiv_class [OF equiv_exprel] fun_def fun_respects by fastforce
  then show ?thesis
    by (metis ExpList_rep)
qed

definition
  args :: "exp \<Rightarrow> exp list" where
  "args X = the_elem (\<Union>U \<in> Rep_Exp X. {Abs_ExpList (freeargs U)})"

text\<open>This result can probably be generalized to arbitrary equivalence
relations, but with little benefit here.\<close>
lemma Abs_ExpList_eq:
     "(y, z) \<in> listrel exprel \<Longrightarrow> Abs_ExpList (y) = Abs_ExpList (z)"
  by (induct set: listrel) simp_all

lemma args_respects: "(\<lambda>U. {Abs_ExpList (freeargs U)}) respects exprel"
  by (auto simp add: congruent_def Abs_ExpList_eq exprel_imp_eqv_freeargs)

lemma args_FnCall [simp]: "args (FnCall F Xs) = Xs"
proof -
  have "\<And>Us. Xs = Abs_ExpList Us \<Longrightarrow> args (FnCall F Xs) = Xs"
    by (simp add: FnCall args_def UN_equiv_class [OF equiv_exprel args_respects])
  then show ?thesis
    by (metis ExpList_rep)
qed

lemma FnCall_FnCall_eq [iff]: "(FnCall F Xs = FnCall F' Xs') \<longleftrightarrow> (F=F' \<and> Xs=Xs')"
  by (metis args_FnCall fun_FnCall)

subsection\<open>The Abstract Discriminator\<close>
text\<open>However, as \<open>FnCall_Var_neq_Var\<close> illustrates, we don't need this
function in order to prove discrimination theorems.\<close>

definition
  discrim :: "exp \<Rightarrow> int" where
  "discrim X = the_elem (\<Union>U \<in> Rep_Exp X. {freediscrim U})"

lemma discrim_respects: "(\<lambda>U. {freediscrim U}) respects exprel"
by (auto simp add: congruent_def exprel_imp_eq_freediscrim)

text\<open>Now prove the four equations for \<^term>\<open>discrim\<close>\<close>

lemma discrim_Var [simp]: "discrim (Var N) = 0"
  by (simp add: discrim_def Var_def UN_equiv_class [OF equiv_exprel discrim_respects])

lemma discrim_Plus [simp]: "discrim (Plus X Y) = 1"
proof -
  have "\<And>U V. \<lbrakk>X = Abs_Exp (exprel``{U}); Y = Abs_Exp (exprel``{V})\<rbrakk> \<Longrightarrow> discrim (Plus X Y) = 1"
    by (simp add: discrim_def Plus  UN_equiv_class [OF equiv_exprel discrim_respects])
  then show ?thesis
    by (meson eq_Abs_Exp)
qed

lemma discrim_FnCall [simp]: "discrim (FnCall F Xs) = 2"
proof -
  have "discrim (FnCall F (Abs_ExpList Us)) = 2" for Us
    by (simp add: discrim_def FnCall UN_equiv_class [OF equiv_exprel discrim_respects])
  then show ?thesis
    by (metis ExpList_rep)
qed

text\<open>The structural induction rule for the abstract type\<close>
theorem exp_inducts:
  assumes V:    "\<And>nat. P1 (Var nat)"
      and P:    "\<And>exp1 exp2. \<lbrakk>P1 exp1; P1 exp2\<rbrakk> \<Longrightarrow> P1 (Plus exp1 exp2)"
      and F:    "\<And>nat list. P2 list \<Longrightarrow> P1 (FnCall nat list)"
      and Nil:  "P2 []"
      and Cons: "\<And>exp list. \<lbrakk>P1 exp; P2 list\<rbrakk> \<Longrightarrow> P2 (exp # list)"
  shows "P1 exp" and "P2 list"
proof -
  obtain U where exp: "exp = (Abs_Exp (exprel``{U}))" by (cases exp)
  obtain Us where list: "list = Abs_ExpList Us" by (metis ExpList_rep)
  have "P1 (Abs_Exp (exprel``{U}))" and "P2 (Abs_ExpList Us)"
  proof (induct U and Us rule: compat_freeExp.induct compat_freeExp_list.induct)
    case (VAR nat)
    with V show ?case by (simp add: Var_def)
  next
    case (PLUS X Y)
    with P [of "Abs_Exp (exprel``{X})" "Abs_Exp (exprel``{Y})"]
    show ?case by (simp add: Plus)
  next
    case (FNCALL nat list)
    with F [of "Abs_ExpList list"]
    show ?case by (simp add: FnCall)
  next
    case Nil_freeExp
    with Nil show ?case by simp
  next
    case Cons_freeExp
    with Cons show ?case by simp
  qed
  with exp and list show "P1 exp" and "P2 list" by (simp_all only:)
qed

end


(* Title:  Rtrancl_On.thy
   Author: Lars Noschinski, TU München
   Author: René Neumann, TU München
*)

theory Rtrancl_On
imports Main
begin

section {* Reflexive-Transitive Closure on a Domain *}

text {*
  In this section we introduce a variant of the reflexive-transitive closure
  of a relation which is useful to formalize the reachability relation on
  digraphs.
*}

inductive_set
  rtrancl_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a rel"
  for F :: "'a set" and r :: "'a rel"
where
    rtrancl_on_refl [intro!, Pure.intro!, simp]: "a \<in> F \<Longrightarrow> (a, a) \<in> rtrancl_on F r"
  | rtrancl_on_into_rtrancl_on [Pure.intro]:
      "(a, b) \<in> rtrancl_on F r  \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> c \<in> F
      \<Longrightarrow> (a, c) \<in> rtrancl_on F r"

definition symcl :: "'a rel \<Rightarrow> 'a rel" ("(_\<^sup>s)" [1000] 999) where
  "symcl R = R \<union> (\<lambda>(a,b). (b,a)) ` R"

lemma in_rtrancl_on_in_F:
  assumes "(a,b) \<in> rtrancl_on F r" shows "a \<in> F" "b \<in> F"
  using assms by induct auto

lemma rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]:
  assumes "(a, b) \<in> rtrancl_on F r"
    and "a \<in> F \<Longrightarrow> P a"
        "\<And>y z. \<lbrakk>(a, y) \<in> rtrancl_on F r; (y,z) \<in> r; y \<in> F; z \<in> F; P y\<rbrakk> \<Longrightarrow> P z"
  shows "P b"
  using assms by (induct a b) (auto dest: in_rtrancl_on_in_F)

lemma rtrancl_on_trans:
  assumes "(a,b) \<in> rtrancl_on F r" "(b,c) \<in> rtrancl_on F r" shows "(a,c) \<in> rtrancl_on F r"
  using assms(2,1)
  by induct (auto intro: rtrancl_on_into_rtrancl_on)

lemma converse_rtrancl_on_into_rtrancl_on:
  assumes "(a,b) \<in> r" "(b, c) \<in> rtrancl_on F r" "a \<in> F" "b \<in> F"
  shows "(a, c) \<in> rtrancl_on F r"
  apply (rule rtrancl_on_trans)
  apply (rule rtrancl_on_into_rtrancl_on)
  apply (rule rtrancl_on_refl)
  by fact+

theorem rtrancl_on_converseI:
  assumes "(y, x) \<in> rtrancl_on F r" shows "(x, y) \<in> rtrancl_on F (r\<inverse>)"
  using assms
proof induct
  case (step a b)
  then have "(b,b) \<in> rtrancl_on F (r\<inverse>)" "(b,a) \<in> r\<inverse>" by auto
  then show ?case using step
    by (metis rtrancl_on_trans rtrancl_on_into_rtrancl_on)
qed auto

theorem rtrancl_on_converseD:
  assumes "(y, x) \<in> rtrancl_on F (r\<inverse>)" shows "(x, y) \<in> rtrancl_on F r"
  using assms by - (drule rtrancl_on_converseI, simp)

lemma converse_rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]:
  assumes major: "(a, b) \<in> rtrancl_on F r"
    and cases: "b \<in> F \<Longrightarrow> P b"
       "\<And>x y. \<lbrakk>(x,y) \<in> r; (y,b) \<in> rtrancl_on F r; x \<in> F; y \<in> F; P y\<rbrakk> \<Longrightarrow> P x"
  shows "P a"
  using rtrancl_on_converseI[OF major] cases
  by induct (auto intro: rtrancl_on_converseD)

lemma rtrancl_on_sym:
  assumes "sym r" shows "sym (rtrancl_on F r)"
using assms by (auto simp: sym_conv_converse_eq intro: symI dest: rtrancl_on_converseI)

lemma rtrancl_on_mono:
  assumes "s \<subseteq> r" "F \<subseteq> G" "(a,b) \<in> rtrancl_on F s" shows "(a,b) \<in> rtrancl_on G r"
  using assms(3,1,2)
proof induct
  case (step x y) show ?case
    using step assms by (intro converse_rtrancl_on_into_rtrancl_on[OF _ step(5)]) auto
qed auto

lemma rtrancl_consistent_rtrancl_on:
  assumes "(a,b) \<in> r\<^sup>*"
  and "a \<in> F" "b \<in> F"
  and consistent: "\<And>a b. \<lbrakk> a \<in> F; (a,b) \<in> r \<rbrakk> \<Longrightarrow> b \<in> F"
  shows "(a,b) \<in> rtrancl_on F r"
  using assms(1-3)
proof (induction rule: converse_rtrancl_induct)
  case (step y z) then have "z \<in> F" by (rule_tac consistent) simp
  with step have "(z,b) \<in> rtrancl_on F r" by simp
  with step.prems `(y,z) \<in> r` `z \<in> F` show ?case
    using converse_rtrancl_on_into_rtrancl_on
    by metis
qed simp

lemma rtrancl_on_rtranclI:
  "(a,b) \<in> rtrancl_on F r \<Longrightarrow> (a,b) \<in> r\<^sup>*"
  by (induct rule: rtrancl_on_induct) simp_all

lemma rtrancl_on_sub_rtrancl:
  "rtrancl_on F r \<subseteq> r^*"
  using rtrancl_on_rtranclI
  by auto

end


(*
  Authors: Asta Halkjær From & Jørgen Villadsen, DTU Compute
*)

section \<open>Formalization of Łukasiewicz's Axiom System from 1924 for Classical Propositional Logic\<close>

subsection \<open>Syntax, Semantics and Axiom System\<close>

theory Implicational_Logic_Appendix imports Main begin

datatype form =
  Pro nat (\<open>\<cdot>\<close>) |
  Neg form (\<open>\<sim>\<close>) |
  Imp form form (infixr \<open>\<rightarrow>\<close> 55)

primrec semantics (infix \<open>\<Turnstile>\<close> 50) where
  \<open>I \<Turnstile> \<cdot> n = I n\<close> |
  \<open>I \<Turnstile> \<sim> p = (\<not> I \<Turnstile> p)\<close> |
  \<open>I \<Turnstile> p \<rightarrow> q = (I \<Turnstile> p \<longrightarrow> I \<Turnstile> q)\<close>

inductive Ax (\<open>\<turnstile> _\<close> 50) where
  01: \<open>\<turnstile> (p \<rightarrow> q) \<rightarrow> (q \<rightarrow> r) \<rightarrow> p \<rightarrow> r\<close> |
  02: \<open>\<turnstile> (\<sim> p \<rightarrow> p) \<rightarrow> p\<close> |
  03: \<open>\<turnstile> p \<rightarrow> \<sim> p \<rightarrow> q\<close> |
  MP: \<open>\<turnstile> p \<rightarrow> q \<Longrightarrow> \<turnstile> p \<Longrightarrow> \<turnstile> q\<close>

subsection \<open>Soundness and Derived Formulas\<close>

theorem soundness: \<open>\<turnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct p rule: Ax.induct) simp_all

lemma 04: \<open>\<turnstile> (((q \<rightarrow> r) \<rightarrow> p \<rightarrow> r) \<rightarrow> s) \<rightarrow> (p \<rightarrow> q) \<rightarrow> s\<close>
  using MP 01 01 .

lemma 05: \<open>\<turnstile> (p \<rightarrow> q \<rightarrow> r) \<rightarrow> (s \<rightarrow> q) \<rightarrow> p \<rightarrow> s \<rightarrow> r\<close>
  using MP 04 04 .

lemma 06: \<open>\<turnstile> (p \<rightarrow> q) \<rightarrow> ((p \<rightarrow> r) \<rightarrow> s) \<rightarrow> (q \<rightarrow> r) \<rightarrow> s\<close>
  using MP 04 01 .

lemma 07: \<open>\<turnstile> (t \<rightarrow> (p \<rightarrow> r) \<rightarrow> s) \<rightarrow> (p \<rightarrow> q) \<rightarrow> t \<rightarrow> (q \<rightarrow> r) \<rightarrow> s\<close>
  using MP 05 06 .

lemma 09: \<open>\<turnstile> ((\<sim> p \<rightarrow> q) \<rightarrow> r) \<rightarrow> p \<rightarrow> r\<close>
  using MP 01 03 .

lemma 10: \<open>\<turnstile> p \<rightarrow> ((\<sim> p \<rightarrow> p) \<rightarrow> p) \<rightarrow> (q \<rightarrow> p) \<rightarrow> p\<close>
  using MP 09 06 .

lemma 11: \<open>\<turnstile> (q \<rightarrow> (\<sim> p \<rightarrow> p) \<rightarrow> p) \<rightarrow> (\<sim> p \<rightarrow> p) \<rightarrow> p\<close>
  using MP MP 10 02 02 .

lemma 12: \<open>\<turnstile> t \<rightarrow> (\<sim> p \<rightarrow> p) \<rightarrow> p\<close>
  using MP 09 11 .

lemma 13: \<open>\<turnstile> (\<sim> p \<rightarrow> q) \<rightarrow> t \<rightarrow> (q \<rightarrow> p) \<rightarrow> p\<close>
  using MP 07 12 .

lemma 14: \<open>\<turnstile> ((t \<rightarrow> (q \<rightarrow> p) \<rightarrow> p) \<rightarrow> r) \<rightarrow> (\<sim> p \<rightarrow> q) \<rightarrow> r\<close>
  using MP 01 13 .

lemma 15: \<open>\<turnstile> (\<sim> p \<rightarrow> q) \<rightarrow> (q \<rightarrow> p) \<rightarrow> p\<close>
  using MP 14 02 .

lemma 16: \<open>\<turnstile> p \<rightarrow> p\<close>
  using MP 09 02 .

lemma 17: \<open>\<turnstile> p \<rightarrow> (q \<rightarrow> p) \<rightarrow> p\<close>
  using MP 09 15 .

lemma 18: \<open>\<turnstile> q \<rightarrow> p \<rightarrow> q\<close>
  using MP MP 05 17 03 .

lemma 19: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> q \<rightarrow> r\<close>
  using MP 01 18 .

lemma 20: \<open>\<turnstile> p \<rightarrow> (p \<rightarrow> q) \<rightarrow> q\<close>
  using MP 19 15 .

lemma 21: \<open>\<turnstile> (p \<rightarrow> q \<rightarrow> r) \<rightarrow> q \<rightarrow> p \<rightarrow> r\<close>
  using MP 05 20 .

lemma 22: \<open>\<turnstile> (q \<rightarrow> r) \<rightarrow> (p \<rightarrow> q) \<rightarrow> p \<rightarrow> r\<close>
  using MP 21 01 .

lemma 23: \<open>\<turnstile> ((q \<rightarrow> p \<rightarrow> r) \<rightarrow> s) \<rightarrow> (p \<rightarrow> q \<rightarrow> r) \<rightarrow> s\<close>
  using MP 01 21 .

lemma 24: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> p) \<rightarrow> p\<close>
  using MP MP 23 15 03 .

lemma 25: \<open>\<turnstile> ((p \<rightarrow> r) \<rightarrow> s) \<rightarrow> (p \<rightarrow> q) \<rightarrow> (q \<rightarrow> r) \<rightarrow> s\<close>
  using MP 21 06 .

lemma 26: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (r \<rightarrow> p) \<rightarrow> p\<close>
  using MP 25 24 .

lemma 28: \<open>\<turnstile> (((r \<rightarrow> p) \<rightarrow> p) \<rightarrow> s) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> s\<close>
  using MP 01 26 .

lemma 29: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (p \<rightarrow> r) \<rightarrow> r\<close>
  using MP 28 26 .

lemma 31: \<open>\<turnstile> (p \<rightarrow> s) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (s \<rightarrow> r) \<rightarrow> r\<close>
  using MP 07 29 .

lemma 32: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (p \<rightarrow> s) \<rightarrow> (s \<rightarrow> r) \<rightarrow> r\<close>
  using MP 21 31 .

lemma 33: \<open>\<turnstile> (p \<rightarrow> s) \<rightarrow> (s \<rightarrow> q \<rightarrow> p \<rightarrow> r) \<rightarrow> q \<rightarrow> p \<rightarrow> r\<close>
  using MP 32 18 .

lemma 34: \<open>\<turnstile> (s \<rightarrow> q \<rightarrow> p \<rightarrow> r) \<rightarrow> (p \<rightarrow> s) \<rightarrow> q \<rightarrow> p \<rightarrow> r\<close>
  using MP 21 33 .

lemma 35: \<open>\<turnstile> (p \<rightarrow> q \<rightarrow> r) \<rightarrow> (p \<rightarrow> q) \<rightarrow> p \<rightarrow> r\<close>
  using MP 34 22 .

lemma 36: \<open>\<turnstile> \<sim> p \<rightarrow> p \<rightarrow> q\<close>
  using MP 21 03 .

lemmas
  Tran = 01 and
  Clavius = 02 and
  Expl = 03 and
  Frege' = 05 and
  Clavius' = 15 and
  Id = 16 and
  Simp = 18 and
  Swap = 21 and
  Tran' = 22 and
  Peirce = 24 and
  Frege = 35 and
  Expl' = 36

lemma Neg1: \<open>\<turnstile> (q \<rightarrow> s) \<rightarrow> (\<sim> q \<rightarrow> s) \<rightarrow> s\<close>
  using MP Clavius' Expl' Frege' Swap by meson

lemma Neg2: \<open>\<turnstile> ((q \<rightarrow> s) \<rightarrow> s) \<rightarrow> \<sim> q \<rightarrow> s\<close>
  using MP Tran MP Swap Expl .

lemma Imp1: \<open>\<turnstile> (q \<rightarrow> s) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
  using MP Peirce Tran Tran' by meson

lemma Imp2: \<open>\<turnstile> ((r \<rightarrow> s) \<rightarrow> s) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
  using MP Tran MP Tran Simp .

lemma Imp3: \<open>\<turnstile> ((q \<rightarrow> s) \<rightarrow> s) \<rightarrow> (r \<rightarrow> s) \<rightarrow> (q \<rightarrow> r) \<rightarrow> s\<close>
  using MP Swap Tran by meson

subsection \<open>Completeness and Main Theorem\<close>

primrec pros where
  \<open>pros (\<cdot> n) = [n]\<close> |
  \<open>pros (\<sim> p) = pros p\<close> |
  \<open>pros (p \<rightarrow> q) = remdups (pros p @ pros q)\<close>

lemma distinct_pros: \<open>distinct (pros p)\<close>
  by (induct p) simp_all

primrec imply (infixr \<open>\<leadsto>\<close> 56) where
  \<open>[] \<leadsto> q = q\<close> |
  \<open>p # ps \<leadsto> q = p \<rightarrow> ps \<leadsto> q\<close>

lemma imply_append: \<open>ps @ qs \<leadsto> r = ps \<leadsto> qs \<leadsto> r\<close>
  by (induct ps) simp_all

abbreviation Ax_assms (infix \<open>\<turnstile>\<close> 50) where \<open>ps \<turnstile> q \<equiv> \<turnstile> ps \<leadsto> q\<close>

lemma imply_Cons: \<open>ps \<turnstile> q \<Longrightarrow> p # ps \<turnstile> q\<close>
proof -
  assume \<open>ps \<turnstile> q\<close>
  with MP Simp have \<open>\<turnstile> p \<rightarrow> ps \<leadsto> q\<close> .
  then show ?thesis
    by simp
qed

lemma imply_head: \<open>p # ps \<turnstile> p\<close>
  by (induct ps) (use MP Frege Simp imply.simps in metis)+

lemma imply_mem: \<open>p \<in> set ps \<Longrightarrow> ps \<turnstile> p\<close>
  by (induct ps) (use imply_Cons imply_head in auto)

lemma imply_MP: \<open>\<turnstile> ps \<leadsto> (p \<rightarrow> q) \<rightarrow> ps \<leadsto> p \<rightarrow> ps \<leadsto> q\<close>
proof (induct ps)
  case (Cons r ps)
  then have \<open>\<turnstile> (r \<rightarrow> ps \<leadsto> (p \<rightarrow> q)) \<rightarrow> (r \<rightarrow> ps \<leadsto> p) \<rightarrow> r \<rightarrow> ps \<leadsto> q\<close>
    using MP Frege Simp by meson
  then show ?case
    by simp
qed (auto intro: Id)

lemma MP': \<open>ps \<turnstile> p \<rightarrow> q \<Longrightarrow> ps \<turnstile> p \<Longrightarrow> ps \<turnstile> q\<close>
  using MP imply_MP by metis

lemma imply_swap_append: \<open>ps @ qs \<turnstile> r \<Longrightarrow> qs @ ps \<turnstile> r\<close>
  by (induct qs arbitrary: ps) (simp, metis MP' imply_append imply_Cons imply_head imply.simps(2))

lemma imply_deduct: \<open>p # ps \<turnstile> q \<Longrightarrow> ps \<turnstile> p \<rightarrow> q\<close>
  using imply_append imply_swap_append imply.simps by metis

lemma add_imply [simp]: \<open>\<turnstile> p \<Longrightarrow> ps \<turnstile> p\<close>
proof -
  note MP
  moreover have \<open>\<turnstile> p \<rightarrow> ps \<leadsto> p\<close>
    using imply_head by simp
  moreover assume \<open>\<turnstile> p\<close>
  ultimately show ?thesis .
qed

lemma imply_weaken: \<open>ps \<turnstile> p \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> ps' \<turnstile> p\<close>
  by (induct ps arbitrary: p) (simp, metis MP' imply_deduct imply_mem insert_subset list.set(2))

abbreviation \<open>lift t s p \<equiv> if t then (p \<rightarrow> s) \<rightarrow> s else p \<rightarrow> s\<close>

abbreviation \<open>lifts I s \<equiv> map (\<lambda>n. lift (I n) s (\<cdot> n))\<close>

lemma lifts_weaken: \<open>lifts I s l \<turnstile> p \<Longrightarrow> set l \<subseteq> set l' \<Longrightarrow> lifts I s l' \<turnstile> p\<close>
  using imply_weaken by (metis (no_types, lifting) image_mono set_map)

lemma lifts_pros_lift: \<open>lifts I s (pros p) \<turnstile> lift (I \<Turnstile> p) s p\<close>
proof (induct p)
  case (Neg q)
  consider \<open>\<not> I \<Turnstile> q\<close> | \<open>I \<Turnstile> q\<close>
    by blast
  then show ?case
  proof cases
    case 1
    then have \<open>lifts I s (pros (\<sim> q)) \<turnstile> q \<rightarrow> s\<close>
      using Neg by simp
    then have \<open>lifts I s (pros (\<sim> q)) \<turnstile> (\<sim> q \<rightarrow> s) \<rightarrow> s\<close>
      using MP' Neg1 add_imply by blast
    with 1 show ?thesis
      by simp
  next
    case 2
    then have \<open>lifts I s (pros (\<sim> q)) \<turnstile> (q \<rightarrow> s) \<rightarrow> s\<close>
      using Neg by simp
    then have \<open>lifts I s (pros (\<sim> q)) \<turnstile> \<sim> q \<rightarrow> s\<close>
      using MP' Neg2 add_imply by blast
    with 2 show ?thesis
      by simp
  qed
next
  case (Imp q r)
  consider \<open>\<not> I \<Turnstile> q\<close> | \<open>I \<Turnstile> r\<close> | \<open>I \<Turnstile> q\<close> \<open>\<not> I \<Turnstile> r\<close>
    by blast
  then show ?case
  proof cases
    case 1
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> q \<rightarrow> s\<close>
      using Imp(1) lifts_weaken[where l' = \<open>pros (q \<rightarrow> r)\<close>] by simp
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
      using Imp1 MP' add_imply by blast
    with 1 show ?thesis
      by simp
  next
    case 2
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> (r \<rightarrow> s) \<rightarrow> s\<close>
      using Imp(2) lifts_weaken[where l' = \<open>pros (q \<rightarrow> r)\<close>] by simp
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
      using Imp2 MP' add_imply by blast
    with 2 show ?thesis
      by simp
  next
    case 3
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> (q \<rightarrow> s) \<rightarrow> s\<close> \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> r \<rightarrow> s\<close>
      using Imp lifts_weaken[where l' = \<open>pros (q \<rightarrow> r)\<close>] by simp_all
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> (q \<rightarrow> r) \<rightarrow> s\<close>
      using Imp3 MP' add_imply by blast
    with 3 show ?thesis
      by simp
  qed
qed (auto intro: Id)

lemma lifts_pros: \<open>I \<Turnstile> p \<Longrightarrow> lifts I p (pros p) \<turnstile> p\<close>
proof -
  assume \<open>I \<Turnstile> p\<close>
  then have \<open>lifts I p (pros p) \<turnstile> (p \<rightarrow> p) \<rightarrow> p\<close>
    using lifts_pros_lift[of I p p] by simp
  then show ?thesis
    using Id MP' add_imply by blast
qed

theorem completeness: \<open>\<forall>I. I \<Turnstile> p \<Longrightarrow> \<turnstile> p\<close>
proof -
  let ?A = \<open>\<lambda>l I. lifts I p l \<turnstile> p\<close>
  let ?B = \<open>\<lambda>l. \<forall>I. ?A l I \<and> distinct l\<close>
  assume \<open>\<forall>I. I \<Turnstile> p\<close>
  moreover have \<open>?B l \<Longrightarrow> (\<And>n l. ?B (n # l) \<Longrightarrow> ?B l) \<Longrightarrow> ?B []\<close> for l
    by (induct l) blast+
  moreover have \<open>?B (n # l) \<Longrightarrow> ?B l\<close> for n l
  proof -
    assume *: \<open>?B (n # l)\<close>
    show \<open>?B l\<close>
    proof
      fix I
      from * have \<open>?A (n # l) (I(n := True))\<close> \<open>?A (n # l) (I(n := False))\<close>
        by blast+
      moreover from * have \<open>\<forall>m \<in> set l. \<forall>t. (I(n := t)) m = I m\<close>
        by simp
      ultimately have \<open>((\<cdot> n \<rightarrow> p) \<rightarrow> p) # lifts I p l \<turnstile> p\<close> \<open>(\<cdot> n \<rightarrow> p) # lifts I p l \<turnstile> p\<close>
        by (simp_all cong: map_cong)
      then have \<open>?A l I\<close>
        using MP' imply_deduct by blast
      moreover from * have \<open>distinct (n # l)\<close>
        by blast
      ultimately show \<open>?A l I \<and> distinct l\<close>
        by simp
    qed
  qed
  ultimately have \<open>?B []\<close>
    using lifts_pros distinct_pros by blast
  then show ?thesis
    by simp
qed

theorem main: \<open>(\<turnstile> p) = (\<forall>I. I \<Turnstile> p)\<close>
  using soundness completeness by blast

subsection \<open>Reference\<close>

text \<open>Numbered lemmas are from Jan Łukasiewicz: Elements of Mathematical Logic (English Tr. 1963)\<close>

end