import language
import data.nat.parity

namespace first_order

section prf

variables {L : language} {n m : ℕ}

inductive Prf (A : Type) [has_coe A (formula L)] : list (formula L) → formula L → Prop
| Axiom : ∀ {Γ : list (formula L)} (a : A) φ, a = φ → Prf Γ φ
| Assumption : ∀ {Γ : list (formula L)} n φ, Γ.nth n = some φ → Prf Γ φ
| Bot_elim : ∀ {Γ : list (formula L)} φ, Prf Γ F → Prf Γ φ
| Not_elim : ∀ {Γ : list (formula L)} φ ψ, Prf Γ ∼φ → Prf Γ φ → Prf Γ ψ
| By_contradiction : ∀ {Γ : list (formula L)} φ, Prf (∼φ::Γ) F → Prf Γ φ
| Or_intro_left : ∀ {Γ : list (formula L)} φ ψ, Prf Γ φ → Prf Γ (φ or ψ)
| Or_intro_right : ∀ {Γ : list (formula L)} φ ψ, Prf Γ ψ → Prf Γ (φ or ψ)
| Or_elim : ∀ {Γ : list (formula L)} φ ψ χ, Prf Γ (φ or ψ) → Prf (φ::Γ) χ → Prf (ψ::Γ) χ → Prf Γ χ
| All_intro : ∀ {Γ : list (formula L)} φ n m, var_not_free_in_axioms_context m A Γ →
    Prf Γ (replace_formula_with n (term.var m) φ) → Prf Γ (formula.all n φ)
| All_elim : ∀ {Γ : list (formula L)} n t φ ψ, Prf Γ (formula.all n φ) →
    substitutable_for t n φ → Prf ((replace_formula_with n t φ) :: Γ) ψ → Prf Γ ψ
| Cut : ∀ {Γ : list (formula L)} φ ψ, Prf Γ φ → Prf (φ::Γ) ψ → Prf Γ ψ

open Prf

notation A ` ∣ ` Γ` ⊢ `φ := Prf A Γ φ

variables {p p₁ p₂ q q₁ q₂ r s φ : formula L}

variables {Γ γ : list (formula L)} {P Q : list (formula L)} {A : Type} [has_coe A (formula L)]

-- Weakening
lemma nth_append_some : ∀ {A : Type} {l1 l2 : list A} n x, l1.nth n = some x → (l1 ++ l2).nth n = some x
| A (y :: l1) l2 0 x h := h
| A (y :: l1) l2 (n+1) x h := @nth_append_some A l1 l2 n x h

lemma nth_cons_some : ∀ {A : Type} {l1 l2 : list A},
  (∀ n x, l1.nth n = some x → ∃ m, l2.nth m = some x) -> ∀ y,
  (∀ n x, (y :: l1).nth n = some x → ∃ m, (y :: l2).nth m = some x) :=
  begin
    intros, cases n, { existsi 0, assumption },
    { simp at *, cases (ᾰ _ _ ᾰ_1),
        existsi w.succ, assumption },
  end

lemma nth_append_r : ∀ {A : Type} {l1 l2 : list A} n, (l1 ++ l2).nth (n + l1.length) = l2.nth n := begin
  intros A l1 l2 n,
  induction l1,
  simp,
  simp,
  rw ← add_assoc,
  rw ← add_comm,
  rw nat.one_add,
  simp,
  apply l1_ih,
end

def weakening : (forall n x, γ.nth n = some x -> ∃ m, Γ.nth m = some x) →
  (A∣γ ⊢ p) → (A∣Γ ⊢ p) := begin
    intros h γp, revert Γ h,
    induction γp, all_goals { intros Γ h },
      sorry,
      { cases (h _ _ γp_ᾰ), apply Assumption, assumption, },
      apply Bot_elim, apply γp_ih, assumption,
      apply Not_elim,
        { apply γp_ih_ᾰ, assumption },
        { apply γp_ih_ᾰ_1, assumption },
      apply By_contradiction, apply γp_ih, apply nth_cons_some, assumption,
      apply Or_intro_left, apply γp_ih, assumption,
      apply Or_intro_right, apply γp_ih, assumption,
      apply Or_elim,
        { apply γp_ih_ᾰ, assumption },
        { apply γp_ih_ᾰ_1, apply nth_cons_some, assumption },
        { apply γp_ih_ᾰ_2, apply nth_cons_some, assumption },
      admit,
      admit,
      apply Cut,
        { apply γp_ih_ᾰ, assumption },
        { apply γp_ih_ᾰ_1, apply nth_cons_some, assumption },
  end

def weakening_append : (A∣γ ⊢ p) → (A∣(γ ++ Γ) ⊢ p) := begin
    apply weakening,
    intros, existsi n,
    apply nth_append_some, assumption,
  end

-- Converting natural deduction rules into sequent calculus rules
def R_ : (A∣[p] ⊢ q) → ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) := begin
    intros pq Γp,
    apply Cut,
    apply Γp,
    apply weakening _ pq,
    intros n φ pn_eq_φ,
    cases n, simp at pn_eq_φ,
    existsi 0, simp, assumption,
    contradiction,
  end

variables (h : formula L) (l : list (formula L))

def To_Right_Rule_List : (A∣(h::l) ⊢ q) → ∀ Γ : (list (formula L)), (A∣Γ ⊢ h) → (A∣(l ++ Γ) ⊢ q) := begin
    intros h1 Γ h2,
    apply Cut,
    apply weakening _ h2,
    intros n1 h3 h4,
    existsi (n1 + l.length),
    rw nth_append_r,
    apply h4,
    apply weakening,
    intros n2 h5 h6,
    apply nth_cons_some,
    intros n3 h7 h8,
    existsi n3,
    apply nth_append_some,
    apply h8,
    apply h6,
    apply h1,
  end

def L_ : (A∣[p] ⊢ q) → (A∣Γ ⊢ p) → (A∣(q::Γ) ⊢ r) → (A∣Γ ⊢ r) := begin
    intros h1 h2 h3,
    apply Cut,
    apply R_,
    apply h1,
    apply h2,
    apply h3,
  end

def L_R_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → (A∣Γ ⊢ p) → (A∣(q::Γ) ⊢ r) → (A∣Γ ⊢ r) := begin
  intros h1 h2 h3,
  apply Cut,
  apply h1,
  apply h2,
  apply h3,
end

def Proves_impl : (A∣(p::Γ) ⊢ q) → (A∣Γ ⊢ (p ⇒ q)) := begin
  intro h, simp,
  apply By_contradiction,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Cut p,
  apply By_contradiction,
  apply Not_elim,
  apply Assumption 1, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply weakening _ h,
  intros n φ h1,
  cases n,
  existsi 0,
  simp at *,
  apply h1,
  existsi n.succ.succ,
  simp at *,
  apply h1,
end

def R_Not_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ ∼p) → (A∣Γ ⊢ ∼q)) := sorry

def R_Eq_Not_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ ∼p) ↔ (A∣Γ ⊢ ∼q)) := sorry

def R_Left_Or_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p or r)) → (A∣Γ ⊢ (q or r))) := sorry

def R_Eq_Left_Or_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p or r)) ↔ (A∣Γ ⊢ (q or r))) := sorry

def R_Right_Or_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (r or p)) → (A∣Γ ⊢ (r or q))) := sorry

def R_Eq_Right_Or_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (r or p)) ↔ (A∣Γ ⊢ (r or q))) := sorry

def R_Or_ : ((A∣Γ ⊢ p₁) → (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) → (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ or p₂)) → ((A∣Γ ⊢ (q₁ or q₂)))) := sorry

def R_Eq_Or_ : ((A∣Γ ⊢ p₁) ↔ (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) ↔ (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ or p₂)) ↔ ((A∣Γ ⊢ (q₁ or q₂)))) := sorry

def R_Left_And_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p and r)) → (A∣Γ ⊢ (q and r))) := sorry

def R_Eq_Left_And_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p and r)) ↔ (A∣Γ ⊢ (q and r))) := sorry

def R_Right_And_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (r and p)) → (A∣Γ ⊢ (r and q))) := sorry

def R_And_ : ((A∣Γ ⊢ p₁) → (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) → (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ and p₂)) → ((A∣Γ ⊢ (q₁ and q₂)))) := sorry

def R_Eq_And_ : ((A∣Γ ⊢ p₁) ↔ (A∣Γ ⊢ q₁)) → ((A∣Γ ⊢ p₂) ↔ (A∣Γ ⊢ q₂)) → ((A∣Γ ⊢ (p₁ and p₂)) ↔ ((A∣Γ ⊢ (q₁ and q₂)))) := sorry

def R_All_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (all n p)) → (A∣Γ ⊢ (all n q))) := sorry

def R_Eq_All_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (all n p)) ↔ (A∣Γ ⊢ (all n q))) := sorry

def R_Ex_ : ((A∣Γ ⊢ p) → (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (exi n p)) → (A∣Γ ⊢ (exi n q))) := sorry

def R_Eq_Ex_ : ((A∣Γ ⊢ p) ↔ (A∣Γ ⊢ q)) → ((A∣Γ ⊢ (exi n p)) ↔ (A∣Γ ⊢ (exi n q))) := sorry

-- Basic intro and elim ND rules
def Not_intro : (A∣[(p ⇒ F)] ⊢ ∼p) := begin
    apply Or_elim,
    apply Assumption 0, refl,
    apply Assumption 0, refl,
    apply Bot_elim,
    apply Assumption 0, refl,
  end

def Not_impl : A∣[∼p] ⊢ (p ⇒ F) := begin
  apply Or_intro_left,
  apply Assumption 0, refl,
end

def Impl_not : A∣[(p ⇒ F)] ⊢ ∼p := begin
  apply Or_elim,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
  apply R_ Not_intro,
  apply Assumption 1, refl,
end

def Double_negation_elim : A∣[∼∼p] ⊢ p := begin
    apply (By_contradiction p),
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def Double_negation_intro : A∣[p] ⊢ ∼∼p := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 1, refl,
  end

def Top_intro : A∣Γ ⊢ T := begin
  apply By_contradiction,
  apply R_ Double_negation_elim,
  apply Assumption 0, refl,
end

def Absurd : (A∣Γ ⊢ p) → (A∣Γ ⊢ ∼p) → (A∣Γ ⊢ q) := sorry

def Impl_elim_ : A∣[p, p ⇒ q] ⊢ q := begin
    apply Or_elim,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def Impl_elim : (A∣Γ ⊢ p) → ((A∣Γ ⊢ (p ⇒ q)) → ((A∣Γ ⊢ q))) := begin
    intros h1 h2,
    apply Cut,
    apply h2,
    apply To_Right_Rule_List _ _ Impl_elim_,
    assumption,
  end

def And_intro : (A∣[p, q] ⊢ (p and q)) := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Or_elim,
    apply Assumption 0, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 2, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply Assumption 3, refl,
  end

def And_intro_R : (A∣Γ ⊢ p) → (A∣Γ ⊢ q) → (A∣Γ ⊢ (p and q)) := begin
    intros h1 h2,
    apply Cut,
    apply h2,
    apply To_Right_Rule_List _ _ And_intro,
    apply h1,
  end

def And_elim_left : A∣[(p and q)] ⊢ p := begin
      apply By_contradiction,
      apply Not_elim,
      apply Assumption 1, refl,
      apply Or_intro_left,
      apply Assumption 0, refl,
    end

def And_elim_right : A∣[(p and q)] ⊢ q := begin
      apply By_contradiction,
      apply Not_elim,
      apply Assumption 1, refl,
      apply Or_intro_right,
      apply Assumption 0, refl,
    end

def NonContradiction : A∣[(p and ∼p)] ⊢ F := begin
    apply Not_elim,
    apply And_elim_right,
    apply And_elim_left,
  end

-- DeMorgan laws
def DeMorganNotAnd : A∣[∼(p and q)] ⊢ (∼p or ∼q) := begin
    apply By_contradiction,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def DeMorganNotOr : A∣[∼(p or q)] ⊢ (∼p and ∼q) := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Or_elim,
    apply Assumption 0, refl,
    apply Or_intro_left,
    apply R_ Double_negation_elim,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply R_ Double_negation_elim,
    apply Assumption 0, refl,
  end

def ExcludedMiddle : A∣[p] ⊢ (q or ∼q) := begin
  apply By_contradiction,
  apply L_ DeMorganNotOr,
  apply Assumption 0, refl,
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply Not_elim,
  apply Assumption 2, refl,
  apply Or_intro_right,
  apply Assumption 0, refl,
end

def DeMorganOr : A∣[(∼p or ∼q)] ⊢ ∼(p and q) := begin
    apply R_ Not_intro,
    apply Proves_impl,
    apply Or_elim,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 0, refl,
    apply L_ And_elim_left,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
    apply L_ And_elim_right,
    apply Assumption 1, refl,
    apply Not_elim,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def DeMorganAnd : A∣[(∼p and ∼q)] ⊢ ∼(p or q) := begin
  apply By_contradiction,
  apply L_ Double_negation_elim,
  apply Assumption 0, refl,
  apply Or_elim,
  apply Assumption 0, refl,
  apply L_ And_elim_left,
  apply Assumption 3, refl,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  apply L_ And_elim_right,
  apply Assumption 3, refl,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

-- Distribution of and and or
-- TODO: Right now there are 8 distribution rules, is there any way to simplify this?
def DistributionAndOrInLeft : A∣[(r and (p or q))] ⊢ ((r and p) or (r and q)) := begin
    apply L_ And_elim_right,
    apply Assumption 0, refl,
    apply L_ And_elim_left,
    apply Assumption 1, refl,
    apply Or_elim,
    apply Assumption 1, refl,
    apply Or_intro_left,
    apply And_intro_R,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply And_intro_R,
    apply Assumption 1, refl,
    apply Assumption 0, refl,
  end

def DistributionAndOrInRight : A∣[((p or q) and r)] ⊢ ((p and r) or (q and r)) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 1, refl,
  apply Or_intro_left,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  apply Or_intro_right,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

def DistributionAndOrOutLeft : A∣[((r and p) or (r and q))] ⊢ (r and (p or q)) := begin
  apply And_intro_R,
  apply Or_elim,
  apply Assumption 0, refl,
  any_goals { by {
    apply L_ And_elim_left,
    repeat { apply Assumption 0, refl, }
  } },
  apply Or_elim,
  apply Assumption 0, refl,
  any_goals { by {
    apply L_ And_elim_right,
    apply Assumption 0, refl,
    { apply Or_intro_left, apply Assumption 0, refl }
      <|>
    { apply Or_intro_right, apply Assumption 0, refl }
  } },
end

def DistributionAndOrOutRight : A∣[((p and r) or (q and r))] ⊢ ((p or q) and r) := begin
  apply And_intro_R,
  apply Or_elim,
  apply Assumption 0, refl,
  any_goals {
    apply L_ And_elim_left,
    apply Assumption 0, refl,
    { apply Or_intro_left, apply Assumption 0, refl }
      <|>
    { apply Or_intro_right, apply Assumption 0, refl }
  },
  apply Or_elim,
  apply Assumption 0, refl,
  all_goals {
    apply L_ And_elim_right,
    repeat { apply Assumption 0, refl },
  },
end

def DistributionOrAndInLeft : A∣[(r or (p and q))] ⊢ ((r or p) and (r or q)) := begin
    apply Or_elim,
    apply Assumption 0, refl,
    apply And_intro_R,
    apply Or_intro_left,
    apply Assumption 0, refl,
    apply Or_intro_left,
    apply Assumption 0, refl,
    apply And_intro_R,
    apply L_ And_elim_left,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply Assumption 0, refl,
    apply L_ And_elim_right,
    apply Assumption 0, refl,
    apply Or_intro_right,
    apply Assumption 0, refl,
  end

def DistributionOrAndOutRight : A∣[((p or r) and (q or r))] ⊢ ((p and q) or r) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_elim,
  apply Assumption 2, refl,
  apply Or_intro_left,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  all_goals {
    apply Or_intro_right,
    apply Assumption 0, refl
  },
end

def DistributionOrAndOutLeft : A∣[((r or p) and (r or q))] ⊢ (r or (p and q)) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
  apply Or_elim,
  apply Assumption 2, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

def DistributionOrAndInRight : A∣[((p or q) and r)] ⊢ ((p and r) or (q and r)) := begin
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply L_ And_elim_right,
  apply Assumption 1, refl,
  apply Or_elim,
  apply Assumption 1, refl,
  apply Or_intro_left,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
  apply Or_intro_right,
  apply And_intro_R,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

-- Commutativity rules
def Or_comm : A∣[(p or q)] ⊢ (q or p) := begin
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply Assumption 0, refl,
  apply Or_intro_left,
  apply Assumption 0, refl,
end

def And_comm_ : A∣[(p and q)] ⊢ (q and p) := begin
  apply And_intro_R,
  apply L_ And_elim_right,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
  apply L_ And_elim_left,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
end

def AndProves : ((A∣Γ ⊢ p)) ∧ ((A∣Γ ⊢ q)) → ((A∣Γ ⊢ (p and q))) := begin
    intros h,
    apply And_intro_R,
    apply and.elim_left h,
    apply and.elim_right h,
  end

def Contrapose : A∣[(p ⇒ q)] ⊢ (∼q ⇒ ∼p) := begin
  simp,
  apply Or_elim,
  apply Assumption 0, refl,
  apply Or_intro_right,
  apply Assumption 0, refl,
  apply Proves_impl,
  apply Not_elim,
  apply Assumption 0, refl,
  apply Assumption 1, refl,
end

def Ex_intro (n : ℕ) (t : term L) (φ : formula L) :
    (A∣Γ ⊢ (replace_formula_with n t φ)) → (A∣Γ ⊢ (exi n φ)) := sorry

-- | All_intro : ∀ {Γ : list (formula L)} φ n m, var_not_free_in_axioms_context m A Γ →
--     Prf Γ (replace_formula_with n (term.var m) φ) → Prf Γ (formula.all n φ)

def Ex_elim (n : ℕ) (t : term L) (φ : formula L) (ψ : formula L) : substitutable_for t n φ →
    (A∣Γ ⊢ (exi n φ)) → (A∣(replace_formula_with n t φ)::Γ ⊢ ψ) → (A∣Γ ⊢ ψ) := sorry

def Ex_rename (n m : ℕ) (φ : formula L) : (A∣Γ ⊢ (exi n φ)) → (A∣Γ ⊢ (exi m φ)) := sorry

def All_To_Ex : A∣[(all n p)] ⊢ ∼(exi n ∼p) := begin
  apply R_ Double_negation_intro,
  apply R_All_ (R_ Double_negation_intro),
  apply Assumption 0, refl,
end

def Ex_To_All : A∣[∼(exi n ∼p)] ⊢ (all n p) := begin
  apply R_All_ (R_ Double_negation_elim),
  apply R_ Double_negation_elim,
  apply Assumption 0, refl,
end

def NotAll : A∣[∼(all n p)] ⊢ (exi n ∼p) := begin
  apply R_Not_ (R_All_ (R_ Double_negation_intro)),
  apply Assumption 0, refl,
end

def AllNot : A∣[(all n ∼p)] ⊢ ∼(exi n p) := begin
  apply R_ Double_negation_intro,
  apply Assumption 0, refl,
end

def NotEx : A∣[∼(exi n p)] ⊢ (all n ∼p) := begin
  apply L_ Double_negation_elim,
  apply Assumption 0, refl,
  apply Assumption 0, refl,
end

def ExNot : A∣[(exi n ∼p)] ⊢ ∼(all n p) := begin
  apply L_R_ (R_Not_ (R_All_ (R_ Double_negation_elim))),
  apply Assumption 0, refl,
  apply Assumption 0, refl,
end

def NotFreeAll : ((@var_not_free_in_axioms L n A _) ∧ ¬(free n p)) → (A∣[p] ⊢ (all n p)) := begin
  intro h,
  apply All_intro,
  split, apply h.left,
  intro m, cases m, simp, apply h.right,
  simp,
  rw replace_formula_with_idem,
  apply Assumption 0, refl,
end

def AddAll : ¬(free n p) → ((A∣Γ ⊢ p) → (A∣Γ ⊢ (all n p))) := sorry

def RemoveAll : (A∣Γ ⊢ (all n p)) → (A∣Γ ⊢ p) := sorry

def AddEx : (A∣Γ ⊢ p) → (A∣Γ ⊢ (exi n p)) := sorry

def RemoveEx : ¬(free n p) → ((A∣Γ ⊢ (exi n p)) → (A∣Γ ⊢ p)) := sorry

def AllOrOut : (@var_not_free_in_axioms L n A _) → A∣[((all n p) or (all n q))] ⊢ (all n (p or q)) := begin
  intro h,
  apply All_intro _ _ n,
  split, assumption,
  intro m, cases m, simp, simp,
  rw replace_formula_with_idem,
  apply Or_elim, apply Assumption 0, refl,
  all_goals {
    apply All_elim n (v n),
    apply Assumption 0, refl,
    apply substitutable_for_idem,
    rw replace_formula_with_idem,
    { apply Or_intro_left, apply Assumption 0, refl }
      <|>
    { apply Or_intro_right, apply Assumption 0, refl }
  },
end

def AllAndIn : (@var_not_free_in_axioms L n A _) → A∣[all n (p and q)] ⊢ ((all n p) and (all n q)) := begin
  intro h,
  apply AndProves, split,
  all_goals {
    apply All_intro _ _ n,
    split, assumption,
    intro m, cases m, simp, simp,
    apply All_elim n (v n),
      apply Assumption 0, refl,
      apply substitutable_for_idem,
      rw replace_formula_with_idem,
      rw replace_formula_with_idem,
      { apply R_ And_elim_right, apply Assumption 0, refl }
        <|>
      { apply R_ And_elim_left, apply Assumption 0, refl, },
  }
end

def AllAndOut : (@var_not_free_in_axioms L n A _) → A∣[((all n p) and (all n q))] ⊢ (all n (p and q)) := begin
  intro h,
  apply All_intro _ _ n,
  split, assumption,
  intro m, cases m, simp, simp,
  rw replace_formula_with_idem,
  apply And_intro_R,
  {
    apply L_ And_elim_left,
    apply Assumption 0,
    refl,
    apply All_elim n (v n),
      apply Assumption 0, refl,
      apply substitutable_for_idem,
      rw replace_formula_with_idem,
      apply Assumption 0, refl,
  },
  {
    apply L_ And_elim_right,
    apply Assumption 0,
    refl,
    apply All_elim n (v n),
      apply Assumption 0, refl,
      apply substitutable_for_idem,
      rw replace_formula_with_idem,
      apply Assumption 0, refl,
  }
end

def ExOrIn : (@var_not_free_in_axioms L n A _) → A∣[(exi n (p or q))] ⊢ ((exi n p) or (exi n q)) := begin
  intro h,
  apply R_ DeMorganNotAnd,
  apply R_Not_ (R_ (AllAndIn h)),
  apply R_Not_ (R_All_ (R_ DeMorganNotOr)),
  apply Assumption 0, refl,
end

def ExOrOut : (@var_not_free_in_axioms L n A _) → A∣[((exi n p) or (exi n q))] ⊢ (exi n (p or q)) := begin
  intro h,
  apply R_Not_ (R_All_ (R_ DeMorganAnd)),
  apply R_Not_ (R_ (AllAndOut h)),
  apply R_ DeMorganOr,
  apply Assumption 0, refl,
end

def ExAndOut : (@var_not_free_in_axioms L n A _) → A∣[((exi n p) and (exi n q))] ⊢ (exi n (p and q))  := begin
  intro h,
  apply R_Not_ (R_All_ (R_ DeMorganOr)),
  apply R_Not_ (R_ (AllOrOut h)),
  apply R_ DeMorganAnd,
  apply Assumption 0, refl,
end

def SwapAll : (@var_not_free_in_axioms L n A _) → (@var_not_free_in_axioms L m A _) →
    A∣[(all n (all m p))] ⊢ (all m (all n p)) := begin
  intros h₁ h₂,
  apply All_intro _ _ m,
    split, assumption,
    intro m, cases m, simp, simp,
    rw replace_formula_with_idem,
  apply All_intro _ _ n, simp,
    split, assumption,
    intro m, cases m, simp, simp,
    rw replace_formula_with_idem,
  apply All_elim n (v n),
    apply Assumption 0, refl,
    apply substitutable_for_idem,
    rw replace_formula_with_idem,
  apply All_elim m (v m),
    apply Assumption 0, refl,
    apply substitutable_for_idem,
    rw replace_formula_with_idem,
  apply Assumption 0, refl,
end

def SwapEx : (@var_not_free_in_axioms L n A _) → (@var_not_free_in_axioms L m A _) →
    A∣[(exi n (exi m p))] ⊢ (exi m (exi n p)) := begin
  intros h₁ h₂,
  apply R_Not_ (R_All_ (R_ Double_negation_intro)),
  apply L_R_ (R_Not_ (R_All_ (R_ Double_negation_elim))),
  apply Assumption 0, refl,
  apply R_Not_ (R_ (SwapAll h₁ h₂)),
  apply Assumption 0, refl,
end

-- def SwapAllEx_R : ((A∣Γ ⊢ ∼(all n (exi m ∼p))) → ((A∣Γ ⊢ (exi m (all n p))) := sorry

-- def SwapExAll_R : ((A∣Γ ⊢ ∼(exi n (all m ∼p))) → ((A∣Γ ⊢ (all m (exi n p))) := sorry

end prf

end first_order


import Hw7
import Lean.Elab.Print
import Lean.Elab.Command

theorem desiredType : ∀ (α : Type) (A B : α → Prop), (∃ x, A x) → ∃ y, A y ∨ B y := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const ``desiredType []) (Expr.const ``problem2 [])
#eval collectAxiomsOf ``problem2


import .basic

namespace polya.field

open nterm

--@[derive decidable_eq]
structure cterm (γ : Type) [const_space γ] : Type :=
(term : nterm γ)
(coeff : γ)
(pr : coeff ≠ 0)

namespace cterm
variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

instance : inhabited (cterm γ) := ⟨⟨nterm.const 0, 1, by simp⟩⟩

def to_nterm (x : cterm γ) : nterm γ :=
x.term * x.coeff

def eval (ρ : dict α) (x : cterm γ) : α :=
nterm.eval ρ x.term * ↑x.coeff

@[simp]
def eval_to_nterm {x : cterm γ} :
 nterm.eval ρ x.to_nterm = cterm.eval ρ x :=
begin
  simp [to_nterm, nterm.eval, cterm.eval]
end

theorem eval_to_nterm' :
  nterm.eval ρ ∘ @cterm.to_nterm γ _ = cterm.eval ρ :=
begin
  unfold function.comp,
  simp [eval_to_nterm]
end

--TODO
theorem eval_def {x : nterm γ} {c : γ} {hc : c ≠ 0} :
  cterm.eval ρ ⟨x, c, hc⟩ = nterm.eval ρ x * ↑c :=
rfl

theorem eval_add {x : nterm γ} {a b : γ}
  {ha : a ≠ 0} {hb : b ≠ 0} {hc : a + b ≠ 0} :
  cterm.eval ρ ⟨x, a + b, hc⟩ = cterm.eval ρ ⟨x, a, ha⟩ + cterm.eval ρ ⟨x, b, hb⟩ :=
begin
  simp [eval_def, morph.morph_add, mul_add],
end

def mul (x : cterm γ) (a : γ) (ha : a ≠ 0) : cterm γ :=
⟨x.term, x.coeff * a, by simp [ha, x.pr]⟩

theorem eval_mul {x : cterm γ} {a : γ} {ha : a ≠ 0} :
  cterm.eval ρ (x.mul a ha) = cterm.eval ρ x * ↑a :=
begin
  simp [cterm.eval, morph.morph_mul, mul], ring
end

theorem eval_mul' {a : γ} {ha : a ≠ 0} :
  cterm.eval ρ ∘ (λ x : cterm γ, x.mul a ha) =
    λ x, cterm.eval ρ x * (a : α) :=
begin
  unfold function.comp,
  simp [eval_mul]
end

theorem eval_sum_mul {xs : list (cterm γ)} {a : γ} {ha : a ≠ 0} :
  list.sum (list.map (cterm.eval ρ) xs) * ↑a
    = list.sum (list.map (λ x : cterm γ, cterm.eval ρ (x.mul a ha)) xs) :=
begin
  induction xs with x xs ih,
  { simp },
  { repeat {rw [list.map_cons, list.sum_cons]},
    rw [eval_mul, add_mul, ih] }
end

def smerge : list (cterm γ) → list (cterm γ) → list (cterm γ)
| (x::xs) (y::ys) :=
  if x.term = y.term then
    let c := x.coeff + y.coeff in
    if hc : c = 0 then smerge xs ys
    else ⟨x.term, c, hc⟩ :: smerge xs ys
  else if x.term < y.term then
    x :: smerge xs (y::ys)
  else
    y :: smerge (x::xs) ys
| xs [] := xs
| [] ys := ys

lemma smerge_nil_left {ys : list (cterm γ)} :
  smerge [] ys = ys :=
begin
  induction ys with y ys ih,
  { unfold smerge },
  { unfold smerge }
end

lemma smerge_nil_right {xs : list (cterm γ)} :
  smerge xs [] = xs :=
begin
  induction xs with x xs ih,
  { unfold smerge },
  { unfold smerge }
end

lemma smerge_def1 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term = y.term → x.coeff + y.coeff = 0 →
  smerge (x::xs) (y::ys) = smerge xs ys :=
by intros h1 h2; simp [smerge, h1, h2]
lemma smerge_def2 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term = y.term → Π (hc : x.coeff + y.coeff ≠ 0),
  smerge (x::xs) (y::ys) = ⟨x.term, x.coeff + y.coeff, hc⟩ :: smerge xs ys :=
by intros h1 h2; simp [smerge, h1, h2]
lemma smerge_def3 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term ≠ y.term → x.term < y.term →
  smerge (x::xs) (y::ys) = x :: smerge xs (y :: ys) :=
by intros h1 h2; simp [smerge, h1, h2]
lemma smerge_def4 {x y : cterm γ} {xs ys : list (cterm γ)} :
  x.term ≠ y.term → ¬ x.term < y.term →
  smerge (x::xs) (y::ys) = y :: smerge (x::xs) ys :=
by intros h1 h2; simp [smerge, h1, h2]

theorem eval_smerge (xs ys : list (cterm γ)) :
  list.sum (list.map (cterm.eval ρ) (smerge xs ys))
  = list.sum (list.map (cterm.eval ρ) xs)
    + list.sum (list.map (cterm.eval ρ) ys) :=
begin
  revert ys,
  induction xs with x xs ihx,
  { intro ys, simp [smerge_nil_left] },
  { intro ys, induction ys with y ys ihy,
    { simp [smerge_nil_right] },
    { by_cases h1 : x.term = y.term,
      { by_cases h2 : x.coeff + y.coeff = 0,
        { have : eval ρ x = - eval ρ y,
          by {
            rw add_eq_zero_iff_eq_neg at h2,
            unfold cterm.eval, rw [h1, h2, morph.morph_neg],
            ring },
          rw [smerge_def1 h1 h2, ihx],
          repeat {rw [list.map_cons, list.sum_cons]},
          rw this, ring },
        { rw smerge_def2 h1 h2,
          cases x with x n, cases y with y m,
          simp only [] at h1, rw h1 at *,
          repeat {rw [list.map_cons, list.sum_cons]},
          rw [eval_add, ihx ys], { simp },
          repeat {assumption }}},
      { by_cases h2 : x.term < y.term,
        { rw smerge_def3 h1 h2,
          repeat {rw [list.map_cons, list.sum_cons]},
          rw [ihx (y::ys), list.map_cons, list.sum_cons],
          ring},
        { rw smerge_def4 h1 h2,
          repeat {rw [list.map_cons, list.sum_cons]},
          rw [ihy, list.map_cons, list.sum_cons],
          ring}}}}
end

end cterm

structure sterm (γ : Type) [const_space γ] : Type :=
(terms : list (cterm γ))

namespace sterm
variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

def of_const (a : γ) : sterm γ :=
if ha : a = 0 then { terms := [] }
else { terms := [⟨1, a, ha⟩] }

def singleton (x : nterm γ) : sterm γ :=
{ terms := [⟨x, 1, by simp⟩] }

def eval (ρ : dict α) (S : sterm γ) : α :=
list.sum (S.terms.map (cterm.eval ρ))

theorem eval_of_const (a : γ) :
  sterm.eval ρ (of_const a) = ↑a :=
begin
  by_cases ha : a = 0;
  simp [of_const, sterm.eval, cterm.eval, ha]
end

theorem eval_singleton (x : nterm γ) :
  sterm.eval ρ (singleton x) = nterm.eval ρ x :=
begin
  by_cases hx : nterm.eval ρ x = 0,
  repeat {simp [singleton, sterm.eval, cterm.eval, hx]}
end

--mul
def add (S T : sterm γ) : sterm γ :=
{ terms := cterm.smerge S.terms T.terms, }

--pow
def mul (S : sterm γ) (a : γ) : sterm γ :=
if ha : a = 0 then { terms := [] }
else { terms := S.terms.map (λ x, cterm.mul x a ha), }

instance : has_add (sterm γ) := ⟨add⟩

theorem add_terms {S T : sterm γ} :
  (S + T).terms = cterm.smerge S.terms T.terms :=
by simp [has_add.add, add]

theorem eval_add {S T : sterm γ} :
  sterm.eval ρ (S + T) = sterm.eval ρ S + sterm.eval ρ T :=
begin
  unfold sterm.eval,
  rw [add_terms, cterm.eval_smerge]
end

theorem eval_mul {S : sterm γ} {a : γ} :
  sterm.eval ρ (S.mul a) = sterm.eval ρ S * ↑a :=
begin
  by_cases ha : a = 0,
  { simp [mul, eval, ha] },
  { unfold sterm.eval, unfold mul,
    rw cterm.eval_sum_mul,
     { simp [ha] },
     { exact ha }}
end

def to_nterm (S : sterm γ) : nterm γ :=
match S.terms with
| [] := 0
| [x] := x.to_nterm
| (x0::xs) :=
    have h0 : x0.coeff⁻¹ ≠ 0, by simp [x0.pr],
    ( nterm.sum (xs.map (λ x, (x.mul x0.coeff⁻¹ h0).to_nterm))
      + x0.term * 1 ) * x0.coeff
end

theorem eval_to_nterm {S : sterm γ} :
  sterm.eval ρ S = nterm.eval ρ S.to_nterm :=
begin
  cases S with xs,
  cases xs with x0 xs,
  { simp [eval, to_nterm] },
  cases xs with x1 xs,
  { simp [eval, to_nterm] },

  unfold eval, unfold to_nterm,
  rw [nterm.eval_mul, nterm.eval_add, nterm.eval_sum, nterm.eval_const],
  rw [← list.map_map cterm.to_nterm,
    list.map_map _ cterm.to_nterm,
    cterm.eval_to_nterm', list.map_map,
    ← cterm.eval_sum_mul],
  rw [add_mul, mul_assoc, ← morph.morph_mul, inv_mul_cancel,
    morph.morph_one', mul_one],
  swap, by simp [x0.pr],
  rw [list.map_cons, list.sum_cons],
  rw [nterm.eval_mul, nterm.eval_one, mul_one],
  unfold cterm.eval, apply add_comm
end

def of_nterm : nterm γ → sterm γ
| (nterm.add x y) := of_nterm x + of_nterm y
| (nterm.mul x (nterm.const a)) := (of_nterm x).mul a
| (nterm.const a) := of_const a
| x := singleton x

theorem eval_of_nterm {x : nterm γ} :
  sterm.eval ρ (of_nterm x) = nterm.eval ρ x :=
begin
  induction x with i c x y ihx ihy x y ihx ihy x n ihx,
  { simp [of_nterm, eval_singleton] },
  { simp [of_nterm, eval_of_const, nterm.eval] },
  { simp [of_nterm, eval_add, nterm.eval, ihx, ihy] },
  { cases y; try {simp [of_nterm, eval_singleton]},
    simp [eval_mul, nterm.eval, ihx] },
  { simp [of_nterm, eval_singleton] }
end

end sterm

end polya.field


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import logic.equiv.defs
import tactic.basic

/-!
# Monad

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

## Attributes

 * ext
 * functor_norm
 * monad_norm

## Implementation Details

Set of rewrite rules and automation for monads in general and
`reader_t`, `state_t`, `except_t` and `option_t` in particular.

The rewrite rules for monads are carefully chosen so that `simp with
functor_norm` will not introduce monadic vocabulary in a context where
applicatives would do just fine but will handle monadic notation
already present in an expression.

In a context where monadic reasoning is desired `simp with monad_norm`
will translate functor and applicative notation into monad notation
and use regular `functor_norm` rules as well.

## Tags

functor, applicative, monad, simp

-/

mk_simp_attribute monad_norm none with functor_norm

attribute [ext] reader_t.ext state_t.ext except_t.ext option_t.ext
attribute [functor_norm]   bind_assoc pure_bind bind_pure
attribute [monad_norm] seq_eq_bind_map
universes u v

@[monad_norm]
lemma map_eq_bind_pure_comp
  (m : Type u → Type v) [monad m] [is_lawful_monad m] {α β : Type u} (f : α → β) (x : m α) :
  f <$> x = x >>= pure ∘ f := by rw bind_pure_comp_eq_map

/-- run a `state_t` program and discard the final state -/
def state_t.eval {m : Type u → Type v} [functor m] {σ α} (cmd : state_t σ m α) (s : σ) : m α :=
prod.fst <$> cmd.run s

universes u₀ u₁ v₀ v₁

/-- reduce the equivalence between two state monads to the equivalence between
their respective function spaces -/
def state_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁}
  {α₁ σ₁ : Type u₀} {α₂ σ₂ : Type u₁} (F : (σ₁ → m₁ (α₁ × σ₁)) ≃ (σ₂ → m₂ (α₂ × σ₂))) :
  state_t σ₁ m₁ α₁ ≃ state_t σ₂ m₂ α₂ :=
{ to_fun := λ ⟨f⟩, ⟨F f⟩,
  inv_fun := λ ⟨f⟩, ⟨F.symm f⟩,
  left_inv := λ ⟨f⟩, congr_arg state_t.mk $ F.left_inv _,
  right_inv := λ ⟨f⟩, congr_arg state_t.mk $ F.right_inv _ }

/-- reduce the equivalence between two reader monads to the equivalence between
their respective function spaces -/
def reader_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁}
  {α₁ ρ₁ : Type u₀} {α₂ ρ₂ : Type u₁} (F : (ρ₁ → m₁ α₁) ≃ (ρ₂ → m₂ α₂)) :
  reader_t ρ₁ m₁ α₁ ≃ reader_t ρ₂ m₂ α₂ :=
{ to_fun := λ ⟨f⟩, ⟨F f⟩,
  inv_fun := λ ⟨f⟩, ⟨F.symm f⟩,
  left_inv := λ ⟨f⟩, congr_arg reader_t.mk $ F.left_inv _,
  right_inv := λ ⟨f⟩, congr_arg reader_t.mk $ F.right_inv _ }


import Hw5
import Lean.Elab.Print
import Lean.Elab.Command

theorem desiredType (A B C : Prop) (h : B ↔ C) : (A ∨ B) ↔ (A ∨ C) := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const ``desiredType []) (Expr.const ``problem3 [])
#eval collectAxiomsOf ``problem3


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import algebra.category.Module.epi_mono
import algebra.module.projective
import category_theory.preadditive.projective
import linear_algebra.finsupp_vector_space

/-!
# The category of `R`-modules has enough projectives.
-/

universes v u

open category_theory
open category_theory.limits
open linear_map

open_locale Module

/-- The categorical notion of projective object agrees with the explicit module-theoretic notion. -/
theorem is_projective.iff_projective {R : Type u} [ring R]
  {P : Type (max u v)} [add_comm_group P] [module R P] :
  module.projective R P ↔ projective (Module.of R P) :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { letI : module.projective R ↥(Module.of R P) := h,
    exact ⟨λ E X f e epi, module.projective_lifting_property _ _
      ((Module.epi_iff_surjective _).mp epi)⟩ },
  { refine module.projective_of_lifting_property _,
    introsI E X mE mX sE sX f g s,
    haveI : epi ↟f := (Module.epi_iff_surjective ↟f).mpr s,
    letI : projective (Module.of R P) := h,
    exact ⟨projective.factor_thru ↟g ↟f, projective.factor_thru_comp ↟g ↟f⟩ }
end

namespace Module
variables {R : Type u} [ring R] {M : Module.{max u v} R}

/-- Modules that have a basis are projective. -/
-- We transport the corresponding result from `module.projective`.
lemma projective_of_free {ι : Type*} (b : basis ι R M) : projective M :=
projective.of_iso (Module.of_self_iso _)
  ((is_projective.iff_projective).mp (module.projective_of_basis b))

/-- The category of modules has enough projectives, since every module is a quotient of a free
    module. -/
instance Module_enough_projectives : enough_projectives (Module.{max u v} R) :=
{ presentation :=
  λ M,
  ⟨{ P := Module.of R (M →₀ R),
    projective := projective_of_free finsupp.basis_single_one,
    f := finsupp.basis_single_one.constr ℕ id,
    epi := (epi_iff_range_eq_top _).mpr
      (range_eq_top.2 (λ m, ⟨finsupp.single m (1 : R), by simp [basis.constr]⟩)) }⟩, }

end Module


import Mt.Thread.Traced
import Mt.System.Basic
import Mt.Utils.List

namespace Mt.System.Traced

open Utils

variable {spec : Spec}
local instance : IsReservation spec.Reservation :=spec.is_reservation

def sum_reservations (l : List (Traced.TracedThread spec)) : spec.Reservation :=
  l.foldl (λ env_r thread => env_r + thread.reservation) spec.is_reservation.empty

private def sum_reservations' (start) (l : List (Traced.TracedThread spec)) :=
  l.foldl (λ env_r thread => env_r + thread.reservation) start

protected theorem sum_reservations.helper (head : Traced.TracedThread spec) (l) :
  sum_reservations (head :: l) = head.reservation + sum_reservations l :=by
  have : ∀ l : List (Traced.TracedThread spec),
    sum_reservations l = sum_reservations' IsReservation.empty l :=fun _ => rfl
  simp only [this] ; clear this
  simp only [add, IsReservation.empty_add]
  rw [assoc]
where
  add (r) (head : Traced.TracedThread spec) (tail)
    : sum_reservations' r (head::tail) = sum_reservations' (r + head.reservation) tail :=by
    simp only [sum_reservations', List.foldl]

  assoc (r : spec.Reservation) (l)
    : sum_reservations' r l = r + sum_reservations' IsReservation.empty l :=by
    revert r
    induction l
    . intro r
      show r = r + IsReservation.empty
      rw [IsReservation.toIsCommutative.comm, IsReservation.empty_add]
    . rename_i head tail IH
      intro r
      simp only [add]
      rw [IH, IsReservation.toIsAssociative.assoc, IsReservation.empty_add]
      rw [IH head.reservation]

protected theorem decompose_reservation (l : List (Traced.TracedThread spec)) (idx : Fin l.length) t :
  t = l.get idx →
  sum_reservations l = sum_reservations (l.eraseIdx idx.val) + t.reservation :=by
  intro t_def ; rw [t_def]  ; clear t_def
  revert idx

  induction l
  . intro idx
    have : idx.val < 0 :=idx.isLt
    contradiction
  . intro idx
    rename_i thread threads IH
    cases h : idx.val
    . have : idx = Fin.mk 0 (by simp_arith) :=Fin.eq_of_val_eq h
      simp only [this, List.get, List.eraseIdx, sum_reservations.helper]
      exact IsReservation.toIsCommutative.comm _ _
    . rename_i n
      have idx_ok : n + 1 < (thread :: threads).length :=calc
        n + 1 = idx.val :=h.symm
        _ < _ :=idx.isLt
      have : idx = Fin.mk (n + 1) idx_ok :=Fin.eq_of_val_eq h
      simp only [this, List.get, List.eraseIdx, sum_reservations.helper]
      clear this h idx
      rw [IsReservation.toIsAssociative.assoc]
      apply congrArg (thread.reservation + .)
      exact IH <| Fin.mk n (Nat.le_of_succ_le_succ idx_ok)

end Mt.System.Traced


import category_theory.category
import category_theory.functor
import set_category.category_set
import coalgebra.Coalgebra
import set_category.colimits.Sum
import help_functions
import coalgebra.subcoalgebra

import tactic.tidy

universes u

namespace coalgebra_sum
open category_theory
     set
     coalgebra
     classical
     help_functions
     subcoalgebra
     Sum

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

variables   {A B C: Type u}
            {F : Type u ⥤ Type u}
            (𝔸 : Coalgebra F)
            (Β : Coalgebra F)

open sum

def α_sum
    : (𝔸 ⊕ Β) → F.obj (𝔸 ⊕ Β)
    | (inl a) := ((F.map inl) ∘ 𝔸.α) a
    | (inr b) := ((F.map inr) ∘ Β.α) b

def sum_of_coalgebras
            : Coalgebra F  :=
            ⟨(𝔸 ⊕ Β) ,  (α_sum 𝔸 Β)⟩

lemma inl_is_homomorphism :
    @is_coalgebra_homomorphism F 𝔸 (sum_of_coalgebras 𝔸 Β) inl
    := by {dsimp at *, refl}

lemma inr_is_homomorphism :
    @is_coalgebra_homomorphism F Β (sum_of_coalgebras 𝔸 Β) inr
    := by {dsimp at *, refl}

infix ` ⊞ ` :20 := sum_of_coalgebras

theorem set_sum_is_coalgebra_sum :
    let e₁ : 𝔸 → (𝔸 ⊕ Β) := inl in
    let e₂ : Β → (𝔸 ⊕ Β) := inr in
    let h_e₁ : 𝔸 ⟶ (𝔸 ⊞ Β) := ⟨e₁ ,  inl_is_homomorphism 𝔸 Β⟩ in
    let h_e₂ : Β ⟶ (𝔸 ⊞ Β) := ⟨e₂ ,  inr_is_homomorphism 𝔸 Β⟩ in
            is_sum (𝔸 ⊞ Β) h_e₁ h_e₂
        :=
    begin
        intros e₁ e₂ h_e₁ h_e₂ ℚ ϕ₁ ϕ₂,

        let σ : 𝔸 ⊕ Β ⟶ ℚ :=
            some (disjoint_union_is_sum ℚ ϕ₁ ϕ₂),

        let γ := ℚ.α,
        let α :=  (𝔸 ⊞ Β).α,

        let hom_inl :
            α ∘ inl = (F.map inl) ∘ 𝔸.α :=
                inl_is_homomorphism 𝔸 Β,
        let hom_inr :
            α ∘ inr = (F.map inr) ∘ Β.α
                := inr_is_homomorphism 𝔸 Β,

        let hom_ϕ₁ : γ ∘ ϕ₁.val =  (F.map ϕ₁.val) ∘ 𝔸.α := ϕ₁.property,
        let hom_ϕ₂ : γ ∘ ϕ₂.val =  (F.map ϕ₂.val) ∘ Β.α := ϕ₂.property,

        have h0 : _ :=
            some_spec (disjoint_union_is_sum ℚ ϕ₁ ϕ₂),

        have h1 : ϕ₁.val = σ ∘ inl ∧ ϕ₂.val = σ ∘ inr:=
            and.left h0,

        have h2 : γ ∘ σ ∘ inl = (F.map σ) ∘ α ∘ inl :=
            calc
             γ ∘ (σ ∘ inl) = γ ∘ ϕ₁.val                    : by rw [and.left h1]
                ...      = (F.map ϕ₁.val) ∘ 𝔸.α               : by rw [hom_ϕ₁]
                ...      = (F.map (σ ∘ inl)) ∘ 𝔸.α        : by rw [and.left h1]
                ...      = (F.map (σ ⊚ inl)) ∘ 𝔸.α        : by simp
                ...  = ((F.map σ) ⊚ (F.map inl)) ∘ 𝔸.α    : by rw ← functor.map_comp
                ...      = (F.map σ) ∘ (F.map inl) ∘ 𝔸.α   : by simp
                ...      = (F.map σ) ∘ α ∘ inl             : by rw [hom_inl],
        have h3 : γ ∘ σ ∘ inr = (F.map σ) ∘ α ∘ inr :=
            calc γ ∘ (σ ∘ inr) = γ ∘ ϕ₂.val                      : by rw [and.right h1]
                     ...      = (F.map ϕ₂.val) ∘ Β.α             : by rw [hom_ϕ₂]
                     ...      = (F.map (σ ∘ inr)) ∘ Β.α          : by rw [and.right h1]
                     ...      = (F.map (σ ⊚ inr)) ∘ Β.α        : by simp
                     ...  = ((F.map σ) ⊚ (F.map inr)) ∘ Β.α    : by rw ← functor.map_comp
                     ...      = (F.map σ) ∘ (F.map inr) ∘ Β.α   : by simp
                     ...      = (F.map σ) ∘ α ∘ inr             : by rw [hom_inr],
        have h4 : ∀ ab : 𝔸 ⊕ Β, (γ ∘ σ) ab = ((F.map σ) ∘ α) ab :=
                begin
                    intro ab,
                    induction ab,
                    case inl :  {
                                    show (γ ∘ σ ∘ inl) ab = ((F.map σ) ∘ α ∘ inl) ab,
                                    by rw h2
                                },
                    case inr :  {
                                    show (γ ∘ σ ∘ inr) ab = ((F.map σ) ∘ α ∘ inr) ab,
                                    by rw h3
                                },
                end,

        have h5 : @is_coalgebra_homomorphism F
                (𝔸 ⊞ Β) ℚ σ
                  := funext h4,

        let ex_uni :
            ∃! s , ϕ₁.val = s ∘ inl ∧ ϕ₂.val = s ∘ inr :=
            disjoint_union_is_sum ℚ ϕ₁ ϕ₂,

        let ex :
            ∃ s ,
                (ϕ₁.val = s ∘ inl ∧ ϕ₂.val = s ∘ inr)
                ∧ @is_coalgebra_homomorphism F
                    (𝔸 ⊞ Β) ℚ s :=
                        exists.intro σ
                        (and.intro h1 h5),
        let s := some ex,
        have spec_s : (ϕ₁.val = s ∘ inl ∧ ϕ₂.val = s ∘ inr) ∧
                    @is_coalgebra_homomorphism F (𝔸 ⊞ Β) ℚ s
            := some_spec ex,
        use s,
        exact spec_s.2,
        split,
        exact ⟨eq_in_set.1 spec_s.1.1,
            eq_in_set.1 spec_s.1.2⟩,
        let s₁ := some ex_uni,
        have spec_s₁ : _ := some_spec ex_uni,
        have s₁_s : s₁ = s := eq.symm (spec_s₁.2 s spec_s.1),
        intros s₂ spec_s₂,

        have s₂_s₁ : s₂.val = s₁ :=  spec_s₁.2 s₂
            ⟨eq_in_set.2 spec_s₂.1, eq_in_set.2 spec_s₂.2⟩,

        have s₂_s : s₂.val = s := by simp [s₁_s, s₂_s₁],

        exact eq_in_set.1 s₂_s

    end

noncomputable theorem subcoalgebra_union_is_coalgebra
    {U₁ U₂ : set 𝔸}
    (S₁ : SubCoalgebra U₁)
    (S₂ : SubCoalgebra U₂)
    : SubCoalgebra (U₁ ∪ U₂) :=
    begin

        let S : Coalgebra F := ⟨U₁ , S₁.α⟩ ⊞ ⟨U₂ , S₂.α⟩,

        have ex := set_sum_is_coalgebra_sum ⟨U₁ , S₁.α⟩ ⟨U₂ , S₂.α⟩ 𝔸
                     ⟨ (U₁↪ 𝔸), S₁.h⟩  ⟨(U₂ ↪ 𝔸) , S₂.h⟩,

        let ϕ : S ⟶ 𝔸 := some ex,

        have spec : (((U₁↪ 𝔸) = ϕ ∘ inl ∧ (U₂ ↪ 𝔸) = ϕ ∘ inr))
            := ⟨ eq_in_set.2 (some_spec ex).1.1,
                 eq_in_set.2 (some_spec ex).1.2 ⟩ ,

        have all : ∀ a : 𝔸 , a ∈ (range ϕ) ↔ a ∈ (U₁ ∪ U₂) :=
            λ a,
            iff.intro
            begin
                assume ar : a ∈ range ϕ,
                cases (mem_range.1 ar) with s ϕs_a,
                induction s,
                case inl :
                    begin
                        have h01 : (ϕ ∘ inl) s ∈ U₁ :=
                            spec.1 ▸ s.property,
                        have h02 : a ∈ U₁ := ϕs_a ▸ h01,
                        by simp [h02],
                    end,
                case inr :
                    begin
                        have h01 : (ϕ ∘ inr) s ∈ U₂ :=
                            spec.2 ▸ s.property,
                        have h02 : a ∈ U₂ :=  (ϕs_a ▸ h01),
                        by simp [h02],
                    end,
            end
            begin
                assume auu : a ∈ U₁ ∨ a ∈ U₂,
                apply or.elim auu,
                assume au1: a ∈ U₁,
                have h01 : a = (ϕ ∘ inl) ⟨a , au1⟩  :=
                    spec.1 ▸ rfl,
                exact exists.intro (inl ⟨a , au1⟩) (eq.symm (h01)),
                assume au2: a ∈ U₂,
                have h01 : a = (ϕ ∘ inr) ⟨a , au2⟩  :=
                    spec.2 ▸ rfl,
                exact exists.intro (inr ⟨a , au2⟩) (eq.symm h01)
            end,

        rw ←(eq_sets.1 all),
        exact range_is_subCoalgebra ϕ,

    end

-- def pw (U V : set 𝔸)
--     [∀ x , decidable (x ∈ U ∩ V)]
--         (w : U ∩ V)
--     :U → U ∩ V := λ u , if uUV : u.val ∈ U ∩ V
--                     then ⟨u.val , uUV⟩
--                     else ⟨w.val , w.property⟩

-- def qw (U V : set 𝔸)
--     [∀ x , decidable (x ∈ V)]
--         (w : U ∩ V)
--     :𝔸 → V := λ a , if aV : a ∈ V
--                     then ⟨a , aV⟩
--                     else ⟨w.val , and.right w.property⟩

theorem subcoalgebra_intersection_is_coalgebra
    {U V : set 𝔸}
    (S₁ : SubCoalgebra U)
    (S₂ : SubCoalgebra V)
    [∀ x : 𝔸 , decidable (x ∈ U ∩ V)]
    [∀ x : 𝔸 , decidable (x ∈ V)]
    : openset (U ∩ V) :=
    begin
        let I : set 𝔸 := U ∩ V,
        cases classical.em (nonempty (I)) with n_emp emp,

        let w : ↥I := choice n_emp ,

        let incV : I → V := set.inclusion (by simp),
        let incU : I → U := set.inclusion (by simp),

        let p_w :U → U ∩ V := λ u , if uUV : u.val ∈ U ∩ V
                    then ⟨u.val , uUV⟩
                    else ⟨w.val , w.property⟩,
        let q_w :𝔸 → V := λ a , if aV : a ∈ V
                    then ⟨a , aV⟩
                    else ⟨w.val , and.right w.property⟩,

        have h1 : ∀ u:U ,
            (incV ∘ p_w) u = (q_w ∘ (U ↪ 𝔸)) u :=
            assume u,
            @by_cases (u.val ∈ I)  ((incV ∘ p_w) u = (q_w ∘ (U ↪ 𝔸)) u)
                begin
                    intro uI,
                    have pwu_u : p_w u = ⟨u.val , uI⟩:=
                        by simp [p_w , rfl, uI],
                    have qwu_u: (q_w) u.val =
                                    (⟨u.val , uI.2⟩ : V)  :=
                        by simp [q_w, rfl, uI.2],
                    calc (incV ∘ p_w) u
                                = incV  ⟨u.val , uI⟩  : by rw ←pwu_u
                            ... = (⟨u.val , uI.2⟩: V) : rfl
                            ... = q_w u.val          : by rw ←qwu_u
                end
                begin
                    intro uNI,
                    have pwu_w : p_w u = w := by simp [p_w , uNI, rfl],
                    have qwu_u: q_w u.val =
                                    (⟨w.val , (w.property).2⟩ : V)  :=
                        begin
                            simp[q_w],
                            split_ifs,
                            exact absurd (and.intro u.property h) uNI,
                            exact rfl
                        end,
                    calc incV (p_w u)
                                = incV w                      : by rw pwu_w
                            ... = (⟨w.val , w.property.2⟩: V)  : rfl
                            ... = q_w u.val                   : by rw ←qwu_u

                end
            ,
        have h11 : incV ∘ p_w = q_w ∘ (U ↪ 𝔸) :=
            funext h1,

        have h22 : q_w  ∘ (V ↪ 𝔸) = id :=
            funext (by {dsimp at *,  simp [q_w]}),

        let γ := (F.map p_w) ∘ S₁.α ∘ incU,

        have hom_eq : (F.map (I ↪ 𝔸)) ∘ γ = 𝔸.α ∘ (I ↪ 𝔸) :=
            calc (F.map ((V ↪ 𝔸) ⊚ incV)) ∘ (F.map p_w) ∘ S₁.α ∘ incU
                    = ((F.map (V ↪ 𝔸)) ⊚ (F.map incV)) ∘ (F.map p_w) ∘ S₁.α ∘ incU : by rw functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ ((F.map incV) ⊚ (F.map p_w)) ∘ S₁.α ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (incV ⊚ p_w)) ∘ S₁.α ∘ incU : by rw ←functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (incV ∘ p_w)) ∘ S₁.α ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ∘ (U ↪ 𝔸))) ∘ S₁.α ∘ incU : by rw ←h11
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ⊚ (U ↪ 𝔸))) ∘ S₁.α ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ ((F.map q_w) ⊚ ((F.map (U ↪ 𝔸)))) ∘ S₁.α ∘ incU : by rw functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ ((F.map (U ↪ 𝔸)) ∘ S₁.α) ∘ incU : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ 𝔸.α ∘ (U ↪ 𝔸) ∘ incU : by rw  eq.symm S₁.h
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ (𝔸.α ∘ (V ↪ 𝔸)) ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map q_w) ∘ (F.map (V ↪ 𝔸)) ∘ S₂.α ∘ incV : by rw ← (eq.symm S₂.h)
                ... = (F.map (V ↪ 𝔸)) ∘ ((F.map q_w) ⊚ (F.map (V ↪ 𝔸))) ∘ S₂.α ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ⊚ (V ↪ 𝔸))) ∘ S₂.α ∘ incV : by rw ←functor.map_comp
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (q_w ∘ (V ↪ 𝔸))) ∘ S₂.α ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map id) ∘ S₂.α ∘ incV : by rw h22
                ... = (F.map (V ↪ 𝔸)) ∘ (F.map (𝟙 V)) ∘ S₂.α ∘ incV : rfl
                ... = (F.map (V ↪ 𝔸)) ∘ (𝟙 (F.obj V)) ∘ S₂.α ∘ incV : by rw functor.map_id'
                ... = ((F.map (V ↪ 𝔸)) ∘ S₂.α) ∘ incV : rfl
                ... = 𝔸.α ∘ (V ↪ 𝔸) ∘ incV : by rw eq.symm S₂.h,

        exact exists.intro γ (eq.symm hom_eq),

        exact empty_openset emp
    end

end coalgebra_sum


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.subtype
import Mathlib.data.prod
import Mathlib.PostPort

universes u_1 u_2 u v w l

namespace Mathlib

/-!
# Basic definitions about `≤` and `<`

## Definitions

### Predicates on functions

- `monotone f`: a function between two types equipped with `≤` is monotone
  if `a ≤ b` implies `f a ≤ f b`.
- `strict_mono f` : a function between two types equipped with `<` is strictly monotone
  if `a < b` implies `f a < f b`.
- `order_dual α` : a type tag reversing the meaning of all inequalities.

### Transfering orders

- `order.preimage`, `preorder.lift`: transfer a (pre)order on `β` to an order on `α`
  using a function `f : α → β`.
- `partial_order.lift`, `linear_order.lift`: transfer a partial (resp., linear) order on `β` to a
  partial (resp., linear) order on `α` using an injective function `f`.

### Extra classes

- `no_top_order`, `no_bot_order`: an order without a maximal/minimal element.
- `densely_ordered`: an order with no gaps, i.e. for any two elements `a<b` there exists
  `c`, `a<c<b`.

## Main theorems

- `monotone_of_monotone_nat`: if `f : ℕ → α` and `f n ≤ f (n + 1)` for all `n`, then
  `f` is monotone;
- `strict_mono.nat`: if `f : ℕ → α` and `f n < f (n + 1)` for all `n`, then f is strictly monotone.

## TODO

- expand module docs
- automatic construction of dual definitions / theorems

## See also
- `algebra.order` for basic lemmas about orders, and projection notation for orders

## Tags

preorder, order, partial order, linear order, monotone, strictly monotone
-/

theorem preorder.ext {α : Type u_1} {A : preorder α} {B : preorder α} (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) : A = B := sorry

theorem partial_order.ext {α : Type u_1} {A : partial_order α} {B : partial_order α} (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) : A = B := sorry

theorem linear_order.ext {α : Type u_1} {A : linear_order α} {B : linear_order α} (H : ∀ (x y : α), x ≤ y ↔ x ≤ y) : A = B := sorry

/-- Given a relation `R` on `β` and a function `f : α → β`,
  the preimage relation on `α` is defined by `x ≤ y ↔ f x ≤ f y`.
  It is the unique relation on `α` making `f` a `rel_embedding`
  (assuming `f` is injective). -/
@[simp] def order.preimage {α : Sort u_1} {β : Sort u_2} (f : α → β) (s : β → β → Prop) (x : α) (y : α) :=
  s (f x) (f y)

infixl:80 " ⁻¹'o " => Mathlib.order.preimage

/-- The preimage of a decidable order is decidable. -/
protected instance order.preimage.decidable {α : Sort u_1} {β : Sort u_2} (f : α → β) (s : β → β → Prop) [H : DecidableRel s] : DecidableRel (f ⁻¹'o s) :=
  fun (x y : α) => H (f x) (f y)

/-- A function between preorders is monotone if
  `a ≤ b` implies `f a ≤ f b`. -/
def monotone {α : Type u} {β : Type v} [preorder α] [preorder β] (f : α → β) :=
  ∀ {a b : α}, a ≤ b → f a ≤ f b

theorem monotone_id {α : Type u} [preorder α] : monotone id :=
  fun (x y : α) (h : x ≤ y) => h

theorem monotone_const {α : Type u} {β : Type v} [preorder α] [preorder β] {b : β} : monotone fun (a : α) => b :=
  fun (x y : α) (h : x ≤ y) => le_refl b

protected theorem monotone.comp {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder β] [preorder γ] {g : β → γ} {f : α → β} (m_g : monotone g) (m_f : monotone f) : monotone (g ∘ f) :=
  fun (a b : α) (h : a ≤ b) => m_g (m_f h)

protected theorem monotone.iterate {α : Type u} [preorder α] {f : α → α} (hf : monotone f) (n : ℕ) : monotone (nat.iterate f n) :=
  nat.rec_on n monotone_id fun (n : ℕ) (ihn : monotone (nat.iterate f n)) => monotone.comp ihn hf

theorem monotone_of_monotone_nat {α : Type u} [preorder α] {f : ℕ → α} (hf : ∀ (n : ℕ), f n ≤ f (n + 1)) : monotone f := sorry

theorem monotone.reflect_lt {α : Type u_1} {β : Type u_2} [linear_order α] [preorder β] {f : α → β} (hf : monotone f) {x : α} {x' : α} (h : f x < f x') : x < x' :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x < x')) (Eq.symm (propext not_le)))) (id fun (h' : x' ≤ x) => not_le_of_lt h (hf h'))

/-- If `f` is a monotone function from `ℕ` to a preorder such that `y` lies between `f x` and
  `f (x + 1)`, then `y` doesn't lie in the range of `f`. -/
theorem monotone.ne_of_lt_of_lt_nat {α : Type u_1} [preorder α] {f : ℕ → α} (hf : monotone f) (x : ℕ) (x' : ℕ) {y : α} (h1 : f x < y) (h2 : y < f (x + 1)) : f x' ≠ y := sorry

/-- If `f` is a monotone function from `ℤ` to a preorder such that `y` lies between `f x` and
  `f (x + 1)`, then `y` doesn't lie in the range of `f`. -/
theorem monotone.ne_of_lt_of_lt_int {α : Type u_1} [preorder α] {f : ℤ → α} (hf : monotone f) (x : ℤ) (x' : ℤ) {y : α} (h1 : f x < y) (h2 : y < f (x + 1)) : f x' ≠ y := sorry

/-- A function `f` is strictly monotone if `a < b` implies `f a < f b`. -/
def strict_mono {α : Type u} {β : Type v} [HasLess α] [HasLess β] (f : α → β) :=
  ∀ {a b : α}, a < b → f a < f b

theorem strict_mono_id {α : Type u} [HasLess α] : strict_mono id :=
  fun (a b : α) => id

/-- A function `f` is strictly monotone increasing on `t` if `x < y` for `x,y ∈ t` implies
`f x < f y`. -/
def strict_mono_incr_on {α : Type u} {β : Type v} [HasLess α] [HasLess β] (f : α → β) (t : set α) :=
  ∀ {x : α}, x ∈ t → ∀ {y : α}, y ∈ t → x < y → f x < f y

/-- A function `f` is strictly monotone decreasing on `t` if `x < y` for `x,y ∈ t` implies
`f y < f x`. -/
def strict_mono_decr_on {α : Type u} {β : Type v} [HasLess α] [HasLess β] (f : α → β) (t : set α) :=
  ∀ {x : α}, x ∈ t → ∀ {y : α}, y ∈ t → x < y → f y < f x

/-- Type tag for a set with dual order: `≤` means `≥` and `<` means `>`. -/
def order_dual (α : Type u_1) :=
  α

namespace order_dual

protected instance nonempty (α : Type u_1) [h : Nonempty α] : Nonempty (order_dual α) :=
  h

protected instance subsingleton (α : Type u_1) [h : subsingleton α] : subsingleton (order_dual α) :=
  h

protected instance has_le (α : Type u_1) [HasLessEq α] : HasLessEq (order_dual α) :=
  { LessEq := fun (x y : α) => y ≤ x }

protected instance has_lt (α : Type u_1) [HasLess α] : HasLess (order_dual α) :=
  { Less := fun (x y : α) => y < x }

-- `dual_le` and `dual_lt` should not be simp lemmas:

-- they cause a loop since `α` and `order_dual α` are definitionally equal

theorem dual_le {α : Type u} [HasLessEq α] {a : α} {b : α} : a ≤ b ↔ b ≤ a :=
  iff.rfl

theorem dual_lt {α : Type u} [HasLess α] {a : α} {b : α} : a < b ↔ b < a :=
  iff.rfl

theorem dual_compares {α : Type u} [HasLess α] {a : α} {b : α} {o : ordering} : ordering.compares o a b ↔ ordering.compares o b a :=
  ordering.cases_on o iff.rfl eq_comm iff.rfl

protected instance preorder (α : Type u_1) [preorder α] : preorder (order_dual α) :=
  preorder.mk LessEq Less sorry sorry

protected instance partial_order (α : Type u_1) [partial_order α] : partial_order (order_dual α) :=
  partial_order.mk preorder.le preorder.lt sorry sorry sorry

protected instance linear_order (α : Type u_1) [linear_order α] : linear_order (order_dual α) :=
  linear_order.mk partial_order.le partial_order.lt sorry sorry sorry sorry
    ((fun (this : DecidableRel fun (a b : α) => b ≤ a) => this) fun (a b : α) => has_le.le.decidable b a)
    Mathlib.decidable_eq_of_decidable_le
    ((fun (this : DecidableRel fun (a b : α) => b < a) => this) fun (a b : α) => has_lt.lt.decidable b a)

protected instance inhabited {α : Type u} [Inhabited α] : Inhabited (order_dual α) :=
  id

theorem preorder.dual_dual (α : Type u_1) [H : preorder α] : order_dual.preorder (order_dual α) = H :=
  preorder.ext fun (_x _x_1 : order_dual (order_dual α)) => iff.rfl

theorem partial_order.dual_dual (α : Type u_1) [H : partial_order α] : order_dual.partial_order (order_dual α) = H :=
  partial_order.ext fun (_x _x_1 : order_dual (order_dual α)) => iff.rfl

theorem linear_order.dual_dual (α : Type u_1) [H : linear_order α] : order_dual.linear_order (order_dual α) = H :=
  linear_order.ext fun (_x _x_1 : order_dual (order_dual α)) => iff.rfl

theorem cmp_le_flip {α : Type u_1} [HasLessEq α] [DecidableRel LessEq] (x : α) (y : α) : cmp_le x y = cmp_le y x :=
  rfl

end order_dual

namespace strict_mono_incr_on

protected theorem dual {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} {s : set α} (H : strict_mono_incr_on f s) : strict_mono_incr_on f s :=
  fun (x : order_dual α) (hx : x ∈ s) (y : order_dual α) (hy : y ∈ s) => H hy hx

protected theorem dual_right {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} {s : set α} (H : strict_mono_incr_on f s) : strict_mono_decr_on f s :=
  H

theorem le_iff_le {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} {s : set α} {x : α} {y : α} (H : strict_mono_incr_on f s) (hx : x ∈ s) (hy : y ∈ s) : f x ≤ f y ↔ x ≤ y := sorry

theorem lt_iff_lt {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} {s : set α} {x : α} {y : α} (H : strict_mono_incr_on f s) (hx : x ∈ s) (hy : y ∈ s) : f x < f y ↔ x < y := sorry

protected theorem compares {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} {s : set α} {x : α} {y : α} (H : strict_mono_incr_on f s) (hx : x ∈ s) (hy : y ∈ s) {o : ordering} : ordering.compares o (f x) (f y) ↔ ordering.compares o x y := sorry

end strict_mono_incr_on

namespace strict_mono_decr_on

protected theorem dual {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} {s : set α} (H : strict_mono_decr_on f s) : strict_mono_decr_on f s :=
  fun (x : order_dual α) (hx : x ∈ s) (y : order_dual α) (hy : y ∈ s) => H hy hx

protected theorem dual_right {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} {s : set α} (H : strict_mono_decr_on f s) : strict_mono_incr_on f s :=
  H

theorem le_iff_le {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} {s : set α} {x : α} {y : α} (H : strict_mono_decr_on f s) (hx : x ∈ s) (hy : y ∈ s) : f x ≤ f y ↔ y ≤ x :=
  strict_mono_incr_on.le_iff_le (strict_mono_decr_on.dual_right H) hy hx

theorem lt_iff_lt {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} {s : set α} {x : α} {y : α} (H : strict_mono_decr_on f s) (hx : x ∈ s) (hy : y ∈ s) : f x < f y ↔ y < x :=
  strict_mono_incr_on.lt_iff_lt (strict_mono_decr_on.dual_right H) hy hx

protected theorem compares {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} {s : set α} {x : α} {y : α} (H : strict_mono_decr_on f s) (hx : x ∈ s) (hy : y ∈ s) {o : ordering} : ordering.compares o (f x) (f y) ↔ ordering.compares o y x :=
  iff.trans order_dual.dual_compares (strict_mono_incr_on.compares (strict_mono_decr_on.dual_right H) hy hx)

end strict_mono_decr_on

namespace strict_mono

protected theorem strict_mono_incr_on {α : Type u} {β : Type v} [HasLess α] [HasLess β] {f : α → β} (hf : strict_mono f) (s : set α) : strict_mono_incr_on f s :=
  fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ s) (hxy : x < y) => hf hxy

theorem comp {α : Type u} {β : Type v} {γ : Type w} [HasLess α] [HasLess β] [HasLess γ] {g : β → γ} {f : α → β} (hg : strict_mono g) (hf : strict_mono f) : strict_mono (g ∘ f) :=
  fun (a b : α) (h : a < b) => hg (hf h)

protected theorem iterate {α : Type u} [HasLess α] {f : α → α} (hf : strict_mono f) (n : ℕ) : strict_mono (nat.iterate f n) :=
  nat.rec_on n strict_mono_id fun (n : ℕ) (ihn : strict_mono (nat.iterate f n)) => comp ihn hf

theorem id_le {φ : ℕ → ℕ} (h : strict_mono φ) (n : ℕ) : n ≤ φ n :=
  nat.rec_on n (nat.zero_le (φ 0))
    fun (n : ℕ) (hn : n ≤ φ n) => nat.succ_le_of_lt (lt_of_le_of_lt hn (h (nat.lt_succ_self n)))

protected theorem ite' {α : Type u} {β : Type v} [preorder α] [HasLess β] {f : α → β} {g : α → β} (hf : strict_mono f) (hg : strict_mono g) {p : α → Prop} [decidable_pred p] (hp : ∀ {x y : α}, x < y → p y → p x) (hfg : ∀ {x y : α}, p x → ¬p y → x < y → f x < g y) : strict_mono fun (x : α) => ite (p x) (f x) (g x) := sorry

protected theorem ite {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} {g : α → β} (hf : strict_mono f) (hg : strict_mono g) {p : α → Prop} [decidable_pred p] (hp : ∀ {x y : α}, x < y → p y → p x) (hfg : ∀ (x : α), f x ≤ g x) : strict_mono fun (x : α) => ite (p x) (f x) (g x) :=
  strict_mono.ite' hf hg hp fun (x y : α) (hx : p x) (hy : ¬p y) (h : x < y) => has_lt.lt.trans_le (hf h) (hfg y)

theorem lt_iff_lt {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} (H : strict_mono f) {a : α} {b : α} : f a < f b ↔ a < b :=
  strict_mono_incr_on.lt_iff_lt (strict_mono.strict_mono_incr_on H set.univ) trivial trivial

protected theorem compares {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} (H : strict_mono f) {a : α} {b : α} {o : ordering} : ordering.compares o (f a) (f b) ↔ ordering.compares o a b :=
  strict_mono_incr_on.compares (strict_mono.strict_mono_incr_on H set.univ) trivial trivial

theorem injective {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} (H : strict_mono f) : function.injective f :=
  fun (x y : α) (h : f x = f y) =>
    (fun (this : ordering.compares ordering.eq x y) => this) (iff.mp (strict_mono.compares H) h)

theorem le_iff_le {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} (H : strict_mono f) {a : α} {b : α} : f a ≤ f b ↔ a ≤ b :=
  strict_mono_incr_on.le_iff_le (strict_mono.strict_mono_incr_on H set.univ) trivial trivial

theorem top_preimage_top {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} (H : strict_mono f) {a : α} (h_top : ∀ (p : β), p ≤ f a) (x : α) : x ≤ a :=
  iff.mp (le_iff_le H) (h_top (f x))

theorem bot_preimage_bot {α : Type u} {β : Type v} [linear_order α] [preorder β] {f : α → β} (H : strict_mono f) {a : α} (h_bot : ∀ (p : β), f a ≤ p) (x : α) : a ≤ x :=
  iff.mp (le_iff_le H) (h_bot (f x))

protected theorem nat {β : Type u_1} [preorder β] {f : ℕ → β} (h : ∀ (n : ℕ), f n < f (n + 1)) : strict_mono f := sorry

-- `preorder α` isn't strong enough: if the preorder on α is an equivalence relation,

-- then `strict_mono f` is vacuously true.

theorem monotone {α : Type u} {β : Type v} [partial_order α] [preorder β] {f : α → β} (H : strict_mono f) : monotone f :=
  fun (a b : α) (h : a ≤ b) =>
    Or._oldrec (le_of_lt ∘ H) (fun (h_1 : a = b) => Eq._oldrec (fun (h : a ≤ a) => le_refl (f a)) h_1 h)
      (lt_or_eq_of_le h)

end strict_mono

theorem injective_of_lt_imp_ne {α : Type u} {β : Type v} [linear_order α] {f : α → β} (h : ∀ (x y : α), x < y → f x ≠ f y) : function.injective f := sorry

theorem strict_mono_of_monotone_of_injective {α : Type u} {β : Type v} [partial_order α] [partial_order β] {f : α → β} (h₁ : monotone f) (h₂ : function.injective f) : strict_mono f := sorry

theorem monotone.strict_mono_iff_injective {α : Type u} {β : Type v} [linear_order α] [partial_order β] {f : α → β} (h : monotone f) : strict_mono f ↔ function.injective f :=
  { mp := fun (h : strict_mono f) => strict_mono.injective h, mpr := strict_mono_of_monotone_of_injective h }

theorem strict_mono_of_le_iff_le {α : Type u} {β : Type v} [preorder α] [preorder β] {f : α → β} (h : ∀ (x y : α), x ≤ y ↔ f x ≤ f y) : strict_mono f := sorry

/-! ### Order instances on the function space -/

protected instance pi.preorder {ι : Type u} {α : ι → Type v} [(i : ι) → preorder (α i)] : preorder ((i : ι) → α i) :=
  preorder.mk (fun (x y : (i : ι) → α i) => ∀ (i : ι), x i ≤ y i)
    (fun (a b : (i : ι) → α i) => (∀ (i : ι), a i ≤ b i) ∧ ¬∀ (i : ι), b i ≤ a i) sorry sorry

theorem pi.le_def {ι : Type u} {α : ι → Type v} [(i : ι) → preorder (α i)] {x : (i : ι) → α i} {y : (i : ι) → α i} : x ≤ y ↔ ∀ (i : ι), x i ≤ y i :=
  iff.rfl

theorem le_update_iff {ι : Type u} {α : ι → Type v} [(i : ι) → preorder (α i)] [DecidableEq ι] {x : (i : ι) → α i} {y : (i : ι) → α i} {i : ι} {a : α i} : x ≤ function.update y i a ↔ x i ≤ a ∧ ∀ (j : ι), j ≠ i → x j ≤ y j :=
  function.forall_update_iff y fun (j : ι) (z : α j) => x j ≤ z

theorem update_le_iff {ι : Type u} {α : ι → Type v} [(i : ι) → preorder (α i)] [DecidableEq ι] {x : (i : ι) → α i} {y : (i : ι) → α i} {i : ι} {a : α i} : function.update x i a ≤ y ↔ a ≤ y i ∧ ∀ (j : ι), j ≠ i → x j ≤ y j :=
  function.forall_update_iff x fun (j : ι) (z : α j) => z ≤ y j

protected instance pi.partial_order {ι : Type u} {α : ι → Type v} [(i : ι) → partial_order (α i)] : partial_order ((i : ι) → α i) :=
  partial_order.mk preorder.le preorder.lt sorry sorry sorry

theorem comp_le_comp_left_of_monotone {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder β] {f : β → α} {g : γ → β} {h : γ → β} (m_f : monotone f) (le_gh : g ≤ h) : f ∘ g ≤ f ∘ h :=
  fun (x : γ) => m_f (le_gh x)

protected theorem monotone.order_dual {α : Type u} {γ : Type w} [preorder α] [preorder γ] {f : α → γ} (hf : monotone f) : monotone f :=
  fun (x y : order_dual α) (hxy : x ≤ y) => hf hxy

theorem monotone_lam {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder γ] {f : α → β → γ} (m : ∀ (b : β), monotone fun (a : α) => f a b) : monotone f :=
  fun (a a' : α) (h : a ≤ a') (b : β) => m b h

theorem monotone_app {α : Type u} {β : Type v} {γ : Type w} [preorder α] [preorder γ] (f : β → α → γ) (b : β) (m : monotone fun (a : α) (b : β) => f b a) : monotone (f b) :=
  fun (a a' : α) (h : a ≤ a') => m h b

theorem strict_mono.order_dual {α : Type u} {β : Type v} [HasLess α] [HasLess β] {f : α → β} (hf : strict_mono f) : strict_mono f :=
  fun (x y : order_dual α) (hxy : x < y) => hf hxy

/-- Transfer a `preorder` on `β` to a `preorder` on `α` using a function `f : α → β`. -/
def preorder.lift {α : Type u_1} {β : Type u_2} [preorder β] (f : α → β) : preorder α :=
  preorder.mk (fun (x y : α) => f x ≤ f y) (fun (x y : α) => f x < f y) sorry sorry

/-- Transfer a `partial_order` on `β` to a `partial_order` on `α` using an injective
function `f : α → β`. -/
def partial_order.lift {α : Type u_1} {β : Type u_2} [partial_order β] (f : α → β) (inj : function.injective f) : partial_order α :=
  partial_order.mk preorder.le preorder.lt sorry sorry sorry

/-- Transfer a `linear_order` on `β` to a `linear_order` on `α` using an injective
function `f : α → β`. -/
def linear_order.lift {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (inj : function.injective f) : linear_order α :=
  linear_order.mk partial_order.le partial_order.lt sorry sorry sorry sorry (fun (x y : α) => infer_instance)
    (fun (x y : α) => decidable_of_iff (f x = f y) (function.injective.eq_iff inj)) fun (x y : α) => infer_instance

protected instance subtype.preorder {α : Type u_1} [preorder α] (p : α → Prop) : preorder (Subtype p) :=
  preorder.lift subtype.val

@[simp] theorem subtype.mk_le_mk {α : Type u_1} [preorder α] {p : α → Prop} {x : α} {y : α} {hx : p x} {hy : p y} : { val := x, property := hx } ≤ { val := y, property := hy } ↔ x ≤ y :=
  iff.rfl

@[simp] theorem subtype.mk_lt_mk {α : Type u_1} [preorder α] {p : α → Prop} {x : α} {y : α} {hx : p x} {hy : p y} : { val := x, property := hx } < { val := y, property := hy } ↔ x < y :=
  iff.rfl

@[simp] theorem subtype.coe_le_coe {α : Type u_1} [preorder α] {p : α → Prop} {x : Subtype p} {y : Subtype p} : ↑x ≤ ↑y ↔ x ≤ y :=
  iff.rfl

@[simp] theorem subtype.coe_lt_coe {α : Type u_1} [preorder α] {p : α → Prop} {x : Subtype p} {y : Subtype p} : ↑x < ↑y ↔ x < y :=
  iff.rfl

protected instance subtype.partial_order {α : Type u_1} [partial_order α] (p : α → Prop) : partial_order (Subtype p) :=
  partial_order.lift subtype.val subtype.val_injective

protected instance subtype.linear_order {α : Type u_1} [linear_order α] (p : α → Prop) : linear_order (Subtype p) :=
  linear_order.lift subtype.val subtype.val_injective

theorem subtype.mono_coe {α : Type u} [preorder α] (t : set α) : monotone coe :=
  fun (x y : Subtype t) => id

theorem subtype.strict_mono_coe {α : Type u} [preorder α] (t : set α) : strict_mono coe :=
  fun (x y : Subtype t) => id

protected instance prod.has_le (α : Type u) (β : Type v) [HasLessEq α] [HasLessEq β] : HasLessEq (α × β) :=
  { LessEq := fun (p q : α × β) => prod.fst p ≤ prod.fst q ∧ prod.snd p ≤ prod.snd q }

protected instance prod.preorder (α : Type u) (β : Type v) [preorder α] [preorder β] : preorder (α × β) :=
  preorder.mk LessEq (fun (a b : α × β) => a ≤ b ∧ ¬b ≤ a) sorry sorry

/-- The pointwise partial order on a product.
    (The lexicographic ordering is defined in order/lexicographic.lean, and the instances are
    available via the type synonym `lex α β = α × β`.) -/
protected instance prod.partial_order (α : Type u) (β : Type v) [partial_order α] [partial_order β] : partial_order (α × β) :=
  partial_order.mk preorder.le preorder.lt sorry sorry sorry

/-!
### Additional order classes
-/

/-- order without a top element; somtimes called cofinal -/
class no_top_order (α : Type u) [preorder α]
where
  no_top : ∀ (a : α), ∃ (a' : α), a < a'

theorem no_top {α : Type u} [preorder α] [no_top_order α] (a : α) : ∃ (a' : α), a < a' :=
  no_top_order.no_top

protected instance nonempty_gt {α : Type u} [preorder α] [no_top_order α] (a : α) : Nonempty (Subtype fun (x : α) => a < x) :=
  iff.mpr nonempty_subtype (no_top a)

/-- order without a bottom element; somtimes called coinitial or dense -/
class no_bot_order (α : Type u) [preorder α]
where
  no_bot : ∀ (a : α), ∃ (a' : α), a' < a

theorem no_bot {α : Type u} [preorder α] [no_bot_order α] (a : α) : ∃ (a' : α), a' < a :=
  no_bot_order.no_bot

protected instance order_dual.no_top_order (α : Type u) [preorder α] [no_bot_order α] : no_top_order (order_dual α) :=
  no_top_order.mk fun (a : order_dual α) => no_bot a

protected instance order_dual.no_bot_order (α : Type u) [preorder α] [no_top_order α] : no_bot_order (order_dual α) :=
  no_bot_order.mk fun (a : order_dual α) => no_top a

protected instance nonempty_lt {α : Type u} [preorder α] [no_bot_order α] (a : α) : Nonempty (Subtype fun (x : α) => x < a) :=
  iff.mpr nonempty_subtype (no_bot a)

/-- An order is dense if there is an element between any pair of distinct elements. -/
class densely_ordered (α : Type u) [preorder α]
where
  dense : ∀ (a₁ a₂ : α), a₁ < a₂ → ∃ (a : α), a₁ < a ∧ a < a₂

theorem exists_between {α : Type u} [preorder α] [densely_ordered α] {a₁ : α} {a₂ : α} : a₁ < a₂ → ∃ (a : α), a₁ < a ∧ a < a₂ :=
  densely_ordered.dense

protected instance order_dual.densely_ordered (α : Type u) [preorder α] [densely_ordered α] : densely_ordered (order_dual α) :=
  densely_ordered.mk fun (a₁ a₂ : order_dual α) (ha : a₁ < a₂) => Exists.imp (fun (a : α) => and.symm) (exists_between ha)

theorem le_of_forall_le_of_dense {α : Type u} [linear_order α] [densely_ordered α] {a₁ : α} {a₂ : α} (h : ∀ (a₃ : α), a₃ > a₂ → a₁ ≤ a₃) : a₁ ≤ a₂ := sorry

theorem eq_of_le_of_forall_le_of_dense {α : Type u} [linear_order α] [densely_ordered α] {a₁ : α} {a₂ : α} (h₁ : a₂ ≤ a₁) (h₂ : ∀ (a₃ : α), a₃ > a₂ → a₁ ≤ a₃) : a₁ = a₂ :=
  le_antisymm (le_of_forall_le_of_dense h₂) h₁

theorem le_of_forall_ge_of_dense {α : Type u} [linear_order α] [densely_ordered α] {a₁ : α} {a₂ : α} (h : ∀ (a₃ : α), a₃ < a₁ → a₃ ≤ a₂) : a₁ ≤ a₂ := sorry

theorem eq_of_le_of_forall_ge_of_dense {α : Type u} [linear_order α] [densely_ordered α] {a₁ : α} {a₂ : α} (h₁ : a₂ ≤ a₁) (h₂ : ∀ (a₃ : α), a₃ < a₁ → a₃ ≤ a₂) : a₁ = a₂ :=
  le_antisymm (le_of_forall_ge_of_dense h₂) h₁

theorem dense_or_discrete {α : Type u} [linear_order α] (a₁ : α) (a₂ : α) : (∃ (a : α), a₁ < a ∧ a < a₂) ∨ (∀ (a : α), a > a₁ → a₂ ≤ a) ∧ ∀ (a : α), a < a₂ → a ≤ a₁ := sorry

/-- Type synonym to create an instance of `linear_order` from a
`partial_order` and `[is_total α (≤)]` -/
def as_linear_order (α : Type u) :=
  α

protected instance as_linear_order.inhabited {α : Type u_1} [Inhabited α] : Inhabited (as_linear_order α) :=
  { default := Inhabited.default }

protected instance as_linear_order.linear_order {α : Type u_1} [partial_order α] [is_total α LessEq] : linear_order (as_linear_order α) :=
  linear_order.mk partial_order.le partial_order.lt partial_order.le_refl partial_order.le_trans partial_order.le_antisymm
    sorry (classical.dec_rel LessEq) Mathlib.decidable_eq_of_decidable_le Mathlib.decidable_lt_of_decidable_le


import o_minimal.Def

/-
Definable sheaves.

Here we provide just enough definitions, instances and lemmas
to set up the tactic environment. The eventual frontend for all this
is intended to consist of `definable` and the `definable_sheaf` class,
but there is still plenty of construction to do.
-/

namespace o_minimal

universe u

variables {R : Type u} (S : struc R)

class definable_sheaf (X : Type*) :=
(definable : Π {K : Def S}, (K → X) → Prop)
(definable_precomp : ∀ {L K : Def S} (φ : L ⟶ K) (f : K → X),
  definable f → definable (f ∘ φ))
(definable_cover : ∀ {K : Def S} (f : K → X) (𝓛 : Def.cover K),
  (∀ i, definable (f ∘ 𝓛.map i)) → definable f)

namespace definable_sheaf

variables {S}

def rep {W : Type*} [has_coordinates R W] [is_definable S W] :
  definable_sheaf S W :=
{ definable := λ K f, def_fun S f,
  definable_precomp := λ L K φ f hf, hf.comp φ.is_definable,
  definable_cover := λ K f 𝓛 h, Def.subcanonical 𝓛 f h }

instance Def.definable_sheaf {X : Def S} : definable_sheaf S X :=
definable_sheaf.rep

variables {X Y : Type*} [definable_sheaf S X] [definable_sheaf S Y]

instance prod.definable_sheaf : definable_sheaf S (X × Y) :=
{ definable := λ K f,
    definable_sheaf.definable (prod.fst ∘ f) ∧
    definable_sheaf.definable (prod.snd ∘ f),
  definable_precomp := λ L K φ _ h,
    ⟨definable_sheaf.definable_precomp φ _ h.1,
     definable_sheaf.definable_precomp φ _ h.2⟩,
  definable_cover := λ K f 𝓛 h,
    ⟨definable_sheaf.definable_cover _ 𝓛 (λ i, (h i).1),
     definable_sheaf.definable_cover _ 𝓛 (λ i, (h i).2)⟩ }

instance fun.definable_sheaf : definable_sheaf S (X → Y) :=
{ definable := λ K f,
    ∀ (L : Def S) (g : L → K × X) (h : definable_sheaf.definable g),
      definable_sheaf.definable (function.uncurry f ∘ g),
  definable_precomp := λ L K φ f hf M g hg,
    hf M (λ m, (φ (g m).1, (g m).2))
      ⟨definable_sheaf.definable_precomp ⟨λ m, (g m).1, hg.1⟩ φ φ.is_definable, hg.2⟩,
  definable_cover := λ K f 𝓛 h K' g hg, begin
    let g₁ : K' ⟶ K := ⟨λ k', (g k').1, hg.1⟩,
    let 𝓛' := 𝓛.pullback g₁,
    apply definable_sheaf.definable_cover _ 𝓛',
    intro i,
    specialize h i (𝓛'.obj i)
      (λ l', (Def.pullback.π₂ g₁ _ l', (g (𝓛'.map i l')).2))
      ⟨(Def.pullback.π₂ g₁ _).is_definable, definable_sheaf.definable_precomp _ _ hg.2⟩,
    dsimp only [function.uncurry, function.comp] at ⊢ h,
    convert h,
    ext x,
    congr,
    exact x.property.snd.snd,
  end }

/-- Intended to be an implementation detail of the tactic mode.
In "user code", use `definable` instead. -/
structure sect (Γ : Def S) (X : Type*) [definable_sheaf S X] :=
(to_fun : Γ → X)
(definable : definable_sheaf.definable to_fun)

def sect.precomp {Γ' Γ : Def S} (σ : sect Γ X) (φ : Γ' ⟶ Γ) : sect Γ' X :=
{ to_fun := σ.to_fun ∘ φ.to_fun,
  definable := definable_sheaf.definable_precomp φ σ.to_fun σ.definable }

lemma definable_fun_iff {Γ : Def S} {f : Γ → X → Y} :
  definable_sheaf.definable f ↔
  ∀ (Γ' : Def S) (π : Hom Γ' Γ) (σ : sect Γ' X),
    definable_sheaf.definable (λ i', f (π.to_fun i') (σ.to_fun i')) :=
⟨λ H Γ' π σ, H Γ' (λ γ', (π.to_fun γ', σ.to_fun γ')) ⟨π.is_definable, σ.definable⟩,
 λ H M g hg, H M ⟨_, hg.1⟩ ⟨_, hg.2⟩⟩

/- The weird binder types are because this lemma is intended to be applied
by a special `defin` tactic. -/
lemma definable_app {Γ : Def S}
  (f : Γ → X → Y) {hf : definable_sheaf.definable f}
  (x : Γ → X) {hx : definable_sheaf.definable x} :
  definable_sheaf.definable (λ i, f i (x i)) :=
hf Γ (λ γ, (γ, x γ)) ⟨def_fun.id, hx⟩

end definable_sheaf

structure definable {X : Type*} [definable_sheaf S X] (x : X) : Prop :=
(definable : ∀ (K : Def S), definable_sheaf.definable (λ (i : K), x))

end o_minimal


/- Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Douglas, Floris van Doorn
-/

import order.zorn algebra.module

universe variable u

namespace tactic
namespace interactive
setup_tactic_parser
open tactic.interactive
meta def dunfold_coes (loc : parse location) : tactic unit :=
dunfold [
  ``coe, ``coe_t, ``has_coe_t.coe, ``coe_b,``has_coe.coe,
  ``lift, ``has_lift.lift, ``lift_t, ``has_lift_t.lift,
  ``coe_fn, ``has_coe_to_fun.coe, ``coe_sort, ``has_coe_to_sort.coe,
  ``coe_base_aux, ``has_coe_t_aux.coe] loc
  -- note: this adds extra arguments
  -- todo: we need to repeat it, it is not idempotent.
end interactive
end tactic

@[simp] lemma inv_smul_smul {K V : Type*} [field K] [add_comm_group V] [vector_space K V]
  {k : K} {x : V} (h : k ≠ 0) : k⁻¹ • k • x = x :=
by rw [←mul_smul, inv_mul_cancel h, one_smul]

@[simp] lemma smul_inv_smul {K V : Type*} [field K] [add_comm_group V] [vector_space K V]
  {k : K} {x : V} (h : k ≠ 0) : k • k⁻¹ • x = x :=
by rw [←mul_smul, mul_inv_cancel h, one_smul]

lemma subtype.le_def {α : Type*} [partial_order α] {P : α → Prop} {x y : α}
  {hx : P x} {hy : P y} : (⟨x, hx⟩ : subtype P) ≤ ⟨y, hy⟩ ↔ x ≤ y :=
iff.refl _

lemma subtype.prop {α} {p : α → Prop} (x : subtype p) : p x := x.2

namespace zorn

/- A version of Zorn's lemma for partial orders where we only have to find an upper bound for nonempty chains -/
theorem zorn_partial_order_nonempty {α : Type u} [partial_order α] [nonempty α]
  (h : ∀c:set α, chain (≤) c → c.nonempty → ∃ub, ∀a∈c, a ≤ ub) : ∃m:α, ∀a, m ≤ a → a = m :=
begin
  apply zorn_partial_order,
  intros c hc, classical,
  cases c.eq_empty_or_nonempty with h2c h2c,
  { have := _inst_2, cases this with x, use x, intro y, rw h2c, rintro ⟨⟩ },
  { exact h c hc h2c },
end

end zorn

section lattice
variables {α : Type*} [semilattice_sup_top α]

/-- Two elements of a lattice are covering if their sup is the top element. -/
def covering (a b : α) : Prop := ⊤ ≤ a ⊔ b

theorem covering.eq_top {a b : α} (h : covering a b) : a ⊔ b = ⊤ :=
eq_top_iff.2 h

theorem covering_iff {a b : α} : covering a b ↔ a ⊔ b = ⊤ :=
eq_top_iff.symm

theorem covering.comm {a b : α} : covering a b ↔ covering b a :=
by rw [covering, covering, sup_comm]

theorem covering.symm {a b : α} : covering a b → covering b a :=
covering.comm.1

@[simp] theorem covering_top_left {a : α} : covering ⊤ a := covering_iff.2 top_sup_eq
@[simp] theorem covering_top_right {a : α} : covering a ⊤ := covering_iff.2 sup_top_eq

theorem covering.mono {a b c d : α} (h₁ : a ≤ b) (h₂ : c ≤ d) (h : covering a c) : covering b d :=
le_trans h (sup_le_sup h₁ h₂)

theorem covering.mono_left {a b c : α} (h : a ≤ b) : covering a c → covering b c :=
covering.mono h (le_refl _)

theorem covering.mono_right {a b c : α} (h : b ≤ c) : covering a b → covering a c :=
covering.mono (le_refl _) h

@[simp] lemma covering_self {a : α} : covering a a ↔ a = ⊤ :=
by simp [covering]

lemma covering.ne {a b : α} (ha : a ≠ ⊤) (hab : covering a b) : a ≠ b :=
by { intro h, rw [←h, covering_self] at hab, exact ha hab }

end lattice