(*  Title:      JinjaDCI/J/DefAss.thy
    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   2003 Technische Universitaet Muenchen, 2019-20 UIUC

    Based on the Jinja theory J/DefAss.thy by Tobias Nipkow
*)

section \<open> Definite assignment \<close>

theory DefAss imports BigStep begin

subsection "Hypersets"

type_synonym 'a hyperset = "'a set option"

definition hyperUn :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<squnion>" 65)
where
  "A \<squnion> B  \<equiv>  case A of None \<Rightarrow> None
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> None | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<union> B\<rfloor>)"

definition hyperInt :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> 'a hyperset"   (infixl "\<sqinter>" 70)
where
  "A \<sqinter> B  \<equiv>  case A of None \<Rightarrow> B
                 | \<lfloor>A\<rfloor> \<Rightarrow> (case B of None \<Rightarrow> \<lfloor>A\<rfloor> | \<lfloor>B\<rfloor> \<Rightarrow> \<lfloor>A \<inter> B\<rfloor>)"

definition hyperDiff1 :: "'a hyperset \<Rightarrow> 'a \<Rightarrow> 'a hyperset"   (infixl "\<ominus>" 65)
where
  "A \<ominus> a  \<equiv>  case A of None \<Rightarrow> None | \<lfloor>A\<rfloor> \<Rightarrow> \<lfloor>A - {a}\<rfloor>"

definition hyper_isin :: "'a \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<in>\<in>" 50)
where
  "a \<in>\<in> A  \<equiv>  case A of None \<Rightarrow> True | \<lfloor>A\<rfloor> \<Rightarrow> a \<in> A"

definition hyper_subset :: "'a hyperset \<Rightarrow> 'a hyperset \<Rightarrow> bool"   (infix "\<sqsubseteq>" 50)
where
  "A \<sqsubseteq> B  \<equiv>  case B of None \<Rightarrow> True
                 | \<lfloor>B\<rfloor> \<Rightarrow> (case A of None \<Rightarrow> False | \<lfloor>A\<rfloor> \<Rightarrow> A \<subseteq> B)"

lemmas hyperset_defs =
 hyperUn_def hyperInt_def hyperDiff1_def hyper_isin_def hyper_subset_def

lemma [simp]: "\<lfloor>A\<rfloor> \<squnion> \<lfloor>B\<rfloor> = \<lfloor>A \<union> B\<rfloor> \<and> \<lfloor>A\<rfloor> \<ominus> a = \<lfloor>A - {a}\<rfloor>"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "None \<squnion> A = None \<and> A \<squnion> None = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma [simp]: "a \<in>\<in> None \<and> None \<ominus> a = None"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma hyper_isin_union: "x \<in>\<in> \<lfloor>A\<rfloor> \<Longrightarrow> x \<in>\<in> \<lfloor>A\<rfloor> \<squnion> B"
 by(case_tac B, auto simp: hyper_isin_def)

lemma hyperUn_assoc: "(A \<squnion> B) \<squnion> C = A \<squnion> (B \<squnion> C)"
(*<*)by(simp add:hyperset_defs Un_assoc)(*>*)

lemma hyper_insert_comm: "A \<squnion> \<lfloor>{a}\<rfloor> = \<lfloor>{a}\<rfloor> \<squnion> A \<and> A \<squnion> (\<lfloor>{a}\<rfloor> \<squnion> B) = \<lfloor>{a}\<rfloor> \<squnion> (A \<squnion> B)"
(*<*)by(simp add:hyperset_defs)(*>*)

lemma hyper_comm: "A \<squnion> B = B \<squnion> A \<and> A \<squnion> B \<squnion> C = B \<squnion> A \<squnion> C"
(*<*)
proof(cases A)
  case SomeA: Some then show ?thesis
  proof(cases B)
    case SomeB: Some with SomeA show ?thesis
    proof(cases C)
      case SomeC: Some with SomeA SomeB show ?thesis
        by(simp add: Un_left_commute Un_commute)
    qed (simp add: Un_commute)
  qed simp
qed simp
(*>*)

subsection "Definite assignment"

primrec
  \  :: "'a exp \<Rightarrow> 'a hyperset"
  and \s :: "'a exp list \<Rightarrow> 'a hyperset"
where
  "\ (new C) = \<lfloor>{}\<rfloor>"
| "\ (Cast C e) = \ e"
| "\ (Val v) = \<lfloor>{}\<rfloor>"
| "\ (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (Var V) = \<lfloor>{}\<rfloor>"
| "\ (LAss V e) = \<lfloor>{V}\<rfloor> \<squnion> \ e"
| "\ (e\<bullet>F{D}) = \ e"
| "\ (C\<bullet>\<^sub>sF{D}) = \<lfloor>{}\<rfloor>"
| "\ (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (C\<bullet>\<^sub>sF{D}:=e\<^sub>2) = \ e\<^sub>2"
| "\ (e\<bullet>M(es)) = \ e \<squnion> \s es"
| "\ (C\<bullet>\<^sub>sM(es)) = \s es"
| "\ ({V:T; e}) = \ e \<ominus> V"
| "\ (e\<^sub>1;;e\<^sub>2) = \ e\<^sub>1 \<squnion> \ e\<^sub>2"
| "\ (if (e) e\<^sub>1 else e\<^sub>2) =  \ e \<squnion> (\ e\<^sub>1 \<sqinter> \ e\<^sub>2)"
| "\ (while (b) e) = \ b"
| "\ (throw e) = None"
| "\ (try e\<^sub>1 catch(C V) e\<^sub>2) = \ e\<^sub>1 \<sqinter> (\ e\<^sub>2 \<ominus> V)"
| "\ (INIT C (Cs,b) \<leftarrow> e) = \<lfloor>{}\<rfloor>"
| "\ (RI (C,e);Cs \<leftarrow> e') = \ e"

| "\s ([]) = \<lfloor>{}\<rfloor>"
| "\s (e#es) = \ e \<squnion> \s es"

primrec
  \<D>  :: "'a exp \<Rightarrow> 'a hyperset \<Rightarrow> bool"
  and \<D>s :: "'a exp list \<Rightarrow> 'a hyperset \<Rightarrow> bool"
where
  "\<D> (new C) A = True"
| "\<D> (Cast C e) A = \<D> e A"
| "\<D> (Val v) A = True"
| "\<D> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (Var V) A = (V \<in>\<in> A)"
| "\<D> (LAss V e) A = \<D> e A"
| "\<D> (e\<bullet>F{D}) A = \<D> e A"
| "\<D> (C\<bullet>\<^sub>sF{D}) A = True"
| "\<D> (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (C\<bullet>\<^sub>sF{D}:=e\<^sub>2) A = \<D> e\<^sub>2 A"
| "\<D> (e\<bullet>M(es)) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"
| "\<D> (C\<bullet>\<^sub>sM(es)) A = \<D>s es A"
| "\<D> ({V:T; e}) A = \<D> e (A \<ominus> V)"
| "\<D> (e\<^sub>1;;e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \ e\<^sub>1))"
| "\<D> (if (e) e\<^sub>1 else e\<^sub>2) A =
  (\<D> e A \<and> \<D> e\<^sub>1 (A \<squnion> \ e) \<and> \<D> e\<^sub>2 (A \<squnion> \ e))"
| "\<D> (while (e) c) A = (\<D> e A \<and> \<D> c (A \<squnion> \ e))"
| "\<D> (throw e) A = \<D> e A"
| "\<D> (try e\<^sub>1 catch(C V) e\<^sub>2) A = (\<D> e\<^sub>1 A \<and> \<D> e\<^sub>2 (A \<squnion> \<lfloor>{V}\<rfloor>))"
| "\<D> (INIT C (Cs,b) \<leftarrow> e) A = \<D> e A"
| "\<D> (RI (C,e);Cs \<leftarrow> e') A = (\<D> e A \<and> \<D> e' A)"

| "\<D>s ([]) A = True"
| "\<D>s (e#es) A = (\<D> e A \<and> \<D>s es (A \<squnion> \ e))"

lemma As_map_Val[simp]: "\s (map Val vs) = \<lfloor>{}\<rfloor>"
(*<*)by (induct vs) simp_all(*>*)

lemma D_append[iff]: "\<And>A. \<D>s (es @ es') A = (\<D>s es A \<and> \<D>s es' (A \<squnion> \s es))"
(*<*)by (induct es type:list) (auto simp:hyperUn_assoc)(*>*)

lemma A_fv: "\<And>A. \ e = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fv e"
and  "\<And>A. \s es = \<lfloor>A\<rfloor> \<Longrightarrow> A \<subseteq> fvs es"
(*<*)
by (induct e and es rule: \.induct \s.induct)
   (fastforce simp add:hyperset_defs)+
(*>*)

lemma sqUn_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<squnion> B \<sqsubseteq> A' \<squnion> B"
(*<*)by(simp add:hyperset_defs) blast(*>*)

lemma diff_lem: "A \<sqsubseteq> A' \<Longrightarrow> A \<ominus> b \<sqsubseteq> A' \<ominus> b"
(*<*)by(simp add:hyperset_defs) blast(*>*)

(* This order of the premises avoids looping of the simplifier *)
lemma D_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D> e A \<Longrightarrow> \<D> (e::'a exp) A'"
and Ds_mono: "\<And>A A'. A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A \<Longrightarrow> \<D>s (es::'a exp list) A'"
(*<*)
proof(induct e and es rule: \<D>.induct \<D>s.induct)
  case BinOp then show ?case by simp (iprover dest:sqUn_lem)
next
  case Var then show ?case by (fastforce simp add:hyperset_defs)
next
  case FAss then show ?case by simp (iprover dest:sqUn_lem)
next
  case Call then show ?case by simp (iprover dest:sqUn_lem)
next
  case Block then show ?case by simp (iprover dest:diff_lem)
next
  case Seq then show ?case by simp (iprover dest:sqUn_lem)
next
  case Cond then show ?case by simp (iprover dest:sqUn_lem)
next
  case While then show ?case by simp (iprover dest:sqUn_lem)
next
  case TryCatch then show ?case by simp (iprover dest:sqUn_lem)
next
  case Cons_exp then show ?case by simp (iprover dest:sqUn_lem)
qed simp_all
(*>*)

(* And this is the order of premises preferred during application: *)
lemma D_mono': "\<D> e A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D> e A'"
and Ds_mono': "\<D>s es A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> \<D>s es A'"
(*<*)by(blast intro:D_mono, blast intro:Ds_mono)(*>*)

lemma Ds_Vals: "\<D>s (map Val vs) A" by(induct vs, auto)

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype 'a Maybe = Nothing | Just "'a"

datatype 'a Seq = Nil | Cons "'a" "(('a, ('a Maybe)) pair) Seq"

fun y :: "('a => 'b) => 'a Maybe => 'b Maybe" where
"y z (Nothing) = Nothing"
| "y z (Just z2) = Just (z z2)"

fun x :: "('a => 'b Maybe) => 'a Maybe => 'b Maybe" where
"x z (Nothing) = Nothing"
| "x z (Just z2) = z z2"

fun pair3 :: "'a list => (('a, ('a Maybe)) pair) list" where
"pair3 (nil2) = nil2"
| "pair3 (cons2 y2 (nil2)) = cons2 (pair2 y2 (Nothing)) (nil2)"
| "pair3 (cons2 y2 (cons2 y22 xs)) =
     cons2 (pair2 y2 (Just y22)) (pair3 xs)"

fun lookup :: "int => 'a list => 'a Maybe" where
"lookup z (nil2) = Nothing"
| "lookup z (cons2 z2 x2) =
     (if (z = 0) then Just z2 else lookup (z - 1) x2)"

fun index :: "int => 'a Seq => 'a Maybe" where
"index z (Nil) = Nothing"
| "index z (Cons z2 x2) =
     (if (z = 0) then Just z2 else
        (if ((mod z 2) = 0) then
           (case index ((op div) (z - 1) 2) x2 of
              Nothing => Nothing
              | Just x5 => (case x5 of pair2 x6 y3 => y3))
           else
           (case index ((op div) (z - 1) 2) x2 of
              Nothing => Nothing
              | Just x3 => (case x3 of pair2 x4 y22 => Just x4))))"

fun fromList :: "'a list => 'a Seq" where
"fromList (nil2) = Nil"
| "fromList (cons2 y2 xs) = Cons y2 (fromList (pair3 xs))"

theorem property0 :
  "((n >= 0) ==> ((lookup n xs) = (index n (fromList xs))))"
  oops

end


theory sort_MSortTDSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

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

fun msorttd :: "int list => int list" where
"msorttd (Nil2) = Nil2"
| "msorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "msorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge
       (msorttd
          (ztake
             (div (zlength (Cons2 y (Cons2 x2 x3))) 2) (Cons2 y (Cons2 x2 x3))))
       (msorttd
          (zdrop
             (div (zlength (Cons2 y (Cons2 x2 x3))) 2)
             (Cons2 y (Cons2 x2 x3))))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster ztake zlength zdrop lmerge msorttd and2 ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (msorttd x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* Title: Fishers_Inequality.thy
   Author: Chelsea Edmonds
*)

section \<open>Fisher's Inequality\<close>

text \<open>This theory presents the proof of Fisher's Inequality \<^cite>\<open>"fisherExaminationDifferentPossible1940a"\<close>
 on BIBD's (i.e. uniform Fisher's) and the generalised nonuniform Fisher's Inequality \<close>
theory Fishers_Inequality imports Rank_Argument_General Linear_Bound_Argument
begin

subsection \<open> Uniform Fisher's Inequality \<close>
context ordered_bibd
begin

text \<open>Row/Column transformation steps \<close>

text\<open>Following design theory lecture notes from MATH3301 at the University of Queensland
 \<^cite>\<open>"HerkeLectureNotes2016"\<close>, a simple transformation to produce an upper triangular matrix using elementary
row operations is to (1) Subtract the first row from each other row, and (2) add all columns to the first column\<close>

lemma transform_N_step1_vals:
  defines mdef: "M \<equiv> (N * N\<^sup>T)"
  assumes "i < dim_row M"
  assumes "j < dim_col M"
  shows "i = 0 \<Longrightarrow> j = 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<r>)" \<comment> \<open> top left elem \<close>
  and "i \<noteq> 0 \<Longrightarrow> j = 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>) - (int \<r>)" \<comment> \<open> first column ex. 1 \<close>
  and "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>)" \<comment> \<open> first row ex. 1 \<close>
  and "i \<noteq> 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> i = j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<r>) - (int \<Lambda>)" \<comment> \<open> diagonal ex. 1 \<close>
  and "i \<noteq> 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> i \<noteq> j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = 0" \<comment> \<open> everything else \<close>
  using transpose_N_mult_diag v_non_zero assms
proof (simp)
  show "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>)"
    using transpose_N_mult_off_diag v_non_zero assms transpose_N_mult_dim(2) by force
next
  assume a: "j = 0" "i\<noteq>0"
  then have ail: "((-1) * M $$(0, j)) = -(int \<r>)"
    using transpose_N_mult_diag v_non_zero mdef by auto
  then have ijne: "j \<noteq> i" using a by simp
  then have aij: "M $$ (i, j) = (int \<Lambda>)" using assms(2) mdef transpose_N_mult_off_diag a v_non_zero
    by (metis transpose_N_mult_dim(1))
  then have "add_row_to_multiple (-1) [1..<dim_row M] 0 M $$ (i, j) = (-1)*(int \<r>) + (int \<Lambda>)"
    using ail add_first_row_to_multiple_index(2) assms(2) assms(3) a by (metis mult_minus1)
  then show "(add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>) - (int \<r>)"
    by linarith
next
  assume a: "i \<noteq> 0" "j \<noteq> 0"
  have ail: "((-1) * M $$(0, j)) = -(int \<Lambda>)"
    using assms transpose_N_mult_off_diag a v_non_zero transpose_N_mult_dim(1) by auto
  then have  "i = j \<Longrightarrow> M $$ (i, j) = (int \<r>)"
    using assms transpose_N_mult_diag a v_non_zero by (metis transpose_N_mult_dim(1))
  then show "i = j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<r>) - (int \<Lambda>)"
    using ail add_first_row_to_multiple_index(2) assms a by (metis uminus_add_conv_diff)
  then have "i \<noteq> j \<Longrightarrow> M $$ (i, j) = (int \<Lambda>)" using assms transpose_N_mult_off_diag a v_non_zero
    by (metis transpose_N_mult_dim(1) transpose_N_mult_dim(2))
  then show "i \<noteq> j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = 0"
    using ail add_first_row_to_multiple_index(2) assms a by (metis add.commute add.right_inverse)
qed

lemma transform_N_step2_vals:
  defines mdef: "M \<equiv> (add_row_to_multiple (-1) [1..<dim_row (N * N\<^sup>T)] 0 (N * N\<^sup>T))"
  assumes "i < dim_row (M)"
  assumes "j < dim_col (M)"
  shows "i = 0 \<Longrightarrow> j = 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) =
    (int \<r>) + (int \<Lambda>) * (\<v> - 1)" \<comment> \<open> top left element \<close>
  and "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j)  = (int \<Lambda>)" \<comment> \<open> top row \<close>
  and "i \<noteq> 0 \<Longrightarrow> i = j \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (int \<r>) - (int \<Lambda>)" \<comment> \<open> Diagonal \<close>
  and "i \<noteq> 0 \<Longrightarrow> i \<noteq> j \<Longrightarrow>  add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = 0" \<comment> \<open>Everything else\<close>
proof -
  show "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j)  = (int \<Lambda>)"
    using add_all_cols_to_first assms transform_N_step1_vals(3) by simp
  show "i \<noteq> 0 \<Longrightarrow> i = j \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (int \<r>) - (int \<Lambda>)"
    using add_all_cols_to_first assms transform_N_step1_vals(4) by simp
next
  assume a: "i = 0" "j =0"
  then have size: "card {1..<dim_col M} = \<v> - 1" using assms by simp
  have val: "\<And> l . l \<in> {1..<dim_col M} \<Longrightarrow> M $$ (i, l) = (int \<Lambda>)"
    using mdef transform_N_step1_vals(3) by (simp add: a(1))
  have "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (\<Sum>l\<in>{1..<dim_col M}.  M $$(i,l)) + M$$(i,0)"
    using a assms add_all_cols_to_first by blast
  also have "... = (\<Sum>l\<in>{1..<dim_col M}.  (int \<Lambda>)) + M$$(i,0)" using val by simp
  also have "... = (\<v> - 1) * (int \<Lambda>) + M$$(i,0)" using size by (metis sum_constant)
  finally show "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (int \<r>) + (int \<Lambda>) * (\<v> - 1)"
    using transform_N_step1_vals(1) a(1) a(2) assms(1) assms(2) by simp
next
  assume a: "i \<noteq> 0"  "i \<noteq> j"
  then show "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = 0"
  proof (cases "j \<noteq> 0")
    case True
    then show ?thesis using add_all_cols_to_first assms a transform_N_step1_vals(5) by simp
  next
    case False
    then have iin: "i \<in> {1..<dim_col M}" using a(1) assms by simp
    have cond: "\<And> l . l \<in> {1..<dim_col M} \<Longrightarrow> l <dim_col (N * N\<^sup>T) \<and> l \<noteq> 0" using assms by simp
    then have val: "\<And> l . l \<in> {1..<dim_col M } - {i} \<Longrightarrow> M $$ (i, l) = 0"
      using assms(3) transform_N_step1_vals(5) a False assms(1)
      by (metis DiffE iin index_mult_mat(2) index_mult_mat(3) index_transpose_mat(3) insertI1)
    have val2: "M $$ (i, i) = (int \<r>) - (int \<Lambda>)" using mdef transform_N_step1_vals(4) a False
       assms(1) transpose_N_mult_dim(1) transpose_N_mult_dim(2)
      by (metis cond iin)
    have val3: "M$$ (i, 0) = (int \<Lambda>) - (int \<r>)"
      using assms(3) transform_N_step1_vals(2) a False assms(1) assms(2)
      by (metis add_row_to_multiple_dim(1) transpose_N_mult_dim(2) v_non_zero)
    have "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (\<Sum>l\<in>{1..<dim_col M}.  M $$(i,l)) + M$$(i,0)"
      using assms add_all_cols_to_first False by blast
    also have "... = M $$ (i, i)  + (\<Sum>l\<in>{1..<dim_col M} - {i}.  M $$(i,l)) + M$$(i,0)"
      by (metis iin finite_atLeastLessThan sum.remove)
    finally show ?thesis using val val2 val3 by simp
  qed
qed

text \<open>Transformed matrix is upper triangular \<close>
lemma transform_upper_triangular:
  defines mdef: "M \<equiv> (add_row_to_multiple (-1) [1..<dim_row (N * N\<^sup>T)] 0 (N * N\<^sup>T))"
  shows "upper_triangular (add_multiple_cols 1 0 [1..<dim_col M] M)"
  using transform_N_step2_vals(4) by (intro upper_triangularI) (simp add: assms)

text \<open>Find the determinant of the $NN^T$ matrix using transformed matrix values\<close>
lemma determinant_inc_mat_square: "det (N * N\<^sup>T) = (\<r> + \<Lambda> * (\<v> - 1))* (\<r> - \<Lambda>)^(\<v> - 1)"
proof -
\<comment> \<open> Show the matrix is now lower triangular, therefore the det is the product of the sum of diagonal \<close>
  have cm: "(N * N\<^sup>T) \<in> carrier_mat \<v> \<v>"
    using transpose_N_mult_dim(1) transpose_N_mult_dim(2) by blast
  define C where "C \<equiv>(add_row_to_multiple (-1) [1..<dim_row (N * N\<^sup>T)] 0 (N * N\<^sup>T))"
  have "0 \<notin> set [1..<dim_row (N * N\<^sup>T)]" by simp
  then have detbc: "det (N * N\<^sup>T) = det C"
    using C_def add_row_to_multiple_det v_non_zero by (metis cm)
  define D where "D \<equiv> add_multiple_cols 1 0 [1..<dim_col C] C"
  have d00: "D $$ (0, 0) = ((int \<r>) + (int \<Lambda>) * (\<v> - 1))" using transform_N_step2_vals(1)
    by (simp add: C_def D_def v_non_zero)
  have ine0: "\<And> i. i \<in> {1..<dim_row D} \<Longrightarrow> i \<noteq> 0" by simp
  have "\<And> i. i \<in> {1..<dim_row D} \<Longrightarrow> i < dim_row (N * N\<^sup>T)" using D_def C_def by simp
  then have diagnon0: "\<And> i. i \<in> {1..<\<v>} \<Longrightarrow> D $$ (i, i) = (int \<r>) - (int \<Lambda>)"
    using transform_N_step2_vals(3) ine0 D_def C_def by simp (* Slow *)
  have alll: "\<And> l. l \<in> set [1..<dim_col C] \<Longrightarrow> l < \<v>" using C_def by simp
  have cmc: "C \<in> carrier_mat \<v> \<v>" using cm C_def
    by (simp add: add_row_to_multiple_carrier)
  have dimgt2: "dim_row D \<ge> 2"
    using t_lt_order D_def C_def by (simp)
  then have fstterm: "0 \<in> { 0 ..< dim_row D}" by (simp add: points_list_length)
  have "0 \<notin> set [1..<dim_col C]" by simp
  then have "det (N * N\<^sup>T) = det D" using add_multiple_cols_det alll cmc D_def C_def
    by (metis detbc)
  also have "... = prod_list (diag_mat D)" using det_upper_triangular
    using transform_upper_triangular D_def C_def by fastforce
  also have "... = (\<Prod> i = 0 ..< dim_row D. D $$ (i,i))" using prod_list_diag_prod by blast
  also have "... = (\<Prod> i = 0 ..< \<v>. D $$ (i,i))"  by (simp add: D_def C_def)
  finally have "det (N * N\<^sup>T) = D $$ (0, 0) * (\<Prod> i =  1 ..< \<v>. D $$ (i,i))"
    using dimgt2 by (simp add: prod.atLeast_Suc_lessThan v_non_zero)
  then have "det (N * N\<^sup>T) = (\<r> + \<Lambda> * (\<v> - 1)) * ((int \<r>) - (int \<Lambda>))^(\<v> - 1)"
    using d00 diagnon0 by simp
  then have "det (N * N\<^sup>T) = (\<r> + \<Lambda> * (\<v> - 1)) * ( \<r> - \<Lambda>)^(\<v> - 1)"
    using index_lt_replication
    by (metis (no_types, lifting) less_imp_le_nat of_nat_diff of_nat_mult of_nat_power)
  then show ?thesis by blast
qed

text \<open>Fisher's Inequality using the rank argument.
Note that to use the rank argument we must first map N to a real matrix. It is useful to explicitly
include the parameters which should be used in the application of the @{thm [source] "rank_argument_det"} lemma \<close>
theorem Fishers_Inequality_BIBD: "\<v> \<le> \<b>"
proof (intro rank_argument_det[of "map_mat real_of_int N" "\<v>" "\<b>"], simp_all)
  show "N \<in> carrier_mat \<v> (length \<B>s)" using blocks_list_length N_carrier_mat by simp
  let ?B = "map_mat (real_of_int) (N * N\<^sup>T)"
  have b_split: "?B = map_mat (real_of_int) N * (map_mat (real_of_int) N)\<^sup>T"
    using semiring_hom.mat_hom_mult  of_int_hom.semiring_hom_axioms transpose_carrier_mat map_mat_transpose
    by (metis (no_types, lifting) N_carrier_mat)
  have db: "det ?B = (\<r> + \<Lambda> * (\<v> - 1))* (\<r> - \<Lambda>)^(\<v> - 1)"
    using determinant_inc_mat_square by simp
  have lhn0: "(\<r> + \<Lambda> * (\<v> - 1)) > 0"
    using r_gzero by blast
  have "(\<r> - \<Lambda>) > 0"
    using index_lt_replication zero_less_diff by blast
  then have det_not_0:  "det ?B \<noteq> 0" using lhn0 db
    by (metis gr_implies_not0 mult_is_0 of_nat_eq_0_iff power_not_zero)
  thus "det (of_int_hom.mat_hom N * (of_int_hom.mat_hom N)\<^sup>T) \<noteq> (0:: real)" using b_split by simp
qed

end

subsection \<open>Generalised Fisher's Inequality \<close>

context simp_ordered_const_intersect_design
begin

text \<open>Lemma to reason on sum coefficients \<close>
lemma sum_split_coeffs_0:
  fixes c :: "nat \<Rightarrow> real"
  assumes "\<b> \<ge> 2"
  assumes "\<m> > 0"
  assumes "j' < \<b>"
  assumes "0 = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) +
           \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)"
  shows "c j' = 0"
proof (rule ccontr)
  assume cine0: "c j' \<noteq> 0"
  have innerge: "\<And> j . j < \<b>  \<Longrightarrow> (c j)^2 * (card (\<B>s ! j) - (int \<m>))  \<ge> 0"
    using inter_num_le_block_size assms(1) by simp
  then have lhsge: "(\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) \<ge> 0"
    using sum_bounded_below[of "{0..<\<b>}" "0" "\<lambda> i. (c i)^2 * ((card (\<B>s ! i))- (int \<m>))"] by simp
  have "\<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2) \<ge> 0" by simp
  then have rhs0: "\<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2) = 0"
    using assms(2) assms(4) lhsge by linarith
  then have "(\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) = 0"
    using assms by linarith
  then have lhs0inner: "\<And> j . j < \<b>  \<Longrightarrow> (c j)^2 * (card (\<B>s ! j) - (int \<m>)) = 0"
    using innerge sum_nonneg_eq_0_iff[of "{0..<\<b>}" "\<lambda> j . (c j)^2 * (card (\<B>s ! j) - (int \<m>))"]
    by simp
  thus False proof (cases "card (\<B>s ! j') = \<m>")
    case True
    then have cj0: "\<And> j. j \<in> {0..<\<b>} - {j'} \<Longrightarrow> (c j) = 0"
      using lhs0inner const_intersect_block_size_diff assms True by auto
    then have "(\<Sum> i \<in> {0..<\<b>} . c i) \<noteq> 0"
      using sum.remove[of "{0..<\<b>}" "j'" "\<lambda> i. c i"] assms(3) cine0 cj0 by simp
    then show ?thesis using rhs0 assms by simp
  next
    case False
    then have ne: "(card (\<B>s ! j') - (int \<m>)) \<noteq> 0"
      by linarith
    then have "(c j')^2 * (card (\<B>s ! j') - (int \<m>)) \<noteq> 0" using cine0
      by auto
    then show ?thesis using lhs0inner assms(3) by auto
  qed
qed

text \<open>The general non-uniform version of fisher's inequality is also known as the "Block town problem".
In this case we are working in a constant intersect design, hence the inequality is the opposite
way around compared to the BIBD version. The theorem below is the more traditional set theoretic
approach. This proof is based off one by Jukna \<^cite>\<open>"juknaExtremalCombinatorics2011"\<close> \<close>
theorem general_fishers_inequality:  "\<b> \<le> \<v>"
proof (cases "\<m> = 0 \<or> \<b> = 1")
  case True
  then show ?thesis using empty_inter_implies_b_lt_v v_non_zero by linarith
next
  case False
  then have mge: "\<m> > 0" by simp
  then have bge: "\<b> \<ge> 2" using b_positive False blocks_list_length by linarith
  define NR :: "real mat" where "NR \<equiv> lift_01_mat N"
  show ?thesis
  proof (intro lin_bound_argument2[of NR])
    show "distinct (cols NR)" using lift_01_distinct_cols_N NR_def by simp
    show nrcm: "NR \<in> carrier_mat \<v> \<b>" using NR_def N_carrier_mat_01_lift by simp
    have scalar_prod_real1: "\<And> i. i <\<b> \<Longrightarrow>  ((col NR i) \<bullet> (col NR i)) = card (\<B>s ! i)"
      using scalar_prod_block_size_lift_01 NR_def by auto
    have scalar_prod_real2: "\<And> i j. i <\<b> \<Longrightarrow> j <\<b> \<Longrightarrow> i \<noteq> j \<Longrightarrow> ((col NR i) \<bullet> (col NR j)) = \<m>"
      using scalar_prod_inter_num_lift_01 NR_def indexed_const_intersect by auto
    show "\<And>f. vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. f (col NR j) * (col NR j) $ i) = 0\<^sub>v \<v> \<Longrightarrow> \<forall>v\<in>set (cols NR). f v = 0"
    proof (intro ballI)
      fix f v
      assume eq0: "vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. f (col NR j) * col NR j $ i) = 0\<^sub>v \<v>"
      assume vin: "v \<in> set (cols NR)"
      define c where "c \<equiv> (\<lambda> j. f (col NR j))"
      obtain j' where v_def: "col NR j' = v" and jvlt: "j' < dim_col NR"
        using vin by (metis cols_length cols_nth index_less_size_conv nth_index)
      have dim_col: "\<And>j. j \<in> {0..< \<b>} \<Longrightarrow> dim_vec (col NR j) = \<v>" using nrcm by auto
      \<comment> \<open> Summation reasoning to obtain conclusion on coefficients \<close>
      have "0 = (vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. c j * (col NR j) $ i)) \<bullet> (vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. c j * (col NR j) $ i))"
        using vec_prod_zero eq0 c_def by simp
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . c j1 * c j1 * ((col NR j1) \<bullet> (col NR j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * ((col NR j1) \<bullet> (col NR j2))))"
        using scalar_prod_double_sum_fn_vec[of \<b> "col NR" \<v> c] dim_col by simp
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1) * (c j1) * (card (\<B>s ! j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * ((col NR j1) \<bullet> (col NR j2))))"
        using scalar_prod_real1 by simp
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1)^2 * (card (\<B>s ! j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * ((col NR j1) \<bullet> (col NR j2))))"
        by (metis power2_eq_square)
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1)^2 * (card (\<B>s ! j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * \<m>))" using scalar_prod_real2  by auto
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1)^2 * (card (\<B>s ! j1))) +
         \<m> * (\<Sum> j1 \<in> {0..<\<b>} . (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2))"
        using double_sum_mult_hom[of "\<m>" "\<lambda> i j . c i * c j" "\<lambda> i.{0..<\<b>} - {i}" "{0..<\<b>}"]
        by (metis (no_types, lifting) mult_of_nat_commute sum.cong)
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2 - (\<Sum> j \<in> {0..<\<b>} . c j * c j))"
        using double_sum_split_square_diff by auto
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))) + (-\<m>) * (\<Sum> j \<in> {0..<\<b>} . (c j)^2) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (simp add: algebra_simps power2_eq_square)
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))) + (\<Sum> j \<in> {0..<\<b>} . (-\<m>)* (c j)^2) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (simp add: sum_distrib_left)
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))+ (-\<m>)* (c j)^2) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (metis (no_types) sum.distrib)
      finally have sum_rep: "0 = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (simp add: algebra_simps)
      thus "f v = 0" using sum_split_coeffs_0[of "j'" "c"] mge bge jvlt nrcm c_def v_def by simp
    qed
  qed
qed

end

text \<open>Using the dual design concept, it is easy to translate the set theoretic general definition
of Fisher's inequality to a more traditional design theoretic version on pairwise balanced designs.
Two versions of this are given using different trivial (but crucial) conditions on design properties\<close>
context ordered_pairwise_balance
begin

corollary general_nonuniform_fishers: \<comment> \<open>only valid on incomplete designs \<close>
  assumes "\<Lambda> > 0"
  assumes "\<And> bl. bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
    \<comment> \<open> i.e. not a super trivial design with only complete blocks \<close>
  shows "\<v> \<le> \<b>"
proof -
  have "mset (\<B>s*) = dual_blocks \<V> \<B>s" using dual_blocks_ordered_eq by simp
  then interpret des: simple_const_intersect_design "set [0..<(length \<B>s)]" "mset (\<B>s*)" \<Lambda>
    using assms dual_is_simp_const_inter_des by simp
  interpret odes: simp_ordered_const_intersect_design "[0..<length \<B>s]" "\<B>s*" \<Lambda>
    using distinct_upt des.wellformed by (unfold_locales) (blast)
  have "length (\<B>s*) \<le> length [0..<length \<B>s]" using odes.general_fishers_inequality
    using odes.blocks_list_length odes.points_list_length by presburger
  then have "\<v> \<le> length \<B>s"
    by (simp add: dual_blocks_len points_list_length)
  then show ?thesis by auto
qed

corollary general_nonuniform_fishers_comp:
  assumes "\<Lambda> > 0"
  assumes "count \<B> \<V> < \<Lambda>" \<comment> \<open> i.e. not a super trivial design with only complete blocks and single blocks \<close>
  shows "\<v> \<le> \<b>"
proof -
  define B where "B = (removeAll_mset \<V> \<B>)"
  have b_smaller: "size B \<le> \<b>" using B_def removeAll_size_lt by simp
  then have b_incomp: "\<And> bl. bl \<in># B \<Longrightarrow> card bl < \<v>"
    using wellformed B_def by (simp add: psubsetI psubset_card_mono)
  have index_gt: "(\<Lambda> - (count \<B> \<V>)) > 0" using assms by simp
  interpret pbd: pairwise_balance \<V> B "(\<Lambda> - (count \<B> \<V>))"
    using remove_all_complete_blocks_pbd B_def assms(2) by blast
  obtain Bs where m: "mset Bs = B"
    using ex_mset by blast
  interpret opbd: ordered_pairwise_balance \<V>s Bs "(\<Lambda> - (count \<B> \<V>))"
    by (intro pbd.ordered_pbdI) (simp_all add: m distinct)
  have "\<v> \<le> (size B)" using b_incomp opbd.general_nonuniform_fishers
    using index_gt m by blast
  then show ?thesis using b_smaller m by auto
qed

end
end


(*
  File:   Landau_Simprocs.thy
  Author: Manuel Eberl <eberlm@in.tum.de>

  Simplification procedures for Landau symbols, with a particular focus on functions into the reals.
*)
section \<open>Simplification procedures\<close>

theory Landau_Simprocs
imports Landau_Real_Products
begin

subsection \<open>Simplification under Landau symbols\<close>

text \<open>
  The following can be seen as simpset for terms under Landau symbols.
  When given a rule @{term "f \<in> \<Theta>(g)"}, the simproc will attempt to rewrite any occurrence of
  @{term "f"} under a Landau symbol to @{term "g"}.
\<close>

named_theorems landau_simp "BigTheta rules for simplification of Landau symbols"
setup \<open>
  let
    val eq_thms = @{thms landau_theta.cong_bigtheta}
    fun eq_rule thm = get_first (try (fn eq_thm => eq_thm OF [thm])) eq_thms
  in
    Global_Theory.add_thms_dynamic
      (@{binding landau_simps},
        fn context =>
          Named_Theorems.get (Context.proof_of context) @{named_theorems landau_simp}
          |> map_filter eq_rule)
  end
\<close>

lemma bigtheta_const [landau_simp]:
  "NO_MATCH 1 c \<Longrightarrow> c \<noteq> 0 \<Longrightarrow> (\<lambda>x. c) \<in> \<Theta>(\<lambda>x. 1)" by simp

lemmas [landau_simp] = bigtheta_const_ln bigtheta_const_ln_powr bigtheta_const_ln_pow

lemma bigtheta_const_ln' [landau_simp]:
  "0 < a \<Longrightarrow> (\<lambda>x::real. ln (x * a)) \<in> \<Theta>(ln)"
  by (subst mult.commute) (rule bigtheta_const_ln)

lemma bigtheta_const_ln_powr' [landau_simp]:
  "0 < a \<Longrightarrow> (\<lambda>x::real. ln (x * a) powr p) \<in> \<Theta>(\<lambda>x. ln x powr p)"
  by (subst mult.commute) (rule bigtheta_const_ln_powr)

lemma bigtheta_const_ln_pow' [landau_simp]:
  "0 < a \<Longrightarrow> (\<lambda>x::real. ln (x * a) ^ p) \<in> \<Theta>(\<lambda>x. ln x ^ p)"
  by (subst mult.commute) (rule bigtheta_const_ln_pow)

subsection \<open>Simproc setup\<close>

lemma landau_gt_1_cong:
  "landau_symbol L L' Lr \<Longrightarrow> (\<And>x::real. x > 1 \<Longrightarrow> f x = g x) \<Longrightarrow> L at_top (f) = L at_top (g)"
  by (auto intro: eventually_mono [OF eventually_gt_at_top[of 1]] elim!: landau_symbol.cong)

lemma landau_gt_1_in_cong:
  "landau_symbol L L' Lr \<Longrightarrow> (\<And>x::real. x > 1 \<Longrightarrow> f x = g x) \<Longrightarrow> f \<in> L at_top (h) \<longleftrightarrow> g \<in> L at_top (h)"
  by (auto intro: eventually_mono [OF eventually_gt_at_top[of 1]] elim!: landau_symbol.in_cong)

lemma landau_prop_equalsI:
  "landau_symbol L L' Lr \<Longrightarrow> (\<And>x::real. x > 1 \<Longrightarrow> f1 x = f2 x) \<Longrightarrow> (\<And>x. x > 1 \<Longrightarrow> g1 x = g2 x) \<Longrightarrow>
     f1 \<in> L at_top (g1) \<longleftrightarrow> f2 \<in> L at_top (g2)"
apply (subst landau_gt_1_cong, assumption+)
apply (subst landau_gt_1_in_cong, assumption+)
apply (rule refl)
done

lemma ab_diff_conv_add_uminus': "(a::_::ab_group_add) - b = -b + a" by simp
lemma extract_diff_middle: "(a::_::ab_group_add) - (x + b) = -x + (a - b)" by simp

lemma divide_inverse': "(a::_::{division_ring,ab_semigroup_mult}) / b = inverse b * a"
  by (simp add: divide_inverse mult.commute)
lemma extract_divide_middle:"(a::_::{field}) / (x * b) = inverse x * (a / b)"
  by (simp add: divide_inverse algebra_simps)

lemmas landau_cancel = landau_symbol.mult_cancel_left

lemmas mult_cancel_left' = landau_symbol.mult_cancel_left[OF _ bigtheta_refl eventually_nonzeroD]

lemma mult_cancel_left_1:
  assumes "landau_symbol L L' Lr" "eventually_nonzero F f"
  shows   "f \<in> L F (\<lambda>x. f x * g2 x) \<longleftrightarrow> (\<lambda>_. 1) \<in> L F (g2)"
          "(\<lambda>x. f x * f2 x) \<in> L F (f) \<longleftrightarrow> f2 \<in> L F (\<lambda>_. 1)"
          "f \<in> L F (f) \<longleftrightarrow> (\<lambda>_. 1) \<in> L F (\<lambda>_. 1)"
  using mult_cancel_left'[OF assms, of "\<lambda>_. 1"] mult_cancel_left'[OF assms, of _ "\<lambda>_. 1"]
        mult_cancel_left'[OF assms, of "\<lambda>_. 1" "\<lambda>_. 1"] by simp_all

lemmas landau_mult_cancel_simps = mult_cancel_left' mult_cancel_left_1

ML_file \<open>landau_simprocs.ML\<close>

lemmas bigtheta_simps =
  landau_theta.cong_bigtheta[OF bigtheta_const_ln]
  landau_theta.cong_bigtheta[OF bigtheta_const_ln_powr]

text \<open>
  The following simproc attempts to cancel common factors in Landau symbols, i.\,e.\ in a
  goal like $f(x) h(x) \in L(g(x) h(x))$, the common factor $h(x)$ will be cancelled. This only
  works if the simproc can prove that $h(x)$ is eventually non-zero, for which it uses some
  heuristics.
\<close>
simproc_setup landau_cancel_factor (
    "f \<in> o[F](g)" | "f \<in> O[F](g)" | "f \<in> \<omega>[F](g)" | "f \<in> \<Omega>[F](g)" | "f \<in> \<Theta>[F](g)"
  ) = \<open>K Landau.cancel_factor_simproc\<close>

text \<open>
  The next simproc attempts to cancel dominated summands from Landau symbols; e.\,g.\ $O(x + \ln x)$
  is simplified to $O(x)$, since $\ln x \in o(x)$. This can be very slow on large terms, so it
  is not enabled by default.
\<close>
simproc_setup simplify_landau_sum (
    "o[F](\<lambda>x. f x)" | "O[F](\<lambda>x. f x)" | "\<omega>[F](\<lambda>x. f x)" | "\<Omega>[F](\<lambda>x. f x)" | "\<Theta>[F](\<lambda>x. f x)" |
    "f \<in> o[F](g)" | "f \<in> O[F](g)" | "f \<in> \<omega>[F](g)" | "f \<in> \<Omega>[F](g)" | "f \<in> \<Theta>[F](g)"
  ) = \<open>K (Landau.lift_landau_simproc Landau.simplify_landau_sum_simproc)\<close>

text \<open>
  This simproc attempts to simplify factors of an expression in a Landau symbol statement
  independently from another, i.\,e.\ in something like $O(f(x) g(x)$, a simp rule that rewrites
  $O(f(x))$ to $O(f'(x))$ will also rewrite $O(f(x) g(x))$ to $O(f'(x) g(x))$ without any further
  setup.
\<close>
simproc_setup simplify_landau_product (
    "o[F](\<lambda>x. f x)" | "O[F](\<lambda>x. f x)" | "\<omega>[F](\<lambda>x. f x)" | "\<Omega>[F](\<lambda>x. f x)" | "\<Theta>[F](\<lambda>x. f x)" |
    "f \<in> o[F](g)" | "f \<in> O[F](g)" | "f \<in> \<omega>[F](g)" | "f \<in> \<Omega>[F](g)" | "f \<in> \<Theta>[F](g)"
  ) = \<open>K (Landau.lift_landau_simproc Landau.simplify_landau_product_simproc)\<close>

text \<open>
  Lastly, the next very specialised simproc can solve goals of the form
  $f(x) \in L(g(x))$ where $f$ and $g$ are real-valued functions consisting only of multiplications,
  powers of $x$, and powers of iterated logarithms of $x$. This is done by rewriting both sides
  into the form $x^a (\ln x)^b (\ln \ln x)^c$ etc.\ and then comparing the exponents
  lexicographically.

  Note that for historic reasons, this only works for $x\to\infty$.
\<close>
simproc_setup landau_real_prod (
    "(f :: real \<Rightarrow> real) \<in> o(g)" | "(f :: real \<Rightarrow> real) \<in> O(g)" |
    "(f :: real \<Rightarrow> real) \<in> \<omega>(g)" | "(f :: real \<Rightarrow> real) \<in> \<Omega>(g)" |
    "(f :: real \<Rightarrow> real) \<in> \<Theta>(g)"
  ) = \<open>K Landau.simplify_landau_real_prod_prop_simproc\<close>

subsection \<open>Tests\<close>

lemma asymp_equiv_plus_const_left: "(\<lambda>n. c + real n) \<sim>[at_top] (\<lambda>n. real n)"
  by (subst asymp_equiv_add_left) (auto intro!: asymp_equiv_intros eventually_gt_at_top)

lemma asymp_equiv_plus_const_right: "(\<lambda>n. real n + c) \<sim>[at_top] (\<lambda>n. real n)"
  using asymp_equiv_plus_const_left[of c] by (simp add: add.commute)

subsubsection \<open>Product simplification tests\<close>

lemma "(\<lambda>x::real. f x * x) \<in> O(\<lambda>x. g x / (h x / x)) \<longleftrightarrow> f \<in> O(\<lambda>x. g x / h x)"
  by simp

lemma "(\<lambda>x::real. x) \<in> \<omega>(\<lambda>x. g x / (h x / x)) \<longleftrightarrow> (\<lambda>x. 1) \<in> \<omega>(\<lambda>x. g x / h x)"
  by simp

subsubsection \<open>Real product decision procure tests\<close>

lemma "(\<lambda>x. x powr 1) \<in> O(\<lambda>x. x powr 2 :: real)"
  by simp

lemma "\<Theta>(\<lambda>x::real. 2*x powr 3 - 4*x powr 2) = \<Theta>(\<lambda>x::real. x powr 3)"
  by (simp add: landau_theta.absorb)

lemma "p < q \<Longrightarrow> (\<lambda>x::real. c * x powr p * ln x powr r) \<in> o(\<lambda>x::real. x powr q)"
  by simp

lemma "c \<noteq> 0 \<Longrightarrow> p > q \<Longrightarrow> (\<lambda>x::real. c * x powr p * ln x powr r) \<in> \<omega>(\<lambda>x::real. x powr q)"
  by simp

lemma "b > 0 \<Longrightarrow> (\<lambda>x::real. x / ln (2*b*x) * 2) \<in> o(\<lambda>x. x * ln (b*x))"
  by simp
lemma "o(\<lambda>x::real. x * ln (3*x)) = o(\<lambda>x. ln x * x)"
  by (simp add: mult.commute)
lemma "(\<lambda>x::real. x) \<in> o(\<lambda>x. x * ln (3*x))" by simp

ML_val \<open>
  Landau.simplify_landau_real_prod_prop_conv @{context}
  @{cterm "(\<lambda>x::real. 5 * ln (ln x) ^ 2 / (2*x) powr 1.5 * inverse 2) \<in>
           \<omega>(\<lambda>x. 3 * ln x * ln x / x * ln (ln (ln (ln x))))"}
\<close>

lemma "(\<lambda>x. 3 * ln x * ln x / x * ln (ln (ln (ln x)))) \<in>
         \<omega>(\<lambda>x::real. 5 * ln (ln x) ^ 2 / (2*x) powr 1.5 * inverse 2)"
  by simp

subsubsection \<open>Sum cancelling tests\<close>

lemma "\<Theta>(\<lambda>x::real. 2 * x powr 3 + x * x^2/ln x) = \<Theta>(\<lambda>x::real. x powr 3)"
  by simp

(* TODO: tweak simproc with size threshold *)
lemma "\<Theta>(\<lambda>x::real. 2 * x powr 3 + x * x^2/ln x + 42 * x powr 9 + 213 * x powr 5 - 4 * x powr 7) =
         \<Theta>(\<lambda>x::real. x ^ 3 + x / ln x * x powr (3/2) - 2*x powr 9)"
  using [[landau_sum_limit = 5]] by simp

lemma "(\<lambda>x::real. x + x * ln (3*x)) \<in> o(\<lambda>x::real. x^2 + ln (2*x) powr 3)" by simp

end


theory second_incompleteness_class
  imports embedding
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Second Incompleteness Theorem (classical scenario)\<close>

(* Gödel's second incompleteness theorem:

Assume F is a consistent formal system which contains arithmetic.
Let Cons\<^sub>F be a formula of F representing the consistency of the system, then:
                       F \<^bold>\<turnstile>/ Cons\<^sub>F

Below we reconstruct two variants. The conclusion follows from the first one
together with the first incompleteness theorem as a straightforward corollary.
In second variant the conclusion is derived employing a stronger logic (GL).
*)

(* If F is consistent, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_Cons: fixes G
                 assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>\<phi>]"                 (* axiom 4 *)
                 and   "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<sim>\<^bold>\<box>G]"                 (* G's fixed-point *)
                 shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<bottom>]"      (* equivalence of G and Cons *)
proof -
  have "[\<^bold>\<turnstile> \<^bold>\<bottom> \<^bold>\<rightarrow> G]" by simp                (* since \<^bold>\<bottom> implies everything *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<bottom> \<^bold>\<rightarrow> G)]" by simp                      (* by necessitation *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<box>G]" by simp                       (* by modal axiom K *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<sim>G]" using assms(2) by blast  (* using G's fixed-point *)
  hence LtoR: "[\<^bold>\<turnstile> G \<^bold>\<rightarrow> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<bottom>]" by blast               (* by contraposition *)

  have RtoL: "[\<^bold>\<turnstile> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> G]" using assms(1) assms(2) (*use 4 + fixed-point*)
                                   by smt      (* employing an SMT solver *)
  thus "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<bottom>]" using LtoR RtoL by blast
qed

(* If F is consistent, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_Cons: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"        (* axiom L *)
                    shows "\<sim>[\<^bold>\<turnstile> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<bottom>]"           (* Cons is non-provable *)
proof
  assume provCons: "[\<^bold>\<turnstile> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<bottom>]"               (* assume Cons were provable *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<bottom>]" by simp           (* by the properties of negation*)
  hence 1: "[\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<^bold>\<bottom>\<^bold>\<rightarrow>\<^bold>\<bottom>)]" by simp                   (* by necessitation *)
  have  2: "[\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<^bold>\<bottom>\<^bold>\<rightarrow>\<^bold>\<bottom>) \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<bottom>]" using assms(1) by (rule allE) (*inst. L*)
  from 1 2 have provIncons: "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom>]" by simp         (* by modus ponens *)
  from provCons provIncons have "[\<^bold>\<turnstile> \<^bold>\<bottom>]" by simp  (* by plain consistency *)
  thus False by simp
qed

section \<open>Experiments with other variants\<close>

abbreviation "S_consistency \<equiv> \<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi>] \<longrightarrow> [\<^bold>\<turnstile> \<phi>]"
abbreviation S_consistency_obj::"wo" ("S-Cons") where "S-Cons \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<box>\<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>"

abbreviation "star_consistency \<equiv> \<forall>\<phi>. \<sim>[\<^bold>\<turnstile> \<^bold>\<sim>\<phi> \<^bold>\<and> \<^bold>\<box>\<phi>]"
abbreviation star_consistency_obj::"wo" ("*-Cons") where "*-Cons \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<sim>\<^bold>\<box>(\<^bold>\<sim>\<phi> \<^bold>\<and> \<^bold>\<box>\<phi>)"

abbreviation "P_consistency_a \<equiv> \<sim>[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom>]"
abbreviation P_consistency_a_obj::"wo" ("P-Cons-a") where "P-Cons-a \<equiv> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<box>\<^bold>\<bottom>"

(*********** Variant 1 ************)

(* If F is S-consistent, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> S-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_SCons: fixes G
                  assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>\<phi>]"                 (* axiom 4 *)
                  and   "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<sim>\<^bold>\<box>G]"                 (* G's fixed-point *)
                  and   S_consistency
                  shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> S-Cons]"  (* equivalence of G and S-Cons *)
  nitpick oops (* countermodel found *)

(* If F is *-consistent, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> *-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_starCons: fixes G
                     assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>\<phi>]"                 (* axiom 4 *)
                     and   "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<sim>\<^bold>\<box>G]"                 (* G's fixed-point *)
                     and   star_consistency
                     shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> *-Cons]"   (* equivalence of G and *-Cons *)
  nitpick oops (* countermodel found *)

(* If F is P-consistent-a, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> P-Cons-a\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_PCons_a:  fixes G
                     assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>\<phi>]"                 (* axiom 4 *)
                     and   "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<sim>\<^bold>\<box>G]"                 (* G's fixed-point *)
                     and   P_consistency_a
                     shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> P-Cons-a]" (* equivalence of G and P-Cons-a *)
  nitpick oops (* countermodel found *)

(*********** Variant 2 **************)

(* If F is S-consistent, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ S-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_SCons: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"           (* axiom L *)
                  (* and   S_consistency     (* strengthening the assumptions *) *)
                     shows "\<sim>[\<^bold>\<turnstile> S-Cons]"           (* S-Cons is non-provable *)
  nitpick oops (* countermodel found *)
  (* TODO: prove or refute if strengthening the assumptions with S_consistency*)

(* If F is *-consistent, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ *-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_starCons: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"           (* axiom L *)
                        and   star_consistency     (* strengthening the assumptions *)
                        shows "\<sim>[\<^bold>\<turnstile> *-Cons]"           (* *-Cons is non-provable *)
  oops (* by (metis IV_char2 assms(1) mod nonProv_Cons)*)
 (* TODO: seems to be provable from first assumption. Verify *)

(* If F is P-consistent-a, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ P-Cons-a\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_PCons_a: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"           (* axiom L *)
                       and   P_consistency_a     (* strengthening the assumptions *)
                       shows "\<sim>[\<^bold>\<turnstile> P-Cons-a]"          (* P-Cons-a is non-provable *)
  using assms(1) nonProv_Cons by blast

end


(* Author:     Johannes Hoelzl <hoelzl@in.tum.de> 2009 *)

theory Approximation_Ex
imports Complex_Main "../Approximation"
begin

text \<open>

Here are some examples how to use the approximation method.

The approximation method has the following syntax:

approximate "prec" (splitting: "x" = "depth" and "y" = "depth" ...)? (taylor: "z" = "derivates")?

Here "prec" specifies the precision used in all computations, it is specified as
number of bits to calculate. In the proposition to prove an arbitrary amount of
variables can be used, but each one need to be bounded by an upper and lower
bound.

To specify the bounds either \<^term>\<open>l\<^sub>1 \<le> x \<and> x \<le> u\<^sub>1\<close>,
\<^term>\<open>x \<in> { l\<^sub>1 .. u\<^sub>1 }\<close> or \<^term>\<open>x = bnd\<close> can be used. Where the
bound specification are again arithmetic formulas containing variables. They can
be connected using either meta level or HOL equivalence.

To use interval splitting add for each variable whos interval should be splitted
to the "splitting:" parameter. The parameter specifies how often each interval
should be divided, e.g. when x = 16 is specified, there will be \<^term>\<open>65536 = 2^16\<close>
intervals to be calculated.

To use taylor series expansion specify the variable to derive. You need to
specify the amount of derivations to compute. When using taylor series expansion
only one variable can be used.

\<close>

section "Compute some transcendental values"

lemma "\<bar> ln 2 - 544531980202654583340825686620847 / 785593587443817081832229725798400 \<bar> < (inverse (2^51) :: real)"
  by (approximation 60)

lemma "\<bar> exp 1.626 - 5.083499996273 \<bar> < (inverse 10 ^ 10 :: real)"
  by (approximation 40)

lemma "\<bar> sqrt 2 - 1.4142135623730951 \<bar> < inverse 10 ^ 16"
  by (approximation 60)

lemma "\<bar> pi - 3.1415926535897932385 \<bar> < inverse 10 ^ 18"
  by (approximation 70)

lemma "\<bar> sin 100 + 0.50636564110975879 \<bar> < (inverse 10 ^ 17 :: real)"
  by (approximation 70)

section "Use variable ranges"

lemma "0.5 \<le> x \<and> x \<le> 4.5 \<Longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 10)

lemma "x \<in> {0.5 .. 4.5} \<longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 10)

lemma "0.49 \<le> x \<and> x \<le> 4.49 \<Longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 20)

lemma "1 / 2^1 \<le> x \<and> x \<le> 9 / 2^1 \<Longrightarrow> \<bar> arctan x - 0.91 \<bar> < 0.455"
  by (approximation 10)

lemma "3.2 \<le> (x::real) \<and> x \<le> 6.2 \<Longrightarrow> sin x \<le> 0"
  by (approximation 10)

lemma "3.2 \<le> (x::real) \<and> x \<le> 3.9 \<Longrightarrow> real_of_int (ceiling x) \<in> {4 .. 4}"
  by (approximation 10)

lemma
  defines "g \<equiv> 9.80665" and "v \<equiv> 128.61" and "d \<equiv> pi / 180"
  shows "g / v * tan (35 * d) \<in> { 3 * d .. 3.1 * d }"
  using assms by (approximation 20)

lemma "x \<in> { 0 .. 1 :: real } \<longrightarrow> x\<^sup>2 \<le> x"
  by (approximation 30 splitting: x=1 taylor: x = 3)

lemma "(n::real) \<in> {32 .. 62} \<Longrightarrow> \<lceil>log 2 (2 * (\<lfloor>n\<rfloor> div 2) + 1)\<rceil> = \<lceil>log 2 (\<lfloor>n\<rfloor> + 1)\<rceil>"
  unfolding eq_iff
  by (approximation 20)

approximate 10

end


(*
  Author:     Jeremy Dawson and Gerwin Klein, NICTA

  Consequences of type definition theorems, and of extended type definition.
*)

section \<open>Type Definition Theorems\<close>

theory Misc_Typedef
  imports Main
begin

section "More lemmas about normal type definitions"

lemma tdD1: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Rep x \<in> A"
  and tdD2: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Abs (Rep x) = x"
  and tdD3: "type_definition Rep Abs A \<Longrightarrow> \<forall>y. y \<in> A \<longrightarrow> Rep (Abs y) = y"
  by (auto simp: type_definition_def)

lemma td_nat_int: "type_definition int nat (Collect ((\<le>) 0))"
  unfolding type_definition_def by auto

context type_definition
begin

declare Rep [iff] Rep_inverse [simp] Rep_inject [simp]

lemma Abs_eqD: "Abs x = Abs y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x = y"
  by (simp add: Abs_inject)

lemma Abs_inverse': "r \<in> A \<Longrightarrow> Abs r = a \<Longrightarrow> Rep a = r"
  by (safe elim!: Abs_inverse)

lemma Rep_comp_inverse: "Rep \<circ> f = g \<Longrightarrow> Abs \<circ> g = f"
  using Rep_inverse by auto

lemma Rep_eqD [elim!]: "Rep x = Rep y \<Longrightarrow> x = y"
  by simp

lemma Rep_inverse': "Rep a = r \<Longrightarrow> Abs r = a"
  by (safe intro!: Rep_inverse)

lemma comp_Abs_inverse: "f \<circ> Abs = g \<Longrightarrow> g \<circ> Rep = f"
  using Rep_inverse by auto

lemma set_Rep: "A = range Rep"
proof (rule set_eqI)
  show "x \<in> A \<longleftrightarrow> x \<in> range Rep" for x
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma set_Rep_Abs: "A = range (Rep \<circ> Abs)"
proof (rule set_eqI)
  show "x \<in> A \<longleftrightarrow> x \<in> range (Rep \<circ> Abs)" for x
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma Abs_inj_on: "inj_on Abs A"
  unfolding inj_on_def
  by (auto dest: Abs_inject [THEN iffD1])

lemma image: "Abs ` A = UNIV"
  by (auto intro!: image_eqI)

lemmas td_thm = type_definition_axioms

lemma fns1: "Rep \<circ> fa = fr \<circ> Rep \<or> fa \<circ> Abs = Abs \<circ> fr \<Longrightarrow> Abs \<circ> fr \<circ> Rep = fa"
  by (auto dest: Rep_comp_inverse elim: comp_Abs_inverse simp: o_assoc)

lemmas fns1a = disjI1 [THEN fns1]
lemmas fns1b = disjI2 [THEN fns1]

lemma fns4: "Rep \<circ> fa \<circ> Abs = fr \<Longrightarrow> Rep \<circ> fa = fr \<circ> Rep \<and> fa \<circ> Abs = Abs \<circ> fr"
  by auto

end

interpretation nat_int: type_definition int nat "Collect ((\<le>) 0)"
  by (rule td_nat_int)

declare
  nat_int.Rep_cases [cases del]
  nat_int.Abs_cases [cases del]
  nat_int.Rep_induct [induct del]
  nat_int.Abs_induct [induct del]

subsection "Extended form of type definition predicate"

lemma td_conds:
  "norm \<circ> norm = norm \<Longrightarrow>
    fr \<circ> norm = norm \<circ> fr \<longleftrightarrow> norm \<circ> fr \<circ> norm = fr \<circ> norm \<and> norm \<circ> fr \<circ> norm = norm \<circ> fr"
  apply safe
    apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma fn_comm_power: "fa \<circ> tr = tr \<circ> fr \<Longrightarrow> fa ^^ n \<circ> tr = tr \<circ> fr ^^ n"
  apply (rule ext)
  apply (induct n)
   apply (auto dest: fun_cong)
  done

lemmas fn_comm_power' =
  ext [THEN fn_comm_power, THEN fun_cong, unfolded o_def]

locale td_ext = type_definition +
  fixes norm
  assumes eq_norm: "\<And>x. Rep (Abs x) = norm x"
begin

lemma Abs_norm [simp]: "Abs (norm x) = Abs x"
  using eq_norm [of x] by (auto elim: Rep_inverse')

lemma td_th: "g \<circ> Abs = f \<Longrightarrow> f (Rep x) = g x"
  by (drule comp_Abs_inverse [symmetric]) simp

lemma eq_norm': "Rep \<circ> Abs = norm"
  by (auto simp: eq_norm)

lemma norm_Rep [simp]: "norm (Rep x) = Rep x"
  by (auto simp: eq_norm' intro: td_th)

lemmas td = td_thm

lemma set_iff_norm: "w \<in> A \<longleftrightarrow> w = norm w"
  by (auto simp: set_Rep_Abs eq_norm' eq_norm [symmetric])

lemma inverse_norm: "Abs n = w \<longleftrightarrow> Rep w = norm n"
  apply (rule iffI)
   apply (clarsimp simp add: eq_norm)
  apply (simp add: eq_norm' [symmetric])
  done

lemma norm_eq_iff: "norm x = norm y \<longleftrightarrow> Abs x = Abs y"
  by (simp add: eq_norm' [symmetric])

lemma norm_comps:
  "Abs \<circ> norm = Abs"
  "norm \<circ> Rep = Rep"
  "norm \<circ> norm = norm"
  by (auto simp: eq_norm' [symmetric] o_def)

lemmas norm_norm [simp] = norm_comps

lemma fns5: "Rep \<circ> fa \<circ> Abs = fr \<Longrightarrow> fr \<circ> norm = fr \<and> norm \<circ> fr = fr"
  by (fold eq_norm') auto

text \<open>
  following give conditions for converses to \<open>td_fns1\<close>
  \<^item> the condition \<open>norm \<circ> fr \<circ> norm = fr \<circ> norm\<close> says that
    \<open>fr\<close> takes normalised arguments to normalised results
  \<^item> \<open>norm \<circ> fr \<circ> norm = norm \<circ> fr\<close> says that \<open>fr\<close>
    takes norm-equivalent arguments to norm-equivalent results
  \<^item> \<open>fr \<circ> norm = fr\<close> says that \<open>fr\<close>
    takes norm-equivalent arguments to the same result
  \<^item> \<open>norm \<circ> fr = fr\<close> says that \<open>fr\<close> takes any argument to a normalised result
\<close>
lemma fns2: "Abs \<circ> fr \<circ> Rep = fa \<Longrightarrow> norm \<circ> fr \<circ> norm = fr \<circ> norm \<longleftrightarrow> Rep \<circ> fa = fr \<circ> Rep"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: o_assoc)
  apply (rule ext)
  apply (drule_tac x="Rep x" in fun_cong)
  apply auto
  done

lemma fns3: "Abs \<circ> fr \<circ> Rep = fa \<Longrightarrow> norm \<circ> fr \<circ> norm = norm \<circ> fr \<longleftrightarrow> fa \<circ> Abs = Abs \<circ> fr"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: comp_assoc)
  apply (rule ext)
  apply (drule_tac f="a \<circ> b" for a b in fun_cong)
  apply simp
  done

lemma fns: "fr \<circ> norm = norm \<circ> fr \<Longrightarrow> fa \<circ> Abs = Abs \<circ> fr \<longleftrightarrow> Rep \<circ> fa = fr \<circ> Rep"
  apply safe
   apply (frule fns1b)
   prefer 2
   apply (frule fns1a)
   apply (rule fns3 [THEN iffD1])
     prefer 3
     apply (rule fns2 [THEN iffD1])
       apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma range_norm: "range (Rep \<circ> Abs) = A"
  by (simp add: set_Rep_Abs)

end

lemmas td_ext_def' =
  td_ext_def [unfolded type_definition_def td_ext_axioms_def]

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Many_More
  imports
    Main
    "HOL-Library.Word"
    More_Word
    Even_More_List
begin

lemma nat_less_mult_monoish: "\<lbrakk> a < b; c < (d :: nat) \<rbrakk> \<Longrightarrow> (a + 1) * (c + 1) <= b * d"
  apply (drule Suc_leI)+
  apply (drule(1) mult_le_mono)
  apply simp
  done

context
  includes bit_operations_syntax
begin

lemma if_and_helper:
  "(If x v v') AND v'' = If x (v AND v'') (v' AND v'')"
  by (rule if_distrib)

end

lemma eq_eqI:
  "a = b \<Longrightarrow> (a = x) = (b = x)"
  by simp

lemma map2_Cons_2_3:
  "(map2 f xs (y # ys) = (z # zs)) = (\<exists>x xs'. xs = x # xs' \<and> f x y = z \<and> map2 f xs' ys = zs)"
  by (case_tac xs, simp_all)

lemma map2_xor_replicate_False:
  "map2 (\<lambda>x y. x \<longleftrightarrow> \<not> y) xs (replicate n False) = take n xs"
  apply (induct xs arbitrary: n, simp)
  apply (case_tac n; simp)
  done

lemma plus_Collect_helper:
  "(+) x ` {xa. P (xa :: 'a :: len word)} = {xa. P (xa - x)}"
  by (fastforce simp add: image_def)

lemma plus_Collect_helper2:
  "(+) (- x) ` {xa. P (xa :: 'a :: len word)} = {xa. P (x + xa)}"
  using plus_Collect_helper [of "- x" P] by (simp add: ac_simps)

lemma range_subset_eq2:
  "{a :: 'a :: len word .. b} \<noteq> {} \<Longrightarrow> ({a .. b} \<subseteq> {c .. d}) = (c \<le> a \<and> b \<le> d)"
  by simp

lemma nat_mod_power_lem:
  fixes a :: nat
  shows "1 < a \<Longrightarrow> a ^ n mod a ^ m = (if m \<le> n then 0 else a ^ n)"
  apply (clarsimp)
  apply (clarsimp simp add: le_iff_add power_add)
  done

lemma i_hate_words_helper:
  "i \<le> (j - k :: nat) \<Longrightarrow> i \<le> j"
  by simp

lemma i_hate_words:
  "unat (a :: 'a word) \<le> unat (b :: 'a :: len word) - Suc 0
    \<Longrightarrow> a \<noteq> -1"
  apply (frule i_hate_words_helper)
  apply (subst(asm) word_le_nat_alt[symmetric])
  apply (clarsimp simp only: word_minus_one_le)
  apply (simp only: linorder_not_less[symmetric])
  apply (erule notE)
  apply (rule diff_Suc_less)
  apply (subst neq0_conv[symmetric])
  apply (subst unat_eq_0)
  apply (rule notI, drule arg_cong[where f="(+) 1"])
  apply simp
  done

lemma If_eq_obvious:
  "x \<noteq> z \<Longrightarrow> ((if P then x else y) = z) = (\<not> P \<and> y = z)"
  by simp

lemma Some_to_the:
  "v = Some x \<Longrightarrow> x = the v"
  by simp

lemma dom_if_Some:
  "dom (\<lambda>x. if P x then Some (f x) else g x) = {x. P x} \<union> dom g"
  by fastforce

lemma dom_insert_absorb:
  "x \<in> dom f \<Longrightarrow> insert x (dom f) = dom f"
  by (fact insert_absorb)

lemma emptyE2:
  "\<lbrakk> S = {}; x \<in> S \<rbrakk> \<Longrightarrow> P"
  by simp

lemma ptr_add_image_multI:
  "\<lbrakk> \<And>x y. (x * val = y * val') = (x * val'' = y); x * val'' \<in> S \<rbrakk> \<Longrightarrow>
     ptr_add ptr (x * val) \<in> (\<lambda>p. ptr_add ptr (p * val')) ` S"
  by (auto simp add: image_iff) metis

lemmas map_prod_split_imageI'
  = map_prod_imageI[where f="case_prod f" and g="case_prod g"
                    and a="(a, b)" and b="(c, d)" for a b c d f g]
lemmas map_prod_split_imageI = map_prod_split_imageI'[simplified]

lemma dom_if:
  "dom (\<lambda>a. if a \<in> addrs then Some (f a) else g a)  = addrs \<union> dom g"
  by (auto simp: dom_def split: if_split)

lemmas arg_cong_Not = arg_cong [where f=Not]

lemma drop_append_miracle:
  "n = length xs \<Longrightarrow> drop n (xs @ ys) = ys"
  by simp

lemma foldr_does_nothing_to_xf:
  "\<lbrakk> \<And>x s. x \<in> set xs \<Longrightarrow> xf (f x s) = xf s \<rbrakk> \<Longrightarrow> xf (foldr f xs s) = xf s"
  by (induct xs, simp_all)

lemma mod_mod_power_int:
  fixes k :: int
  shows "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ (min m n)"
  by (fact mod_exp_eq)

lemma le_step_down_nat:"\<lbrakk>(i::nat) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by arith

lemma le_step_down_int:"\<lbrakk>(i::int) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by arith

lemma replicate_numeral [simp]: "replicate (numeral k) x = x # replicate (pred_numeral k) x"
  by (simp add: numeral_eq_Suc)

lemma list_exhaust_size_gt0:
  assumes "\<And>a list. y = a # list \<Longrightarrow> P"
  shows "0 < length y \<Longrightarrow> P"
  apply (cases y)
   apply simp
  apply (rule assms)
  apply fastforce
  done

lemma list_exhaust_size_eq0:
  assumes "y = [] \<Longrightarrow> P"
  shows "length y = 0 \<Longrightarrow> P"
  apply (cases y)
   apply (rule assms)
   apply simp
  apply simp
  done

lemma size_Cons_lem_eq: "y = xa # list \<Longrightarrow> size y = Suc k \<Longrightarrow> size list = k"
  by auto

lemma takeWhile_take_has_property:
  "n \<le> length (takeWhile P xs) \<Longrightarrow> \<forall>x \<in> set (take n xs). P x"
  by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)

lemma takeWhile_take_has_property_nth:
  "\<lbrakk> n < length (takeWhile P xs) \<rbrakk> \<Longrightarrow> P (xs ! n)"
  by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)

lemma takeWhile_replicate:
  "takeWhile f (replicate len x) = (if f x then replicate len x else [])"
  by (induct_tac len) auto

lemma takeWhile_replicate_id:
  "f x \<Longrightarrow> takeWhile f (replicate len x) = replicate len x"
  by (simp add: takeWhile_replicate)

lemma nth_rev: "n < length xs \<Longrightarrow> rev xs ! n = xs ! (length xs - 1 - n)"
  using rev_nth by simp

lemma nth_rev_alt: "n < length ys \<Longrightarrow> ys ! n = rev ys ! (length ys - Suc n)"
  by (simp add: nth_rev)

lemma hd_butlast: "length xs > 1 \<Longrightarrow> hd (butlast xs) = hd xs"
  by (cases xs) auto

lemma split_upt_on_n:
  "n < m \<Longrightarrow> [0 ..< m] = [0 ..< n] @ [n] @ [Suc n ..< m]"
  by (metis append_Cons append_Nil less_Suc_eq_le less_imp_le_nat upt_add_eq_append'
            upt_rec zero_less_Suc)

lemma drop_eq_mono:
  assumes le: "m \<le> n"
  assumes drop: "drop m xs = drop m ys"
  shows "drop n xs = drop n ys"
proof -
  have ex: "\<exists>p. n = p + m" by (rule exI[of _ "n - m"]) (simp add: le)
  then obtain p where p: "n = p + m" by blast
  show ?thesis unfolding p drop_drop[symmetric] drop by simp
qed

lemma drop_Suc_nth:
  "n < length xs \<Longrightarrow> drop n xs = xs!n # drop (Suc n) xs"
  by (simp add: Cons_nth_drop_Suc)

lemma and_len: "xs = ys \<Longrightarrow> xs = ys \<and> length xs = length ys"
  by auto

lemma tl_if: "tl (if p then xs else ys) = (if p then tl xs else tl ys)"
  by auto

lemma hd_if: "hd (if p then xs else ys) = (if p then hd xs else hd ys)"
  by auto

lemma if_single: "(if xc then [xab] else [an]) = [if xc then xab else an]"
  by auto

\<comment> \<open>note -- \<open>if_Cons\<close> can cause blowup in the size, if \<open>p\<close> is complex, so make a simproc\<close>
lemma if_Cons: "(if p then x # xs else y # ys) = If p x y # If p xs ys"
  by auto

lemma list_of_false:
  "True \<notin> set xs \<Longrightarrow> xs = replicate (length xs) False"
  by (induct xs, simp_all)

lemma list_all2_induct [consumes 1, case_names Nil Cons]:
  assumes lall: "list_all2 Q xs ys"
  and     nilr: "P [] []"
  and    consr: "\<And>x xs y ys. \<lbrakk>list_all2 Q xs ys; Q x y; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
  shows  "P xs ys"
  using lall
proof (induct rule: list_induct2 [OF list_all2_lengthD [OF lall]])
  case 1 then show ?case by auto fact+
next
  case (2 x xs y ys)

  show ?case
  proof (rule consr)
    from "2.prems" show "list_all2 Q xs ys" and "Q x y" by simp_all
    then show "P xs ys" by (intro "2.hyps")
  qed
qed

lemma replicate_minus:
  "k < n \<Longrightarrow> replicate n False = replicate (n - k) False @ replicate k False"
  by (subst replicate_add [symmetric]) simp

lemma cart_singleton_empty:
  "(S \<times> {e} = {}) = (S = {})"
  by blast

lemma MinI:
  assumes fa: "finite A"
  and     ne: "A \<noteq> {}"
  and     xv: "m \<in> A"
  and    min: "\<forall>y \<in> A. m \<le> y"
  shows "Min A = m" using fa ne xv min
proof (induct A arbitrary: m rule: finite_ne_induct)
  case singleton then show ?case by simp
next
  case (insert y F)

  from insert.prems have yx: "m \<le> y" and fx: "\<forall>y \<in> F. m \<le> y" by auto
  have "m \<in> insert y F" by fact
  then show ?case
  proof
    assume mv: "m = y"

    have mlt: "m \<le> Min F"
      by (rule iffD2 [OF Min_ge_iff [OF insert.hyps(1) insert.hyps(2)] fx])

    show ?case
      apply (subst Min_insert [OF insert.hyps(1) insert.hyps(2)])
      apply (subst mv [symmetric])
      apply (auto simp: min_def mlt)
      done
  next
    assume "m \<in> F"
    then have mf: "Min F = m"
      by (rule insert.hyps(4) [OF _ fx])

    show ?case
      apply (subst Min_insert [OF insert.hyps(1) insert.hyps(2)])
      apply (subst mf)
      apply (rule iffD2 [OF _ yx])
      apply (auto simp: min_def)
      done
  qed
qed

lemma power_numeral: "a ^ numeral k = a * a ^ (pred_numeral k)"
  by (simp add: numeral_eq_Suc)

lemma funpow_numeral [simp]: "f ^^ numeral k = f \<circ> f ^^ (pred_numeral k)"
  by (simp add: numeral_eq_Suc)

lemma funpow_minus_simp: "0 < n \<Longrightarrow> f ^^ n = f \<circ> f ^^ (n - 1)"
  by (auto dest: gr0_implies_Suc)

lemma rco_alt: "(f \<circ> g) ^^ n \<circ> f = f \<circ> (g \<circ> f) ^^ n"
  apply (rule ext)
  apply (induct n)
   apply (simp_all add: o_def)
  done

lemma union_sub:
  "\<lbrakk>B \<subseteq> A; C \<subseteq> B\<rbrakk> \<Longrightarrow> (A - B) \<union> (B - C) = (A - C)"
  by fastforce

lemma insert_sub:
  "x \<in> xs \<Longrightarrow> (insert x (xs - ys)) = (xs - (ys - {x}))"
  by blast

lemma ran_upd:
  "\<lbrakk> inj_on f (dom f); f y = Some z \<rbrakk> \<Longrightarrow> ran (\<lambda>x. if x = y then None else f x) = ran f - {z}"
  unfolding ran_def
  apply (rule set_eqI)
  apply simp
  by (metis domI inj_on_eq_iff option.sel)

lemma if_apply_def2:
  "(if P then F else G) = (\<lambda>x. (P \<longrightarrow> F x) \<and> (\<not> P \<longrightarrow> G x))"
  by simp

lemma case_bool_If:
  "case_bool P Q b = (if b then P else Q)"
  by simp

lemma if_f:
  "(if a then f b else f c) = f (if a then b else c)"
  by simp

lemma size_if: "size (if p then xs else ys) = (if p then size xs else size ys)"
  by (fact if_distrib)

lemma if_Not_x: "(if p then \<not> x else x) = (p = (\<not> x))"
  by auto

lemma if_x_Not: "(if p then x else \<not> x) = (p = x)"
  by auto

lemma if_same_and: "(If p x y \<and> If p u v) = (if p then x \<and> u else y \<and> v)"
  by auto

lemma if_same_eq: "(If p x y  = (If p u v)) = (if p then x = u else y = v)"
  by auto

lemma if_same_eq_not: "(If p x y = (\<not> If p u v)) = (if p then x = (\<not> u) else y = (\<not> v))"
  by auto

lemma the_elemI: "y = {x} \<Longrightarrow> the_elem y = x"
  by simp

lemma nonemptyE: "S \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> R) \<Longrightarrow> R"
  by auto

lemmas xtr1 = xtrans(1)
lemmas xtr2 = xtrans(2)
lemmas xtr3 = xtrans(3)
lemmas xtr4 = xtrans(4)
lemmas xtr5 = xtrans(5)
lemmas xtr6 = xtrans(6)
lemmas xtr7 = xtrans(7)
lemmas xtr8 = xtrans(8)

lemmas if_fun_split = if_apply_def2

lemma not_empty_eq:
  "(S \<noteq> {}) = (\<exists>x. x \<in> S)"
  by auto

lemma range_subset_lower:
  fixes c :: "'a ::linorder"
  shows "\<lbrakk> {a..b} \<subseteq> {c..d}; x \<in> {a..b} \<rbrakk> \<Longrightarrow> c \<le> a"
  apply (frule (1) subsetD)
  apply (rule classical)
  apply clarsimp
  done

lemma range_subset_upper:
  fixes c :: "'a ::linorder"
  shows "\<lbrakk> {a..b} \<subseteq> {c..d}; x \<in> {a..b} \<rbrakk> \<Longrightarrow> b \<le> d"
  apply (frule (1) subsetD)
  apply (rule classical)
  apply clarsimp
  done

lemma range_subset_eq:
  fixes a::"'a::linorder"
  assumes non_empty: "a \<le> b"
  shows "({a..b} \<subseteq> {c..d}) = (c \<le> a \<and> b \<le> d)"
  apply (insert non_empty)
  apply (rule iffI)
   apply (frule range_subset_lower [where x=a], simp)
   apply (drule range_subset_upper [where x=a], simp)
   apply simp
  apply auto
  done

lemma range_eq:
  fixes a::"'a::linorder"
  assumes non_empty: "a \<le> b"
  shows "({a..b} = {c..d}) = (a = c \<and> b = d)"
  by (metis atLeastatMost_subset_iff eq_iff non_empty)

lemma range_strict_subset_eq:
  fixes a::"'a::linorder"
  assumes non_empty: "a \<le> b"
  shows "({a..b} \<subset> {c..d}) = (c \<le> a \<and> b \<le> d \<and> (a = c \<longrightarrow> b \<noteq> d))"
  apply (insert non_empty)
  apply (subst psubset_eq)
  apply (subst range_subset_eq, assumption+)
  apply (subst range_eq, assumption+)
  apply simp
  done

lemma range_subsetI:
  fixes x :: "'a :: order"
  assumes xX: "X \<le> x"
  and     yY: "y \<le> Y"
  shows   "{x .. y} \<subseteq> {X .. Y}"
  using xX yY by auto

lemma set_False [simp]:
  "(set bs \<subseteq> {False}) = (True \<notin> set bs)" by auto

lemma int_not_emptyD:
  "A \<inter> B \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> A \<and> x \<in> B"
  by (erule contrapos_np, clarsimp simp: disjoint_iff_not_equal)

definition
  sum_map :: "('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a + 'c \<Rightarrow> 'b + 'd" where
 "sum_map f g x \<equiv> case x of Inl v \<Rightarrow> Inl (f v) | Inr v' \<Rightarrow> Inr (g v')"

lemma sum_map_simps[simp]:
  "sum_map f g (Inl v) = Inl (f v)"
  "sum_map f g (Inr w) = Inr (g w)"
  by (simp add: sum_map_def)+

lemma CollectPairFalse [iff]:
  "{(a,b). False} = {}"
  by (simp add: split_def)

lemma if_P_True1:
  "Q \<Longrightarrow> (if P then True else Q)"
  by simp

lemma if_P_True2:
  "Q \<Longrightarrow> (if P then Q else True)"
  by simp

lemmas nat_simps = diff_add_inverse2 diff_add_inverse

lemmas nat_iffs = le_add1 le_add2

lemma nat_min_simps:
  "(a::nat) \<le> b \<Longrightarrow> min b a = a"
  "a \<le> b \<Longrightarrow> min a b = a"
  by simp_all

lemmas zadd_diff_inverse =
  trans [OF diff_add_cancel [symmetric] add.commute]

lemmas add_diff_cancel2 =
  add.commute [THEN diff_eq_eq [THEN iffD2]]

lemmas mcl = mult_cancel_left [THEN iffD1, THEN make_pos_rule]

lemma pl_pl_rels: "a + b = c + d \<Longrightarrow> a \<ge> c \<and> b \<le> d \<or> a \<le> c \<and> b \<ge> d"
  for a b c d :: nat
  by arith

lemmas pl_pl_rels' = add.commute [THEN [2] trans, THEN pl_pl_rels]

lemma iszero_minus:
  \<open>iszero (- z) \<longleftrightarrow> iszero z\<close>
  by (simp add: iszero_def)

lemma diff_le_eq': "a - b \<le> c \<longleftrightarrow> a \<le> b + c"
  for a b c :: int
  by arith

lemma zless2: "0 < (2 :: int)"
  by (fact zero_less_numeral)

lemma zless2p: "0 < (2 ^ n :: int)"
  by arith

lemma zle2p: "0 \<le> (2 ^ n :: int)"
  by arith

lemma ex_eq_or: "(\<exists>m. n = Suc m \<and> (m = k \<or> P m)) \<longleftrightarrow> n = Suc k \<or> (\<exists>m. n = Suc m \<and> P m)"
  by auto

lemma power_minus_simp: "0 < n \<Longrightarrow> a ^ n = a * a ^ (n - 1)"
  by (auto dest: gr0_implies_Suc)

lemma n2s_ths:
  \<open>2 + n = Suc (Suc n)\<close>
  \<open>n + 2 = Suc (Suc n)\<close>
  by (fact add_2_eq_Suc add_2_eq_Suc')+

lemma s2n_ths:
  \<open>Suc (Suc n) = 2 + n\<close>
  \<open>Suc (Suc n) = n + 2\<close>
  by simp_all

lemma gt_or_eq_0: "0 < y \<or> 0 = y"
  for y :: nat
  by arith

lemma sum_imp_diff: "j = k + i \<Longrightarrow> j - i = k"
  for k :: nat
  by simp

lemma le_diff_eq': "a \<le> c - b \<longleftrightarrow> b + a \<le> c"
  for a b c :: int
  by arith

lemma less_diff_eq': "a < c - b \<longleftrightarrow> b + a < c"
  for a b c :: int
  by arith

lemma diff_less_eq': "a - b < c \<longleftrightarrow> a < b + c"
  for a b c :: int
  by arith

lemma axxbyy: "a + m + m = b + n + n \<Longrightarrow> a = 0 \<or> a = 1 \<Longrightarrow> b = 0 \<or> b = 1 \<Longrightarrow> a = b \<and> m = n"
  for a b m n :: int
  by arith

lemma minus_eq: "m - k = m \<longleftrightarrow> k = 0 \<or> m = 0"
  for k m :: nat
  by arith

lemma pl_pl_mm: "a + b = c + d \<Longrightarrow> a - c = d - b"
  for a b c d :: nat
  by arith

lemmas pl_pl_mm' = add.commute [THEN [2] trans, THEN pl_pl_mm]

lemma less_le_mult': "w * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> (w + 1) * c \<le> b * c"
  for b c w :: int
  apply (rule mult_right_mono)
   apply (rule zless_imp_add1_zle)
   apply (erule (1) mult_right_less_imp_less)
  apply assumption
  done

lemma less_le_mult: "w * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> w * c + c \<le> b * c"
  for b c w :: int
  using less_le_mult' [of w c b] by (simp add: algebra_simps)

lemmas less_le_mult_minus = iffD2 [OF le_diff_eq less_le_mult,
  simplified left_diff_distrib]

lemma gen_minus: "0 < n \<Longrightarrow> f n = f (Suc (n - 1))"
  by auto

lemma mpl_lem: "j \<le> i \<Longrightarrow> k < j \<Longrightarrow> i - j + k < i"
  for i j k :: nat
  by arith

lemmas dme = div_mult_mod_eq
lemmas dtle = div_times_less_eq_dividend
lemmas th2 = order_trans [OF order_refl [THEN [2] mult_le_mono] div_times_less_eq_dividend]

lemmas sdl = div_nat_eqI

lemma given_quot: "f > 0 \<Longrightarrow> (f * l + (f - 1)) div f = l"
  for f l :: nat
  by (rule div_nat_eqI) (simp_all)

lemma given_quot_alt: "f > 0 \<Longrightarrow> (l * f + f - Suc 0) div f = l"
  for f l :: nat
  apply (frule given_quot)
  apply (rule trans)
   prefer 2
   apply (erule asm_rl)
  apply (rule_tac f="\<lambda>n. n div f" in arg_cong)
  apply (simp add : ac_simps)
  done

lemma x_power_minus_1:
  fixes x :: "'a :: {ab_group_add, power, numeral, one}"
  shows "x + (2::'a) ^ n - (1::'a) = x + (2 ^ n - 1)" by simp

lemma nat_diff_add:
  fixes i :: nat
  shows "\<lbrakk> i + j = k \<rbrakk> \<Longrightarrow> i = k - j"
  by arith

lemma pow_2_gt: "n \<ge> 2 \<Longrightarrow> (2::int) < 2 ^ n"
  by (induct n) auto

lemma sum_to_zero:
  "(a :: 'a :: ring) + b = 0 \<Longrightarrow> a = (- b)"
  by (drule arg_cong[where f="\<lambda> x. x - a"], simp)

lemma arith_is_1:
  "\<lbrakk> x \<le> Suc 0; x > 0 \<rbrakk> \<Longrightarrow> x = 1"
  by arith

lemma suc_le_pow_2:
  "1 < (n::nat) \<Longrightarrow> Suc n < 2 ^ n"
  by (induct n; clarsimp)
     (case_tac "n = 1"; clarsimp)

lemma nat_le_Suc_less_imp:
  "x < y \<Longrightarrow> x \<le> y - Suc 0"
  by arith

lemma power_sub_int:
  "\<lbrakk> m \<le> n; 0 < b \<rbrakk> \<Longrightarrow> b ^ n div b ^ m = (b ^ (n - m) :: int)"
  apply (subgoal_tac "\<exists>n'. n = m + n'")
   apply (clarsimp simp: power_add)
  apply (rule exI[where x="n - m"])
  apply simp
  done

lemma nat_Suc_less_le_imp:
  "(k::nat) < Suc n \<Longrightarrow> k \<le> n"
  by auto

lemma nat_add_less_by_max:
  "\<lbrakk> (x::nat) \<le> xmax ; y < k - xmax \<rbrakk> \<Longrightarrow> x + y < k"
  by simp

lemma nat_le_Suc_less:
  "0 < y \<Longrightarrow> (x \<le> y - Suc 0) = (x < y)"
  by arith

lemma nat_power_minus_less:
  "a < 2 ^ (x - n) \<Longrightarrow> (a :: nat) < 2 ^ x"
  by (erule order_less_le_trans) simp

lemma less_le_mult_nat':
  "w * c < b * c ==> 0 \<le> c ==> Suc w * c \<le> b * (c::nat)"
  apply (rule mult_right_mono)
   apply (rule Suc_leI)
   apply (erule (1) mult_right_less_imp_less)
  apply assumption
  done

lemma less_le_mult_nat:
  \<open>0 < c \<and> w < b \<Longrightarrow> c + w * c \<le> b * c\<close> for b c w :: nat
  using less_le_mult_nat' [of w c b] by simp

lemma p_assoc_help:
  fixes p :: "'a::{ring,power,numeral,one}"
  shows "p + 2^sz - 1 = p + (2^sz - 1)"
  by simp

lemma pow_mono_leq_imp_lt:
  "x \<le> y \<Longrightarrow> x < 2 ^ y"
  by (simp add: le_less_trans)

lemma small_powers_of_2:
  "x \<ge> 3 \<Longrightarrow> x < 2 ^ (x - 1)"
  by (induct x; simp add: suc_le_pow_2)

lemma nat_less_power_trans2:
  fixes n :: nat
  shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> n * 2 ^ k  < 2 ^ m"
  by (subst mult.commute, erule (1) nat_less_power_trans)

lemma nat_move_sub_le: "(a::nat) + b \<le> c \<Longrightarrow> a \<le> c - b"
  by arith

lemma plus_minus_one_rewrite:
  "v + (- 1 :: ('a :: {ring, one, uminus})) \<equiv> v - 1"
  by (simp add: field_simps)

lemma Suc_0_lt_2p_len_of: "Suc 0 < 2 ^ LENGTH('a :: len)"
  by (metis One_nat_def len_gt_0 lessI numeral_2_eq_2 one_less_power)

lemma bin_rest_code: "i div 2 = drop_bit 1 i" for i :: int
  by (simp add: drop_bit_eq_div)

end


theory Int_State_Monad_HL
imports
  Main
  "~~/src/HOL/Library/State_Monad"
begin

definition return:: "'a \<Rightarrow> ('b, 'a) state" where "return = State_Monad.return"
definition get:: "(nat, nat) state" where "get = State (\<lambda>x. (x,x))"
definition put:: "nat \<Rightarrow> (nat, unit) state" where "put x = State (\<lambda>_. ((),x))"
definition skip:: "(nat, unit) state" where "skip = State (\<lambda>x. ((),x))"

lemma monad_example1: "fst(run_state (do { return 1 }) 2) = 1"
  by (simp add: return_def)

lemma monad_example2: "fst(run_state (do { put 1; x \<leftarrow> get; return x }) 2) = 1"
  by (simp add: get_def put_def return_def)

lemma monad_example3: "snd(run_state (do { put 1; x \<leftarrow> get; return x }) 2) = 1"
  by (simp add: get_def put_def return_def)

lemma monad_example4:
"fst((run_state (do { x \<leftarrow> return 1; put x; return x })::(nat \<Rightarrow> nat \<times> nat)) 2) = 1"
  by (simp add: put_def return_def)

lemma monad_example5: "snd((run_state (do { x \<leftarrow> return 1; put x })::(nat \<Rightarrow> unit \<times> nat)) 2) = 1"
  by (simp add: put_def return_def)

definition prog:: "(nat, nat) state"
  where "prog = do { a \<leftarrow> get; b \<leftarrow> return (a + 1); put b; return b }"

definition init_prog:: "(nat, nat) state" where "init_prog = do { put 1; prog }"

lemma monad_example6: "snd (run_state init_prog 0) = 2"
  by (simp add: init_prog_def prog_def put_def get_def return_def)

fun accfact:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
af1:  "accfact 0 a = a" |
af2: "accfact (Suc n) a = accfact n (a * Suc n)"

lemma accfact_mult: "accfact n (a * b) = b * accfact n a"
  apply (induction n arbitrary: a b)
   apply (simp)
  apply (simp only: af2)
  by (simp add: semiring_normalization_rules(19))

lemma accfact_aux: "accfact (Suc n) x = (Suc n) * accfact n x"
  apply (induction n)
   apply simp
  using Int_State_Monad.af2 accfact_mult by presburger

fun monfact:: "nat \<Rightarrow> (nat, unit) state" where
mf1: "monfact 0 = skip" |
mf2: "monfact (Suc n) = do { y \<leftarrow> get; y \<leftarrow> return (y * (Suc n)); put y; monfact n }"

lemma monfact_mult: "snd (run_state (monfact n) (a * b)) = b * snd (run_state (monfact n) a)"
  apply (induction n arbitrary: a b)
  apply (simp add: skip_def)
  apply (simp add: return_def put_def get_def)
  by (metis mult.assoc mult.commute mult_Suc)

lemma monfact_shift: "snd (run_state (monfact (Suc n)) x) = snd (run_state (monfact n) ((Suc n) * x))"
  apply (induction n arbitrary: x)
  apply (simp add: get_def put_def return_def)
  apply (simp add: put_def return_def get_def)
  by (simp add: mult.commute)

lemma monfact_aux: "snd (run_state (monfact (Suc n)) x) = (Suc n) * snd (run_state (monfact n) x)"
  apply (induction n arbitrary: x)
   apply (simp add: skip_def return_def get_def put_def)
  by (metis monfact_mult monfact_shift mult.commute)

lemma fact_basic: "snd (run_state (monfact n) (x::nat)) = accfact n (x::nat)"
  apply (induction n)
   apply (simp add: put_def fst_def skip_def)
  using accfact_aux monfact_aux by auto

lemma fact_main: "snd (run_state (do { put (1::nat); monfact n }) (x::nat)) = accfact n (1::nat)"
  by (simp add: fact_basic put_def)

fun fibacc :: "nat \<Rightarrow> nat => nat \<Rightarrow> nat" where
fa1: "fibacc 0 a b = a"|
fa2: "fibacc (Suc 0) a b = b"|
fa3: "fibacc (Suc (Suc n)) a b = fibacc (Suc n) b (a+b)"

definition fib_wrap:: "nat \<Rightarrow> nat" where
  "fib_wrap n \<equiv> fibacc n 1 1"

fun monfibacc :: "nat \<Rightarrow> nat => (nat, unit) state" where
m1:  "monfibacc 0 a = skip"|
m3:  "monfibacc (Suc n) a  = do{b \<leftarrow> get; put (a + b); monfibacc n b}"

definition monfib_wrap where
  "monfib_wrap n \<equiv> (monfibacc n 1)"

value \<open>fibacc 9 1 1 = 55\<close>
value \<open>snd (run_state (monfibacc 9 0) (1::nat)) = 55\<close>
value \<open>fib_wrap 9 = 55\<close>
value \<open>snd (run_state (monfib_wrap 9) (1::nat))\<close>
value \<open>snd (run_state (monfib_wrap 2) (1::nat))\<close>
value \<open>snd (run_state (monfib_wrap (Suc 0)) (snd (run_state (monfib_wrap 0) 1)))\<close>
value \<open>snd (run_state (monfib_wrap (Suc (Suc 0))) 1)\<close>

lemma fib_base[simp]: "snd (run_state (monfib_wrap 0) (Suc 0)) = fib_wrap 0"
  by (simp add: fib_wrap_def monfib_wrap_def put_def skip_def)

lemma fib_basic: "snd (run_state (monfib_wrap n) 1) = fib_wrap n"
  apply (induction n)
   apply (simp)
  sorry

end


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

datatype Nat = Z | S "Nat"

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

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

fun altmul :: "Nat => Nat => Nat" where
"altmul (Z) y = Z"
| "altmul (S z) (Z) = Z"
| "altmul (S z) (S x2) =
     plus (plus (plus (S Z) (altmul z x2)) z) x2"

theorem property0 :
  "((altmul x y) = (times x y))"
  oops

end


section \<open>Extended Natural Numbers\<close>

theory ENat_Extensions
imports
  Coinductive.Coinductive_Nat
begin

  declare eSuc_enat[simp]
  declare iadd_Suc[simp] iadd_Suc_right[simp]
  declare enat_0[simp] enat_1[simp] one_eSuc[simp]
  declare enat_0_iff[iff] enat_1_iff[iff]
  declare Suc_ile_eq[iff]

  lemma enat_Suc0[simp]: "enat (Suc 0) = eSuc 0" by (metis One_nat_def one_eSuc one_enat_def)

  lemma le_epred[iff]: "l < epred k \<longleftrightarrow> eSuc l < k"
    by (metis eSuc_le_iff epred_eSuc epred_le_epredI less_le_not_le not_le)

  lemma eq_infI[intro]:
    assumes "\<And> n. enat n \<le> m"
    shows "m = \<infinity>"
    using assms by (metis enat_less_imp_le enat_ord_simps(5) less_le_not_le)

end