theory Field_Theory
  imports "Comm_Ring_Theory"
          (* "Polynomials.MPoly_PM" *)
          (* "HOL-Computational_Algebra.Polynomial" *)
          "HOL.Topological_Spaces"

begin

section \<open>Fields\<close>

no_notation plus (infixl "+" 65)

locale field = comm_ring R "(+)" "(\<cdot>)" "\<zero>" "\<one>"
  for R and addition (infixl "+" 65) and multiplication (infixl "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>") +
  assumes nonzero: "\<zero> \<noteq> \<one>" and invertible_mult: "a \<in> R \<Longrightarrow> a \<noteq> \<zero> \<Longrightarrow> \<exists>b\<in>R. a \<cdot> b = \<one>"

begin

declare nonzero [simp]
lemma nonzero' [simp]: "\<one> \<noteq> \<zero>"
  using nonzero by blast

lemma left_inv_mult_is_right_inv:
  assumes "a \<in> R" and "b \<in> R" and "a \<cdot> b = \<one>"
  shows "b \<cdot> a = \<one>"
  using assms commutative_mult by simp

lemma uniqueness_of_inv:
  assumes "a \<cdot> b = \<one>" "a \<cdot> c = \<one>" "a \<in> R" "b \<in> R" "c \<in> R"
  shows "b = c"
  using assms commutative_mult multiplicative.inverse_unique by presburger

end

locale subfield = subring S R "(+)" "(\<cdot>)" "\<zero>" "\<one>"
  for S and R and addition (infix "+" 65) and multiplication (infix "\<cdot>" 70) and zero ("\<zero>") and unit ("\<one>") +
  assumes stable_under_inv: "\<lbrakk>a \<in> S; b \<in> R\<rbrakk> \<Longrightarrow> a \<noteq> \<zero> \<Longrightarrow> a \<cdot> b = \<one> \<Longrightarrow> b \<in> S"

section \<open>Univariate Polynomials\<close>

type_synonym 'a upoly = "nat \<Rightarrow> 'a"

context ring
begin

definition degree :: "'a upoly \<Rightarrow> nat"
  where "degree p = (LEAST n. \<forall>i>n. p i = \<zero>)"

definition zero_poly :: "'a upoly"
  where "zero_poly \<equiv> \<lambda>_. \<zero>"

definition coeffs :: "'a upoly \<Rightarrow> 'a list"
  where "coeffs p = (if p = zero_poly then [] else map (\<lambda>i. p i) [0 ..< Suc (degree p)])"

definition fold_coeffs :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a upoly \<Rightarrow> 'b \<Rightarrow> 'b"
  where "fold_coeffs f p = foldr f (coeffs p)"

definition eval_poly :: "'a upoly \<Rightarrow> 'a \<Rightarrow> 'a"
  where "eval_poly p = fold_coeffs (\<lambda>a f x. a + x \<cdot> f x) p (\<lambda>x. \<zero>)" \<comment> \<open>The Horner Schema\<close>

definition is_upoly :: "'a set \<Rightarrow> 'a upoly \<Rightarrow> bool"
  where "is_upoly carrier f \<equiv>  ((\<forall>\<^sub>\<infinity> n. f n = \<zero>) \<and> (\<forall>n. f n \<in> carrier))"

definition upoly_with_coeff_in :: "'a set \<Rightarrow> ('a upoly) set"
  where "upoly_with_coeff_in carrier = {f. is_upoly carrier f}"

end

section \<open>Algebraically Closed Fields\<close>

locale alg_closed_field = field +
  assumes alg_closed: "\<forall>f \<in> upoly_with_coeff_in R. degree f > 0 \<longrightarrow> (\<exists>r\<in>R. eval_poly f r = \<zero>)"

(* Possibly some equivalent formulations of the property of being algebraically closed *)

end


(*  Title:      Sequents/LK/Nat.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1999  University of Cambridge
*)

section \<open>Theory of the natural numbers: Peano's axioms, primitive recursion\<close>

theory Nat
imports "../LK"
begin

typedecl nat
instance nat :: "term" ..

axiomatization
  Zero :: nat      ("0") and
  Suc :: "nat \<Rightarrow> nat" and
  rec :: "[nat, 'a, [nat,'a] \<Rightarrow> 'a] \<Rightarrow> 'a"
where
  induct:  "\<lbrakk>$H \<turnstile> $E, P(0), $F;
             \<And>x. $H, P(x) \<turnstile> $E, P(Suc(x)), $F\<rbrakk> \<Longrightarrow> $H \<turnstile> $E, P(n), $F" and

  Suc_inject:  "\<turnstile> Suc(m) = Suc(n) \<longrightarrow> m = n" and
  Suc_neq_0:   "\<turnstile> Suc(m) \<noteq> 0" and
  rec_0:       "\<turnstile> rec(0,a,f) = a" and
  rec_Suc:     "\<turnstile> rec(Suc(m), a, f) = f(m, rec(m,a,f))"

definition add :: "[nat, nat] \<Rightarrow> nat"  (infixl "+" 60)
  where "m + n == rec(m, n, \<lambda>x y. Suc(y))"

declare Suc_neq_0 [simp]

lemma Suc_inject_rule: "$H, $G, m = n \<turnstile> $E \<Longrightarrow> $H, Suc(m) = Suc(n), $G \<turnstile> $E"
  by (rule L_of_imp [OF Suc_inject])

lemma Suc_n_not_n: "\<turnstile> Suc(k) \<noteq> k"
  apply (rule_tac n = k in induct)
  apply simp
  apply (fast add!: Suc_inject_rule)
  done

lemma add_0: "\<turnstile> 0 + n = n"
  apply (unfold add_def)
  apply (rule rec_0)
  done

lemma add_Suc: "\<turnstile> Suc(m) + n = Suc(m + n)"
  apply (unfold add_def)
  apply (rule rec_Suc)
  done

declare add_0 [simp] add_Suc [simp]

lemma add_0_right: "\<turnstile> m + 0 = m"
  apply (rule_tac n = "m" in induct)
  apply simp_all
  done

lemma add_Suc_right: "\<turnstile> m + Suc(n) = Suc(m + n)"
  apply (rule_tac n = "m" in induct)
  apply simp_all
  done

lemma "(\<And>n. \<turnstile> f(Suc(n)) = Suc(f(n))) \<Longrightarrow> \<turnstile> f(i + j) = i + f(j)"
  apply (rule_tac n = "i" in induct)
  apply simp_all
  done

end


section \<open>The direct sum of modules.\<close>

theory SumSpaces
imports Main
  "HOL-Algebra.Module"
  "HOL-Algebra.Coset"
  RingModuleFacts
  MonoidSums
  FunctionLemmas
  LinearCombinations
begin

text \<open>We define the direct sum $M_1\oplus M_2$ of 2 vector spaces as the set $M_1\times M_2$ under
componentwise addition and scalar multiplication.\<close>
definition direct_sum:: "('a,'b, 'd) module_scheme \<Rightarrow> ('a, 'c, 'e) module_scheme \<Rightarrow>('a, ('b\<times>'c)) module" (*(infixl "(\<oplus>)" 50)*)
  where  "direct_sum M1 M2 = \<lparr>carrier = carrier M1 \<times> carrier M2,
                  mult = undefined,
                  one = undefined,
                  zero = (\<zero>\<^bsub>M1\<^esub>, \<zero>\<^bsub>M2\<^esub>),
                  add = (\<lambda> v w. (fst v \<oplus>\<^bsub>M1\<^esub> fst w, snd v \<oplus>\<^bsub>M2\<^esub> snd w)),
                  smult = (\<lambda> c v. (c \<odot>\<^bsub>M1\<^esub> fst v, c \<odot>\<^bsub>M2\<^esub> snd v))\<rparr>"

lemma direct_sum_is_module:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "module R (direct_sum M1 M2)"
proof -
  from h1 have 1: "cring R" by (unfold module_def, auto)
  from h1 interpret v1: module R M1 by auto
  from h2 interpret v2: module R M2 by auto
  from h1 h2 have 2: "abelian_group (direct_sum M1 M2)"
    apply (intro abelian_groupI, auto)
         apply (unfold direct_sum_def, auto)
       by (auto simp add: v1.a_ac v2.a_ac)
  from h1 h2 assms have 3: "module_axioms R (direct_sum M1 M2)"
    apply (unfold module_axioms_def, auto)
        apply (unfold direct_sum_def, auto)
         by (auto simp add: v1.smult_l_distr v2.smult_l_distr v1.smult_r_distr v2.smult_r_distr
      v1.smult_assoc1 v2.smult_assoc1)
  from 1 2 3  show ?thesis by (unfold module_def, auto)
qed

definition inj1 :: "('a, 'b, 'm1) module_scheme \<Rightarrow> ('a, 'c, 'm2) module_scheme \<Rightarrow> 'b \<Rightarrow> 'b\<times>'c"
  where "inj1 M1 M2 = (\<lambda>v. (v, \<zero>\<^bsub>M2\<^esub>))"

definition inj2 :: "('a, 'b, 'm1) module_scheme \<Rightarrow> ('a, 'c, 'm2) module_scheme \<Rightarrow> 'c \<Rightarrow> 'b\<times>'c"
  where "inj2 M1 M2 = (\<lambda>v. (\<zero>\<^bsub>M1\<^esub>, v))"

lemma inj1_hom:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "mod_hom R M1 (direct_sum M1 M2) (inj1 M1 M2)"
proof -
  from h1 interpret v1:module R M1 by auto
  from h2 interpret v2:module R M2 by auto
  from h1 h2 show ?thesis
    apply (unfold mod_hom_def module_hom_def mod_hom_axioms_def inj1_def, auto)
       apply (rule direct_sum_is_module, auto)
      by (unfold direct_sum_def, auto)
qed

lemma inj2_hom:
  fixes R M1 M2
  assumes h1: "module R M1" and h2: "module R M2"
  shows "mod_hom R M2 (direct_sum M1 M2) (inj2 M1 M2)"
proof -
  from h1 interpret v1:module R M1 by auto
  from h2 interpret v2:module R M2 by auto
  from h1 h2 show ?thesis
    apply (unfold mod_hom_def module_hom_def mod_hom_axioms_def inj2_def, auto)
       apply (rule direct_sum_is_module, auto)
      by (unfold direct_sum_def, auto)
qed

text \<open>For submodules $M_1,M_2\subseteq M$, the map $M_1\oplus M_2\to M$ given by $(m_1,m_2)\mapsto
m_1+m_2$ is linear.\<close>
lemma (in module) sum_map_hom:
  fixes M1 M2
  assumes h1: "submodule M1 R M" and h2: "submodule M2 R M"
  shows "mod_hom R (direct_sum (md M1) (md M2)) M (\<lambda> v. (fst v) \<oplus>\<^bsub>M\<^esub> (snd v))"
proof -
  have 0: "module R M"..
  from h1 have 1: "module R (md M1)" by (rule submodule_is_module)
  from h2 have 2: "module R (md M2)" by (rule submodule_is_module)
  from h1 interpret w1: module R "(md M1)" by (rule submodule_is_module)
  from h2 interpret w2: module R "(md M2)" by (rule submodule_is_module)
  from 0 h1 h2 1 2 show ?thesis
    apply (unfold mod_hom_def mod_hom_axioms_def module_hom_def, auto)
       apply (rule direct_sum_is_module, auto)
      apply (unfold direct_sum_def, auto)
      using submoduleE apply auto
     by (auto simp add: a_ac smult_r_distr ring_subset_carrier)
      (*key is a_ac, permutative rewrite rule*)
qed

lemma (in module) sum_is_submodule:
  fixes N1 N2
  assumes h1: "submodule N1 R M" and h2: "submodule N2 R M"
  shows "submodule (submodule_sum N1 N2) R M"
proof -
  from h1 h2 interpret l: mod_hom R "(direct_sum (md N1) (md N2))" M "(\<lambda> v. (fst v) \<oplus>\<^bsub>M\<^esub> (snd v))"
    by (rule sum_map_hom)
  have 1: "l.im =submodule_sum N1 N2"
    apply (unfold l.im_def submodule_sum_def)
    apply (unfold direct_sum_def, auto)
    by (unfold image_def, auto)
  have 2: "submodule (l.im) R M" by (rule l.im_is_submodule)
  from 1 2 show ?thesis by auto
qed

lemma (in module) in_sum:
  fixes N1 N2
  assumes h1: "submodule N1 R M" and h2: "submodule N2 R M"
  shows "N1 \<subseteq> submodule_sum N1 N2"
proof -
  from h1 h2 show ?thesis
    apply auto
    apply (unfold submodule_sum_def image_def, auto)
    apply (rename_tac v)
    apply (rule_tac x="v" in bexI)
     apply (rule_tac x="\<zero>\<^bsub>M\<^esub>" in bexI)
    using submoduleE by (auto simp: ring_subset_carrier M.add.one_in_subset)
qed

lemma (in module) msum_comm:
  fixes N1 N2
  assumes h1: "submodule N1 R M" and h2: "submodule N2 R M"
  shows "(submodule_sum N1 N2) = (submodule_sum N2 N1)"
proof -
  (*have 0: "module R M"..*)
  from h1 h2 show ?thesis
    apply (unfold submodule_sum_def image_def, auto)
     apply (unfold submodule_def)
     apply (rename_tac v w)
    using M.add.m_comm M.add.subgroupE(1) by blast+
qed

text \<open>If $M_1,M_2\subseteq M$ are submodules, then $M_1+M_2$ is the minimal subspace such that
both $M_1\subseteq M$ and $M_2\subseteq M$.\<close>
lemma (in module) sum_is_minimal:
  fixes N N1 N2
  assumes h1: "submodule N1 R M" and h2: "submodule N2 R M" and h3: "submodule N R M"
  shows "(submodule_sum N1 N2) \<subseteq> N \<longleftrightarrow> N1 \<subseteq> N \<and> N2 \<subseteq> N"
proof -
  have 1: "(submodule_sum N1 N2) \<subseteq> N \<Longrightarrow> N1 \<subseteq> N \<and> N2 \<subseteq> N"
  proof -
    assume 10: "(submodule_sum N1 N2) \<subseteq> N"
    from h1 h2 have 11: "N1\<subseteq>submodule_sum N1 N2" by (rule in_sum)
    from h2 h1 have 12: "N2\<subseteq>submodule_sum N2 N1" by (rule in_sum)
    from 12 h1 h2 have 13: "N2\<subseteq>submodule_sum N1 N2" by (metis msum_comm)
    from 10 11 13 show ?thesis by auto
  qed
  have 2: "N1 \<subseteq> N \<and> N2 \<subseteq> N \<Longrightarrow> (submodule_sum N1 N2) \<subseteq> N"
  proof -
    assume 19: "N1 \<subseteq> N \<and> N2 \<subseteq> N"
    {
    fix v
    assume 20: "v\<in>submodule_sum N1 N2"
    from 20 obtain w1 w2 where 21: "w1\<in>N1" and 22: "w2\<in>N2" and 23: "v=w1\<oplus>\<^bsub>M\<^esub> w2"
      by (unfold submodule_sum_def image_def, auto)
    from 19 21 22 23 h3 have "v \<in> N"
      apply (unfold submodule_def, auto)
      using submoduleE(5) by blast
(*how is an obtain goal rep'd?*)
    }
    thus ?thesis
      by (metis subset_iff)
  qed
  from 1 2 show ?thesis by metis
qed

text \<open>$\text{span} A\cup B = \text{span} A + \text{span} B$\<close>
lemma (in module) span_union_is_sum:
  fixes A B
  assumes  h2: "A\<subseteq>carrier M" and h3: "B\<subseteq>carrier M"
  shows "span (A\<union> B) = submodule_sum (span A) (span B)"
proof-
  let ?AplusB="submodule_sum (span A) (span B)"
  from  h2 have s0: "submodule (span A) R M" by (rule span_is_submodule)
  from  h3 have s1: "submodule (span B) R M" by (rule span_is_submodule)
  from s0 have s0_1: "(span A)\<subseteq>carrier M" by (simp add: h2 span_is_subset2)
  from s1 have s1_1: "(span B)\<subseteq>carrier M" by (simp add: submoduleE(1))
  from h2 h3 have 1: "A\<union>B\<subseteq>carrier M" by auto
  from  1 have 2: "submodule (span (A\<union>B)) R M" by (rule span_is_submodule)
  from s0 s1 have 3: "submodule ?AplusB R M" by (rule sum_is_submodule)
  have c1: "span (A\<union>B) \<subseteq> ?AplusB"
(*span(A\<union>B) \<subseteq> span(A) + span(B) *)
  proof -
    from  h2 have a1: "A\<subseteq>span A" by (rule in_own_span)
    from s0 s1 have a2: "span A \<subseteq> ?AplusB" by (rule in_sum) (*M\<subseteq>M+N*)
    from a1 a2 have a3: "A\<subseteq> ?AplusB" by auto
    (*similarly*)
    from  h3 have b1: "B\<subseteq>span B" by (rule in_own_span)
    from s1 s0 have b2: "span B \<subseteq> ?AplusB" by (metis in_sum msum_comm) (*M\<subseteq>M+N*)
    from b1 b2 have b3: "B\<subseteq> ?AplusB" by auto
    from a3 b3 have 5: "A\<union>B\<subseteq> ?AplusB" by auto
      (*by default simp *)
    from 5 3 show ?thesis by (rule span_is_subset)
  qed
  have c2: "?AplusB \<subseteq> span (A\<union>B)"
  proof -
    have 11: "A\<subseteq>A\<union>B" by auto
    have 12: "B\<subseteq>A\<union>B" by auto
    from  11 have 21:"span A \<subseteq>span (A\<union>B)" by (rule span_is_monotone)
    from  12 have 22:"span B \<subseteq>span (A\<union>B)" by (rule span_is_monotone)
    from s0 s1 2 21 22 show ?thesis by (simp add: sum_is_minimal)
  qed
  from c1 c2 show ?thesis by auto
qed

end


theory AbstractSpec

imports Main

begin

text "Abstract Specification"

section "Dates"

datatype day = Mo | Tu | We | Th | Fr | Sa | Su

datatype month = Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec

record date =
  year :: nat
  month :: month
  day :: nat

definition next_month :: "month => month" where
"next_month d =
  (case d of
    Jan \<Rightarrow> Feb |
    Feb \<Rightarrow> Mar |
    Mar \<Rightarrow> Apr |
    Apr \<Rightarrow> May |
    May \<Rightarrow> Jun |
    Jun \<Rightarrow> Jul |
    Jul \<Rightarrow> Aug |
    Aug \<Rightarrow> Sep |
    Sep \<Rightarrow> Oct |
    Oct \<Rightarrow> Nov |
    Nov \<Rightarrow> Dec |
    Dec \<Rightarrow> Jan)"

definition month_ord :: "month \<Rightarrow> nat" where
"month_ord m =
  (case m of
    Jan \<Rightarrow> 0 |
    Feb \<Rightarrow> 1 |
    Mar \<Rightarrow> 2 |
    Apr \<Rightarrow> 3 |
    May \<Rightarrow> 4 |
    Jun \<Rightarrow> 5 |
    Jul \<Rightarrow> 6 |
    Aug \<Rightarrow> 7 |
    Sep \<Rightarrow> 8 |
    Oct \<Rightarrow> 9 |
    Nov \<Rightarrow> 10 |
    Dec \<Rightarrow> 11)"

definition date_next_month :: "date \<Rightarrow> date" where
"date_next_month d =
  (if (month d) = Dec then
    \<lparr> year = year d + 1, month = Jan, day = day d \<rparr>
  else
    d\<lparr> month := next_month (month d) \<rparr>
  )"

definition date_gte :: "date \<Rightarrow> date \<Rightarrow> bool" where
"date_gte d1 d2 = (year d1 \<ge> year d2 \<and> month_ord (month d1) \<ge> month_ord (month d2) \<and> day d1 \<ge> day d2)"

definition date_lte :: "date \<Rightarrow> date \<Rightarrow> bool" where
"date_lte d1 d2 = (year d1 \<le> year d2 \<and> month_ord (month d1) \<le> month_ord (month d2) \<and> day d1 \<le> day d2)"

section "Recurring Transaction Administration"

datatype monthly_rule =
  ByMonthDay "nat list"

datatype weekly_rule =
  ByDay "day list"

datatype recur_rule =
  Monthly monthly_rule
  | Weekly weekly_rule

record recurring_transaction =
  r_amount :: int
  rule :: recur_rule
  name :: string

definition create_recurring_transaction :: "recurring_transaction \<Rightarrow> recurring_transaction set \<Rightarrow> recurring_transaction set" where
"create_recurring_transaction t ts = insert t ts"

section "Concrete Transactions - Within Date Interval"

record transaction =
  amount :: int
  date :: date

datatype transaction_filter =
  CurrentMonth

(* Expands a recurring transaction into concrete transactions within the given date range *)
definition expand :: "date \<Rightarrow> date \<Rightarrow> recurring_transaction \<Rightarrow> transaction set" where
"expand st ed rt = {t. date_gte (date t) st \<and> date_lte (date t) ed }"

definition transactions_by_date :: "date \<Rightarrow> date \<Rightarrow> recurring_transaction set \<Rightarrow> transaction set" where
"transactions_by_date st ed ts = \<Union> ((expand st ed) ` ts)"

definition current_month_range :: "date \<Rightarrow> (date * date)" where
"current_month_range now = (\<lparr> year = 2021, month = Dec, day = 1\<rparr>, \<lparr> year = 2021, month = Dec, day = 31 \<rparr>)"

(* add transaction_filter param *)
(* Returns concrete transactions within a date range *)
definition transactions_within :: "date \<Rightarrow> recurring_transaction set \<Rightarrow> transaction set" where
"transactions_within now ts =
    (let (first_of_month, last_of_month) = current_month_range now in
    transactions_by_date first_of_month last_of_month ts)"

(* theorem "ts' = create_transaction r ts \<longrightarrow> view_transactions d ts f = ts'" *)

section "Test data"

value "transaction :: recurring_transaction \<equiv> \<lparr> r_amount = 5, rule = Monthly (ByMonthDay [1]), name = ''test'' \<rparr>"

definition make_recurring_transaction :: "(int * recur_rule * string) \<Rightarrow> recurring_transaction" where
"make_recurring_transaction d = (let (a, r, n) = d in \<lparr> r_amount = a, rule = r, name = n \<rparr>)"

definition "recurring_transactions = map make_recurring_transaction [
  (10, Monthly (ByMonthDay [1]), ''t1''),
  (11, Weekly (ByDay [Mo]), ''t2'')
]"

definition "now = \<lparr> year = 2021, month = Dec, day = 11 \<rparr>"
definition "jan = \<lparr> year = 2022, month = Jan, day = 11 \<rparr>"

(*
value "
  (let ts = foldl (\<lambda>ts tr. create_recurring_transaction tr ts) {} recurring_transactions in
  view_transactions now ts)" *)

value "recurring_transactions"

(* value "expand transaction now jan" *)

end


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

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

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

datatype Nat = Z | S "Nat"

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

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

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

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

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge2sort2 :: "Nat list => Nat list"
  and stoogesort2 :: "Nat list => Nat list"
  and stooge2sort1 :: "Nat list => Nat list" where
  "stooge2sort2 y =
   (case
      splitAt (idiv (S (times (S (S Z)) (length y))) (S (S (S Z)))) y
      of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (stoogesort2 xs)"
  oops

end


section\<open>Modular and Distributive Lattices\<close>

(*
    Author: Viorel Preoteasa
*)

theory Modular_Distrib_Lattice
imports Lattice_Prop
begin

text \<open>
The main result of this theory is the fact that a lattice is distributive
if and only if it satisfies the following property:
\<close>

term "(\<forall> x y z . x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y)"

text\<open>
This result was proved by Bergmann in \cite{bergmann:1929}. The formalization
presented here is based on \cite{birkhoff:1967,burris:sankappanavar:1981}.
\<close>

class modular_lattice = lattice +
  assumes modular: "x \<le> y \<Longrightarrow>  x \<squnion> (y \<sqinter> z) = y \<sqinter> (x \<squnion> z)"

context distrib_lattice begin
subclass modular_lattice
  apply unfold_locales
  by (simp add: inf_sup_distrib inf_absorb2)
end

context lattice begin
definition
  "d_aux a b c = (a \<sqinter> b) \<squnion> (b \<sqinter> c) \<squnion> (c \<sqinter> a)"

lemma d_b_c_a: "d_aux b c a = d_aux a b c"
  by (metis d_aux_def sup.assoc sup_commute)

lemma d_c_a_b: "d_aux c a b = d_aux a b c"
  by (metis d_aux_def sup.assoc sup_commute)

definition
  "e_aux a b c = (a \<squnion> b) \<sqinter> (b \<squnion> c) \<sqinter> (c \<squnion> a)"

lemma e_b_c_a: "e_aux b c a = e_aux a b c"
  apply (simp add: e_aux_def)
  apply (rule antisym)
  by (simp_all add: sup_commute)

lemma e_c_a_b: "e_aux c a b = e_aux a b c"
  apply (simp add: e_aux_def)
  apply (rule antisym)
  by (simp_all add: sup_commute)

definition
  "a_aux a b c = (a \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

definition
  "b_aux a b c = (b \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

definition
  "c_aux a b c = (c \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

lemma b_a: "b_aux a b c = a_aux b c a"
  by (simp add: a_aux_def b_aux_def e_b_c_a d_b_c_a)

lemma c_a: "c_aux a b c = a_aux c a b"
  by (simp add: a_aux_def c_aux_def e_c_a_b d_c_a_b)

lemma [simp]: "b_aux a b c \<le> e_aux a b c"
  apply (unfold b_a)
  apply (subst e_b_c_a [THEN sym])
  by simp

lemma [simp]: "c_aux a b c \<le> e_aux a b c"
  apply (unfold c_a)
  apply (subst e_c_a_b [THEN sym])
  by simp

lemma [simp]: "d_aux a b c \<le> a_aux a b c"
  by (simp add: a_aux_def e_aux_def d_aux_def)

lemma [simp]: "d_aux a b c \<le> b_aux a b c"
  apply (unfold b_a)
  apply (subst d_b_c_a [THEN sym])
  by simp

lemma [simp]: "d_aux a b c \<le> c_aux a b c"
  apply (unfold c_a)
  apply (subst d_c_a_b [THEN sym])
  by simp

lemma a_meet_e: "a \<sqinter> (e_aux a b c) = a \<sqinter> (b \<squnion> c)"
  apply (simp add: e_aux_def)
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = "(a \<squnion> b) \<sqinter> (b \<squnion> c) \<sqinter> (c \<squnion> a)" in order_trans)
  apply (rule inf_le2)
  by simp

lemma b_meet_e: "b \<sqinter> (e_aux a b c) = b \<sqinter> (c \<squnion> a)"
  by (simp add: a_meet_e [THEN sym] e_b_c_a)

lemma c_meet_e: "c \<sqinter> (e_aux a b c) = c \<sqinter> (a \<squnion> b)"
  by (simp add: a_meet_e [THEN sym] e_c_a_b)

lemma a_join_d: "a \<squnion> d_aux a b c = a \<squnion> (b \<sqinter> c)"
  apply (simp add: d_aux_def)
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = "a \<sqinter> b \<squnion> b \<sqinter> c \<squnion> c \<sqinter> a" in order_trans)
  by simp_all

lemma b_join_d: "b \<squnion> d_aux a b c = b \<squnion> (c \<sqinter> a)"
  by (simp add: a_join_d [THEN sym] d_b_c_a)

end

context lattice begin
definition
  "no_distrib a b c = (a \<sqinter> b \<squnion> c \<sqinter> a < a \<sqinter> (b \<squnion> c))"

definition
  "incomp x y = (\<not> x \<le> y \<and> \<not> y \<le> x)"

definition
  "N5_lattice a b c = (a \<sqinter> c = b \<sqinter> c \<and> a < b \<and> a \<squnion> c = b \<squnion> c)"

definition
  "M5_lattice a b c = (a \<sqinter> b = b \<sqinter> c \<and> c \<sqinter> a = b \<sqinter> c \<and> a \<squnion> b = b \<squnion> c \<and> c \<squnion> a = b \<squnion> c \<and> a \<sqinter> b < a \<squnion> b)"

lemma M5_lattice_incomp: "M5_lattice a b c \<Longrightarrow> incomp a b"
  apply (simp add: M5_lattice_def incomp_def)
  apply safe
  apply (simp_all add: inf_absorb1 inf_absorb2 )
  apply (simp_all add: sup_absorb1 sup_absorb2 )
  apply (subgoal_tac "c \<sqinter> (b \<squnion> c) = c")
  apply simp
  apply (subst sup_commute)
  by simp
end

context modular_lattice begin

lemma a_meet_d: "a \<sqinter> (d_aux a b c) = (a \<sqinter> b) \<squnion> (c \<sqinter> a)"
  proof -
    have "a \<sqinter> (d_aux a b c) = a \<sqinter> ((a \<sqinter> b) \<squnion> (b \<sqinter> c) \<squnion> (c \<sqinter> a))" by (simp add: d_aux_def)
    also have "... = a \<sqinter> (a \<sqinter> b \<squnion> c \<sqinter> a \<squnion> b \<sqinter> c)" by (simp add: sup_assoc, simp add: sup_commute)
    also have "... = (a \<sqinter> b \<squnion> c \<sqinter> a) \<squnion> (a \<sqinter> (b \<sqinter> c))" by (simp add: modular)
    also have "... = (a \<sqinter> b) \<squnion> (c \<sqinter> a)" by (rule antisym, simp_all, rule_tac y = "a \<sqinter> b" in order_trans, simp_all)
    finally show ?thesis by simp
  qed

lemma b_meet_d: "b \<sqinter> (d_aux a b c) = (b \<sqinter> c) \<squnion> (a \<sqinter> b)"
  by (simp add: a_meet_d [THEN sym] d_b_c_a)

lemma c_meet_d: "c \<sqinter> (d_aux a b c) = (c \<sqinter> a) \<squnion> (b \<sqinter> c)"
  by (simp add: a_meet_d [THEN sym] d_c_a_b)

lemma d_less_e: "no_distrib a b c \<Longrightarrow> d_aux a b c < e_aux a b c"
  apply (subst less_le)
  apply(case_tac "d_aux a b c = e_aux a b c")
  apply simp_all
  apply (simp add: no_distrib_def a_meet_e [THEN sym] a_meet_d [THEN sym])
  apply (rule_tac y = "a_aux a b c" in order_trans)
  by simp_all

lemma a_meet_b_eq_d: " d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c \<sqinter> b_aux a b c = d_aux a b c"
  proof -
    assume d_less_e: " d_aux a b c \<le> e_aux a b c"
    have "(a \<sqinter> e_aux a b c \<squnion> d_aux a b c) \<sqinter> (b \<sqinter> e_aux a b c \<squnion> d_aux a b c) = (b \<sqinter> e_aux a b c \<squnion>  d_aux a b c) \<sqinter> (d_aux a b c \<squnion> a \<sqinter> e_aux a b c)"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> ((b \<sqinter> e_aux a b c \<squnion> d_aux a b c) \<sqinter> (a \<sqinter> e_aux a b c))"
      by (simp add: modular)
    also have "\<dots> = d_aux a b c \<squnion> (d_aux a b c \<squnion> e_aux a b c \<sqinter> b) \<sqinter> (a \<sqinter> e_aux a b c)"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> (e_aux a b c \<sqinter> (d_aux a b c \<squnion> b)) \<sqinter> (a \<sqinter> e_aux a b c)"
      by (cut_tac d_less_e, simp add: modular [THEN sym] less_le)
    also have "\<dots> =  d_aux a b c \<squnion> ((a \<sqinter> e_aux a b c) \<sqinter> (e_aux a b c \<sqinter> (b \<squnion> d_aux a b c)))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> e_aux a b c \<sqinter> (b \<squnion> d_aux a b c))" by (simp add: inf_assoc)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> e_aux a b c \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: b_join_d)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> c) \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: a_meet_e)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> ((b \<squnion> c) \<sqinter> (b \<squnion> (c \<sqinter> a))))" by (simp add: inf_assoc)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> ((b \<squnion> c) \<sqinter> (c \<sqinter> a))))" by (simp add: modular)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: inf_absorb2)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> ((c \<sqinter> a) \<squnion> b))" by (simp add: sup_commute inf_commute)
    also have "\<dots> = d_aux a b c \<squnion> ((c \<sqinter> a) \<squnion> (a \<sqinter> b))" by (simp add: modular)
    also have "\<dots> = d_aux a b c"
      by (rule antisym, simp_all add: d_aux_def)
    finally show ?thesis by (simp add: a_aux_def b_aux_def)
  qed

lemma b_meet_c_eq_d: " d_aux a b c \<le> e_aux a b c \<Longrightarrow> b_aux a b c \<sqinter> c_aux a b c = d_aux a b c"
  apply (subst b_a)
  apply (subgoal_tac "c_aux a b c = b_aux b c a")
  apply simp
  apply (subst a_meet_b_eq_d)
  by (simp_all add: c_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma c_meet_a_eq_d: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> c_aux a b c \<sqinter> a_aux a b c = d_aux a b c"
  apply (subst c_a)
  apply (subgoal_tac "a_aux a b c = b_aux c a b")
  apply simp
  apply (subst a_meet_b_eq_d)
  by (simp_all add: a_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma a_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c = (a \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (simp add: a_aux_def)
  apply (subst inf_commute)
  apply (subst sup_commute)
  apply (simp add: modular)
  by (simp add: inf_commute sup_commute)

lemma b_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> b_aux a b c = (b \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (cut_tac a = b and b = c and c = a in a_def_equiv)
  by (simp_all add: d_b_c_a e_b_c_a b_a)

lemma c_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> c_aux a b c = (c \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (cut_tac a = c and b = a and c = b in a_def_equiv)
  by (simp_all add: d_c_a_b e_c_a_b c_a)

lemma a_join_b_eq_e: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c \<squnion> b_aux a b c = e_aux a b c"
  proof -
    assume d_less_e: " d_aux a b c \<le> e_aux a b c"
    have "((a \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> ((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) = ((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> (e_aux a b c \<sqinter> (a \<squnion> d_aux a b c))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> (((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> (a \<squnion> d_aux a b c))"
      by (simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> ((e_aux a b c \<sqinter> (d_aux a b c \<squnion> b)) \<squnion> (a \<squnion> d_aux a b c))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> ((d_aux a b c \<squnion> (e_aux a b c \<sqinter> b)) \<squnion> (a \<squnion> d_aux a b c))"
      by (cut_tac d_less_e, simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> ((a \<squnion> d_aux a b c) \<squnion> (d_aux a b c \<squnion> (b \<sqinter> e_aux a b c)))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> d_aux a b c \<squnion> (b \<sqinter> e_aux a b c))" by (simp add: sup_assoc)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> d_aux a b c \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: b_meet_e)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> c) \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: a_join_d)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> ((b \<sqinter> c) \<squnion> (b \<sqinter> (c \<squnion> a))))" by (simp add: sup_assoc)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> ((b \<sqinter> c) \<squnion> (c \<squnion> a))))" by (simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: sup_absorb2)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> ((c \<squnion> a) \<sqinter> b))" by (simp add: sup_commute inf_commute)
    also have "\<dots> = e_aux a b c \<sqinter> ((c \<squnion> a) \<sqinter> (a \<squnion> b))" by (simp add: modular)
    also have "\<dots> = e_aux a b c"
      by (rule antisym, simp_all, simp_all add: e_aux_def)
    finally show ?thesis by (cut_tac d_less_e, simp add: a_def_equiv b_def_equiv)
  qed

lemma b_join_c_eq_e: " d_aux a b c <= e_aux a b c \<Longrightarrow> b_aux a b c \<squnion> c_aux a b c = e_aux a b c"
  apply (subst b_a)
  apply (subgoal_tac "c_aux a b c = b_aux b c a")
  apply simp
  apply (subst a_join_b_eq_e)
  by (simp_all add: c_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma c_join_a_eq_e: "d_aux a b c <= e_aux a b c \<Longrightarrow> c_aux a b c \<squnion> a_aux a b c = e_aux a b c"
  apply (subst c_a)
  apply (subgoal_tac "a_aux a b c = b_aux c a b")
  apply simp
  apply (subst a_join_b_eq_e)
  by (simp_all add: a_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma "no_distrib a b c \<Longrightarrow> incomp a b"
  apply (simp add: no_distrib_def incomp_def)
  apply safe
  apply (simp add: inf_absorb1)
  apply (subgoal_tac "a \<squnion> c \<sqinter> a = a \<and> a \<sqinter> (b \<squnion> c) = a")
  apply simp
  apply safe
  apply (rule antisym)
  apply simp
  apply simp
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = b in order_trans)
  apply simp_all
  apply (simp add: inf_absorb2)
  apply (unfold modular [THEN sym])
  by (simp add: inf_commute)

lemma M5_modular: "no_distrib a b c \<Longrightarrow> M5_lattice (a_aux a b c) (b_aux a b c) (c_aux a b c)"
  apply (frule d_less_e)
  by (simp add: M5_lattice_def a_meet_b_eq_d b_meet_c_eq_d c_meet_a_eq_d a_join_b_eq_e b_join_c_eq_e c_join_a_eq_e)

lemma M5_modular_def: "M5_lattice a b c = (a \<sqinter> b = b \<sqinter> c \<and> c \<sqinter> a = b \<sqinter> c \<and> a \<squnion> b = b \<squnion> c \<and> c \<squnion> a = b \<squnion> c \<and> a \<sqinter> b < a \<squnion> b)"
  by (simp add: M5_lattice_def)

end

context lattice begin

lemma not_modular_N5: "(\<not> class.modular_lattice inf ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) sup) =
   (\<exists> a b c::'a . N5_lattice a b c)"
  apply (subgoal_tac "class.lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) sup")
  apply (unfold N5_lattice_def class.modular_lattice_def class.modular_lattice_axioms_def)
  apply simp_all
  apply safe
  apply (subgoal_tac "x \<squnion> y \<sqinter> z < y \<sqinter> (x \<squnion> z)")
  apply (rule_tac x = "x \<squnion> y \<sqinter> z" in exI)
  apply (rule_tac x = "y \<sqinter> (x \<squnion> z)" in exI)
  apply (rule_tac x = z in exI)
  apply safe
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "x \<squnion> y \<sqinter> z" in order_trans)
  apply simp_all
  apply (rule_tac y = "y \<sqinter> z" in order_trans)
  apply simp_all
  apply (rule antisym)
  apply simp_all
  apply (rule_tac y = "y \<sqinter> (x \<squnion> z)" in order_trans)
  apply simp_all
  apply (rule_tac y = "x \<squnion> z" in order_trans)
  apply simp_all
  apply (rule neq_le_trans)
  apply simp
  apply simp
  apply (rule_tac x = a in exI)
  apply (rule_tac x = b in exI)
  apply safe
  apply (simp add: less_le)
  apply (rule_tac x = c in exI)
  apply simp
  apply (simp add: less_le)
  apply safe
  apply (subgoal_tac "a \<squnion> a \<sqinter> c = b")
  apply (unfold sup_inf_absorb) [1]
  apply simp
  apply simp
  proof qed

lemma not_distrib_N5_M5: "(\<not> class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)) =
   ((\<exists> a b c::'a . N5_lattice a b c) \<or> (\<exists> a b c::'a . M5_lattice a b c))"
  apply (unfold not_modular_N5 [THEN sym])
  proof
    assume A: "\<not> class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
    have B: "\<exists> a b c:: 'a . (a \<sqinter> b) \<squnion> (a \<sqinter> c) < a \<sqinter> (b \<squnion> c)"
      apply (cut_tac A)
      apply (unfold  class.distrib_lattice_def)
      apply safe
      apply simp_all
      proof
        fix x y z::'a
        assume A: "\<forall>(a::'a) (b::'a) c::'a. \<not> a \<sqinter> b \<squnion> a \<sqinter> c < a \<sqinter> (b \<squnion> c)"
        show "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
          apply (cut_tac A)
          apply (rule distrib_imp1)
          by (simp add: less_le)
      qed
    from B show "\<not> class.modular_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>) \<or> (\<exists>a b c::'a. M5_lattice a b c)"
      proof (unfold disj_not1, safe)
        fix a b c::'a
        assume A: "a \<sqinter> b \<squnion> a \<sqinter> c < a \<sqinter> (b \<squnion> c)"
        assume B: "class.modular_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
        interpret modular: modular_lattice "(\<sqinter>)" "((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool)" "(<)" "(\<squnion>)"
          by (fact B)

        have H: "M5_lattice (a_aux a b c) (b_aux a b c) (c_aux a b c)"
          apply (cut_tac a = a and b = b and c = c in  modular.M5_modular)
          apply (unfold no_distrib_def)
          by (simp_all add: A inf_commute)
        from H show "\<exists>a b c::'a. M5_lattice a b c" by blast
     qed
   next
     assume A: "\<not> class.modular_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>) \<or> (\<exists>(a::'a) (b::'a) c::'a. M5_lattice a b c)"
     show "\<not> class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
       apply (cut_tac A)
       apply safe
       apply (erule notE)
       apply unfold_locales
       apply (unfold class.distrib_lattice_def)
       apply (unfold class.distrib_lattice_axioms_def)
       apply safe
       apply (simp add: sup_absorb2)
       apply (frule M5_lattice_incomp)
       apply (unfold M5_lattice_def)
       apply (drule_tac x = a in spec)
       apply (drule_tac x = b in spec)
       apply (drule_tac x = c in spec)
       apply safe
       proof -
         fix a b c:: 'a
         assume A:"a \<squnion> b \<sqinter> c = (a \<squnion> b) \<sqinter> (a \<squnion> c)"
         assume B: "a \<sqinter> b = b \<sqinter> c"
         assume D: "a \<squnion> b = b \<squnion> c"
         assume E: "c \<squnion> a = b \<squnion> c"
         assume G: "incomp a b"
         have H: "a \<squnion> b \<sqinter> c = a" by (simp add: B [THEN sym] sup_absorb1)
         have I: "(a \<squnion> b) \<sqinter> (a \<squnion> c) = a \<squnion> b" by (cut_tac E, simp add: sup_commute D)
         have J: "a = a \<squnion> b" by (cut_tac A, simp add: H I)
         show False
           apply (cut_tac G J)
           apply (subgoal_tac "b \<le> a")
           apply (simp add: incomp_def)
           apply (rule_tac y = "a \<squnion> b" in order_trans)
           apply (rule sup_ge2)
           by simp
       qed
     qed

lemma distrib_not_N5_M5: "(class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)) =
   ((\<forall> a b c::'a . \<not> N5_lattice a b c) \<and> (\<forall> a b c::'a . \<not> M5_lattice a b c))"
  apply (cut_tac not_distrib_N5_M5)
  by auto

lemma distrib_inf_sup_eq:
  "(class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)) =
    (\<forall> x y z::'a . x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<longrightarrow> x = y)"
  apply safe
  proof -
    fix x y z:: 'a
    assume A: "class.distrib_lattice (\<sqinter>) ((\<le>) ::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
    interpret distrib: distrib_lattice "(\<sqinter>)" "(\<le>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool" "(<)" "(\<squnion>)"
      by (fact A)
    assume B: "x \<sqinter> z = y \<sqinter> z"
    assume C: "x \<squnion> z = y \<squnion> z"
    have "x = x \<sqinter> (x \<squnion> z)" by simp
    also have "\<dots> = x \<sqinter> (y \<squnion> z)" by (simp add: C)
    also have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" by (simp add: distrib.inf_sup_distrib)
    also have "\<dots> = (y \<sqinter> x) \<squnion> (y \<sqinter> z)" by (simp add: B inf_commute)
    also have "\<dots> = y \<sqinter> (x \<squnion> z)" by (simp add: distrib.inf_sup_distrib)
    also have "\<dots> = y" by (simp add: C)
    finally show "x = y" .
  next
    assume A: "(\<forall>x y z:: 'a. x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<longrightarrow> x = y)"
    have B: "!! x y z :: 'a. x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y"
      by (cut_tac A, blast)
    show "class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
      apply (unfold distrib_not_N5_M5)
      apply safe
      apply (unfold N5_lattice_def)
      apply (cut_tac x = a and y = b and z = c in B)
      apply (simp_all)
      apply (unfold M5_lattice_def)
      apply (cut_tac x = a and y = b and z = c in B)
      by (simp_all add: inf_commute sup_commute)
 qed
end

class inf_sup_eq_lattice = lattice +
  assumes inf_sup_eq: "x \<sqinter> z = y \<sqinter> z \<Longrightarrow> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y"
begin
subclass distrib_lattice
  by (metis distrib_inf_sup_eq inf_sup_eq)
end

end


(*
  Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory LT2 imports System_L1 begin

text \<open>System from Jan Lukasiewicz and Alfred Tarski (1930): Untersuchungen über den Aussagenkalkül\<close>

text \<open>Inspired by Shotaro Tanaka (1965): On Axiom Systems of Propositional Calculi. XIII\<close>

inductive LT (\<open>\<tturnstile>\<close>) where
  LT_MP: \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  LT_1:  \<open>\<tturnstile> (((p \<rightarrow> (q \<rightarrow> p))
              \<rightarrow> (((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u)))) \<rightarrow> v))
             \<rightarrow> (w \<rightarrow> v))\<close>

lemma LT_5: \<open>\<tturnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_1 LT_MP by metis

lemma LT_15: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close>
  using LT_1 LT_5 LT_MP by metis

lemma LT_11: \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_5 LT_15 LT_MP by metis

lemma LT_20: \<open>\<tturnstile> ((\<sim> p \<rightarrow> p) \<rightarrow> p)\<close>
  using LT_1 LT_15 LT_MP by metis

lemma LT_21: \<open>\<tturnstile> (p \<rightarrow> (\<sim> p \<rightarrow> q))\<close>
  using LT_1 LT_15 LT_MP by metis

theorem LT_iff_L1: \<open>\<tturnstile> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_LT_1:
    \<open>\<turnstile> (((p \<rightarrow> (q \<rightarrow> p))
          \<rightarrow> (((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u)))) \<rightarrow> v))
         \<rightarrow> (w \<rightarrow> v))\<close> for p q r s t u v w
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by (induct) (metis MP, metis L1_LT_1)
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis LT_MP, metis LT_11, metis LT_20, metis LT_21)
qed

theorem LT_soundness: \<open>\<tturnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: LT.induct) auto

theorem LT_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<tturnstile> p\<close>
  using LT_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<tturnstile> p\<close>
  unfolding valid_def using LT_soundness LT_completeness by blast

lemmas LT = LT.intros main

end


section\<open>Lattice Orderd Groups\<close>

(*
    Author: Viorel Preoteasa
*)

theory Lattice_Ordered_Group
imports Modular_Distrib_Lattice
begin

text\<open>
This theory introduces lattice ordered groups \cite{birkhoff:1942}
and proves some results about them. The most important result is
that a lattice ordered group is also a distributive lattice.
\<close>

class lgroup = group_add + lattice +
assumes add_order_preserving: "a \<le> b \<Longrightarrow> u + a + v \<le> u + b + v"
begin

lemma add_order_preserving_left: "a \<le> b \<Longrightarrow> u + a \<le> u + b"
  apply (cut_tac a = a and b = b and u = u and v = 0 in add_order_preserving)
  by simp_all

lemma add_order_preserving_right: "a \<le> b \<Longrightarrow> a + v \<le> b + v"
  apply (cut_tac a = a and b = b and u = 0 and v = v in add_order_preserving)
  by simp_all

lemma minus_order: "-a \<le> -b \<Longrightarrow> b \<le> a"
  apply (cut_tac a = "-a" and b = "-b" and u = a and v = b in add_order_preserving)
  by simp_all

lemma right_move_to_left: "a + - c \<le> b \<Longrightarrow> a \<le> b + c"
  apply (drule_tac v = "c" in add_order_preserving_right)
  by (simp add: add.assoc)

lemma right_move_to_right: "a \<le> b + -c \<Longrightarrow> a + c \<le> b"
  apply (drule_tac v = "c" in add_order_preserving_right)
  by (simp add: add.assoc)

lemma [simp]: "(a \<sqinter> b) - c = (a - c) \<sqinter> (b - c)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma left_move_to_left: "-c + a \<le> b \<Longrightarrow> a \<le> c + b"
  apply (drule_tac u = "c" in add_order_preserving_left)
  by (simp add: add.assoc [THEN sym])

lemma left_move_to_right: "a \<le> - c + b \<Longrightarrow> c + a \<le> b"
  apply (drule_tac u = "c" in add_order_preserving_left)
  by (simp add: add.assoc [THEN sym])

lemma [simp]: "c + (a \<sqinter> b) = (c + a) \<sqinter> (c + b)"
  apply (rule order.antisym)
  apply simp
  apply safe
  apply (rule add_order_preserving_left)
  apply simp
  apply (rule add_order_preserving_left)
  apply simp
  apply (rule left_move_to_left)
  apply simp
  apply safe
  apply (rule left_move_to_right)
  apply simp
  apply (rule left_move_to_right)
  by simp

lemma [simp]: "- (a \<sqinter> b) = (- a) \<squnion> (- b)"
  apply (rule order.antisym)
  apply (rule minus_order)
  apply simp
  apply safe
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  apply simp
  apply simp
  apply safe
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  by simp

lemma [simp]: "(a \<squnion> b) + c = (a + c) \<squnion> (b + c)"
  apply (rule order.antisym)
  apply (rule right_move_to_right)
  apply simp
  apply safe
  apply (simp_all only: diff_conv_add_uminus)
  apply (rule right_move_to_left)
  apply simp
  apply (rule right_move_to_left)
  apply simp
  apply simp
  apply safe
  apply (rule add_order_preserving_right)
  apply simp
  apply (rule add_order_preserving_right)
  by simp

lemma [simp]: "c + (a \<squnion> b) = (c + a) \<squnion> (c + b)"
  apply (rule order.antisym)
  apply (rule left_move_to_right)
  apply simp
  apply safe
  apply (rule left_move_to_left)
  apply simp
  apply (rule left_move_to_left)
  apply simp
  apply simp
  apply safe
  apply (rule add_order_preserving_left)
  apply simp
  apply (rule add_order_preserving_left)
  by simp

lemma [simp]: "c - (a \<sqinter> b) = (c - a) \<squnion> (c - b)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma [simp]: "(a \<squnion> b) - c = (a - c) \<squnion>  (b - c)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma [simp]: "- (a \<squnion> b) = (- a) \<sqinter> (- b)"
  apply (rule order.antisym)
  apply simp
  apply safe
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  by simp

lemma [simp]: "c - (a \<squnion> b) = (c - a) \<sqinter> (c - b)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma add_pos: "0 \<le> a \<Longrightarrow> b \<le> b + a"
  apply (cut_tac a = 0 and b = a and u = b and v = 0 in add_order_preserving)
  by simp_all

lemma add_pos_left: "0 \<le> a \<Longrightarrow> b \<le> a + b"
  apply (rule right_move_to_left)
  by simp

lemma inf_sup: "a - (a \<sqinter> b) + b = a \<squnion> b"
  by (simp add: add.assoc sup_commute)

lemma inf_sup_2: "b = (a \<sqinter> b) - a + (a \<squnion> b)"
  apply (unfold inf_sup [THEN sym])
  proof -
    fix a b:: 'a
    have "b = (a \<sqinter> b) + (- a + a) + - (a \<sqinter> b) + b" by (simp only: right_minus left_minus add_0_right add_0_left)
    also have "\<dots> = (a \<sqinter> b) + - a + (a + - (a \<sqinter> b) + b)" by (unfold add.assoc, simp)
    also have "\<dots> = (a \<sqinter> b) - a + (a - (a \<sqinter> b) + b)" by simp
    finally show "b = (a \<sqinter> b) - a + (a - (a \<sqinter> b) + b)" .
  qed

subclass inf_sup_eq_lattice
  proof
    fix x y z:: 'a
    assume A: "x \<sqinter> z = y \<sqinter> z"
    assume B: "x \<squnion> z = y \<squnion> z"
    have "x = (z \<sqinter> x) - z + (z \<squnion> x)" by (rule inf_sup_2)
    also have "\<dots> = (z \<sqinter> y) - z + (z \<squnion> y)" by (simp add: sup_commute inf_commute A B)
    also have "\<dots> = y" by (simp only: inf_sup_2 [THEN sym])
    finally show "x = y" .
  qed
end

end