(*
Concrete Semantics with Isabelle/HOL
3. Case Study: IMP Expressions
*)

theory "imp_stack_compiler" imports Main begin

(*********************************************)
subsection "Arithmetic Expressions"
(*********************************************)

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp = N int | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)" (* 12 *)
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))" (* 12 *)

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>" (* 12 *)
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>" (* 5 *)

(*********************************************)
subsection "Constant Folding"
(*********************************************)

fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const (N n) = N n" |
  "asimp_const (V x) = V x" |
  "asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"

lemma aval_asimp_const : "aval (asimp_const a) s = aval a s"
  apply (induction a)
    apply (auto split: aexp.split)
done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
  "plus (N i) a = (if i=0 then a else Plus (N i) a)" |
  "plus a (N i) = (if i=0 then a else Plus a (N i))" |
  "plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma aval_plus [simp] : "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction a1 a2 rule: plus.induct)
              apply simp_all (* just for a change from auto *)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))" (* "V ''x''" *)

lemma aval_asimp [simp] : "aval (asimp a) s = aval a s"
  apply (induction a)
    apply simp_all
  done

(*********************************************)
subsection "Stack Machine"
(*********************************************)

type_synonym stack = "val list"

datatype instr = LOADI val | LOAD vname | ADD

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
  "exec1 (LOADI n) _ stk  =  n # stk" |
  "exec1 (LOAD x) s stk  =  s(x) # stk" |
  "exec1 ADD _ stk  =  (hd2 stk + hd stk) # tl2 stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
  "exec [] _ stk = stk" |
  "exec (i # is) s stk = exec is s (exec1 i s stk)"

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]" (* [48, 50] *)

lemma exec_append [simp] : "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk)"
  apply (induction is1 arbitrary: stk)
   apply auto
  done

(*********************************************)
subsection "Compilation"
(*********************************************)

fun comp :: "aexp \<Rightarrow> instr list" where
  "comp (N n) = [LOADI n]" |
  "comp (V x) = [LOAD x]" |
  "comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"
  (* "[LOAD ''x'', LOADI 1, ADD, LOAD ''z'', ADD]" *)

theorem exec_comp : "exec (comp a) s stk = aval a s # stk"
  apply (induction a arbitrary: stk)
    apply auto
  done

end


subsection \<open>Binomial Coefficient is Diophantine\<close>

theory Binomial_Coefficient
  imports Digit_Function
begin

lemma bin_coeff_diophantine:
  shows "c = a choose b \<longleftrightarrow> (\<exists>u.(u = 2^(Suc a) \<and> c = nth_digit ((u+1)^a) b u))"
proof-
  have "(u + 1)^a = (\<Sum>k\<le>a. (a choose k) * u ^ k)" for u
    using binomial[of u 1 a] by auto
  moreover have "a choose k < 2 ^ Suc a" for k
    using binomial_le_pow2[of a k] by (simp add: le_less_trans)
  ultimately have "nth_digit (((2 ^ Suc a) + 1)^a) b (2 ^ Suc a) = a choose b"
    using nth_digit_gen_power_series[of "\<lambda>k.(a choose k)" a a b] by (simp add: atLeast0AtMost)
  then show ?thesis by auto
qed

definition binomial_coefficient ("[_ = _ choose _]" 1000)
  where "[A = B choose C] \<equiv> (TERNARY (\<lambda>a b c. a = b choose c) A B C)"

lemma binomial_coefficient_dioph[dioph]:
  fixes A B C :: polynomial
  defines "DR \<equiv> [C = A choose B]"
  shows "is_dioph_rel DR"
proof -
  define A' B' C' where pushed_def:
    "A' \<equiv> (push_param A 2)" "B' \<equiv> (push_param B 2)" "C' \<equiv> (push_param C 2)"

  (* Param 0 = u = 2^(a + 1), Param 1 = (u+1)^a *)
  define DS where "DS \<equiv> [\<exists>2] [Param 0 = Const 2 ^ (A' [+] \<^bold>1)]
                              [\<and>] [Param 1 = (Param 0 [+] \<^bold>1) ^ A']
                              [\<and>] [C' = Digit (Param 1) B' (Param 0)]"

  have "eval DS a = eval DR a" for a
  proof -
    have "eval DS a = (peval C a = nth_digit ((2 ^ Suc (peval A a) + 1)^ peval A a)
                                                      (peval B a) (2 ^ Suc (peval A a)))"
      unfolding DS_def defs pushed_def apply (auto simp add: push_push)
      apply (rule exI[of _ "[2 * 2 ^ peval A a, Suc (2 * 2 ^ peval A a) ^ peval A a]"])
      apply (auto simp add: push_push push_list_eval)
      by (metis (mono_tags, lifting) Suc_lessI mult_pos_pos n_not_Suc_n
                numeral_2_eq_2 one_eq_mult_iff pos2 zero_less_power)

    then show ?thesis
      unfolding DR_def binomial_coefficient_def defs by (simp add: bin_coeff_diophantine)
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (auto simp: dioph)

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

declare binomial_coefficient_def[defs]

text \<open>odd function is diophantine\<close>

lemma odd_dioph_repr:
  fixes a :: nat
  shows "odd a \<longleftrightarrow> (\<exists>x::nat. a = 2*x + 1)"
  by (meson dvd_triv_left even_plus_one_iff oddE)

definition odd_lift ("ODD _" [999] 1000)
  where "ODD A \<equiv> (UNARY (odd) A)"

lemma odd_dioph[dioph]:
  fixes A
  defines "DR \<equiv> (ODD A)"
  shows "is_dioph_rel DR"
proof -
  define DS where "DS \<equiv> [\<exists>] (push_param A 1) [=] Const 2 [*] Param 0 [+] Const 1"

  have "eval DS a = eval DR a" for a
    unfolding DS_def DR_def odd_lift_def defs using push_push1 by (simp add: odd_dioph_repr push0)

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (auto simp: dioph)

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

declare odd_lift_def[defs]

end


section \<open>Signed Modulo Operation\<close>

theory Signed_Modulo
  imports
    Berlekamp_Zassenhaus.Poly_Mod
    Sqrt_Babylonian.Sqrt_Babylonian_Auxiliary
begin

text \<open>The upcoming definition of symmetric modulo
  is different to the HOL-Library-Signed\_Division.smod, since
  here the modulus will be in range $\{-m/2,...,m/2\}$,
  whereas there -1 symmod m = m - 1.

  The advantage of have range $\{-m/2,...,m/2\}$ is that small negative
  numbers are represented by small numbers.

  One limitation is that the symmetric modulo is only working properly,
  if the modulus is a positive number.\<close>

definition sym_mod :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "symmod" 70) where
  "sym_mod x y = poly_mod.inv_M y (x mod y)"

lemma sym_mod_code[code]: "sym_mod x y = (let m = x mod y
   in if m + m \<le> y then m else m - y)"
  unfolding sym_mod_def poly_mod.inv_M_def Let_def ..

lemma sym_mod_zero[simp]: "n symmod 0 = n" "n > 0 \<Longrightarrow> 0 symmod n = 0"
  unfolding sym_mod_def poly_mod.inv_M_def by auto

lemma sym_mod_range:
  \<open>x symmod y \<in> {- ((y - 1) div 2) .. y div 2}\<close> if \<open>y > 0\<close>
proof -
  from that have \<open>x mod y < y\<close>
    by (rule pos_mod_bound)
  then have \<open>x mod y - y < 0\<close>
    by simp
  moreover from that have \<open>- ((y - 1) div 2) \<le> 0\<close> \<open>0 \<le> x mod y\<close>
    by simp_all
  then have \<open>- ((y - 1) div 2) \<le> x mod y\<close>
    by (rule order_trans)
  ultimately show ?thesis
    by (auto simp add: sym_mod_def poly_mod.inv_M_def)
qed

text \<open>The range is optimal in the sense that exactly y elements can be represented.\<close>
lemma card_sym_mod_range: "y > 0 \<Longrightarrow> card {- ((y - 1) div 2) .. y div 2} = y"
  by simp

lemma sym_mod_abs: "y > 0 \<Longrightarrow> \<bar>x symmod y\<bar> < y"
  "y \<ge> 1 \<Longrightarrow> \<bar>x symmod y\<bar> \<le> y div 2"
  using sym_mod_range[of y x] by auto

lemma sym_mod_sym_mod[simp]: "x symmod y symmod y = x symmod (y :: int)"
  unfolding sym_mod_def using poly_mod.M_def poly_mod.M_inv_M_id by auto

lemma sym_mod_diff_eq: "(a symmod c - b symmod c) symmod c = (a - b) symmod c"
  unfolding sym_mod_def
  by (metis mod_diff_cong mod_mod_trivial poly_mod.M_def poly_mod.M_inv_M_id)

lemma sym_mod_sym_mod_cancel: "c dvd b \<Longrightarrow> a symmod b symmod c = a symmod c"
  using mod_mod_cancel[of c b] unfolding sym_mod_def
  by (metis poly_mod.M_def poly_mod.M_inv_M_id)

lemma sym_mod_diff_right_eq: "(a - b symmod c) symmod c = (a - b) symmod c"
  using sym_mod_diff_eq by (metis sym_mod_sym_mod)

lemma sym_mod_mult_right_eq: "a * (b symmod c) symmod c = a * b symmod c"
  unfolding sym_mod_def by (metis poly_mod.M_def poly_mod.M_inv_M_id mod_mult_right_eq)

lemma dvd_imp_sym_mod_0 [simp]:
  "b symmod a = 0" if "a > 0" "a dvd b"
  unfolding sym_mod_def poly_mod.inv_M_def using that by simp

lemma sym_mod_0_imp_dvd [dest!]:
  "b dvd a" if "a symmod b = 0"
  using that apply (simp add: sym_mod_def poly_mod.inv_M_def not_le split: if_splits)
  using pos_mod_bound [of b a] apply auto
  done

definition sym_div :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "symdiv" 70) where
  "sym_div x y = (let d = x div y; m = x mod y in
       if m + m \<le> y then d else d + 1)"

lemma of_int_mod_integer: "(of_int (x mod y) :: integer) = (of_int x :: integer) mod (of_int y)"
  using integer_of_int_eq_of_int modulo_integer.abs_eq by presburger

lemma sym_div_code[code]:
  "sym_div x y = (let yy = integer_of_int y in
     (case divmod_integer (integer_of_int x) yy
     of (d, m) \<Rightarrow> if m + m \<le> yy then int_of_integer d else (int_of_integer (d + 1))))"
  unfolding sym_div_def Let_def divmod_integer_def split
  apply (rule if_cong, subst of_int_le_iff[symmetric], unfold of_int_add)
  by (subst (1 2) of_int_mod_integer, auto)

lemma sym_mod_sym_div: assumes y: "y > 0" shows "x symmod y = x - sym_div x y * y"
proof -
  let ?z = "x - y * (x div y)"
  let ?u = "y * (x div y)"
  have "x = y * (x div y) + x mod y" using y by simp
  hence id: "x mod y = ?z" by linarith
  have "x symmod y = poly_mod.inv_M y ?z" unfolding sym_mod_def id by auto
  also have "\<dots> = (if ?z + ?z \<le> y then ?z else ?z - y)" unfolding poly_mod.inv_M_def ..
  also have "\<dots> = x - (if (x mod y) + (x mod y) \<le> y then x div y else x div y + 1) * y"
    by (simp add: algebra_simps id)
  also have "(if (x mod y) + (x mod y) \<le> y then x div y else x div y + 1) = sym_div x y"
    unfolding sym_div_def Let_def ..
  finally show ?thesis .
qed

lemma dvd_sym_div_mult_right [simp]:
  "(a symdiv b) * b = a" if "b > 0" "b dvd a"
  using sym_mod_sym_div[of b a] that by simp

lemma dvd_sym_div_mult_left [simp]:
  "b * (a symdiv b) = a" if "b > 0" "b dvd a"
  using dvd_sym_div_mult_right[OF that] by (simp add: ac_simps)

end


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

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun toNat :: "Bin => int" where
"toNat (One) = 1"
| "toNat (ZeroAnd xs) = (toNat xs) + (toNat xs)"
| "toNat (OneAnd ys) = (1 + (toNat ys)) + (toNat ys)"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((toNat (times x y)) = ((toNat x) * (toNat y)))"
  oops

end


theory Object2
  imports Main
begin

section \<open>Datatypes\<close>

text \<open>We begin by defining a datatype as an initial value plus a transition function, which takes a
verson and argument to a (value', ret-val) tuple. We define a datatype to encapsulate this tuple:\<close>

datatype ('v, 'r) write_out = WriteOut 'v 'r

primrec write_out_value :: "('v, 'r) write_out \<Rightarrow> 'v" where
"write_out_value (WriteOut v r) = v"

primrec write_out_ret :: "('v, 'r) write_out \<Rightarrow> 'r" where
"write_out_ret (WriteOut v r) = r"

text \<open>And a locale which fixes the initial value and transition function w.\<close>

locale data_type =
  fixes init :: "'v"
  and w :: "'v \<Rightarrow> 'a \<Rightarrow> ('v, 'r) write_out"
begin

text \<open>Given a sequence of write arguments, we can construct a function which applies those arguments
in sequence.\<close>

primrec apply_args :: "'v \<Rightarrow> 'a list \<Rightarrow> 'v" where
"apply_args v [] = v" |
"apply_args v (a # as) = apply_args (write_out_value (w v a)) as"

text \<open>Some lemmata around apply_args\<close>

lemma apply_args_Cons: "apply_args v (a#as) = apply_args (write_out_value (w v a)) as"
  by auto

text \<open>A database is traceable if, for any version, there exists exactly one sequence of args that
leads to that version.\<close>

definition is_traceable :: "bool" where
"is_traceable \<equiv> \<forall> args1 args2 . apply_args init args1 = apply_args init args2 \<longrightarrow> args1 = args2"

end

locale traceable_data_type = data_type init w for init w +
  assumes traceable:"is_traceable"
begin

text \<open>Here, we prove facts about traceable data types.\<close>

end

section \<open>Append-only lists\<close>

text \<open>We begin by showing that list append over lists of naturals can form a data type.\<close>

definition list_append_w :: "'x list \<Rightarrow> 'x \<Rightarrow> ('x list, bool) write_out" where
"list_append_w xs x \<equiv> WriteOut (xs @ [x]) True"

value "list_append_w [a, b] c"

interpretation list_append: data_type "[]" list_append_w .

text \<open>We want to show this datatype is traceable. First, we prove that applying a sequence of args
produces that list of args itself.\<close>

value "list_append.apply_args x [a,b]"

lemma list_append_args_are_value:"list_append.apply_args [] xs = xs"
proof (induct xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  then show ?case
    apply (simp add: data_type.apply_args_Cons)

qed

interpretation list_append_traceable:traceable_data_type "[]" "list_append_w"
  using list_append.is_traceable_def traceable_data_type_def

end


theory Exercise_2_10
  imports Main
begin
datatype tree0 = Tip | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Tip = Suc 0" |
  "nodes (Node l r) = Suc ((nodes l) + (nodes r))"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t" |
  "explode (Suc n) t = explode n (Node t t)"

lemma explode_size: "nodes (explode n t) = (2^n)*(nodes t) + (2^n) - 1"
  apply(induction n arbitrary:t)
  apply(auto simp add: algebra_simps)
  done


theory Ex1_5
  imports Main
begin

primrec occurs :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "occurs _ [] = 0"|
  "occurs val (x # xs) = (if x = val then 1 else 0) + occurs val xs"

corollary helper1 : "occurs a (xs @ ys) = occurs a xs + occurs a ys" by (induct xs , simp_all)

lemma "occurs a xs = occurs a (rev xs)" by (induct xs , simp_all add : helper1)

lemma "occurs a xs \<le> length xs" by (induct xs, simp_all)

(*lemma "occurs a (map f xs) = occurs (f a) xs" quickcheck *)

lemma "a \<noteq> b \<Longrightarrow>let f = (\<lambda>x. if x = a then b else x) in occurs a (map f [a,b]) = occurs (f a) [a,b] \<Longrightarrow> False" by simp

lemma "occurs a (filter P xs) = occurs (a,True)( zip xs (map P xs))" by (induct xs ; simp)

lemma "occurs a (filter P xs) = (if P a then occurs a xs else 0 )" by (induct xs ; simp)

primrec remDups :: "'a list \<Rightarrow> 'a list" where
  "remDups [] = []"|
  "remDups (x#xs) = (if occurs x xs > 0 then remDups xs else x # remDups xs)"

lemma "occurs x (remDups xs) = (if occurs x xs \<ge> 1 then 1 else 0)" by (induct xs; simp)

primrec unique :: "'a list \<Rightarrow> bool" where
  "unique [] = True"|
  "unique (x#xs) = ((occurs x xs = 0)  \<and> unique xs)"

lemma helper2 : "(occurs x xs = 0) = (occurs x (remDups xs) = 0)" by (induct xs; auto)

lemma "unique (remDups xs)"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume hyp:"unique (remDups xs)"
  show ?case
  proof (cases "occurs a xs")
    case 0
    assume a:"occurs a xs = 0"
    have "unique (remDups (a # xs)) = unique (a # remDups  xs) " by (simp add : a)
    also have "\<dots> = ((occurs a (remDups xs) = 0) \<and> unique (remDups xs))" by simp
    also have "\<dots> = ((occurs a  xs = 0) \<and> unique (remDups xs))" by (subst helper2, rule refl)
    finally show ?thesis using hyp by auto
  next
    case (Suc nat)
    then show ?thesis using hyp by simp
  qed
qed


(*<*)
theory Szpilrajn
  imports Main
begin
  (*>*)

section "Introduction"

text \<open>
  We formalize the Szpilrajn extension theorem~\cite{Szpilrajn:1930}, also known
as order-extension principal:
  Every strict partial order can be extended to strict linear order.
This is a formalization of the proof presented in the Wikipedia article~\cite{wiki}.

A strict partial order is a transitive and irreflexive relation:\<close>

definition "strict_partial_order r \<equiv> trans r \<and> irrefl r"

lemma show_strict_partial_order[intro]:
  assumes "trans r" and "irrefl r"
  shows "strict_partial_order r"
  by (simp add: assms strict_partial_order_def)

lemma strict_partial_order_acyclic:
  assumes "strict_partial_order r"
  shows "acyclic r"
  by (metis acyclic_irrefl assms strict_partial_order_def trancl_id)

text \<open>A typical example is \<^term>\<open>(\<subset>)\<close> on sets:\<close>

lemma strict_partial_order_subset:
  "strict_partial_order {(x,y). x \<subset> y}"
proof
  show "trans {(x,y). x \<subset> y}"
    by (auto simp add: trans_def)
  show "irrefl {(x, y). x \<subset> y}"
    by (simp add: irrefl_def)
qed

text \<open>A strict linear order has all the properties of a strict partial order, but is also total: \<close>

lemma strict_linear_order_def:
  "strict_linear_order r \<longleftrightarrow> strict_partial_order r \<and> total r"
  by (simp add: strict_linear_order_on_def strict_partial_order_def)

section "The Proof"

text \<open>A relation \<^term>\<open>r\<close> is a strict extension of a base relation \<^term>\<open>base_r\<close>
if \<^term>\<open>r\<close> is a strict partial order and \<^term>\<open>r\<close> includes \<^term>\<open>base_r\<close>:\<close>

definition "strict_ext base_r r \<equiv> strict_partial_order r \<and>  base_r \<subseteq> r"

text \<open>We start by proving that a strict partial order with two incomparable elements
\<^term>\<open>x\<close> and \<^term>\<open>y\<close> can be extended to a strict partial order where \<^term>\<open>x < y\<close>. \<close>

lemma can_extend_partial_order:
  assumes spo: "strict_partial_order r"
    and no1: "(x,y) \<notin> r"
    and no2: "(y,x) \<notin> r"
    and neq: "x\<noteq>y"
  shows "strict_ext r ((r \<union> {(x,y)})\<^sup>+)"
  unfolding strict_ext_def proof (intro conjI show_strict_partial_order)
  show "trans ((r \<union> {(x, y)})\<^sup>+)"
    by simp
  show "r \<subseteq> (r \<union> {(x, y)})\<^sup>+" by auto

  from spo have "trans r" and "irrefl r"
    by (auto simp add: strict_partial_order_def)

  show "irrefl ((r \<union> {(x, y)})\<^sup>+)"
  proof (clarsimp simp add: acyclic_irrefl[symmetric], intro conjI)
    show "acyclic r"
      by (simp add: spo strict_partial_order_acyclic)
    show "(y, x) \<notin> r\<^sup>*"
      using \<open>trans r\<close> neq no2 rtranclD by fastforce
  qed
qed

text \<open>With this, we can start the proof of the Szpilrajn extension theorem.
For this we will use a variant of Zorns Lemma, which only considers nonempty chains:\<close>

lemma Zorns_po_lemma_nonempty:
  assumes po: "Partial_order r"
    and u: "\<And>C. \<lbrakk>C \<in> Chains r; C\<noteq>{}\<rbrakk> \<Longrightarrow> \<exists>u\<in>Field r. \<forall>a\<in>C. (a, u) \<in> r"
    and ne: "r \<noteq> {}"
  shows "\<exists>m\<in>Field r. \<forall>a\<in>Field r. (m, a) \<in> r \<longrightarrow> a = m"
proof -
  from `r\<noteq>{}` obtain x where "x\<in>Field r"
    using FieldI2 by fastforce
  with assms show ?thesis
    using Zorns_po_lemma by (metis empty_iff)
qed

theorem Szpilrajn:
  assumes "strict_partial_order base_r"
  shows "\<exists>r. strict_linear_order r \<and> base_r \<subseteq> r"
proof -
  text \<open>We define an order on the set of strict extensions of the base relation \<^term>\<open>base_r\<close>,
    where \<^term>\<open>r \<le> s\<close> iff \<^term>\<open>r \<subseteq> s\<close>:\<close>

  define order_of_orders :: "('a rel) rel" where order_of_orders_def:
    "order_of_orders = {(r,s). r\<subseteq>s \<and> strict_ext base_r r \<and> strict_ext base_r s }"

  have ord_Field: "Field order_of_orders = {r. strict_ext base_r r}"
    by (auto simp add: Field_def order_of_orders_def)

  text \<open>We now show that this set has a maximum and that any maximum of this set is
    a strict linear order and as thus is one of the extensions we are looking for.\<close>

  text \<open>We begin by showing the existence of a maximal element \<^term>\<open>m\<close> using Zorns Lemma:\<close>

  have "\<exists>m\<in>Field order_of_orders.
      \<forall>a\<in>Field order_of_orders. (m, a) \<in> order_of_orders \<longrightarrow> a = m"
  proof (rule Zorns_po_lemma_nonempty)

    text \<open>Zorns Lemma requires us to prove that our \<^term>\<open>order_of_orders\<close> is a nonempty  partial order
   and that every nonempty chain has an upper bound.
   The partial order property is trivial, since we used \<^term>\<open>(\<subseteq>)\<close> for the relation:\<close>

    show "Partial_order order_of_orders"
      by (auto simp add: order_of_orders_def order_on_defs refl_on_def Field_def trans_def antisym_def)

    text \<open>Also, our order is obviously not empty since it contains \<^term>\<open>(base_r, base_r)\<close>:\<close>

    have "(base_r, base_r)\<in>order_of_orders"
      using assms strict_ext_def by (auto simp add: order_of_orders_def)
    thus "order_of_orders \<noteq> {}" by force

    text \<open>Next we show that each chain has an upper bound.
    For the upper bound we take the union of all relations in the chain. \<close>

    show "\<exists>u\<in>Field order_of_orders. \<forall>a\<in>C. (a, u) \<in> order_of_orders"
      if C_def: "C \<in> Chains order_of_orders" and C_nonemtpy: "C \<noteq> {}"
      for C
    proof (rule bexI[where x="\<Union>C"])

      text \<open>Obviously each element in the chain is a strict extension of \<^term>\<open>base_r\<close> by definition
      and as such it is transitive, irreflexive and extends the base relation.\<close>

      have r_se: "strict_ext base_r r" if "r \<in> C" for r
        using `r \<in> C` C_def by (auto simp add: Chains_def order_of_orders_def)

      hence r_trans: "trans r"
        and r_irrefl: "irrefl r"
        and r_extends_base: "base_r \<subseteq> r"
        if "r \<in> C" for r
        using that by (auto simp add: strict_ext_def strict_partial_order_def)

      text \<open>Because a chain is ordered, the union of the chain is also transitive:\<close>

      have C_ordered: "r\<subseteq>s \<or> s\<subseteq>r" if "r \<in> C" and "s \<in> C" for r s
        using C_def that by (auto simp add: Chains_def order_of_orders_def)

      hence "trans (\<Union>C)"
        by (simp add: chain_subset_def chain_subset_trans_Union r_trans)

      text \<open>The other properties also can be transferred from the single relations
       to the union of the chain.
       Therefore the union is also a strict extension of \<^term>\<open>base_r\<close>: \<close>

      moreover have "irrefl (\<Union>C)"
        using irrefl_def r_irrefl by auto

      moreover have "base_r \<subseteq> (\<Union>C)"
        by (simp add: less_eq_Sup r_extends_base that)

      ultimately have "strict_ext base_r (\<Union>C)"
        by (simp add: show_strict_partial_order strict_ext_def that)

      show "(\<Union>C) \<in> Field order_of_orders"
        by (simp add: \<open>strict_ext base_r (\<Union> C)\<close> ord_Field)

      text \<open>The union is obviously an upper bound for the chain: \<close>
      show "\<forall>a\<in>C. (a, \<Union> C) \<in> order_of_orders"
        by (simp add: Sup_upper \<open>strict_ext base_r (\<Union> C)\<close> order_of_orders_def r_se)
    qed
  qed

  text \<open>Let our maximal element be named \<^term>\<open>max\<close>:\<close>

  from this obtain max
    where max_field: "max\<in>Field order_of_orders"
      and is_max:
        "\<forall>a\<in>Field order_of_orders. (max, a) \<in> order_of_orders \<longrightarrow> a = max"
    by auto

  from max_field have max_se: "strict_ext base_r max"
    using ord_Field by auto
  hence max_spo: "strict_partial_order max"
    and "base_r \<subseteq> max"
    using strict_ext_def by auto

  text \<open>We still have to show, that \<^term>\<open>max\<close> is a strict linear order,
  meaning that it is also a total order: \<close>

  have "total max"
  proof
    fix x y :: 'a
    assume "x\<noteq>y"

    show "(x, y) \<in> max \<or> (y, x) \<in> max"
    proof (rule ccontr, auto)

      text \<open>Assume that \<^term>\<open>max\<close> is not total, and \<^term>\<open>x\<close> and \<^term>\<open>y\<close> are incomparable.
      Then we can extend \<^term>\<open>max\<close> by setting $x < y$:\<close>

      assume "(x, y) \<notin> max" and "(y, x) \<notin> max"
      let ?max' = "((max \<union> {(x, y)})\<^sup>+)"

      from max_spo `(x, y) \<notin> max` `(y, x) \<notin> max` `x\<noteq>y`
      have max'_se_max: "strict_ext max ?max'" by (rule can_extend_partial_order)

      hence max'_se: "strict_ext base_r ?max'"
        by (meson \<open>base_r \<subseteq> max\<close> strict_ext_def subset_trans)

      text \<open>The extended relation is greater than \<^term>\<open>max\<close>, which is a contradiction.\<close>

      have "(max, ?max')\<in>order_of_orders"
        using max'_se by (auto simp add: order_of_orders_def max_se)
      thus False
        using FieldI2 \<open>(x, y) \<notin> max\<close> is_max by fastforce
    qed
  qed

  with max_spo have "strict_linear_order max"
    by (auto simp add: strict_linear_order_def)

  with \<open>base_r \<subseteq> max\<close>
  show "\<exists>r. strict_linear_order r \<and> base_r \<subseteq> r" by auto
qed

text \<open>As a corollary, we can also show that we can extend any \<^term>\<open>acyclic\<close> relation
to a strict linear order: \<close>

corollary can_extend_acyclic_order_to_strict_linear:
  assumes "acyclic base_r"
  shows "\<exists>r. strict_linear_order r \<and> base_r \<subseteq> r"
proof -
  have "strict_partial_order (base_r\<^sup>+)"
    using acyclic_irrefl assms trans_trancl by blast
  thus ?thesis
    by (meson Szpilrajn r_into_trancl' subset_iff)
qed

text \<open>Let us conclude with an example, showing that there exists a strict linear
order on sets, which includes the subset relation:\<close>

lemma exists_strict_partial_order_on_sets:
  shows "\<exists>r. strict_linear_order r \<and> {(x,y). x \<subset> y} \<subseteq> r"
  using strict_partial_order_subset by (rule Szpilrajn)

(*<*)
end
(*>*)


(*  Title:      HOL/Fun.thy
    Author:     Tobias Nipkow, Cambridge University Computer Laboratory
    Author:     Andrei Popescu, TU Muenchen
    Copyright   1994, 2012
*)

section \<open>Notions about functions\<close>

theory Fun
  imports Set
  keywords "functor" :: thy_goal
begin

lemma apply_inverse: "f x = u \<Longrightarrow> (\<And>x. P x \<Longrightarrow> g (f x) = x) \<Longrightarrow> P x \<Longrightarrow> x = g u"
  by auto

text \<open>Uniqueness, so NOT the axiom of choice.\<close>
lemma uniq_choice: "\<forall>x. \<exists>!y. Q x y \<Longrightarrow> \<exists>f. \<forall>x. Q x (f x)"
  by (force intro: theI')

lemma b_uniq_choice: "\<forall>x\<in>S. \<exists>!y. Q x y \<Longrightarrow> \<exists>f. \<forall>x\<in>S. Q x (f x)"
  by (force intro: theI')

subsection \<open>The Identity Function \<open>id\<close>\<close>

definition id :: "'a \<Rightarrow> 'a"
  where "id = (\<lambda>x. x)"

lemma id_apply [simp]: "id x = x"
  by (simp add: id_def)

lemma image_id [simp]: "image id = id"
  by (simp add: id_def fun_eq_iff)

lemma vimage_id [simp]: "vimage id = id"
  by (simp add: id_def fun_eq_iff)

lemma eq_id_iff: "(\<forall>x. f x = x) \<longleftrightarrow> f = id"
  by auto

code_printing
  constant id \<rightharpoonup> (Haskell) "id"

subsection \<open>The Composition Operator \<open>f \<circ> g\<close>\<close>

definition comp :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c"  (infixl "\<circ>" 55)
  where "f \<circ> g = (\<lambda>x. f (g x))"

notation (ASCII)
  comp  (infixl "o" 55)

lemma comp_apply [simp]: "(f \<circ> g) x = f (g x)"
  by (simp add: comp_def)

lemma comp_assoc: "(f \<circ> g) \<circ> h = f \<circ> (g \<circ> h)"
  by (simp add: fun_eq_iff)

lemma id_comp [simp]: "id \<circ> g = g"
  by (simp add: fun_eq_iff)

lemma comp_id [simp]: "f \<circ> id = f"
  by (simp add: fun_eq_iff)

lemma comp_eq_dest: "a \<circ> b = c \<circ> d \<Longrightarrow> a (b v) = c (d v)"
  by (simp add: fun_eq_iff)

lemma comp_eq_elim: "a \<circ> b = c \<circ> d \<Longrightarrow> ((\<And>v. a (b v) = c (d v)) \<Longrightarrow> R) \<Longrightarrow> R"
  by (simp add: fun_eq_iff)

lemma comp_eq_dest_lhs: "a \<circ> b = c \<Longrightarrow> a (b v) = c v"
  by clarsimp

lemma comp_eq_id_dest: "a \<circ> b = id \<circ> c \<Longrightarrow> a (b v) = c v"
  by clarsimp

lemma image_comp: "f ` (g ` r) = (f \<circ> g) ` r"
  by auto

lemma vimage_comp: "f -` (g -` x) = (g \<circ> f) -` x"
  by auto

lemma image_eq_imp_comp: "f ` A = g ` B \<Longrightarrow> (h \<circ> f) ` A = (h \<circ> g) ` B"
  by (auto simp: comp_def elim!: equalityE)

lemma image_bind: "f ` (Set.bind A g) = Set.bind A (op ` f \<circ> g)"
  by (auto simp add: Set.bind_def)

lemma bind_image: "Set.bind (f ` A) g = Set.bind A (g \<circ> f)"
  by (auto simp add: Set.bind_def)

lemma (in group_add) minus_comp_minus [simp]: "uminus \<circ> uminus = id"
  by (simp add: fun_eq_iff)

lemma (in boolean_algebra) minus_comp_minus [simp]: "uminus \<circ> uminus = id"
  by (simp add: fun_eq_iff)

code_printing
  constant comp \<rightharpoonup> (SML) infixl 5 "o" and (Haskell) infixr 9 "."

subsection \<open>The Forward Composition Operator \<open>fcomp\<close>\<close>

definition fcomp :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'c"  (infixl "\<circ>>" 60)
  where "f \<circ>> g = (\<lambda>x. g (f x))"

lemma fcomp_apply [simp]:  "(f \<circ>> g) x = g (f x)"
  by (simp add: fcomp_def)

lemma fcomp_assoc: "(f \<circ>> g) \<circ>> h = f \<circ>> (g \<circ>> h)"
  by (simp add: fcomp_def)

lemma id_fcomp [simp]: "id \<circ>> g = g"
  by (simp add: fcomp_def)

lemma fcomp_id [simp]: "f \<circ>> id = f"
  by (simp add: fcomp_def)

lemma fcomp_comp: "fcomp f g = comp g f"
  by (simp add: ext)

code_printing
  constant fcomp \<rightharpoonup> (Eval) infixl 1 "#>"

no_notation fcomp (infixl "\<circ>>" 60)

subsection \<open>Mapping functions\<close>

definition map_fun :: "('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd"
  where "map_fun f g h = g \<circ> h \<circ> f"

lemma map_fun_apply [simp]: "map_fun f g h x = g (h (f x))"
  by (simp add: map_fun_def)

subsection \<open>Injectivity and Bijectivity\<close>

definition inj_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool"  \<comment> \<open>injective\<close>
  where "inj_on f A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. f x = f y \<longrightarrow> x = y)"

definition bij_betw :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool"  \<comment> \<open>bijective\<close>
  where "bij_betw f A B \<longleftrightarrow> inj_on f A \<and> f ` A = B"

text \<open>
  A common special case: functions injective, surjective or bijective over
  the entire domain type.
\<close>

abbreviation "inj f \<equiv> inj_on f UNIV"

abbreviation (input) surj :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "surj f \<equiv> range f = UNIV"

abbreviation "bij f \<equiv> bij_betw f UNIV UNIV"

lemma injI: "(\<And>x y. f x = f y \<Longrightarrow> x = y) \<Longrightarrow> inj f"
  unfolding inj_on_def by auto

theorem range_ex1_eq: "inj f \<Longrightarrow> b \<in> range f \<longleftrightarrow> (\<exists>!x. b = f x)"
  unfolding inj_on_def by blast

lemma injD: "inj f \<Longrightarrow> f x = f y \<Longrightarrow> x = y"
  by (simp add: inj_on_def)

lemma inj_on_eq_iff: "inj_on f A \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
  by (force simp add: inj_on_def)

lemma inj_on_cong: "(\<And>a. a \<in> A \<Longrightarrow> f a = g a) \<Longrightarrow> inj_on f A = inj_on g A"
  unfolding inj_on_def by auto

lemma inj_on_strict_subset: "inj_on f B \<Longrightarrow> A \<subset> B \<Longrightarrow> f ` A \<subset> f ` B"
  unfolding inj_on_def by blast

lemma inj_comp: "inj f \<Longrightarrow> inj g \<Longrightarrow> inj (f \<circ> g)"
  by (simp add: inj_on_def)

lemma inj_fun: "inj f \<Longrightarrow> inj (\<lambda>x y. f x)"
  by (simp add: inj_on_def fun_eq_iff)

lemma inj_eq: "inj f \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
  by (simp add: inj_on_eq_iff)

lemma inj_on_id[simp]: "inj_on id A"
  by (simp add: inj_on_def)

lemma inj_on_id2[simp]: "inj_on (\<lambda>x. x) A"
  by (simp add: inj_on_def)

lemma inj_on_Int: "inj_on f A \<or> inj_on f B \<Longrightarrow> inj_on f (A \<inter> B)"
  unfolding inj_on_def by blast

lemma surj_id: "surj id"
  by simp

lemma bij_id[simp]: "bij id"
  by (simp add: bij_betw_def)

lemma bij_uminus: "bij (uminus :: 'a \<Rightarrow> 'a::ab_group_add)"
  unfolding bij_betw_def inj_on_def
  by (force intro: minus_minus [symmetric])

lemma inj_onI [intro?]: "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> x = y) \<Longrightarrow> inj_on f A"
  by (simp add: inj_on_def)

lemma inj_on_inverseI: "(\<And>x. x \<in> A \<Longrightarrow> g (f x) = x) \<Longrightarrow> inj_on f A"
  by (auto dest:  arg_cong [of concl: g] simp add: inj_on_def)

lemma inj_onD: "inj_on f A \<Longrightarrow> f x = f y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x = y"
  unfolding inj_on_def by blast

lemma inj_on_subset:
  assumes "inj_on f A"
    and "B \<subseteq> A"
  shows "inj_on f B"
proof (rule inj_onI)
  fix a b
  assume "a \<in> B" and "b \<in> B"
  with assms have "a \<in> A" and "b \<in> A"
    by auto
  moreover assume "f a = f b"
  ultimately show "a = b" using assms
    by (auto dest: inj_onD)
qed

lemma comp_inj_on: "inj_on f A \<Longrightarrow> inj_on g (f ` A) \<Longrightarrow> inj_on (g \<circ> f) A"
  by (simp add: comp_def inj_on_def)

lemma inj_on_imageI: "inj_on (g \<circ> f) A \<Longrightarrow> inj_on g (f ` A)"
  by (auto simp add: inj_on_def)

lemma inj_on_image_iff:
  "\<forall>x\<in>A. \<forall>y\<in>A. g (f x) = g (f y) \<longleftrightarrow> g x = g y \<Longrightarrow> inj_on f A \<Longrightarrow> inj_on g (f ` A) = inj_on g A"
  unfolding inj_on_def by blast

lemma inj_on_contraD: "inj_on f A \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x \<noteq> f y"
  unfolding inj_on_def by blast

lemma inj_singleton [simp]: "inj_on (\<lambda>x. {x}) A"
  by (simp add: inj_on_def)

lemma inj_on_empty[iff]: "inj_on f {}"
  by (simp add: inj_on_def)

lemma subset_inj_on: "inj_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> inj_on f A"
  unfolding inj_on_def by blast

lemma inj_on_Un: "inj_on f (A \<union> B) \<longleftrightarrow> inj_on f A \<and> inj_on f B \<and> f ` (A - B) \<inter> f ` (B - A) = {}"
  unfolding inj_on_def by (blast intro: sym)

lemma inj_on_insert [iff]: "inj_on f (insert a A) \<longleftrightarrow> inj_on f A \<and> f a \<notin> f ` (A - {a})"
  unfolding inj_on_def by (blast intro: sym)

lemma inj_on_diff: "inj_on f A \<Longrightarrow> inj_on f (A - B)"
  unfolding inj_on_def by blast

lemma comp_inj_on_iff: "inj_on f A \<Longrightarrow> inj_on f' (f ` A) \<longleftrightarrow> inj_on (f' \<circ> f) A"
  by (auto simp add: comp_inj_on inj_on_def)

lemma inj_on_imageI2: "inj_on (f' \<circ> f) A \<Longrightarrow> inj_on f A"
  by (auto simp add: comp_inj_on inj_on_def)

lemma inj_img_insertE:
  assumes "inj_on f A"
  assumes "x \<notin> B"
    and "insert x B = f ` A"
  obtains x' A' where "x' \<notin> A'" and "A = insert x' A'" and "x = f x'" and "B = f ` A'"
proof -
  from assms have "x \<in> f ` A" by auto
  then obtain x' where *: "x' \<in> A" "x = f x'" by auto
  then have A: "A = insert x' (A - {x'})" by auto
  with assms * have B: "B = f ` (A - {x'})" by (auto dest: inj_on_contraD)
  have "x' \<notin> A - {x'}" by simp
  from this A \<open>x = f x'\<close> B show ?thesis ..
qed

lemma linorder_injI:
  assumes hyp: "\<And>x y::'a::linorder. x < y \<Longrightarrow> f x \<noteq> f y"
  shows "inj f"
  \<comment> \<open>Courtesy of Stephan Merz\<close>
proof (rule inj_onI)
  show "x = y" if "f x = f y" for x y
   by (rule linorder_cases) (auto dest: hyp simp: that)
qed

lemma surj_def: "surj f \<longleftrightarrow> (\<forall>y. \<exists>x. y = f x)"
  by auto

lemma surjI:
  assumes *: "\<And> x. g (f x) = x"
  shows "surj g"
  using *[symmetric] by auto

lemma surjD: "surj f \<Longrightarrow> \<exists>x. y = f x"
  by (simp add: surj_def)

lemma surjE: "surj f \<Longrightarrow> (\<And>x. y = f x \<Longrightarrow> C) \<Longrightarrow> C"
  by (simp add: surj_def) blast

lemma comp_surj: "surj f \<Longrightarrow> surj g \<Longrightarrow> surj (g \<circ> f)"
  by (simp add: image_comp [symmetric])

lemma bij_betw_imageI: "inj_on f A \<Longrightarrow> f ` A = B \<Longrightarrow> bij_betw f A B"
  unfolding bij_betw_def by clarify

lemma bij_betw_imp_surj_on: "bij_betw f A B \<Longrightarrow> f ` A = B"
  unfolding bij_betw_def by clarify

lemma bij_betw_imp_surj: "bij_betw f A UNIV \<Longrightarrow> surj f"
  unfolding bij_betw_def by auto

lemma bij_betw_empty1: "bij_betw f {} A \<Longrightarrow> A = {}"
  unfolding bij_betw_def by blast

lemma bij_betw_empty2: "bij_betw f A {} \<Longrightarrow> A = {}"
  unfolding bij_betw_def by blast

lemma inj_on_imp_bij_betw: "inj_on f A \<Longrightarrow> bij_betw f A (f ` A)"
  unfolding bij_betw_def by simp

lemma bij_def: "bij f \<longleftrightarrow> inj f \<and> surj f"
  unfolding bij_betw_def ..

lemma bijI: "inj f \<Longrightarrow> surj f \<Longrightarrow> bij f"
  by (simp add: bij_def)

lemma bij_is_inj: "bij f \<Longrightarrow> inj f"
  by (simp add: bij_def)

lemma bij_is_surj: "bij f \<Longrightarrow> surj f"
  by (simp add: bij_def)

lemma bij_betw_imp_inj_on: "bij_betw f A B \<Longrightarrow> inj_on f A"
  by (simp add: bij_betw_def)

lemma bij_betw_trans: "bij_betw f A B \<Longrightarrow> bij_betw g B C \<Longrightarrow> bij_betw (g \<circ> f) A C"
  by (auto simp add:bij_betw_def comp_inj_on)

lemma bij_comp: "bij f \<Longrightarrow> bij g \<Longrightarrow> bij (g \<circ> f)"
  by (rule bij_betw_trans)

lemma bij_betw_comp_iff: "bij_betw f A A' \<Longrightarrow> bij_betw f' A' A'' \<longleftrightarrow> bij_betw (f' \<circ> f) A A''"
  by (auto simp add: bij_betw_def inj_on_def)

lemma bij_betw_comp_iff2:
  assumes bij: "bij_betw f' A' A''"
    and img: "f ` A \<le> A'"
  shows "bij_betw f A A' \<longleftrightarrow> bij_betw (f' \<circ> f) A A''"
  using assms
proof (auto simp add: bij_betw_comp_iff)
  assume *: "bij_betw (f' \<circ> f) A A''"
  then show "bij_betw f A A'"
    using img
  proof (auto simp add: bij_betw_def)
    assume "inj_on (f' \<circ> f) A"
    then show "inj_on f A"
      using inj_on_imageI2 by blast
  next
    fix a'
    assume **: "a' \<in> A'"
    with bij have "f' a' \<in> A''"
      unfolding bij_betw_def by auto
    with * obtain a where 1: "a \<in> A \<and> f' (f a) = f' a'"
      unfolding bij_betw_def by force
    with img have "f a \<in> A'" by auto
    with bij ** 1 have "f a = a'"
      unfolding bij_betw_def inj_on_def by auto
    with 1 show "a' \<in> f ` A" by auto
  qed
qed

lemma bij_betw_inv:
  assumes "bij_betw f A B"
  shows "\<exists>g. bij_betw g B A"
proof -
  have i: "inj_on f A" and s: "f ` A = B"
    using assms by (auto simp: bij_betw_def)
  let ?P = "\<lambda>b a. a \<in> A \<and> f a = b"
  let ?g = "\<lambda>b. The (?P b)"
  have g: "?g b = a" if P: "?P b a" for a b
  proof -
    from that s have ex1: "\<exists>a. ?P b a" by blast
    then have uex1: "\<exists>!a. ?P b a" by (blast dest:inj_onD[OF i])
    then show ?thesis
      using the1_equality[OF uex1, OF P] P by simp
  qed
  have "inj_on ?g B"
  proof (rule inj_onI)
    fix x y
    assume "x \<in> B" "y \<in> B" "?g x = ?g y"
    from s \<open>x \<in> B\<close> obtain a1 where a1: "?P x a1" by blast
    from s \<open>y \<in> B\<close> obtain a2 where a2: "?P y a2" by blast
    from g [OF a1] a1 g [OF a2] a2 \<open>?g x = ?g y\<close> show "x = y" by simp
  qed
  moreover have "?g ` B = A"
  proof (auto simp: image_def)
    fix b
    assume "b \<in> B"
    with s obtain a where P: "?P b a" by blast
    with g[OF P] show "?g b \<in> A" by auto
  next
    fix a
    assume "a \<in> A"
    with s obtain b where P: "?P b a" by blast
    with s have "b \<in> B" by blast
    with g[OF P] show "\<exists>b\<in>B. a = ?g b" by blast
  qed
  ultimately show ?thesis
    by (auto simp: bij_betw_def)
qed

lemma bij_betw_cong: "(\<And>a. a \<in> A \<Longrightarrow> f a = g a) \<Longrightarrow> bij_betw f A A' = bij_betw g A A'"
  unfolding bij_betw_def inj_on_def by safe force+  (* somewhat slow *)

lemma bij_betw_id[intro, simp]: "bij_betw id A A"
  unfolding bij_betw_def id_def by auto

lemma bij_betw_id_iff: "bij_betw id A B \<longleftrightarrow> A = B"
  by (auto simp add: bij_betw_def)

lemma bij_betw_combine:
  "bij_betw f A B \<Longrightarrow> bij_betw f C D \<Longrightarrow> B \<inter> D = {} \<Longrightarrow> bij_betw f (A \<union> C) (B \<union> D)"
  unfolding bij_betw_def inj_on_Un image_Un by auto

lemma bij_betw_subset: "bij_betw f A A' \<Longrightarrow> B \<le> A \<Longrightarrow> f ` B = B' \<Longrightarrow> bij_betw f B B'"
  by (auto simp add: bij_betw_def inj_on_def)

lemma bij_pointE:
  assumes "bij f"
  obtains x where "y = f x" and "\<And>x'. y = f x' \<Longrightarrow> x' = x"
proof -
  from assms have "inj f" by (rule bij_is_inj)
  moreover from assms have "surj f" by (rule bij_is_surj)
  then have "y \<in> range f" by simp
  ultimately have "\<exists>!x. y = f x" by (simp add: range_ex1_eq)
  with that show thesis by blast
qed

lemma surj_image_vimage_eq: "surj f \<Longrightarrow> f ` (f -` A) = A"
  by simp

lemma surj_vimage_empty:
  assumes "surj f"
  shows "f -` A = {} \<longleftrightarrow> A = {}"
  using surj_image_vimage_eq [OF \<open>surj f\<close>, of A]
  by (intro iffI) fastforce+

lemma inj_vimage_image_eq: "inj f \<Longrightarrow> f -` (f ` A) = A"
  unfolding inj_on_def by blast

lemma vimage_subsetD: "surj f \<Longrightarrow> f -` B \<subseteq> A \<Longrightarrow> B \<subseteq> f ` A"
  by (blast intro: sym)

lemma vimage_subsetI: "inj f \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> f -` B \<subseteq> A"
  unfolding inj_on_def by blast

lemma vimage_subset_eq: "bij f \<Longrightarrow> f -` B \<subseteq> A \<longleftrightarrow> B \<subseteq> f ` A"
  unfolding bij_def by (blast del: subsetI intro: vimage_subsetI vimage_subsetD)

lemma inj_on_image_eq_iff: "inj_on f C \<Longrightarrow> A \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
  by (fastforce simp add: inj_on_def)

lemma inj_on_Un_image_eq_iff: "inj_on f (A \<union> B) \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
  by (erule inj_on_image_eq_iff) simp_all

lemma inj_on_image_Int: "inj_on f C \<Longrightarrow> A \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
  unfolding inj_on_def by blast

lemma inj_on_image_set_diff: "inj_on f C \<Longrightarrow> A - B \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` (A - B) = f ` A - f ` B"
  unfolding inj_on_def by blast

lemma image_Int: "inj f \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
  unfolding inj_on_def by blast

lemma image_set_diff: "inj f \<Longrightarrow> f ` (A - B) = f ` A - f ` B"
  unfolding inj_on_def by blast

lemma inj_on_image_mem_iff: "inj_on f B \<Longrightarrow> a \<in> B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f a \<in> f ` A \<longleftrightarrow> a \<in> A"
  by (auto simp: inj_on_def)

(*FIXME DELETE*)
lemma inj_on_image_mem_iff_alt: "inj_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f a \<in> f ` A \<Longrightarrow> a \<in> B \<Longrightarrow> a \<in> A"
  by (blast dest: inj_onD)

lemma inj_image_mem_iff: "inj f \<Longrightarrow> f a \<in> f ` A \<longleftrightarrow> a \<in> A"
  by (blast dest: injD)

lemma inj_image_subset_iff: "inj f \<Longrightarrow> f ` A \<subseteq> f ` B \<longleftrightarrow> A \<subseteq> B"
  by (blast dest: injD)

lemma inj_image_eq_iff: "inj f \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
  by (blast dest: injD)

lemma surj_Compl_image_subset: "surj f \<Longrightarrow> - (f ` A) \<subseteq> f ` (- A)"
  by auto

lemma inj_image_Compl_subset: "inj f \<Longrightarrow> f ` (- A) \<subseteq> - (f ` A)"
  by (auto simp add: inj_on_def)

lemma bij_image_Compl_eq: "bij f \<Longrightarrow> f ` (- A) = - (f ` A)"
  by (simp add: bij_def inj_image_Compl_subset surj_Compl_image_subset equalityI)

lemma inj_vimage_singleton: "inj f \<Longrightarrow> f -` {a} \<subseteq> {THE x. f x = a}"
  \<comment> \<open>The inverse image of a singleton under an injective function is included in a singleton.\<close>
  by (simp add: inj_on_def) (blast intro: the_equality [symmetric])

lemma inj_on_vimage_singleton: "inj_on f A \<Longrightarrow> f -` {a} \<inter> A \<subseteq> {THE x. x \<in> A \<and> f x = a}"
  by (auto simp add: inj_on_def intro: the_equality [symmetric])

lemma (in ordered_ab_group_add) inj_uminus[simp, intro]: "inj_on uminus A"
  by (auto intro!: inj_onI)

lemma (in linorder) strict_mono_imp_inj_on: "strict_mono f \<Longrightarrow> inj_on f A"
  by (auto intro!: inj_onI dest: strict_mono_eq)

lemma bij_betw_byWitness:
  assumes left: "\<forall>a \<in> A. f' (f a) = a"
    and right: "\<forall>a' \<in> A'. f (f' a') = a'"
    and "f ` A \<subseteq> A'"
    and img2: "f' ` A' \<subseteq> A"
  shows "bij_betw f A A'"
  using assms
  unfolding bij_betw_def inj_on_def
proof safe
  fix a b
  assume "a \<in> A" "b \<in> A"
  with left have "a = f' (f a) \<and> b = f' (f b)" by simp
  moreover assume "f a = f b"
  ultimately show "a = b" by simp
next
  fix a' assume *: "a' \<in> A'"
  with img2 have "f' a' \<in> A" by blast
  moreover from * right have "a' = f (f' a')" by simp
  ultimately show "a' \<in> f ` A" by blast
qed

corollary notIn_Un_bij_betw:
  assumes "b \<notin> A"
    and "f b \<notin> A'"
    and "bij_betw f A A'"
  shows "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
proof -
  have "bij_betw f {b} {f b}"
    unfolding bij_betw_def inj_on_def by simp
  with assms show ?thesis
    using bij_betw_combine[of f A A' "{b}" "{f b}"] by blast
qed

lemma notIn_Un_bij_betw3:
  assumes "b \<notin> A"
    and "f b \<notin> A'"
  shows "bij_betw f A A' = bij_betw f (A \<union> {b}) (A' \<union> {f b})"
proof
  assume "bij_betw f A A'"
  then show "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
    using assms notIn_Un_bij_betw [of b A f A'] by blast
next
  assume *: "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
  have "f ` A = A'"
  proof auto
    fix a
    assume **: "a \<in> A"
    then have "f a \<in> A' \<union> {f b}"
      using * unfolding bij_betw_def by blast
    moreover
    have False if "f a = f b"
    proof -
      have "a = b"
        using * ** that unfolding bij_betw_def inj_on_def by blast
      with \<open>b \<notin> A\<close> ** show ?thesis by blast
    qed
    ultimately show "f a \<in> A'" by blast
  next
    fix a'
    assume **: "a' \<in> A'"
    then have "a' \<in> f ` (A \<union> {b})"
      using * by (auto simp add: bij_betw_def)
    then obtain a where 1: "a \<in> A \<union> {b} \<and> f a = a'" by blast
    moreover
    have False if "a = b" using 1 ** \<open>f b \<notin> A'\<close> that by blast
    ultimately have "a \<in> A" by blast
    with 1 show "a' \<in> f ` A" by blast
  qed
  then show "bij_betw f A A'"
    using * bij_betw_subset[of f "A \<union> {b}" _ A] by blast
qed

subsection \<open>Function Updating\<close>

definition fun_upd :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
  where "fun_upd f a b = (\<lambda>x. if x = a then b else f x)"

nonterminal updbinds and updbind

syntax
  "_updbind" :: "'a \<Rightarrow> 'a \<Rightarrow> updbind"             ("(2_ :=/ _)")
  ""         :: "updbind \<Rightarrow> updbinds"             ("_")
  "_updbinds":: "updbind \<Rightarrow> updbinds \<Rightarrow> updbinds" ("_,/ _")
  "_Update"  :: "'a \<Rightarrow> updbinds \<Rightarrow> 'a"            ("_/'((_)')" [1000, 0] 900)

translations
  "_Update f (_updbinds b bs)" \<rightleftharpoons> "_Update (_Update f b) bs"
  "f(x:=y)" \<rightleftharpoons> "CONST fun_upd f x y"

(* Hint: to define the sum of two functions (or maps), use case_sum.
         A nice infix syntax could be defined by
notation
  case_sum  (infixr "'(+')"80)
*)

lemma fun_upd_idem_iff: "f(x:=y) = f \<longleftrightarrow> f x = y"
  unfolding fun_upd_def
  apply safe
   apply (erule subst)
   apply (rule_tac [2] ext)
   apply auto
  done

lemma fun_upd_idem: "f x = y \<Longrightarrow> f(x := y) = f"
  by (simp only: fun_upd_idem_iff)

lemma fun_upd_triv [iff]: "f(x := f x) = f"
  by (simp only: fun_upd_idem)

lemma fun_upd_apply [simp]: "(f(x := y)) z = (if z = x then y else f z)"
  by (simp add: fun_upd_def)

(* fun_upd_apply supersedes these two, but they are useful
   if fun_upd_apply is intentionally removed from the simpset *)
lemma fun_upd_same: "(f(x := y)) x = y"
  by simp

lemma fun_upd_other: "z \<noteq> x \<Longrightarrow> (f(x := y)) z = f z"
  by simp

lemma fun_upd_upd [simp]: "f(x := y, x := z) = f(x := z)"
  by (simp add: fun_eq_iff)

lemma fun_upd_twist: "a \<noteq> c \<Longrightarrow> (m(a := b))(c := d) = (m(c := d))(a := b)"
  by (rule ext) auto

lemma inj_on_fun_updI: "inj_on f A \<Longrightarrow> y \<notin> f ` A \<Longrightarrow> inj_on (f(x := y)) A"
  by (fastforce simp: inj_on_def)

lemma fun_upd_image: "f(x := y) ` A = (if x \<in> A then insert y (f ` (A - {x})) else f ` A)"
  by auto

lemma fun_upd_comp: "f \<circ> (g(x := y)) = (f \<circ> g)(x := f y)"
  by auto

lemma fun_upd_eqD: "f(x := y) = g(x := z) \<Longrightarrow> y = z"
  by (simp add: fun_eq_iff split: if_split_asm)

subsection \<open>\<open>override_on\<close>\<close>

definition override_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b"
  where "override_on f g A = (\<lambda>a. if a \<in> A then g a else f a)"

lemma override_on_emptyset[simp]: "override_on f g {} = f"
  by (simp add:override_on_def)

lemma override_on_apply_notin[simp]: "a \<notin> A \<Longrightarrow> (override_on f g A) a = f a"
  by (simp add:override_on_def)

lemma override_on_apply_in[simp]: "a \<in> A \<Longrightarrow> (override_on f g A) a = g a"
  by (simp add:override_on_def)

lemma override_on_insert: "override_on f g (insert x X) = (override_on f g X)(x:=g x)"
  unfolding override_on_def by (simp add: fun_eq_iff)

lemma override_on_insert': "override_on f g (insert x X) = (override_on (f(x:=g x)) g X)"
  unfolding override_on_def by (simp add: fun_eq_iff)

subsection \<open>\<open>swap\<close>\<close>

definition swap :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
  where "swap a b f = f (a := f b, b:= f a)"

lemma swap_apply [simp]:
  "swap a b f a = f b"
  "swap a b f b = f a"
  "c \<noteq> a \<Longrightarrow> c \<noteq> b \<Longrightarrow> swap a b f c = f c"
  by (simp_all add: swap_def)

lemma swap_self [simp]: "swap a a f = f"
  by (simp add: swap_def)

lemma swap_commute: "swap a b f = swap b a f"
  by (simp add: fun_upd_def swap_def fun_eq_iff)

lemma swap_nilpotent [simp]: "swap a b (swap a b f) = f"
  by (rule ext) (simp add: fun_upd_def swap_def)

lemma swap_comp_involutory [simp]: "swap a b \<circ> swap a b = id"
  by (rule ext) simp

lemma swap_triple:
  assumes "a \<noteq> c" and "b \<noteq> c"
  shows "swap a b (swap b c (swap a b f)) = swap a c f"
  using assms by (simp add: fun_eq_iff swap_def)

lemma comp_swap: "f \<circ> swap a b g = swap a b (f \<circ> g)"
  by (rule ext) (simp add: fun_upd_def swap_def)

lemma swap_image_eq [simp]:
  assumes "a \<in> A" "b \<in> A"
  shows "swap a b f ` A = f ` A"
proof -
  have subset: "\<And>f. swap a b f ` A \<subseteq> f ` A"
    using assms by (auto simp: image_iff swap_def)
  then have "swap a b (swap a b f) ` A \<subseteq> (swap a b f) ` A" .
  with subset[of f] show ?thesis by auto
qed

lemma inj_on_imp_inj_on_swap: "inj_on f A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> inj_on (swap a b f) A"
  by (auto simp add: inj_on_def swap_def)

lemma inj_on_swap_iff [simp]:
  assumes A: "a \<in> A" "b \<in> A"
  shows "inj_on (swap a b f) A \<longleftrightarrow> inj_on f A"
proof
  assume "inj_on (swap a b f) A"
  with A have "inj_on (swap a b (swap a b f)) A"
    by (iprover intro: inj_on_imp_inj_on_swap)
  then show "inj_on f A" by simp
next
  assume "inj_on f A"
  with A show "inj_on (swap a b f) A"
    by (iprover intro: inj_on_imp_inj_on_swap)
qed

lemma surj_imp_surj_swap: "surj f \<Longrightarrow> surj (swap a b f)"
  by simp

lemma surj_swap_iff [simp]: "surj (swap a b f) \<longleftrightarrow> surj f"
  by simp

lemma bij_betw_swap_iff [simp]: "x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> bij_betw (swap x y f) A B \<longleftrightarrow> bij_betw f A B"
  by (auto simp: bij_betw_def)

lemma bij_swap_iff [simp]: "bij (swap a b f) \<longleftrightarrow> bij f"
  by simp

hide_const (open) swap

subsection \<open>Inversion of injective functions\<close>

definition the_inv_into :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
  where "the_inv_into A f = (\<lambda>x. THE y. y \<in> A \<and> f y = x)"

lemma the_inv_into_f_f: "inj_on f A \<Longrightarrow> x \<in> A \<Longrightarrow> the_inv_into A f (f x) = x"
  unfolding the_inv_into_def inj_on_def by blast

lemma f_the_inv_into_f: "inj_on f A \<Longrightarrow> y \<in> f ` A  \<Longrightarrow> f (the_inv_into A f y) = y"
  apply (simp add: the_inv_into_def)
  apply (rule the1I2)
   apply (blast dest: inj_onD)
  apply blast
  done

lemma the_inv_into_into: "inj_on f A \<Longrightarrow> x \<in> f ` A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> the_inv_into A f x \<in> B"
  apply (simp add: the_inv_into_def)
  apply (rule the1I2)
   apply (blast dest: inj_onD)
  apply blast
  done

lemma the_inv_into_onto [simp]: "inj_on f A \<Longrightarrow> the_inv_into A f ` (f ` A) = A"
  by (fast intro: the_inv_into_into the_inv_into_f_f [symmetric])

lemma the_inv_into_f_eq: "inj_on f A \<Longrightarrow> f x = y \<Longrightarrow> x \<in> A \<Longrightarrow> the_inv_into A f y = x"
  apply (erule subst)
  apply (erule the_inv_into_f_f)
  apply assumption
  done

lemma the_inv_into_comp:
  "inj_on f (g ` A) \<Longrightarrow> inj_on g A \<Longrightarrow> x \<in> f ` g ` A \<Longrightarrow>
    the_inv_into A (f \<circ> g) x = (the_inv_into A g \<circ> the_inv_into (g ` A) f) x"
  apply (rule the_inv_into_f_eq)
    apply (fast intro: comp_inj_on)
   apply (simp add: f_the_inv_into_f the_inv_into_into)
  apply (simp add: the_inv_into_into)
  done

lemma inj_on_the_inv_into: "inj_on f A \<Longrightarrow> inj_on (the_inv_into A f) (f ` A)"
  by (auto intro: inj_onI simp: the_inv_into_f_f)

lemma bij_betw_the_inv_into: "bij_betw f A B \<Longrightarrow> bij_betw (the_inv_into A f) B A"
  by (auto simp add: bij_betw_def inj_on_the_inv_into the_inv_into_into)

abbreviation the_inv :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
  where "the_inv f \<equiv> the_inv_into UNIV f"

lemma the_inv_f_f:
  assumes "inj f"
  shows "the_inv f (f x) = x"
  using assms UNIV_I by (rule the_inv_into_f_f)

subsection \<open>Cantor's Paradox\<close>

theorem Cantors_paradox: "\<nexists>f. f ` A = Pow A"
proof
  assume "\<exists>f. f ` A = Pow A"
  then obtain f where f: "f ` A = Pow A" ..
  let ?X = "{a \<in> A. a \<notin> f a}"
  have "?X \<in> Pow A" by blast
  then have "?X \<in> f ` A" by (simp only: f)
  then obtain x where "x \<in> A" and "f x = ?X" by blast
  then show False by blast
qed

subsection \<open>Setup\<close>

subsubsection \<open>Proof tools\<close>

text \<open>Simplify terms of the form \<open>f(\<dots>,x:=y,\<dots>,x:=z,\<dots>)\<close> to \<open>f(\<dots>,x:=z,\<dots>)\<close>\<close>

simproc_setup fun_upd2 ("f(v := w, x := y)") = \<open>fn _ =>
  let
    fun gen_fun_upd NONE T _ _ = NONE
      | gen_fun_upd (SOME f) T x y = SOME (Const (@{const_name fun_upd}, T) $ f $ x $ y)
    fun dest_fun_T1 (Type (_, T :: Ts)) = T
    fun find_double (t as Const (@{const_name fun_upd},T) $ f $ x $ y) =
      let
        fun find (Const (@{const_name fun_upd},T) $ g $ v $ w) =
              if v aconv x then SOME g else gen_fun_upd (find g) T v w
          | find t = NONE
      in (dest_fun_T1 T, gen_fun_upd (find f) T x y) end

    val ss = simpset_of @{context}

    fun proc ctxt ct =
      let
        val t = Thm.term_of ct
      in
        (case find_double t of
          (T, NONE) => NONE
        | (T, SOME rhs) =>
            SOME (Goal.prove ctxt [] [] (Logic.mk_equals (t, rhs))
              (fn _ =>
                resolve_tac ctxt [eq_reflection] 1 THEN
                resolve_tac ctxt @{thms ext} 1 THEN
                simp_tac (put_simpset ss ctxt) 1)))
      end
  in proc end
\<close>

subsubsection \<open>Functorial structure of types\<close>

ML_file "Tools/functor.ML"

functor map_fun: map_fun
  by (simp_all add: fun_eq_iff)

functor vimage
  by (simp_all add: fun_eq_iff vimage_comp)

text \<open>Legacy theorem names\<close>

lemmas o_def = comp_def
lemmas o_apply = comp_apply
lemmas o_assoc = comp_assoc [symmetric]
lemmas id_o = id_comp
lemmas o_id = comp_id
lemmas o_eq_dest = comp_eq_dest
lemmas o_eq_elim = comp_eq_elim
lemmas o_eq_dest_lhs = comp_eq_dest_lhs
lemmas o_eq_id_dest = comp_eq_id_dest

end


(*
    Title:      Determinants2.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Computing determinants of matrices using the Gauss Jordan algorithm\<close>

theory Determinants2
imports
  Gauss_Jordan_PA
begin

subsection\<open>Some previous properties\<close>

subsubsection\<open>Relationships between determinants and elementary row operations\<close>

lemma det_interchange_rows:
shows "det (interchange_rows A i j) = of_int (if i = j then 1 else -1) * det A"
proof -
  have "(interchange_rows A i j) = (\<chi> a. A $ (Transposition.transpose i j) a)"
    unfolding interchange_rows_def Transposition.transpose_def by vector
  hence "det(interchange_rows A i j) = det(\<chi> a. A$(Transposition.transpose i j) a)" by simp
  also have "... = of_int (sign (Transposition.transpose i j)) * det A" by (rule det_permute_rows[of "Transposition.transpose i j" A], simp add: permutes_swap_id)
  finally show ?thesis unfolding sign_swap_id .
qed

corollary det_interchange_different_rows:
assumes i_not_j: "i \<noteq> j"
shows "det (interchange_rows A i j) = - det A" unfolding det_interchange_rows using i_not_j by simp

corollary det_interchange_same_rows:
assumes i_eq_j: "i = j"
shows "det (interchange_rows A i j) = det A" unfolding det_interchange_rows using i_eq_j by simp

lemma det_mult_row:
shows "det (mult_row A a k) = k * det A"
proof -
have A_rw: "(\<chi> i. if i = a then A$a else A$i) = A" by vector
have "(mult_row A a k) = (\<chi> i. if i = a then k *s A $ a else A $ i)" unfolding mult_row_def by vector
hence "det(mult_row A a k) = det(\<chi> i. if i = a then k *s A $ a else A $ i)" by simp
also have "... =  k * det(\<chi> i. if i = a then A$a else A$i)" unfolding det_row_mul ..
also have "... = k * det A" unfolding A_rw ..
finally show ?thesis .
qed

(*The name det_row_add is already used in the Determinants.thy file of the standard library*)
lemma det_row_add':
assumes i_not_j: "i \<noteq> j"
shows "det (row_add A i j q) = det A"
proof -
have "(row_add A i j q) = (\<chi> k. if k = i then row i A + q *s row j A else row k A)"
unfolding row_add_def row_def by vector
hence "det(row_add A i j q) = det(\<chi> k. if k = i then row i A + q *s row j A else row k A)" by simp
also have "... = det A" unfolding det_row_operation[OF i_not_j] ..
finally show ?thesis .
qed

subsubsection\<open>Relationships between determinants and elementary column operations\<close>

lemma det_interchange_columns:
shows "det (interchange_columns A i j) = of_int (if i = j then 1 else -1) * det A"
proof -
  have "(interchange_columns A i j) = (\<chi> a b. A $ a $ (Transposition.transpose i j) b)"
    unfolding interchange_columns_def Transposition.transpose_def by vector
hence "det(interchange_columns A i j) = det(\<chi> a b. A $ a $ (Transposition.transpose i j) b)" by simp
also have "... = of_int (sign (Transposition.transpose i j)) * det A" by (rule det_permute_columns[of "Transposition.transpose i j" A], simp add: permutes_swap_id)
finally show ?thesis unfolding sign_swap_id .
qed

corollary det_interchange_different_columns:
assumes i_not_j: "i \<noteq> j"
shows "det (interchange_columns A i j) = - det A" unfolding det_interchange_columns using i_not_j by simp

corollary det_interchange_same_columns:
assumes i_eq_j: "i = j"
shows "det (interchange_columns A i j) = det A" unfolding det_interchange_columns using i_eq_j by simp

lemma det_mult_columns:
shows "det (mult_column A a k) = k * det A"
proof -
have "mult_column A a k = transpose (mult_row (transpose A) a k)" unfolding transpose_def mult_row_def mult_column_def by vector
hence "det (mult_column A a k) = det (transpose (mult_row (transpose A) a k))" by simp
also have "... = det (mult_row (transpose A) a k)" unfolding det_transpose ..
also have "... = k * det (transpose A)" unfolding det_mult_row ..
also have "... = k * det A" unfolding det_transpose ..
finally show ?thesis .
qed

lemma det_column_add:
assumes i_not_j: "i \<noteq> j"
shows "det (column_add A i j q) = det A"
proof -
have "(column_add A i j q) = (transpose (row_add (transpose A) i j q))" unfolding transpose_def column_add_def row_add_def by vector
hence "det (column_add A i j q) = det (transpose (row_add (transpose A) i j q))" by simp
also have "... = det (row_add (transpose A) i j q)" unfolding det_transpose ..
also have "... = det A" unfolding det_row_add'[OF i_not_j] det_transpose ..
finally show ?thesis .
qed

subsection\<open>Proving that the determinant can be computed by means of the Gauss Jordan algorithm\<close>

subsubsection\<open>Previous properties\<close>

lemma det_row_add_iterate_upt_n:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
assumes n: "n<nrows A"
shows "det (row_add_iterate A n i j) = det A"
using n
proof (induct n arbitrary: A)
case 0
show ?case unfolding row_add_iterate.simps using det_row_add'[of 0 i A] by auto
next
case (Suc n)
show ?case  unfolding row_add_iterate.simps
proof (auto)
show "det (row_add_iterate A n i j) = det A" using Suc.hyps Suc.prems by simp
assume Suc_n_not_i: "Suc n \<noteq> to_nat i"
have "det (row_add_iterate (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)) n i j)
= det (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j))"
proof (rule Suc.hyps, unfold nrows_def)
show " n < CARD('n)" using Suc.prems unfolding nrows_def by auto
qed
also have "... = det A"
  proof (rule det_row_add',rule ccontr, simp)
    assume "from_nat (Suc n) = i"
      hence "to_nat (from_nat (Suc n)::'n) = to_nat i" by simp
      hence "(Suc n) = to_nat i" unfolding to_nat_from_nat_id[OF Suc.prems[unfolded nrows_def]] .
      thus False using Suc_n_not_i by contradiction
    qed
finally show "det (row_add_iterate (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)) n i j) = det A" .
qed
qed

corollary det_row_add_iterate:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
shows "det (row_add_iterate A (nrows A - 1) i j) = det A"
by (metis det_row_add_iterate_upt_n diff_less neq0_conv nrows_not_0 zero_less_one)

lemma det_Gauss_Jordan_in_ij:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
shows "det (Gauss_Jordan_in_ij A i j) = det A' "
proof -
have nrows_eq: "nrows A' = nrows A" unfolding nrows_def by simp
have "row_add_iterate A' (nrows A - 1) i j  =  Gauss_Jordan_in_ij A i j" using row_add_iterate_eq_Gauss_Jordan_in_ij  unfolding A' .
hence "det (Gauss_Jordan_in_ij A i j) = det (row_add_iterate A' (nrows A - 1) i j)" by simp
also have "... = det A'" by (rule det_row_add_iterate[of A', unfolded nrows_eq])
finally show ?thesis .
qed

lemma det_Gauss_Jordan_in_ij_1:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
assumes i: "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) = i"
shows "det (Gauss_Jordan_in_ij A i j) = 1/(A$i$j) * det A"
proof -
have "det (Gauss_Jordan_in_ij A i j) = det A' " using det_Gauss_Jordan_in_ij unfolding A' by auto
also have "... = 1/(A$i$j) * det A" unfolding A' det_mult_row unfolding i det_interchange_rows by auto
finally show ?thesis .
qed

lemma det_Gauss_Jordan_in_ij_2:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
assumes i: "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) \<noteq> i"
shows "det (Gauss_Jordan_in_ij A i j) = - 1/(A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) * det A"
proof -
have "det (Gauss_Jordan_in_ij A i j) = det A' " using det_Gauss_Jordan_in_ij unfolding A' by auto
also have "... = - 1/(A$ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $j) * det A" unfolding A' det_mult_row unfolding det_interchange_rows using i by auto
finally show ?thesis .
qed

subsubsection\<open>Definitions\<close>

text\<open>The following definitions allow the computation of the determinant of a matrix using the Gauss-Jordan algorithm. In the first component the determinant of each transformation
is accumulated and the second component contains the matrix transformed into a reduced row echelon form matrix\<close>

definition Gauss_Jordan_in_ij_det_P :: "'a::{semiring_1, inverse, one, uminus}^'m^'n::{finite, ord}=> 'n=>'m=>('a \<times> ('a^'m^'n::{finite, ord}))"
  where "Gauss_Jordan_in_ij_det_P A i j = (let n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) in (if i = n then 1/(A $ i $ j) else - 1/(A $ n $ j), Gauss_Jordan_in_ij A i j))"

definition Gauss_Jordan_column_k_det_P where "Gauss_Jordan_column_k_det_P A' k =
(let det_P= fst A'; i = fst (snd A'); A = snd (snd A'); from_nat_i = from_nat i; from_nat_k = from_nat k
 in if (\<forall>m\<ge>from_nat_i. A $ m $ from_nat_k = 0) \<or> i = nrows A then (det_P, i, A)
    else let gauss = Gauss_Jordan_in_ij_det_P A (from_nat_i) (from_nat_k) in (fst gauss * det_P, i + 1, snd gauss))"

definition Gauss_Jordan_upt_k_det_P
  where "Gauss_Jordan_upt_k_det_P A k = (let foldl = foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k] in (fst foldl, snd (snd foldl)))"
definition Gauss_Jordan_det_P
  where "Gauss_Jordan_det_P A = Gauss_Jordan_upt_k_det_P A (ncols A - 1)"

subsubsection\<open>Proofs\<close>

text\<open>This is an equivalent definition created to achieve a more efficient computation.\<close>
lemma Gauss_Jordan_in_ij_det_P_code[code]:
shows "Gauss_Jordan_in_ij_det_P A i j =
    (let n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n);
         interchange_A = interchange_rows A i n;
         A' = mult_row interchange_A i (1 / interchange_A $ i $ j) in (if i = n then 1/(A $ i $ j) else - 1/(A $ n $ j), Gauss_Jordan_wrapper i j A' interchange_A))"
         unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_def Gauss_Jordan_wrapper_def Let_def by auto

lemma det_Gauss_Jordan_in_ij_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
shows "(fst (Gauss_Jordan_in_ij_det_P A i j)) * det A  = det (snd (Gauss_Jordan_in_ij_det_P A i j))"
unfolding Gauss_Jordan_in_ij_det_P_def Let_def fst_conv snd_conv
using det_Gauss_Jordan_in_ij_1[of A j i]
using det_Gauss_Jordan_in_ij_2[of A j i] by auto

lemma det_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes det: "det_P * det B = det A"
shows "(fst (Gauss_Jordan_column_k_det_P (det_P,i,A) k)) * det B = det (snd (snd (Gauss_Jordan_column_k_det_P (det_P,i,A) k)))"
proof (unfold Gauss_Jordan_column_k_det_P_def Let_def, auto simp add: assms)
fix m
assume i_not_nrows: "i \<noteq> nrows A"
and i_less_m: "from_nat i \<le> m"
and Amk_not_0: "A $ m $ from_nat k \<noteq> 0"
show  "fst (Gauss_Jordan_in_ij_det_P A (from_nat i) (from_nat k)) * det_P * det B =
        det (snd (Gauss_Jordan_in_ij_det_P A (from_nat i) (from_nat k)))" unfolding mult.assoc det
        unfolding det_Gauss_Jordan_in_ij_det_P ..
qed

lemma det_Gauss_Jordan_upt_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "(fst (Gauss_Jordan_upt_k_det_P A k)) * det A = det (snd (Gauss_Jordan_upt_k_det_P A k))"
proof (induct k)
case 0
show ?case
unfolding Gauss_Jordan_upt_k_det_P_def Let_def unfolding fst_conv snd_conv by (simp add:det_Gauss_Jordan_column_k_det_P)
next
case (Suc k)
have suc_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
have fold_expand: "(foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])
= (fst (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]), fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])),
  snd (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])))" by simp
show ?case unfolding Gauss_Jordan_upt_k_det_P_def Let_def
unfolding suc_rw foldl_append List.foldl.simps fst_conv snd_conv
by(subst (1 2) fold_expand, rule det_Gauss_Jordan_column_k_det_P, rule Suc.hyps[unfolded Gauss_Jordan_upt_k_det_P_def Let_def fst_conv snd_conv])
qed

lemma det_Gauss_Jordan_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "(fst (Gauss_Jordan_det_P A)) * det A = det (snd (Gauss_Jordan_det_P A))"
using det_Gauss_Jordan_upt_k_det_P unfolding Gauss_Jordan_det_P_def by simp

definition upper_triangular_upt_k where "upper_triangular_upt_k A k = (\<forall>i j. j<i \<and> to_nat j < k \<longrightarrow> A $ i $ j = 0)"
definition upper_triangular where "upper_triangular A = (\<forall>i j. j<i \<longrightarrow> A $ i $ j = 0)"

lemma upper_triangular_upt_imp_upper_triangular:
assumes "upper_triangular_upt_k A (nrows A)"
shows "upper_triangular A"
using assms unfolding upper_triangular_upt_k_def upper_triangular_def nrows_def
using to_nat_less_card[where ?'a='b] by blast

lemma rref_imp_upper_triagular_upt:
fixes A::"'a::{one, zero}^'n::{mod_type}^'n::{mod_type}"
assumes "reduced_row_echelon_form A"
shows "upper_triangular_upt_k A k"
proof (induct k)
case 0
show ?case unfolding upper_triangular_upt_k_def by simp
next
case (Suc k)
show ?case unfolding upper_triangular_upt_k_def proof (clarify)
fix i j::'n
assume j_less_i: "j < i" and j_less_suc_k: "to_nat j < Suc k"
show "A $ i $ j = 0"
  proof (cases "to_nat j < k")
  case True
  thus ?thesis using Suc.hyps unfolding upper_triangular_upt_k_def using j_less_i True by auto
  next
  case False
  hence j_eq_k: "to_nat j = k" using j_less_suc_k by simp
  have rref_suc: "reduced_row_echelon_form_upt_k A (Suc k)" by (metis assms rref_implies_rref_upt)

  show ?thesis
    proof (cases "A $ i $ from_nat k = 0")
      case True
      have "from_nat k = j" by (metis from_nat_to_nat_id j_eq_k)
      thus ?thesis using True by simp
      next
      case False
      have zero_i_k: "is_zero_row_upt_k i k A" unfolding is_zero_row_upt_k_def
      by (metis (opaque_lifting, mono_tags) Suc.hyps leD le_less_linear less_imp_le j_eq_k j_less_i le_trans to_nat_mono' upper_triangular_upt_k_def)
      have not_zero_i_suc_k: "\<not> is_zero_row_upt_k i (Suc k) A" unfolding is_zero_row_upt_k_def using False by (metis j_eq_k lessI to_nat_from_nat)
      have Least_eq: "(LEAST n. A $ i $ n \<noteq> 0) = from_nat k"
        proof (rule Least_equality)
           show "A $ i $ from_nat k \<noteq> 0" using False by simp
           show "\<And>y. A $ i $ y \<noteq> 0 \<Longrightarrow> from_nat k \<le> y" by (metis (full_types) is_zero_row_upt_k_def not_le_imp_less to_nat_le zero_i_k)
        qed
      have i_not_k: "i \<noteq> from_nat k" by (metis less_irrefl from_nat_to_nat_id j_eq_k j_less_i)
      show ?thesis using rref_upt_condition4_explicit[OF rref_suc not_zero_i_suc_k i_not_k] unfolding Least_eq
      using rref_upt_condition1_explicit[OF rref_suc]
      using Suc.hyps unfolding upper_triangular_upt_k_def
      by (metis (mono_tags) leD not_le_imp_less is_zero_row_upt_k_def is_zero_row_upt_k_suc j_eq_k j_less_i not_zero_i_suc_k to_nat_from_nat to_nat_mono')
qed
qed
qed
qed

lemma rref_imp_upper_triagular:
assumes "reduced_row_echelon_form A"
shows "upper_triangular A"
by (metis assms rref_imp_upper_triagular_upt upper_triangular_upt_imp_upper_triangular)

lemma det_Gauss_Jordan[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det (Gauss_Jordan A) = prod (\<lambda>i. (Gauss_Jordan A)$i$i) (UNIV:: 'n set)"
using det_upperdiagonal rref_imp_upper_triagular[OF rref_Gauss_Jordan[of A]] unfolding upper_triangular_def by blast

lemma snd_Gauss_Jordan_in_ij_det_P_is_snd_Gauss_Jordan_in_ij_PA:
shows "snd (Gauss_Jordan_in_ij_det_P A i j) = snd (Gauss_Jordan_in_ij_PA (P,A) i j)"
unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_PA_def
unfolding  Gauss_Jordan_in_ij_def Let_def snd_conv fst_conv ..

lemma snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA:
shows "snd (Gauss_Jordan_column_k_det_P (n,i,A) k) = snd (Gauss_Jordan_column_k_PA (P,i,A) k)"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv unfolding fst_conv
using snd_Gauss_Jordan_in_ij_det_P_is_snd_Gauss_Jordan_in_ij_PA by auto

lemma det_fst_row_add_iterate_PA:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
assumes n: "n<nrows A"
shows "det (fst (row_add_iterate_PA (P,A) n i j)) = det P"
using n
proof (induct n arbitrary: P A)
case 0
show ?case unfolding row_add_iterate_PA.simps using det_row_add'[of 0 i P] by simp
next
case (Suc n)
have n: "n<nrows A" using Suc.prems by simp
show ?case
proof (cases "Suc n = to_nat i")
case True show ?thesis unfolding row_add_iterate_PA.simps if_P[OF True] using Suc.hyps[OF n] .
next
case False
define P' where "P' = row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
define A' where "A' = row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
have n2: "n< nrows A'" using n unfolding nrows_def .
have "det (fst (row_add_iterate_PA (P, A) (Suc n) i j)) = det (fst (row_add_iterate_PA (P', A') n i j))" unfolding row_add_iterate_PA.simps if_not_P[OF False] P'_def A'_def ..
also have "... = det P'" using Suc.hyps[OF n2] .
also have "... = det P" unfolding P'_def
proof (rule det_row_add', rule ccontr, simp)
    assume "from_nat (Suc n) = i"
      hence "to_nat (from_nat (Suc n)::'n) = to_nat i" by simp
      hence "(Suc n) = to_nat i" unfolding to_nat_from_nat_id[OF Suc.prems[unfolded nrows_def]] .
      thus False using False by contradiction
    qed
finally show ?thesis .
qed
qed

lemma det_fst_Gauss_Jordan_in_ij_PA_eq_fst_Gauss_Jordan_in_ij_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_in_ij_det_P A i j) * det P = det (fst (Gauss_Jordan_in_ij_PA (P,A) i j))"
proof -
define P' where "P' = mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)"
define A' where "A' = mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)"
have "det (fst (Gauss_Jordan_in_ij_PA (P,A) i j)) = det (fst (row_add_iterate_PA (P',A') (nrows A - 1) i j))"
unfolding fst_row_add_iterate_PA_eq_fst_Gauss_Jordan_in_ij_PA[symmetric] A'_def P'_def ..
also have "...= det P'" by (rule det_fst_row_add_iterate_PA, simp add: nrows_def)
also have "... = (if i = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) then 1 / A $ i $ j else - 1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) * det P"
proof (cases "i = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)")
case True show ?thesis
unfolding if_P[OF True] P'_def unfolding True[symmetric] unfolding interchange_same_rows unfolding det_mult_row ..
next
case False
show ?thesis unfolding if_not_P[OF False] P'_def unfolding det_mult_row unfolding det_interchange_different_rows[OF False] by simp
qed
also have "... = fst (Gauss_Jordan_in_ij_det_P A i j) * det P"
unfolding Gauss_Jordan_in_ij_det_P_def by simp
finally show ?thesis ..
qed

lemma det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_column_k_det_P (det P,i,A) k) = det (fst (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv
using det_fst_Gauss_Jordan_in_ij_PA_eq_fst_Gauss_Jordan_in_ij_det_P by auto

lemma fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA:
shows "fst (snd (Gauss_Jordan_column_k_det_P (n,i,A) k)) = fst (snd (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv
by auto

text\<open>The way of proving the following lemma is very similar to the demonstration of @{thm "rref_and_index_Gauss_Jordan_upt_k"}.\<close>

lemma foldl_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows det_fst_Gauss_Jordan_upt_k_PA_eq_fst_Gauss_Jordan_upt_k_det_P: "fst (Gauss_Jordan_upt_k_det_P A k) = det (fst (Gauss_Jordan_upt_k_PA A k))"
and snd_Gauss_Jordan_upt_k_det_P_is_snd_Gauss_Jordan_upt_k_PA: "snd (Gauss_Jordan_upt_k_det_P A k) = snd (Gauss_Jordan_upt_k_PA A k)"
and fst_snd_foldl_Gauss_det_P_PA: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]))"
proof (induct k)
case 0
show "fst (Gauss_Jordan_upt_k_det_P A 0) = det (fst (Gauss_Jordan_upt_k_PA A 0))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def
by (simp, metis det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P det_I)
show "snd (Gauss_Jordan_upt_k_det_P A 0) = snd (Gauss_Jordan_upt_k_PA A 0)"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def snd_conv
apply auto using snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA by metis
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc 0])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc 0]))"
using [[unfold_abs_def = false]]
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def apply auto
using fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA by metis
next
fix k
assume hyp1: "fst (Gauss_Jordan_upt_k_det_P A k) = det (fst (Gauss_Jordan_upt_k_PA A k))"
and hyp2: "snd (Gauss_Jordan_upt_k_det_P A k) = snd (Gauss_Jordan_upt_k_PA A k)"
and hyp3: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]))"
have list_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
have det_mat_nn: "det (mat 1::'a^'n::{mod_type}^'n::{mod_type}) = 1" using det_I by simp
define f where "f = foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]"
define g where "g = foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]"
have f_rw: "f = (fst f, fst (snd f), snd(snd f))" by simp
have g_rw: "g = (fst g, fst (snd g), snd(snd g))" by simp
have fst_snd: "fst (snd f) = fst (snd g)" unfolding f_def g_def using hyp3 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv .
have snd_snd: "snd (snd f) = snd (snd g)" unfolding f_def g_def using hyp2 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv .
have fst_det: "fst f = det (fst g)" unfolding f_def g_def using hyp1 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv by simp
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) \<Longrightarrow>
        fst (Gauss_Jordan_upt_k_det_P A (Suc k)) = det (fst (Gauss_Jordan_upt_k_PA A (Suc k)))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det
by (rule det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P)
show "snd (Gauss_Jordan_upt_k_det_P A (Suc k)) = snd (Gauss_Jordan_upt_k_PA A (Suc k))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det
by (metis fst_snd prod.collapse snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA snd_eqD snd_snd)
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc (Suc k)])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)]))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det by (rule fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA)
qed

lemma snd_Gauss_Jordan_det_P_is_Gauss_Jordan:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "snd (Gauss_Jordan_det_P A) = (Gauss_Jordan A)"
unfolding Gauss_Jordan_det_P_def Gauss_Jordan_def unfolding snd_Gauss_Jordan_upt_k_det_P_is_snd_Gauss_Jordan_upt_k_PA
snd_Gauss_Jordan_upt_k_PA ..

lemma det_snd_Gauss_Jordan_det_P[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det (snd (Gauss_Jordan_det_P A)) = prod (\<lambda>i. (snd (Gauss_Jordan_det_P A))$i$i) (UNIV:: 'n set)"
unfolding snd_Gauss_Jordan_det_P_is_Gauss_Jordan det_Gauss_Jordan ..

lemma det_fst_Gauss_Jordan_PA_eq_fst_Gauss_Jordan_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_det_P A) = det (fst (Gauss_Jordan_PA A))"
by (unfold Gauss_Jordan_det_P_def Gauss_Jordan_PA_def, rule det_fst_Gauss_Jordan_upt_k_PA_eq_fst_Gauss_Jordan_upt_k_det_P)

lemma fst_Gauss_Jordan_det_P_not_0:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_det_P A) \<noteq> 0"
unfolding det_fst_Gauss_Jordan_PA_eq_fst_Gauss_Jordan_det_P
by (metis (mono_tags) det_I det_mul invertible_fst_Gauss_Jordan_PA matrix_inv_right mult_zero_left zero_neq_one)

lemma det_code_equation[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det A = (let A' = Gauss_Jordan_det_P A in prod (\<lambda>i. (snd (A'))$i$i) (UNIV::'n set)/(fst (A')))"
unfolding Let_def using det_Gauss_Jordan_det_P[of A]
unfolding det_snd_Gauss_Jordan_det_P
by (simp add: fst_Gauss_Jordan_det_P_not_0 nonzero_eq_divide_eq ac_simps)

end


theory GabrielaLimonta
imports Main "~~/src/HOL/IMP/Star"
begin

subsection "Expressions"

datatype val = Iv int | Bv bool

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

datatype exp =  N int | V vname | Plus exp exp |
  Bc bool | Not exp | And exp exp | Less exp exp

inductive eval :: "exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"eval (N i) s (Iv i)" |
"eval (V x) s (s x)" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2)
 \<Longrightarrow> eval (Plus a1 a2) s (Iv(i1+i2))" |
"eval (Bc v) s (Bv v)" |
"eval b s (Bv bv) \<Longrightarrow> eval (Not b) s (Bv(\<not> bv))" |
"eval b1 s (Bv bv1) \<Longrightarrow> eval b2 s (Bv bv2) \<Longrightarrow> eval (And b1 b2) s (Bv(bv1 & bv2))" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2) \<Longrightarrow> eval (Less a1 a2) s (Bv(i1 < i2))"

inductive_cases [elim!]:
  "eval (N i) s v"
  "eval (V x) s v"
  "eval (Plus a1 a2) s v"
  "eval (Bc b) s v"
  "eval (Not b) s v"
  "eval (And b1 b2) s v"
  "eval (Less a1 a2) s v"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname exp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     exp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  exp com         ("WHILE _ DO _"  [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "eval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "eval b s (Bv True) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "eval b s (Bv False) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Ity | Bty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive etyping :: "tyenv \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> N i : Ity" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : Ity" |
B_ty: "\<Gamma> \<turnstile> Bc v : Bty" |
Not_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> Not b : Bty" |
And_ty: "\<Gamma> \<turnstile> b1 : Bty \<Longrightarrow> \<Gamma> \<turnstile> b2 : Bty \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2 : Bty" |
Less_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2 : Bty"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"

inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Bv r) = Bty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Bty[simp]: "type v = Bty \<longleftrightarrow> (\<exists>r. v = Bv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

lemma epreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> eval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
  apply (induction rule: etyping.induct)
  apply (auto intro: etyping.intros)
  by (metis styping_def)

lemma eprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. eval a s v"
  apply (induction rule: etyping.induct)
  apply (auto intro: eval.intros)
  apply (metis (full_types) epreservation eval.intros(3) type_eq_Ity)
  apply (metis epreservation eval.intros(5) type_eq_Bty)
  apply (metis epreservation eval.intros(6) type_eq_Bty)
  by (metis (full_types) epreservation eval.intros(7) type_eq_Ity)

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
  apply (induction rule: ctyping.induct)
  apply (auto intro: ctyping.intros)
  apply (metis Assign eprogress)
  apply (metis Seq1 Seq2)
sorry

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
  apply (induction rule: small_step_induct)
  apply (auto intro: small_step.intros)
  sorry

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
  apply (induction rule: small_step_induct)
  apply (auto intro: small_step.intros)
  by (auto intro: ctyping.intros)

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
oops

end