import tactic set_theory.ordinal order.bounded_lattice order.zorn data.set.intervals.ord_connected order.rel_iso data.finset.preimage

open_locale cardinal

set_option old_structure_cmd true

/-- A partial order with a least and greatest element. -/
class bounded_partial_order (α : Type*) extends order_top α, order_bot α

namespace bounded_partial_order
section

  parameters {α : Type*} [bl : bounded_lattice α]

  -- A bounded lattice is a bounded partial order.
  instance of_top_bot : bounded_partial_order α :=
  { ..bl }

end
end bounded_partial_order

/-- A face `c` covers `a` whenever `a < c` and no face `b` exists such that `a < b < c`. -/
def covers {α : Type*} [preorder α] (a c : α) : Prop :=
a < c ∧ ¬ ∃ b, a < b ∧ b < c

/-- A graded poset has a function from elements to naturals that's compatible
    with the ordering, and consistent with the covering relation. -/
class graded (α : Type*) extends order_bot α :=
(grade : α → ℕ)
(grade_bot_eq_zero : grade ⊥ = 0)
(lt_grade_of_lt : ∀ {a b : α}, a < b → grade a < grade b)
(eq_p1_of_cover : ∀ {a b : α}, covers a b → grade a + 1 = grade b)

namespace graded
section

  parameters {α : Type*} [graded α]

  /-- If `a ≤ b`, then `grade a ≤ grade b`. -/
  theorem le_grade_of_le : ∀ {a b : α}, a ≤ b → graded.grade a ≤ graded.grade b :=
  begin
    intros a b a_le_b,
    cases lt_or_eq_of_le a_le_b with a_lt_b a_eq_b, {
      exact le_of_lt (graded.lt_grade_of_lt a_lt_b),
    },
    exact (congr_arg grade (eq.symm a_eq_b)).ge,
  end

  /-- If `grade a = 0`, then `a = ⊥`. -/
  theorem eq_bot_of_grade_eq_zero {a : α} : grade a = 0 → a = ⊥ :=
  begin
    contrapose,
    intro a_ne_bot,
    have h : grade a > grade (⊥ : α) :=  lt_grade_of_lt (lt_of_le_of_ne (bot_le a) (ne.symm a_ne_bot)),
    rw grade_bot_eq_zero at h,
    exact ne_of_gt h,
  end

end
end graded

/-- A graded, bounded partial order. -/
class graded_bounded_partial_order (α : Type*) extends bounded_partial_order α, graded α

namespace graded_bounded_partial_order
section

  parameters {α : Type*} [graded_bounded_partial_order α] (a : α)

  /-- If `grade a = grade ⊤`, then `a = ⊤`. -/
  theorem eq_top_of_grade_eq_grade_top : graded.grade a = graded.grade (⊤ : α) → a = ⊤ :=
  begin
    contrapose,
    intro a_ne_bot,
    exact ne_of_lt ( lt_grade_of_lt (lt_of_le_of_ne (le_top a) a_ne_bot)),
  end

  /-- The grade of any face is in the interval `[0, grade ⊤]`. -/
  theorem grade_mem_Iic : graded.grade a ∈ set.Iic (graded.grade (⊤ : α)) :=
  graded.le_grade_of_le (le_top a)

  /-- The grade of a face as a member of a finite set. -/
  def fin_grade : α → fin (grade (⊤ : α) + 1) :=
  λ a, ⟨graded.grade a, nat.lt_succ_iff.mpr (graded.le_grade_of_le (le_top a))⟩

end
end graded_bounded_partial_order

namespace flag
section

  variables {α : Type*} [graded_bounded_partial_order α] {f f' : set α}

  /-- A flag is a maximal chain. -/
  def is_flag (c : set α) : Prop := @zorn.is_max_chain _ (<) c

  /-- Two flags are adjacent when they differ by exactly one element. -/
  def flag_adj (f f' : set α) : Prop :=
  is_flag f → is_flag f' → #(set.diff f f') = 1

  /-- If one attempts to extend a flag `f` by an element `e` which is comparable to
  --  all other faces of the flag, we obtain a contradiction. -/
  lemma flag_extend (e : α) : is_flag f → e ∉ f → ¬(∀ a ∈ f, a ≠ e → a < e ∨ e < a) :=
  begin
    -- We define `f' = f ∪ {e}`.
    intros ff e_nmem_f h,
    let f' := f ∪ {e},
    have hf' : ∀ a ∈ f', a ∈ f ∨ a = e := by simp,
    apply ff.right,
    use f',

    -- `f` is not equal to `f'`.
    have f_ne_f' : f ≠ f' := begin
      intro f_eq_f',
      rw f_eq_f' at e_nmem_f,
      exact e_nmem_f (set.mem_union_right f rfl),
    end,

    -- We prove that `f'` is a superchain of `f`, a contradiction!
    split, {
      intros a a_mem_f' b b_mem_f' a_ne_b,

      -- Cases depending on whether `a` or `b` equal `e`.
      cases hf' a a_mem_f' with a_mem_f a_eq_t, {
        cases hf' b b_mem_f' with b_mem_f b_eq_t, {
          exact ff.left a a_mem_f b b_mem_f a_ne_b,
        },
        rw b_eq_t at *,
        exact h a a_mem_f a_ne_b,
      },
      cases hf' b b_mem_f' with b_mem_f b_eq_t, {
        rw a_eq_t at *,
        exact or.swap (h b b_mem_f (ne.symm a_ne_b)),
      },
      rw b_eq_t at *,
      exact false.elim (a_ne_b a_eq_t),
    },

    exact set.ssubset_iff_subset_ne.mpr ⟨set.subset_union_left f {e}, f_ne_f'⟩,
  end

  -- Any flag contains the bottom face `⊥`.
  theorem bot_in_flag : is_flag f → ⊥ ∈ f :=
  begin
    -- We use the `flag_extend` lemma.
    intro ff,
    by_contra bot_nmem_f,
    apply flag_extend ⊥ ff bot_nmem_f,

    -- The bottom face is less or equal to any other.
    intros a a_mem_f a_ne_bot,
    exact or.inr (lt_of_le_of_ne bot_le (ne.symm a_ne_bot)),
  end

  -- Any flag contains the top face `⊤`.
  theorem top_in_flag : is_flag f → ⊤ ∈ f :=
  begin
    -- We use the `flag_extend` lemma.
    intro ff,
    by_contra top_nmem_f,
    apply flag_extend ⊤ ff top_nmem_f,

    -- The top face is greater or equal to any other.
    intros a a_mem_f a_ne_bot,
    exact or.inl (lt_of_le_of_ne le_top (a_ne_bot)),
  end

end
end flag

-- The faces of a flag are merely its elements.
def flag_faces {α : Type*} [graded_bounded_partial_order α] {f : set α} (ff : flag.is_flag f) : Type* := f

namespace flag_faces
section

  parameters {α : Type*} [graded_bounded_partial_order α] {f : set α} {ff : flag.is_flag f} (a b : flag_faces ff)

  -- Subtyping preserves equality and viceversa.
  @[simp] lemma eq_iff_subtype : a = b ↔ a.val = b.val := subtype.ext_iff_val

  -- Subtyping preserves inequality and viceversa.
  lemma ne_iff_subtype : a ≠ b ↔ a.val ≠ b.val := by simp

  -- Flag faces form a partial order.
  instance of_partial_order : partial_order (flag_faces ff) :=
  {
    le := λ a b, a.val ≤ b.val,
    le_refl := λ a, le_refl a.val,
    le_trans := λ _ _ _ a_le_b b_le_c, le_trans a_le_b b_le_c,
    le_antisymm := λ _ _ a_le_b b_le_a, subtype.eq (le_antisymm a_le_b b_le_a),
  }

  -- Subtyping preserves order and viceversa.
  @[simp] lemma lt_iff_subtype : a < b ↔ a.val < b.val := iff.symm lt_iff_le_not_le

  -- Flag faces form a linear order.
  noncomputable instance of_linear_order : linear_order (flag_faces ff) :=
  {
    le_total := begin
      intros a b,

      -- `a = b` is trivial.
      by_cases a_eq_b : a = b, {
        exact or.inl (eq.symm a_eq_b).ge,
      },

      -- If `a ≠ b`, then either `a < b`...
      cases ff.left a.val (subtype.mem a) b.val (subtype.mem b) ((ne_iff_subtype a b).mp a_eq_b) with av_lt_bv bv_lt_av, {
        exact or.inl (le_of_lt ((lt_iff_subtype a b).mpr av_lt_bv)),
      },

      -- ...or `b < a`.
      exact or.inr (le_of_lt ((lt_iff_subtype b a).mpr bv_lt_av)),
    end,

    decidable_le := classical.dec_rel _,

    ..of_partial_order
  }

  -- Flag faces form a graded bounded partial order.
  instance of_graded_bounded_partial_order : graded_bounded_partial_order (flag_faces ff) :=
  {
    bot := ⟨⊥, flag.bot_in_flag ff⟩,
    bot_le := λ _, bot_le,

    top := ⟨⊤, flag.top_in_flag ff⟩,
    le_top := λ _, @le_top α _ _,

    grade := λ a, graded.grade a.val,
    grade_bot_eq_zero := graded.grade_bot_eq_zero,

    lt_grade_of_lt := begin
      intros _ _ a_lt_b,
      exact graded.lt_grade_of_lt ((lt_iff_subtype _ _).mp a_lt_b),
    end,

    eq_p1_of_cover := begin
      -- It suffices to prove that `a` covers `c`.
      rintros a c ⟨a_lt_c, hne⟩,
      apply graded.eq_p1_of_cover,
      use (lt_iff_subtype a c).mp a_lt_c,

      -- To do this, we prove that any element between `a` and `c` must be in `f`.
      by_contra he,
      rcases he with ⟨bv, av_lt_bv, bv_lt_cv⟩,
      apply hne,

      -- To use the `flag_extend` lemma, we must prove that any `x ∈ f` is comparable to `b`.
      have bv_mem_f : bv ∈ f := begin
        by_contra b_nmem_f,
        apply flag.flag_extend bv ff b_nmem_f,
        intros xv x_mem_f _,
        let x : flag_faces ff := ⟨xv, x_mem_f⟩,

        -- `x` must be below `a` or above `c` (since there's no elements in between).
        have x_le_a_or_c_le_x : x ≤ a ∨ c ≤ x := begin
          by_cases x_le_a : x ≤ a, {
            exact or.inl x_le_a,
          },
          by_cases c_le_x : c ≤ x, {
            exact or.inr c_le_x,
          },
          exfalso,
          exact hne ⟨x, not_le.mp x_le_a, not_le.mp c_le_x⟩,
        end,

        -- We finish by transitivity.
        cases x_le_a_or_c_le_x with x_le_a c_le_x, {
          exact or.inl (lt_of_le_of_lt x_le_a av_lt_bv),
        },
        exact or.inr (lt_of_lt_of_le bv_lt_cv c_le_x),
      end,

      let b : flag_faces ff := ⟨bv, bv_mem_f⟩,
      exact ⟨b, (lt_iff_subtype a b).mpr av_lt_bv, (lt_iff_subtype b c).mpr bv_lt_cv⟩,
    end,

    ..of_partial_order,
  }

end
end flag_faces

namespace flag
section

  variables {α : Type*} [graded_bounded_partial_order α] {f f' : set α}

  /-- Casts a flag into a set of its own faces. -/
  def to_flag_faces (ff : is_flag f) : set (flag_faces ff) := subtype.val ⁻¹' f

  /-- Every set of faces in a flag is a subset of the entire set. -/
  lemma ssubset_flag_faces {ff : is_flag f} (s : set (flag_faces ff)) : s ⊆ to_flag_faces ff :=
  λ s _, subtype.mem s

  /-- If `s` contains all faces of a flag, it must be the set of all faces. -/
  lemma eq_of_ssubset_flag_faces (ff : is_flag f) (s : set (flag_faces ff)) : to_flag_faces ff ⊆ s → s = to_flag_faces ff :=
  begin
    intro ff_subset_s,
    refine set.eq_of_subset_of_subset _ ff_subset_s,
    exact ssubset_flag_faces s,
  end

  /-- Applying `to_flag_faces` to a flag does not change the fact that it is a flag. -/
  theorem to_flag_faces_is_flag (ff : is_flag f) : is_flag (to_flag_faces ff) :=
  begin
    split, {
      intros _ _ _ _ a_ne_b,
      exact ne.lt_or_lt a_ne_b,
    },
    by_contra h,
    rcases h with ⟨ch, _, sch⟩,
    rw set.ssubset_def at sch,
    exact sch.right (ssubset_flag_faces ch),
  end

  /-- The subtypes of all elements of a flag form the original set. -/
  lemma subtype_of_flag_faces_eq_flag (ff : is_flag f) : subtype.val '' to_flag_faces ff = f :=
  begin
    apply set.ext,
    intro x,
    split, {
      intro h,
      rcases h with ⟨_, a_mem_ff, av_eq_x⟩,
      exact set.mem_of_eq_of_mem (eq.symm av_eq_x) a_mem_ff,
    },
    intro x_mem_f,
    use ⟨x, x_mem_f⟩,
    use x_mem_f,
  end

  /-- The set of grades of a flag. -/
  def flag_grades (f : set α): set ℕ := {n | ∃ a ∈ f, graded.grade a = n}

  /-- In a flag, `grade a < grade b` implies `a < b`. -/
  theorem grade_lt_of_lt {ff : is_flag f} {a b : flag_faces ff} : graded.grade a < graded.grade b → a < b :=
  begin
    rintros ga_lt_gb,
    cases lt_trichotomy a b with a_lt_b a_nlt_b, {
      exact a_lt_b,
    },
    cases a_nlt_b with a_eq_b a_gt_b, {
      rw a_eq_b at ga_lt_gb,
      exact false.elim (nat.lt_asymm ga_lt_gb ga_lt_gb),
    },
    exact false.elim (nat.lt_asymm ga_lt_gb (graded.lt_grade_of_lt a_gt_b)),
  end

  /-- No two elements in a flag have the same grade. -/
  theorem grade_eq_of_eq {ff : is_flag f} {a b : flag_faces ff} : graded.grade a = graded.grade b → a = b :=
  begin
    rintros ga_eq_gb,
    cases lt_trichotomy a b with a_lt_b a_nlt_b, {
      exact false.elim (ne_of_lt (graded.lt_grade_of_lt a_lt_b) ga_eq_gb),
    },
    cases a_nlt_b with a_eq_b a_gt_b, {
      exact a_eq_b,
    },
    exact false.elim (ne_of_gt (graded.lt_grade_of_lt a_gt_b) ga_eq_gb),
  end

  /-- Flag grades on a flag are sent to the interval `[0, grade ⊤]`. -/
  theorem flag_grades_maps_to (ff : is_flag f) : set.maps_to graded.grade f (set.Iic (graded.grade (⊤ : α))) :=
  λ _ _,  graded.le_grade_of_le le_top

  /-- Flag grades are injective on a flag. -/
  theorem flag_grades_inj_on (ff : is_flag f) : set.inj_on graded.grade f :=
  begin
    intros a a_mem_f b b_mem_f ga_eq_gb,
    apply (flag_faces.eq_iff_subtype ⟨a, a_mem_f⟩ ⟨b, b_mem_f⟩).mp,
    apply grade_eq_of_eq,
    exact ga_eq_gb,
    exact ff,
  end

  /-- `fin_grade` is an embedding from `flag_faces ff` into `fin (grade ⊤ + 1)`. -/
  def fin_grade_inj (ff : is_flag f) : flag_faces ff ↪ fin (graded.grade (⊤ : α) + 1) := begin
    use graded_bounded_partial_order.fin_grade,
    intros a b fga_eq_fgb,
    exact grade_eq_of_eq (fin.mk.inj_iff.mp fga_eq_fgb),
  end

  /-- Flag grades are injective on a flag. -/
  theorem flag_grades_inj_on' (ff : is_flag f) : set.inj_on graded.grade (to_flag_faces ff) :=
  begin
    apply flag_grades_inj_on,
    exact to_flag_faces_is_flag ff,
  end

  /-- The faces of a flag have a fintype, i.e. every flag is finite. -/
  noncomputable theorem flag_fintype (ff : is_flag f) : fintype (flag_faces ff) := begin
    -- We define the interval `[0, grade ⊤]` and its inverse image under `grade`, onto `f`.
    let I := set.Iic (graded.grade (⊤ : α)),
    let I_fin := set.finite_le_nat (graded.grade (⊤ : α)),
    let f' : set (flag_faces ff) := graded.grade ⁻¹' I,
    have f'_eq_to_flag_faces_ff : f' = to_flag_faces ff := begin
      apply eq_of_ssubset_flag_faces,
      intros a _,
      exact graded_bounded_partial_order.grade_mem_Iic a,
    end,

    -- The `grade` function is injective on the flag.
    have flag_grades_inj_on_ff : @set.inj_on (flag_faces ff) ℕ graded.grade f' := begin
      rw f'_eq_to_flag_faces_ff,
      apply flag_grades_inj_on',
    end,

    -- Since `I` is finite, so are `f'` and `f`.
    have f'_fin : f'.finite := @set.finite.preimage (flag_faces ff) ℕ I graded.grade flag_grades_inj_on_ff I_fin,
    rw f'_eq_to_flag_faces_ff at f'_fin,
    have f_fin : f.finite := begin
      have h := set.finite.image subtype.val f'_fin,
      rw subtype_of_flag_faces_eq_flag at h,
      exact h,
    end,
    exact set.finite.fintype f_fin,
  end

  /-- The assertion that a flag is finite. -/
  def flag_finite (ff : is_flag f) : f.finite :=
  ⟨flag_fintype ff⟩

  /-- A flag contains faces of each grade up to the grade of its topmost face. -/
  theorem flag_grades_Iic (ff : is_flag f) : flag_grades f = set.Iic (graded.grade (⊤ : α)) :=
  begin
    let G := flag_grades f,
    let N := graded.grade (⊤ : α),
    let I := set.Iic N,

    -- Every flag grade is between `0` and `N`.
    have G_in_I : G ⊆ I := begin
      rintros _ ⟨_, a_mem_f, ga_eq_f⟩,
      rw ←ga_eq_f,
      exact flag_grades_maps_to ff a_mem_f,
    end,

    -- Every number between `0` and `N` is a flag grade.
    have I_in_G : I ⊆ G := begin
      -- We suppose, by contradiction, that we're missing a number `n`.
      intros n n_mem_I,
      by_contra n_nmem_G,

      -- We build the intersection `[0, n] ∩ G` and prove that it's finite and non-empty.
      let Sm := (set.Iic n) ∩ G,
      let Sm_finite : Sm.finite := set.finite.inf_of_left (set.finite_le_nat n) G,
      let Sm_finset := set.finite.to_finset Sm_finite,
      have Sm_finset_non : Sm_finset.nonempty := begin
        use 0,
        rw set.finite.mem_to_finset,
        exact ⟨zero_le n, ⟨⊥, bot_in_flag ff, graded.grade_bot_eq_zero⟩⟩,
      end,

      -- We build the largest grade in `G` that's lesser than `n`.
      let m := Sm_finset.max' Sm_finset_non,
      have m_mem_Sm := (set.finite.mem_to_finset Sm_finite).mp (Sm_finset.max'_mem Sm_finset_non),
      cases m_mem_Sm with m_le_n m_mem_G,
      have m_lt_n : m < n := begin
        apply lt_of_le_of_ne,
        apply m_le_n,
        by_contra m_eq_n,
        have h : m = n ↔ ¬ m ≠ n := not_not.symm,
        rw ←h at m_eq_n,
        rw ←m_eq_n at n_nmem_G,
        exact n_nmem_G m_mem_G,
      end,

      -- We prove that no grades in `(m, n)` may appear in `G`.
      have hm : ∀ k : ℕ, k ∈ set.Ioo m n → k ∉ G := begin
        intros k k_mem_i,
        by_contra k_mem_G,
        have k_le_m : k ≤ m := begin
          apply finset.le_max',
          apply set.mem_to_finset.mpr,
          exact set.mem_sep (set.mem_Iic.mpr (le_of_lt k_mem_i.right)) k_mem_G,
        end,
        exact false.elim (not_lt.mpr k_le_m k_mem_i.left),
      end,

      -- We build the intersection `[n, ∞] ∩ G`.
      let SM := (set.Ici n) ∩ G,
      have SM_non : SM.nonempty := ⟨N, set.mem_inter n_mem_I ⟨⊤, top_in_flag ff, rfl⟩⟩,

      -- We build the smallest grade in `G` that's greater than `N`.
      let M : ℕ := well_founded.min nat.lt_wf SM SM_non,
      have M_mem_SM := nat.lt_wf.min_mem SM SM_non,
      cases M_mem_SM with n_le_M M_mem_G,
      have n_lt_M : n < M := begin
        apply lt_of_le_of_ne,
        apply n_le_M,
        by_contra n_eq_M,
        have h : n = M ↔ ¬ n ≠ M := not_not.symm,
        rw ←h at n_eq_M,
        rw n_eq_M at n_nmem_G,
        exact n_nmem_G M_mem_G,
      end,

      -- We prove that no grades in `[n, M)` may appear in `G`.
      have hM : ∀ k : ℕ, k ∈ set.Ico n M → k ∉ G := begin
        intros k k_mem_i,
        by_contra k_mem_G,
        have k_ge_m : k ≥ M := begin
          apply le_of_not_lt,
          apply well_founded.not_lt_min nat.lt_wf SM SM_non,
          exact set.mem_sep (set.mem_Ici.mpr k_mem_i.left) k_mem_G,
        end,
        exact false.elim (not_lt.mpr k_ge_m k_mem_i.right),
      end,

      -- `m < M`, obviously.
      have m_lt_M : m < M := lt_trans m_lt_n n_lt_M,

      -- We build faces `a` and `c` in the flag with grades `m` and `M`.
      cases m_mem_G with a ea,
      cases M_mem_G with c ec,
      cases ea with a_mem_f ga_eq_m,
      cases ec with c_mem_f gc_eq_M,
      let a : flag_faces ff := ⟨a, a_mem_f⟩,
      let c : flag_faces ff := ⟨c, c_mem_f⟩,

      -- `a` must be less than `c`.
      have ga_eq_m : graded.grade a = m := ga_eq_m,
      have gc_eq_M : graded.grade c = M := gc_eq_M,
      have a_lt_c : a < c := begin
        rw ←ga_eq_m at m_lt_M,
        rw ←gc_eq_M at m_lt_M,
        exact grade_lt_of_lt m_lt_M,
      end,

      -- There can't exist any face in the flag that's between `a` and `c`.
      have C : ¬ ∃ b, a < b ∧ b < c := begin
        intro he,
        cases he with b he,
        cases he with a_lt_b b_lt_c,

        let g := graded.grade b,
        have m_lt_g : m < g := begin
          rw ←ga_eq_m,
          exact graded.lt_grade_of_lt a_lt_b,
        end,
        have g_lt_M : g < M := begin
          rw ←gc_eq_M,
          exact graded.lt_grade_of_lt b_lt_c,
        end,
        have g_mem_G : g ∈ G := ⟨b.val, subtype.mem b, rfl⟩,
        by_cases g_lt_n : g < n, {
          exact hm g (set.mem_inter m_lt_g g_lt_n) g_mem_G,
        },
        exact hM g (set.mem_inter (le_of_not_gt g_lt_n) g_lt_M) g_mem_G,
      end,

      -- As a consequence, `m + 1 = M`.
      have ga_p1_eq_gc : graded.grade a + 1 = graded.grade c := graded.eq_p1_of_cover ⟨a_lt_c, C⟩,
      have m_p1_eq_M : m + 1 = M := begin
        rw ga_eq_m at ga_p1_eq_gc,
        rw gc_eq_M at ga_p1_eq_gc,
        exact ga_p1_eq_gc,
      end,

      -- But then, the existence of `n` such that `m < n < M` is impossible!
      linarith,
    end,

    exact set.subset.antisymm G_in_I I_in_G,
  end

  /-- Flag grades are surjective from a flag onto `[0, grade ⊤]`. -/
  theorem flag_grades_surj_on (ff : is_flag f) : set.surj_on graded.grade f (set.Iic (graded.grade (⊤ : α))) :=
  begin
    intros n n_mem_Iic,
    have h : graded.grade '' f = flag_grades f := set.image_eq graded.grade f,
    rw h,
    rw flag_grades_Iic ff,
    exact n_mem_Iic,
  end

  /-- Flag grades are surjective from a flag onto `[0, grade ⊤]`. -/
  theorem flag_grades_surj_on' (ff : is_flag f) : set.surj_on graded.grade (to_flag_faces ff) (set.Iic (graded.grade (⊤ : α))) :=
  begin
    apply flag_grades_surj_on,
    exact to_flag_faces_is_flag ff,
  end

  /-- Flag grades are bijective from a flag onto `[0, grade ⊤]`. -/
  theorem flag_grades_bij_on (ff : is_flag f) : set.bij_on graded.grade f (set.Iic (graded.grade (⊤ : α))) :=
  ⟨flag_grades_maps_to ff, flag_grades_inj_on ff, flag_grades_surj_on ff⟩

  /-- Flag grades are bijective from a flag onto `[0, grade ⊤]`. -/
  theorem flag_grades_bij_on' (ff : is_flag f) : set.bij_on graded.grade (to_flag_faces ff) (set.Iic (graded.grade (⊤ : α))) :=
  begin
    apply flag_grades_bij_on,
    exact to_flag_faces_is_flag ff,
  end

  def fin_grade_inv (ff : is_flag f) : fin (graded.grade (⊤ : α) + 1) → flag_faces ff :=
  begin
    --have h := function.embedding.inv_of_mem_range graded_bounded_partial_order.fin_grade,
    sorry,
  end

  def faces_equiv_grades (ff : is_flag f) : flag_faces ff ≃ fin (graded.grade (⊤ : α) + 1) :=
  begin
    use graded_bounded_partial_order.fin_grade,
    sorry,
    sorry,
    sorry,
  end

  /-- The cardinality of a flag. -/
  def flag_card (ff : is_flag f) [fintype (flag_faces ff)] : ℕ := fintype.card (flag_faces ff)

  /-- Any flag's cardinality equals the grade of the top face, plus one. -/
  theorem flag_card_eq_grade_top_p1 (ff : is_flag f) [fintype (flag_faces ff)] : flag_card ff = graded.grade (⊤ : α) + 1 :=
  begin
    let N := graded.grade (⊤ : α),
    rw ←fintype.card_fin (N + 1),
    apply fintype.card_congr,
    split, rotate, rotate, {
      intro a,
      use graded.grade a,
    }, {
      sorry,
    }, {
      sorry,
    },
    sorry,
  end

  /-- All flags have the same cardinality. -/
  theorem all_flags_same_card (ff : is_flag f) (ff' : is_flag f') [fintype (flag_faces ff)] [fintype (flag_faces ff')] : flag_card ff = flag_card ff' :=
  begin
    have h₁ := flag_card_eq_grade_top_p1 ff,
    rw ←(flag_card_eq_grade_top_p1 ff') at h₁,
    exact h₁,
  end

  /-- Flag adjacency in an abstract polytope is commutative. -/
  theorem flag_adj_comm : flag.is_flag f → flag.is_flag f' → flag.flag_adj f f' → flag.flag_adj f' f :=
  begin
    intros ff ff',
    sorry,
  end

end
end flag

namespace flag_faces
section

  parameters {α : Type*} [graded_bounded_partial_order α] {f : set α} {ff : flag.is_flag f}

  instance of_well_order : is_well_order (flag_faces ff) (<) :=
  {
    wf := begin
      apply well_founded.intro,
      have h : ∀ {n : ℕ} (a : flag_faces ff), graded.grade a ≤ n → acc (<) a := begin
        intro n,
        induction n with n hn, {
          intros a ga_le_zero,
          apply acc.intro,
          intros y y_lt_a,
          rw (graded.eq_bot_of_grade_eq_zero (nat.le_zero_iff.mp ga_le_zero)) at y_lt_a,
          have bot_le_y : ⊥ ≤ y := bot_le,
          exact false.elim ((not_lt.mpr bot_le_y) y_lt_a),
        },
        intros a ga_le_ns,
        apply acc.intro,
        intros y y_lt_a,
        exact hn y (nat.lt_succ_iff.mp (lt_of_lt_of_le (graded.lt_grade_of_lt y_lt_a) ga_le_ns)),
      end,
      intro a,
      exact h a rfl.ge,
    end
  }

end
end flag_faces

set_option old_structure_cmd false

class abstract_polytope (α : Type*) extends (graded_bounded_partial_order α) :=
(diamond : ∀ {a b : α}, grade a + 2 = grade b → #(set.Ioo a b) = 2)

set_option old_structure_cmd true

namespace abstract_polytope

  variables {α : Type*} [abstract_polytope α] {f f' : set α}

  def grade : ℕ := graded.grade (⊤ : α)

  -- Any nontrivial section contains a vertex.
  theorem section_vertex (a b : α) : b < a → ∃ c ∈ set.Icc b a, covers b c :=
  begin
    -- Set up an induction on (grade a), which can almost certainly be done more elegantly
    let m := nat.succ (graded.grade a),
    have grade_a_m_succ : graded.grade a < m,
    {
      apply lt_add_one,
    },
    revert grade_a_m_succ,
    generalize : m = n,
    clear m,
    revert a b,
    induction n with n ih,
    {
      intros a b grade_a_lt_zero,
      cases nat.not_lt_zero _ grade_a_lt_zero,
    },
    intros a b grade_a_n_succ b_lt_a,
    -- Is there something between a and b?
    by_cases ∃ c : α, b < c ∧ c < a,
    {
      -- Yes, try to find a cover between that and b.
      cases h with c h,
      cases h with b_lt_c c_lt_a,
      have h : ∃ (d ∈ set.Icc b c), covers b d,
      {
        apply ih,
        {
          let grade_c_lt_grade_a := graded.lt_grade_of_lt c_lt_a,
          have grade_a_le_n : graded.grade a ≤ n,
          {
            exact nat.le_of_lt_succ grade_a_n_succ,
          },
          exact nat.lt_of_lt_of_le grade_c_lt_grade_a grade_a_le_n,
        },
        exact b_lt_c,
      },
      cases h with d h,
      use d,
      cases h with d_between_b_a covers_b_d,
      split,
      {
        rewrite set.mem_Icc,
        rewrite set.mem_Icc at d_between_b_a,
        cases d_between_b_a with b_le_d d_le_c,
        split,
        {
          exact b_le_d,
        },
        exact le_trans d_le_c (le_of_lt c_lt_a),
      },
      exact covers_b_d,
    },
    -- No, so a is covering.
    use a,
    split,
    {
      rewrite set.mem_Icc,
      split,
      {
        exact le_of_lt b_lt_a,
      },
      apply le_refl,
    },
    split,
    {
      exact b_lt_a,
    },
    exact h,
  end

end abstract_polytope

#lint


/-
Copyright (c) 2020 Johan Commelin, Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import data.mv_polynomial.rename
import data.mv_polynomial.variables

/-!

# Monad operations on `mv_polynomial`

This file defines two monadic operations on `mv_polynomial`. Given `p : mv_polynomial σ R`,

* `mv_polynomial.bind₁` and `mv_polynomial.join₁` operate on the variable type `σ`.
* `mv_polynomial.bind₂` and `mv_polynomial.join₂` operate on the coefficient type `R`.

- `mv_polynomial.bind₁ f φ` with `f : σ → mv_polynomial τ R` and `φ : mv_polynomial σ R`,
  is the polynomial `φ(f 1, ..., f i, ...) : mv_polynomial τ R`.
- `mv_polynomial.join₁ φ` with `φ : mv_polynomial (mv_polynomial σ R) R` collapses `φ` to
  a `mv_polynomial σ R`, by evaluating `φ` under the map `X f ↦ f` for `f : mv_polynomial σ R`.
  In other words, if you have a polynomial `φ` in a set of variables indexed by a polynomial ring,
  you evaluate the polynomial in these indexing polynomials.
- `mv_polynomial.bind₂ f φ` with `f : R →+* mv_polynomial σ S` and `φ : mv_polynomial σ R`
  is the `mv_polynomial σ S` obtained from `φ` by mapping the coefficients of `φ` through `f`
  and considering the resulting polynomial as polynomial expression in `mv_polynomial σ R`.
- `mv_polynomial.join₂ φ` with `φ : mv_polynomial σ (mv_polynomial σ R)` collapses `φ` to
  a `mv_polynomial σ R`, by considering `φ` as polynomial expression in `mv_polynomial σ R`.

These operations themselves have algebraic structure: `mv_polynomial.bind₁`
and `mv_polynomial.join₁` are algebra homs and
`mv_polynomial.bind₂` and `mv_polynomial.join₂` are ring homs.

They interact in convenient ways with `mv_polynomial.rename`, `mv_polynomial.map`,
`mv_polynomial.vars`, and other polynomial operations.
Indeed, `mv_polynomial.rename` is the "map" operation for the (`bind₁`, `join₁`) pair,
whereas `mv_polynomial.map` is the "map" operation for the other pair.

## Implementation notes

We add an `is_lawful_monad` instance for the (`bind₁`, `join₁`) pair.
The second pair cannot be instantiated as a `monad`,
since it is not a monad in `Type` but in `CommRing` (or rather `CommSemiRing`).

-/

open_locale big_operators
noncomputable theory
namespace mv_polynomial
open finsupp

variables {σ : Type*} {τ : Type*}
variables {R S T : Type*} [comm_semiring R] [comm_semiring S] [comm_semiring T]

/--
`bind₁` is the "left hand side" bind operation on `mv_polynomial`, operating on the variable type.
Given a polynomial `p : mv_polynomial σ R` and a map `f : σ → mv_polynomial τ R` taking variables
in `p` to polynomials in the variable type `τ`, `bind₁ f p` replaces each variable in `p` with
its value under `f`, producing a new polynomial in `τ`. The coefficient type remains the same.
This operation is an algebra hom.
-/
def bind₁ (f : σ → mv_polynomial τ R) : mv_polynomial σ R →ₐ[R] mv_polynomial τ R :=
aeval f

/--
`bind₂` is the "right hand side" bind operation on `mv_polynomial`,
operating on the coefficient type.
Given a polynomial `p : mv_polynomial σ R` and
a map `f : R → mv_polynomial σ S` taking coefficients in `p` to polynomials over a new ring `S`,
`bind₂ f p` replaces each coefficient in `p` with its value under `f`,
producing a new polynomial over `S`.
The variable type remains the same. This operation is a ring hom.
-/
def bind₂ (f : R →+* mv_polynomial σ S) : mv_polynomial σ R →+* mv_polynomial σ S :=
eval₂_hom f X

/--
`join₁` is the monadic join operation corresponding to `mv_polynomial.bind₁`. Given a polynomial `p`
with coefficients in `R` whose variables are polynomials in `σ` with coefficients in `R`,
`join₁ p` collapses `p` to a polynomial with variables in `σ` and coefficients in `R`.
This operation is an algebra hom.
-/
def join₁ : mv_polynomial (mv_polynomial σ R) R →ₐ[R] mv_polynomial σ R :=
aeval id

/--
`join₂` is the monadic join operation corresponding to `mv_polynomial.bind₂`. Given a polynomial `p`
with variables in `σ` whose coefficients are polynomials in `σ` with coefficients in `R`,
`join₂ p` collapses `p` to a polynomial with variables in `σ` and coefficients in `R`.
This operation is a ring hom.
-/
def join₂ : mv_polynomial σ (mv_polynomial σ R) →+* mv_polynomial σ R :=
eval₂_hom (ring_hom.id _) X

@[simp] lemma aeval_eq_bind₁ (f : σ → mv_polynomial τ R) :
  aeval f = bind₁ f := rfl

@[simp] lemma eval₂_hom_C_eq_bind₁ (f : σ → mv_polynomial τ R) :
  eval₂_hom C f = bind₁ f := rfl

@[simp] lemma eval₂_hom_eq_bind₂ (f : R →+* mv_polynomial σ S) :
  eval₂_hom f X = bind₂ f := rfl

section
variables (σ R)
@[simp] lemma aeval_id_eq_join₁ :
  aeval id = @join₁ σ R _ := rfl

lemma eval₂_hom_C_id_eq_join₁ (φ : mv_polynomial (mv_polynomial σ R) R) :
  eval₂_hom C id φ = join₁ φ := rfl

@[simp] lemma eval₂_hom_id_X_eq_join₂ :
  eval₂_hom (ring_hom.id _) X = @join₂ σ R _ := rfl

end

-- In this file, we don't want to use these simp lemmas,
-- because we first need to show how these new definitions interact
-- and the proofs fall back on unfolding the definitions and call simp afterwards

local attribute [-simp] aeval_eq_bind₁ eval₂_hom_C_eq_bind₁ eval₂_hom_eq_bind₂
                        aeval_id_eq_join₁ eval₂_hom_id_X_eq_join₂

@[simp]
lemma bind₁_X_right (f : σ → mv_polynomial τ R) (i : σ) : bind₁ f (X i) = f i :=
aeval_X f i

@[simp]
lemma bind₂_X_right (f : R →+* mv_polynomial σ S) (i : σ) : bind₂ f (X i) = X i :=
eval₂_hom_X' f X i

@[simp]
lemma bind₁_X_left : bind₁ (X : σ → mv_polynomial σ R) = alg_hom.id R _ :=
by { ext1 i, simp }

variable (f : σ → mv_polynomial τ R)

@[simp]
lemma bind₁_C_right (f : σ → mv_polynomial τ R) (x) : bind₁ f (C x) = C x :=
by simp [bind₁, algebra_map_eq]

@[simp]
lemma bind₂_C_right (f : R →+* mv_polynomial σ S) (r : R) : bind₂ f (C r) = f r :=
eval₂_hom_C f X r

@[simp]
lemma bind₂_C_left : bind₂ (C : R →+* mv_polynomial σ R) = ring_hom.id _ :=
by { ext : 2; simp }

@[simp]
lemma bind₂_comp_C (f : R →+* mv_polynomial σ S) :
  (bind₂ f).comp C = f :=
ring_hom.ext $ bind₂_C_right _

@[simp]
lemma join₂_map (f : R →+* mv_polynomial σ S) (φ : mv_polynomial σ R) :
  join₂ (map f φ) = bind₂ f φ :=
by simp only [join₂, bind₂, eval₂_hom_map_hom, ring_hom.id_comp]

@[simp]
lemma join₂_comp_map (f : R →+* mv_polynomial σ S) :
  join₂.comp (map f) = bind₂ f :=
ring_hom.ext $ join₂_map _

lemma aeval_id_rename (f : σ → mv_polynomial τ R) (p : mv_polynomial σ R) :
  aeval id (rename f p) = aeval f p :=
by rw [aeval_rename, function.comp.left_id]

@[simp]
lemma join₁_rename (f : σ → mv_polynomial τ R) (φ : mv_polynomial σ R) :
  join₁ (rename f φ) = bind₁ f φ :=
aeval_id_rename _ _

@[simp]
lemma bind₁_id : bind₁ (@id (mv_polynomial σ R)) = join₁ := rfl

@[simp]
lemma bind₂_id : bind₂ (ring_hom.id (mv_polynomial σ R)) = join₂ := rfl

lemma bind₁_bind₁ {υ : Type*} (f : σ → mv_polynomial τ R) (g : τ → mv_polynomial υ R)
  (φ : mv_polynomial σ R) :
  (bind₁ g) (bind₁ f φ) = bind₁ (λ i, bind₁ g (f i)) φ :=
by simp [bind₁, ← comp_aeval]

lemma bind₁_comp_bind₁ {υ : Type*} (f : σ → mv_polynomial τ R) (g : τ → mv_polynomial υ R) :
  (bind₁ g).comp (bind₁ f) = bind₁ (λ i, bind₁ g (f i)) :=
by { ext1, apply bind₁_bind₁ }

lemma bind₂_comp_bind₂ (f : R →+* mv_polynomial σ S) (g : S →+* mv_polynomial σ T) :
  (bind₂ g).comp (bind₂ f) = bind₂ ((bind₂ g).comp f) :=
by { ext : 2; simp }

lemma bind₂_bind₂ (f : R →+* mv_polynomial σ S) (g : S →+* mv_polynomial σ T)
  (φ : mv_polynomial σ R) :
  (bind₂ g) (bind₂ f φ) = bind₂ ((bind₂ g).comp f) φ :=
ring_hom.congr_fun (bind₂_comp_bind₂ f g) φ

lemma rename_comp_bind₁ {υ : Type*} (f : σ → mv_polynomial τ R) (g : τ → υ) :
  (rename g).comp (bind₁ f) = bind₁ (λ i, rename g $ f i) :=
by { ext1 i, simp }

lemma rename_bind₁ {υ : Type*} (f : σ → mv_polynomial τ R) (g : τ → υ) (φ : mv_polynomial σ R) :
  rename g (bind₁ f φ) = bind₁ (λ i, rename g $ f i) φ :=
alg_hom.congr_fun (rename_comp_bind₁ f g) φ

lemma map_bind₂ (f : R →+* mv_polynomial σ S) (g : S →+* T) (φ : mv_polynomial σ R) :
  map g (bind₂ f φ) = bind₂ ((map g).comp f) φ :=
begin
  simp only [bind₂, eval₂_comp_right, coe_eval₂_hom, eval₂_map],
  congr' 1 with : 1,
  simp only [function.comp_app, map_X]
end

lemma bind₁_comp_rename {υ : Type*} (f : τ → mv_polynomial υ R) (g : σ → τ) :
  (bind₁ f).comp (rename g) = bind₁ (f ∘ g) :=
by { ext1 i, simp }

lemma bind₁_rename {υ : Type*} (f : τ → mv_polynomial υ R) (g : σ → τ) (φ : mv_polynomial σ R) :
  bind₁ f (rename g φ) = bind₁ (f ∘ g) φ :=
alg_hom.congr_fun (bind₁_comp_rename f g) φ

lemma bind₂_map (f : S →+* mv_polynomial σ T) (g : R →+* S) (φ : mv_polynomial σ R) :
  bind₂ f (map g φ) = bind₂ (f.comp g) φ :=
by simp [bind₂]

@[simp]
lemma map_comp_C (f : R →+* S) : (map f).comp (C : R →+* mv_polynomial σ R) = C.comp f :=
by { ext1, apply map_C }

-- mixing the two monad structures

lemma map_bind₁ (f : R →+* S) (g : σ → mv_polynomial τ R) (φ : mv_polynomial σ R) :
  map f (bind₁ g φ) = bind₁ (λ (i : σ), (map f) (g i)) (map f φ) :=
by { rw [hom_bind₁, map_comp_C, ← eval₂_hom_map_hom], refl }

@[simp]
lemma eval₂_hom_comp_C (f : R →+* S) (g : σ → S) :
  (eval₂_hom f g).comp C = f :=
by { ext1 r, exact eval₂_C f g r }

lemma eval₂_hom_bind₁ (f : R →+* S) (g : τ → S) (h : σ → mv_polynomial τ R)
  (φ : mv_polynomial σ R) :
  eval₂_hom f g (bind₁ h φ) = eval₂_hom f (λ i, eval₂_hom f g (h i)) φ :=
by rw [hom_bind₁, eval₂_hom_comp_C]

lemma aeval_bind₁ [algebra R S] (f : τ → S) (g : σ → mv_polynomial τ R) (φ : mv_polynomial σ R) :
  aeval f (bind₁ g φ) = aeval (λ i, aeval f (g i)) φ :=
eval₂_hom_bind₁ _ _ _ _

lemma aeval_comp_bind₁ [algebra R S] (f : τ → S) (g : σ → mv_polynomial τ R) :
  (aeval f).comp (bind₁ g) = aeval (λ i, aeval f (g i)) :=
by { ext1, apply aeval_bind₁ }

lemma eval₂_hom_comp_bind₂ (f : S →+* T) (g : σ → T) (h : R →+* mv_polynomial σ S) :
  (eval₂_hom f g).comp (bind₂ h) = eval₂_hom ((eval₂_hom f g).comp h) g :=
by { ext : 2; simp }

lemma eval₂_hom_bind₂ (f : S →+* T) (g : σ → T) (h : R →+* mv_polynomial σ S)
  (φ : mv_polynomial σ R) :
  eval₂_hom f g (bind₂ h φ) = eval₂_hom ((eval₂_hom f g).comp h) g φ :=
ring_hom.congr_fun (eval₂_hom_comp_bind₂ f g h) φ

lemma aeval_bind₂ [algebra S T] (f : σ → T) (g : R →+* mv_polynomial σ S) (φ : mv_polynomial σ R) :
  aeval f (bind₂ g φ) = eval₂_hom ((↑(aeval f : _ →ₐ[S] _) : _ →+* _).comp g) f φ :=
eval₂_hom_bind₂ _ _ _ _

lemma eval₂_hom_C_left (f : σ → mv_polynomial τ R) : eval₂_hom C f = bind₁ f := rfl

lemma bind₁_monomial (f : σ → mv_polynomial τ R) (d : σ →₀ ℕ) (r : R) :
  bind₁ f (monomial d r) = C r * ∏ i in d.support, f i ^ d i :=
by simp only [monomial_eq, alg_hom.map_mul, bind₁_C_right, finsupp.prod,
  alg_hom.map_prod, alg_hom.map_pow, bind₁_X_right]

lemma bind₂_monomial (f : R →+* mv_polynomial σ S) (d : σ →₀ ℕ) (r : R) :
  bind₂ f (monomial d r) = f r * monomial d 1 :=
by simp only [monomial_eq, ring_hom.map_mul, bind₂_C_right, finsupp.prod,
  ring_hom.map_prod, ring_hom.map_pow, bind₂_X_right, C_1, one_mul]

@[simp]
lemma bind₂_monomial_one (f : R →+* mv_polynomial σ S) (d : σ →₀ ℕ) :
  bind₂ f (monomial d 1) = monomial d 1 :=
by rw [bind₂_monomial, f.map_one, one_mul]

section
open_locale classical

lemma vars_bind₁ (f : σ → mv_polynomial τ R) (φ : mv_polynomial σ R) :
  (bind₁ f φ).vars ⊆ φ.vars.bUnion (λ i, (f i).vars) :=
begin
  calc (bind₁ f φ).vars
      = (φ.support.sum (λ (x : σ →₀ ℕ), (bind₁ f) (monomial x (coeff x φ)))).vars :
        by { rw [← alg_hom.map_sum, ← φ.as_sum], }
  ... ≤ φ.support.bUnion (λ (i : σ →₀ ℕ), ((bind₁ f) (monomial i (coeff i φ))).vars) :
        vars_sum_subset _ _
  ... = φ.support.bUnion (λ (d : σ →₀ ℕ), (C (coeff d φ) * ∏ i in d.support, f i ^ d i).vars) :
        by simp only [bind₁_monomial]
  ... ≤ φ.support.bUnion (λ (d : σ →₀ ℕ), d.support.bUnion (λ i, (f i).vars)) : _ -- proof below
  ... ≤ φ.vars.bUnion (λ (i : σ), (f i).vars) : _, -- proof below
  { apply finset.bUnion_mono,
    intros d hd,
    calc (C (coeff d φ) * ∏ (i : σ) in d.support, f i ^ d i).vars
        ≤ (C (coeff d φ)).vars ∪ (∏ (i : σ) in d.support, f i ^ d i).vars : vars_mul _ _
    ... ≤ (∏ (i : σ) in d.support, f i ^ d i).vars :
      by simp only [finset.empty_union, vars_C, finset.le_iff_subset, finset.subset.refl]
    ... ≤ d.support.bUnion (λ (i : σ), (f i ^ d i).vars) : vars_prod _
    ... ≤ d.support.bUnion (λ (i : σ), (f i).vars) : _,
    apply finset.bUnion_mono,
    intros i hi,
    apply vars_pow, },
  { intro j,
    simp_rw finset.mem_bUnion,
    rintro ⟨d, hd, ⟨i, hi, hj⟩⟩,
    exact ⟨i, (mem_vars _).mpr ⟨d, hd, hi⟩, hj⟩ }
end
end

lemma mem_vars_bind₁ (f : σ → mv_polynomial τ R) (φ : mv_polynomial σ R) {j : τ}
  (h : j ∈ (bind₁ f φ).vars) :
  ∃ (i : σ), i ∈ φ.vars ∧ j ∈ (f i).vars :=
by simpa only [exists_prop, finset.mem_bUnion, mem_support_iff, ne.def] using vars_bind₁ f φ h

instance monad : monad (λ σ, mv_polynomial σ R) :=
{ map := λ α β f p, rename f p,
  pure := λ _, X,
  bind := λ _ _ p f, bind₁ f p }

instance is_lawful_functor : is_lawful_functor (λ σ, mv_polynomial σ R) :=
{ id_map := by intros; simp [(<$>)],
  comp_map := by intros; simp [(<$>)] }

instance is_lawful_monad : is_lawful_monad (λ σ, mv_polynomial σ R) :=
{ pure_bind := by intros; simp [pure, bind],
  bind_assoc := by intros; simp [bind, ← bind₁_comp_bind₁] }

/-
Possible TODO for the future:
Enable the following definitions, and write a lot of supporting lemmas.

def bind (f : R →+* mv_polynomial τ S) (g : σ → mv_polynomial τ S) :
  mv_polynomial σ R →+* mv_polynomial τ S :=
eval₂_hom f g

def join (f : R →+* S) : mv_polynomial (mv_polynomial σ R) S →ₐ[S] mv_polynomial σ S :=
aeval (map f)

def ajoin [algebra R S] : mv_polynomial (mv_polynomial σ R) S →ₐ[S] mv_polynomial σ S :=
join (algebra_map R S)

-/

end mv_polynomial


import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Init.Data.Int.Basic
import Mathlib.Tactic.LibrarySearch
import Mathlib.Data.Equiv.Basic
import Mathlib.Init.Data.Int.Order
import Timelib.Date.Year
import Timelib.Date.Month
import Timelib.Date.ScalarDate
import Timelib.Date.OrdinalDate
import Timelib.Date.Ymd
import Timelib.Date.Convert
import Timelib.Util
import Timelib.Date.Lemmas.YmdOrdinalEquiv

instance : Equiv Ymd OrdinalDate where
  toFun := Ymd.toOrdinalDate
  invFun := OrdinalDate.toYmd
  left_inv := Ymd.toOrdinalDate_left_inv
  right_inv := OrdinalDate.toYmd_right_inv

instance : Equiv OrdinalDate ScalarDate where
  toFun := OrdinalDate.toScalarDate
  invFun := ScalarDate.toOrdinalDate
  left_inv := sorry
  right_inv := sorry

instance : Equiv Ymd ScalarDate :=
  Equiv.trans instEquivYmdOrdinalDate instEquivOrdinalDateScalarDate

theorem OrdinalDate.toYmd_monotonic {ω π : OrdinalDate} : ω <= π → ω.toYmd <= π.toYmd := sorry

theorem Ymd.toOrdinalDate_monotonic {d₁ d₂ : Ymd} : d₁ <= d₂ → d₁.toOrdinalDate <= d₂.toOrdinalDate := sorry

theorem OrdinalDate.toScalarDate_monotonic {ω π : OrdinalDate} : ω <= π → ω.toScalarDate <= π.toScalarDate := sorry

theorem ScalarDate.toOrdinalDate_monotonic {d1 d2 : ScalarDate} : d1 <= d2 → d1.toOrdinalDate <= d2.toOrdinalDate := sorry

theorem Ymd.toScalarDate_monotonic {y1 y2 : Ymd} : y1 <= y2 → y1.toScalarDate <= y2.toScalarDate :=
  OrdinalDate.toScalarDate_monotonic ∘ Ymd.toOrdinalDate_monotonic

theorem ScalarDate.toYmd_monotonic {d1 d2 : ScalarDate} : d1 <= d2 → d1.toYmd <= d2.toYmd :=
  OrdinalDate.toYmd_monotonic ∘ ScalarDate.toOrdinalDate_monotonic


import ring_theory.algebraic
-- import data.finset
-- import algebra.field
-- import field_theory.subfield
import field_theory.algebraic_closure
-- import order.zorn
import Rings.ToMathlib
-- import data.mv_polynomial.equiv
-- import data.equiv.fin

open classical
local attribute [instance] prop_decidable

universes u v v0

section nttn

@[simp] def algebra.image
  (K : Type u) (L : Type v) [comm_semiring K] [semiring L] [algebra K L] : set L :=
set.range (algebra_map K L)

@[simp] def subfield_generated
  (K : Type u) {L : Type v} [field K] [field L] [algebra K L] (S : set L)
  : subfield L :=
subfield.closure (S ∪ algebra.image K L)

namespace subfield_generated

variables
  (K : Type*) {L : Type*} [field K] [field L] [algebra K L] (S : set L)

lemma subset_closure_set : S ⊆ subfield_generated K S :=
begin
  intros _ hs,
  simp only [subfield_generated, set_like.mem_coe],
  apply subfield.subset_closure,
  left,
  exact hs,
end

lemma subset_closure_base (a : K) : algebra_map K L a ∈ subfield_generated K S :=
begin
  simp only [subfield_generated, set_like.mem_coe],
  apply subfield.subset_closure,
  right,
  simp only [set.mem_range_self, algebra.image]
end

@[simp] def ring_hom : K →+* subfield_generated K S :=
⟨
  (λ a, ⟨ algebra_map K L a , subset_closure_base K S a⟩ ),
  begin simp only [ring_hom.map_one], refl end,
  begin intros, simp only [ring_hom.map_mul], refl end,
  begin simp only [ring_hom.map_zero], refl end,
  begin intros, simp only [ring_hom.map_add], refl end
⟩

instance has_scalar : has_scalar K (subfield_generated K S) :=
⟨ λ a r, (ring_hom K S a) * r ⟩
-- #check algebra

@[simp] instance algebra : algebra K (subfield_generated K S) :=
⟨
  ring_hom K S ,
  λ r, field.mul_comm (ring_hom K S r),
  (λ r x, rfl) ,
⟩

@[simp] noncomputable def eval {n : ℕ} (as : fin n → L) (has : Π k, as k ∈ S) :
  mv_polynomial (fin n) K →+* subfield_generated K S :=
  mv_polynomial.eval₂_hom (algebra_map K (subfield_generated K S))
    (λ k, ⟨ as k , subfield_generated.subset_closure_set K S (has k) ⟩)

lemma eval_proj {n : ℕ} (as : fin n → L) (has : Π k, as k ∈ S) (p : mv_polynomial (fin n) K) :
  ((subfield_generated.eval K S as has) p).val
    = mv_polynomial.eval as (p : mv_polynomial (fin n) L) :=
-- lemma eval_proj {n : ℕ} (as : fin n → L) (has : Π k, as k ∈ S) (p : mv_polynomial (fin n) K) :
--   ((subfield_generated.eval K S as has) p).val
--     = mv_polynomial.eval as (mv_polynomial.map (algebra_map K L) p) :=
-- mv_polynomial.induction_on p _ _ _

@mv_polynomial.induction_on K (fin n) _
  (λ q, ((subfield_generated.eval K S as has) q).val
    = mv_polynomial.eval as (q : mv_polynomial (fin n) L))
  p
(begin
  intro a,
  simp only [eval, mv_polynomial.map_C, mv_polynomial.eval_C, ring_hom.to_fun_eq_coe,
    mv_polynomial.eval₂_hom_C, subtype.val_eq_coe, algebra_map],
  unfold_coes,
  simpa,
end)
(begin
  intros p q hp hq,
  simp only [eval, mv_polynomial.coe_eval₂_hom, subfield.coe_add, ring_hom.to_fun_eq_coe,
     mv_polynomial.eval₂_add, mv_polynomial.eval_map, subtype.val_eq_coe],
  simp only [eval, mv_polynomial.coe_eval₂_hom, subfield.coe_add, ring_hom.to_fun_eq_coe,
     mv_polynomial.eval₂_add, mv_polynomial.eval_map, subtype.val_eq_coe] at hp hq,
  rw [hp, hq],
  unfold_coes,
  simp,
end)
(begin
  intros p n hp,
  unfold_coes,
  simp only [mv_polynomial.eval_X, eval, subfield.coe_mul, ring_hom.to_fun_eq_coe,
    mv_polynomial.coe_eval₂_hom, subfield_generated,
    mv_polynomial.eval_map, subfield_generated.algebra,
    subtype.coe_mk, mul_eq_mul_right_iff, mv_polynomial.eval₂_X,
    ring_hom.map_mul, subtype.val_eq_coe, mv_polynomial.map_X],
  left,
  unfold_coes at hp,
  simp only [eval, mv_polynomial.coe_eval₂_hom, ring_hom.to_fun_eq_coe,
    mv_polynomial.eval_map, subtype.val_eq_coe] at hp,
  exact hp,
end)

end subfield_generated

end nttn

namespace transcendent

variables
  (K : Type u) {L : Type u} [field K] [field L] [algebra K L]

def indep (S : set L) : Prop :=
Π (n : ℕ) (f : mv_polynomial (fin n) K) (as : fin n → L),
(Π k, as k ∈ S) → mv_polynomial.eval as (f : mv_polynomial (fin n) L) = 0 → f = 0

lemma indep_subset (S T : set L) (hST : S ⊆ T) : indep K T → indep K S :=
begin
  intros hT _ f as has hf,
  have has' : Π k, as k ∈ T := λ k, hST (has k),
  exact hT _ f as has' hf,
end

lemma indep_empty : indep K (∅ : set L)
| nat.zero f as has hf :=
begin
  apply @mv_polynomial.map_injective K L (fin 0) _ _ (algebra_map K L) (ring_hom.injective _),
  simp,
  rw mv_polynomial.is_empty (fin.is_empty) (mv_polynomial.map (algebra_map K L) f) as,
  rw ← mv_polynomial.C_0,
  rw (mv_polynomial.C_inj L),
  rw ← hf,
  simp only [mv_polynomial.eval, mv_polynomial.eval_map],
  unfold_coes,
end
| (nat.succ n) f as has hf :=
begin
  exfalso,
  rw ← set.mem_empty_eq (as 0),
  {apply has},
end

lemma indep_sUnion_chain {c : set (set L)} (hchain : zorn.chain has_subset.subset c)
  (h0 : c.nonempty)
  (hc : Π (S : set L) (hS : S ∈ c), indep K S) :
  indep K ⋃₀ c :=
begin
  intros k f as has hf,
  cases zorn.fin_range_sub_mem_chain_of_sub_union hchain h0 as has with S hS,
  cases hS with hSc hS,
  apply hc S hSc _ _ as _ hf,
  exact hS,
end

def basis (B : set L) : Prop := indep K B ∧ Π (S : set L), indep K S → B ⊆ S → S = B

lemma extend_to_basis_aux (S : set L) (hindS : indep K S) :
  ∃ (B : set L) (H : B ∈ {T : set L | S ⊆ T ∧ indep K T}),
  S ⊆ B ∧ Π (T : set L), T ∈ {T : set L | S ⊆ T ∧ indep K T} → B ⊆ T → T = B :=
(@zorn.zorn_subset_nonempty L { T : set L | S ⊆ T ∧ indep K T }
  (λ c hcsub hchain hc0,
    ⟨
      -- the upper bound by taking union
      ⋃₀ c ,
      ⟨
        let hScup : S ⊆ ⋃₀ c :=
        begin
          cases hc0 with T hT,
          cases hcsub hT with hST hand,
          have hTcup : T ⊆ ⋃₀ c := λ t ht , ⟨ T , hT , ht ⟩,
          exact set.subset.trans hST hTcup,
        end in
        ⟨ -- the upper bound is in the set
          hScup ,
          indep_sUnion_chain K hchain hc0 (λ S hs, (hcsub hs).2)
        ⟩ ,
        (λ S hS s hs, ⟨ S , hS , hs ⟩) -- showing the maximal element is in the set
      ⟩
    ⟩
  )
  S -- give U for the set being non-empty
  ⟨ set.subset.refl _ , hindS ⟩)

lemma subfield_mem (a : L) (K : subfield L) (haK : a ∈ K) :
  a = algebra_map K L (⟨ a , haK ⟩ : K) := rfl

lemma is_algebraic_subfield {a : L} {K : subfield L} (haK : a ∈ K) : is_algebraic K a :=
⟨
  polynomial.X - polynomial.C (⟨ a , haK ⟩ : K) ,
  polynomial.X_sub_C_ne_zero _ ,
  begin
    simp only [polynomial.aeval_X, polynomial.aeval_C, alg_hom.map_sub],
    rw ← subfield_mem a K haK,
    simp,
  end
⟩

-- #check @mv_polynomial.map_injective
-- -- mv_polynomial.eval₂ polynomial.C bs (⇑(mv_polynomial.map (subfield_generated.ring_hom K B)) f)

-- #check @ring_hom.injective

-- #check @mv_polynomial.eval₂

-- #check mv_polynomial.eval₂_zero
-- --
-- #check polynomial.as_sum_range

lemma mv_polynomial.zero_iff {K : Type u} {R : Type v} {σ : Type v0} [field K] [comm_semiring R]
  [nontrivial R] (f : K →+* R) (p : mv_polynomial σ K) : p = 0 ↔ mv_polynomial.map f p = 0 :=
begin
  split,
  {intro hp, rw hp, simp,},
  {
    intro hp,
    apply mv_polynomial.map_injective f (ring_hom.injective f),
    simpa using hp,
  },
end

-- #check mv_polynomial.fin_succ_equiv

-- #check mv_polynomial.eval₂

-- #check mv_polynomial.mv_polynomial_equiv_mv_polynomial

lemma insert_dependent_to_is_algebraic_aux {n : ℕ} {S : set L} {a : L} :
  (∃ (p : mv_polynomial (fin n.succ) K) (as : fin n.succ → L) (has : ∀ (k : fin n.succ), as k ∈ S ∪ {a})
    (hp : (mv_polynomial.eval as) p = 0), p ≠ 0)
  →
  (∃ (p : polynomial (mv_polynomial (fin n) K)) (as : fin n → L)
    (has : ∀ (k : fin n), as k ∈ S)
    (hp : (polynomial.aeval a) (polynomial.map (subfield_generated.eval K S as has) p) = 0), p ≠ 0) :=
sorry

-- should really be iff
lemma insert_dependent_to_is_algebraic (S : set L) (hS : indep K S) (a : L) :
  ¬ indep K (S ∪ {a}) → is_algebraic (subfield_generated K S) a :=
begin
  intro hdep,
  simp only [indep, not_forall] at hdep,
  cases hdep with n hdep,
  cases n,
  {
    cases hdep with f hdep,
    cases hdep with as hdep,
    cases hdep with has hdep,
    cases hdep with hf hf0,
    exfalso,
    apply hf0,
    have h := mv_polynomial.is_empty fin.is_empty (f : mv_polynomial (fin 0) L) as,
    rw (congr_arg (@mv_polynomial.C L (fin 0) _) hf) at h,
    simp only [mv_polynomial.C_0] at h,
    rw mv_polynomial.zero_iff (algebra_map K L) f,
    exact h,
  },
  {
    have hf := insert_dependent_to_is_algebraic_aux K hdep,
    cases hf with f hf,
    cases hf with as hf,
    cases hf with has hf,
    cases hf with hf hf0,
    -- evaluate f at the terms in S to produce a polynomial in K(S)[X]
    -- (subfield_generated.eval K S as has) : mv_polynomial (fin n) K →+* subfield_generated K S
    use polynomial.map (subfield_generated.eval K S as has) f,
    split,
    {
      intro hp,
      apply hf0,
      apply polynomial.ext,
      intro m,
      rw polynomial.coeff_zero,
      rw polynomial.ext_iff at hp,
      have hpm := hp m,
      rw polynomial.coeff_zero at hpm,
      rw polynomial.coeff_map at hpm,
      -- we use that S is independent to show each `f.coeff m` is 0 ~ they evaluate to 0 via
      -- elements of S
      apply hS n (f.coeff m) as has,
      -- it remains to show that evaluating at `as` in K(S) is the same as evaluating at `as` in L
      rw ← subfield_generated.eval_proj K S as has (f.coeff m),
      rw hpm,
      simp only [subfield.coe_zero, subtype.val_eq_coe],
    },
    {exact hf,},
  },
end

-- lemma insert_dependent_iff_is_algebraic (S : set L) (a : L) :
--   ¬ indep K (S ∪ {a}) → is_algebraic (subfield_generated K S) a :=
-- begin
--   intro hdep,
--   simp only [indep, not_forall] at hdep,
--     cases hdep with n hdep,
--     cases hdep with f hdep,
--     cases hdep with as hdep,
--     cases hdep with has hdep,
--     cases hdep with hf hf0,
--     let bs : fin n → polynomial (subfield_generated K S) :=
--     λ k, @decidable.by_cases (as k ∈ S) (polynomial (subfield_generated K S)) _
--       (λ h, polynomial.C
--         (⟨ as k , subfield_generated.subset_closure_set K S h ⟩ : subfield_generated K S))
--       (λ _, polynomial.X),
--     let p : polynomial (subfield_generated K S) :=
--       mv_polynomial.eval₂ polynomial.C bs
--       (mv_polynomial.map (subfield_generated.ring_hom K S) f),
--     use p,
--     split,
--     {
--       intro hp,
--       apply hf0,
--       rw mv_polynomial.zero_iff (subfield_generated.ring_hom K S),

--       sorry,
--     },
--     {
--       simp only [p],
--       rw ← hf,
--       simp,
--       sorry,
--     },
-- end

lemma algebraic_over_basis (B : set L) (hB : basis K B) :
  algebra.is_algebraic (subfield_generated K B) L :=
begin
  intro x,
  by_cases hind : indep K (B ∪ {x}),
  {
    -- if B ∪ {x} is independent then x ∈ B since B is a basis
    have hBx := hB.2 (B ∪ {x}) hind (by simp),
    -- hence x ∈ K(B) and is independent over K(B)
    have hxBx : x ∈ subfield_generated K B,
    {apply subfield.subset_closure, left, rw ← hBx, right, exact set.mem_singleton x},
    apply is_algebraic_subfield hxBx,
  },
  {
    apply insert_dependent_to_is_algebraic K B hB.1 x hind,
  }
end

variables (K) (L)

lemma extend_to_basis (S : set L) (hindS : indep K S) :
    ∃ (B : set L), S ⊆ B ∧ basis K B :=
begin
  cases extend_to_basis_aux K S hindS with B hB,
  cases hB with hmem hB,
  cases hB with hSB hbasis,
  use B,
  split,
  {exact hSB},
  {
    split,
    {exact hmem.2},
    {
      intros T hindT hBT,
      apply hbasis T _ hBT,
      exact ⟨ set.subset.trans hSB hBT , hindT ⟩,
    }
  }
end

lemma basis_ex : ∃ (B : set L), basis K B :=
begin
  cases extend_to_basis K L ∅ (indep_empty K) with B hB,
  use B,
  exact hB.2,
end

lemma basis_some : set L := @classical.some (set L) (λ S, basis K S) (basis_ex K L)

lemma degree : cardinal.{u} := cardinal.mk (basis_some K L)

end transcendent

namespace field_theory

variables
  {K L0 L1 : Type u}
  [field K] [field L0] [field L1]
  [algebra K L0] [algebra K L1]

open transcendent algebra

lemma iso_of_bij_indep (S0 : set L0) (S1 : set L1) :
  indep K S0 → indep K S1 → equiv S0 S1 →
  subfield_generated K S0 ≃+* subfield_generated K S1 :=
sorry

lemma iso_of_alg_closed_algebraic
  {K0 K1 L0 L1: Type u} [field K0] [field K1] [field L0] [field L1]
  [is_alg_closed L0] [is_alg_closed L1]
  [algebra K0 L0] [algebra K1 L1] : K0 ≃+* K1 →
  is_algebraic K0 L0 → is_algebraic K1 L1 → L0 ≃+* L1 := sorry

lemma iso_of_alg_closed_of_eq_trans_deg [is_alg_closed L0] [is_alg_closed L1]
  (B0 : set L0) (B1 : set L1) : transcendent.basis K B0 → transcendent.basis K B1 →
  equiv B0 B1
  → L0 ≃+* L1 :=
begin
  intros hB0 hB1 htdeg,
  apply iso_of_alg_closed_algebraic _
  (algebraic_over_basis K B0 hB0)
  (algebraic_over_basis K B1 hB1),
  apply iso_of_bij_indep B0 B1 hB0.1 hB1.1 htdeg,
end

end field_theory


import algebra
import data.real.basic
import data.vector
import tactic.explode
import tactic.find
import tactic.induction
import tactic.linarith
import tactic.rcases
import tactic.rewrite
import tactic.ring_exp
import tactic.tidy
import tactic.where

/-! # LoVe Library

This files contains a few extensions on top of Lean's core libraries and
`mathlib`. -/

namespace LoVe

/-! ## Structured Proofs -/

notation `fix ` binders `, ` r:(scoped f, f) := r

/-! ## Logical Connectives -/

meta def tactic.dec_trivial := `[exact dec_trivial]

lemma not_def (a : Prop) :
  ¬ a ↔ a → false :=
by refl

@[simp] lemma not_not_iff (a : Prop) [decidable a] :
  ¬¬ a ↔ a :=
by by_cases a; simp [h]

@[simp] lemma and_imp_distrib (a b c : Prop) :
  (a ∧ b → c) ↔ (a → b → c) :=
iff.intro
  (assume h ha hb, h ⟨ha, hb⟩)
  (assume h ⟨ha, hb⟩, h ha hb)

@[simp] lemma or_imp_distrib {a b c : Prop} :
  a ∨ b → c ↔ (a → c) ∧ (b → c) :=
iff.intro
  (assume h,
   ⟨assume ha, h (or.intro_left _ ha), assume hb, h (or.intro_right _ hb)⟩)
  (assume ⟨ha, hb⟩ h, match h with or.inl h := ha h | or.inr h := hb h end)

@[simp] lemma exists_imp_distrib {α : Sort*} {p : α → Prop} {a : Prop} :
  ((∃x, p x) → a) ↔ (∀x, p x → a) :=
iff.intro
  (assume h hp ha, h ⟨hp, ha⟩)
  (assume h ⟨hp, ha⟩, h hp ha)

lemma and_exists {α : Sort*} {p : α → Prop} {a : Prop} :
  (a ∧ (∃x, p x)) ↔ (∃x, a ∧ p x) :=
iff.intro
  (assume ⟨ha, x, hp⟩, ⟨x, ha, hp⟩)
  (assume ⟨x, ha, hp⟩, ⟨ha, x, hp⟩)

@[simp] lemma exists_false {α : Sort*} :
  (∃x : α, false) ↔ false :=
iff.intro (assume ⟨a, f⟩, f) (assume h, h.elim)

/-! ## Natural Numbers -/

attribute [simp] nat.add

/-! ## Integers -/

@[simp] lemma int.neg_comp_neg :
  int.neg ∘ int.neg = id :=
begin
  apply funext,
  apply neg_neg
end

/-! ## Reflexive Transitive Closure -/

namespace rtc

inductive star {α : Sort*} (r : α → α → Prop) (a : α) : α → Prop
| refl {}    : star a
| tail {b c} : star b → r b c → star c

attribute [refl] star.refl

namespace star

variables {α : Sort*} {r : α → α → Prop} {a b c d : α}

@[trans] lemma trans (hab : star r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction' hbc,
  case refl {
    assumption },
  case tail : c d hbc hcd hac {
    exact (tail (hac hab)) hcd }
end

lemma single (hab : r a b) :
  star r a b :=
refl.tail hab

lemma head (hab : r a b) (hbc : star r b c) :
  star r a c :=
begin
  induction' hbc,
  case refl {
    exact (tail refl) hab },
  case tail : c d hbc hcd hac {
    exact (tail (hac hab)) hcd }
end

lemma head_induction_on {α : Sort*} {r : α → α → Prop} {b : α}
  {P : ∀a : α, star r a b → Prop} {a : α} (h : star r a b)
  (refl : P b refl)
  (head : ∀{a c} (h' : r a c) (h : star r c b), P c h → P a (h.head h')) :
  P a h :=
begin
  induction' h,
  case refl {
    exact refl },
  case tail : b c hab hbc ih {
    apply ih,
    show P b _, from
      head hbc _ refl,
    show ∀a a', r a a' → star r a' b → P a' _ → P a _, from
      assume a a' hab hbc, head hab _ }
end

lemma trans_induction_on {α : Sort*} {r : α → α → Prop}
    {p : ∀{a b : α}, star r a b → Prop} {a b : α} (h : star r a b)
    (ih₁ : ∀a, @p a a refl) (ih₂ : ∀{a b} (h : r a b), p (single h))
    (ih₃ : ∀{a b c} (h₁ : star r a b) (h₂ : star r b c), p h₁ →
       p h₂ → p (h₁.trans h₂)) :
  p h :=
begin
  induction' h,
  case refl {
    exact ih₁ a },
  case tail : b c hab hbc ih {
    exact ih₃ hab (single hbc) (ih ih₁ @ih₂ @ih₃) (ih₂ hbc) }
end

lemma lift {β : Sort*} {s : β → β → Prop} (f : α → β)
  (h : ∀a b, r a b → s (f a) (f b)) (hab : star r a b) :
  star s (f a) (f b) :=
hab.trans_induction_on
  (assume a, refl)
  (assume a b, single ∘ h _ _)
  (assume a b c _ _, trans)

lemma mono {p : α → α → Prop} :
  (∀a b, r a b → p a b) → star r a b → star p a b :=
lift id

lemma star_star_eq :
  star (star r) = star r :=
funext
  (assume a,
   funext
     (assume b,
      propext (iff.intro
        (assume h,
         begin
           induction' h,
           { refl },
           { transitivity;
               assumption }
         end)
        (star.mono (assume a b,
           single)))))

end star

end rtc

export rtc

/-! ## States -/

def state : Type :=
string → ℕ

def state.update (name : string) (val : ℕ) (s : state) : state :=
λname', if name' = name then val else s name'

notation s `{` name ` ↦ ` val `}` := state.update name val s

instance : has_emptyc state :=
{ emptyc := λ_, 0 }

@[simp] lemma update_apply (name : string) (val : ℕ) (s : state) :
  s{name ↦ val} name = val :=
if_pos rfl

@[simp] lemma update_apply_ne (name name' : string) (val : ℕ) (s : state)
    (h : name' ≠ name . tactic.dec_trivial) :
  s{name ↦ val} name' = s name' :=
if_neg h

@[simp] lemma update_override (name : string) (val₁ val₂ : ℕ) (s : state) :
  s{name ↦ val₂}{name ↦ val₁} = s{name ↦ val₁} :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp [h]
end

@[simp] lemma update_swap (name₁ name₂ : string) (val₁ val₂ : ℕ) (s : state)
    (h : name₁ ≠ name₂ . tactic.dec_trivial) :
  s{name₂ ↦ val₂}{name₁ ↦ val₁} = s{name₁ ↦ val₁}{name₂ ↦ val₂} :=
begin
  apply funext,
  intro name',
  by_cases name' = name₁;
    by_cases name' = name₂;
    simp * at *
end

@[simp] lemma update_id (name : string) (s : state) :
  s{name ↦ s name} = s :=
begin
  apply funext,
  intro name',
  by_cases name' = name;
    simp * at *
end

@[simp] lemma update_same_const (name : string) (val : ℕ) :
  (λ_, val){name ↦ val} = (λ_, val) :=
by apply funext; simp

example (s : state) :
  s{"a" ↦ 0}{"a" ↦ 2} = s{"a" ↦ 2} :=
by simp

example (s : state) :
  s{"a" ↦ 0}{"b" ↦ 2} = s{"b" ↦ 2}{"a" ↦ 0} :=
by simp

example (s : state) :
  s{"a" ↦ s "a"}{"b" ↦ 0} = s{"b" ↦ 0} :=
by simp

/-! ## Relations -/

def Id {α : Type} : set (α × α) :=
{ab | prod.snd ab = prod.fst ab}

@[simp] lemma mem_Id {α : Type} (a b : α) :
  (a, b) ∈ @Id α ↔ b = a :=
by refl

def comp {α : Type} (r₁ r₂ : set (α × α)) : set (α × α) :=
{ac | ∃b, (prod.fst ac, b) ∈ r₁ ∧ (b, prod.snd ac) ∈ r₂}

infixl ` ◯ ` : 90 := comp

@[simp] lemma mem_comp {α : Type} (r₁ r₂ : set (α × α))
    (a b : α) :
  (a, b) ∈ r₁ ◯ r₂ ↔ (∃c, (a, c) ∈ r₁ ∧ (c, b) ∈ r₂) :=
by refl

def restrict {α : Type} (r : set (α × α)) (p : α → Prop) :
  set (α × α) :=
{ab | ab ∈ r ∧ p (prod.fst ab)}

infixl ` ⇃ ` : 90 := restrict

@[simp] lemma mem_restrict {α : Type} (r : set (α × α))
    (p : α → Prop) (a b : α) :
  (a, b) ∈ r ⇃ p ↔ (a, b) ∈ r ∧ p a :=
by refl

/-! ## Setoids -/

def equivalence_rel : Type → Type :=
setoid

end LoVe


import quarterround

import category_theory.category.basic

open quarterround

open category_theory

namespace quarterround_examples

variable [category (bitvec params.word_len)]

/-!
  # Examples from the spec.

  https://cr.yp.to/snuffle/spec.pdf
-/

/-!
## Example 1 :

> quarterround(0x00000000, 0x00000000, 0x00000000, 0x00000000) = (0x00000000, 0x00000000, 0x00000000, 0x00000000)
-/

/-- `quarterround (0, 0, 0, 0) = (0, 0, 0, 0)` -/
lemma example1_quarterround : quarterround (0x00000000, 0x00000000, 0x00000000, 0x00000000) =
    (0x000000000, 0x00000000, 0x00000000, 0x00000000) := by refl

/-!
## Example 2 :

> quarterround(0x00000001, 0x00000000, 0x00000000, 0x00000000) = (0x08008145, 0x00000080, 0x00010200, 0x20500000)
-/

/-- `qr1 (1, 0, 0, 0) = 128` -/
lemma example2_qr1 : qr1 0x00000001 0x00000000 0x00000000 0x00000000 = 0x00000080 :=
begin
  rw [qr1, operations.operation, operations.operation_rhs, operations.xor, operations.mod,
    operations.rotl, params.max_bitvec, params.mod, params.word_len, bitvec.of_nat,
    bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num1,
  refl,
end

/-- `qr2 (1, 0, 0, 0) = 66048` -/
lemma example2_qr2 : qr2 0x00000001 0x00000000 0x00000000 0x00000000 = 0x00010200 :=
begin
  rw [qr2, qr1],
  repeat {
    rw [operations.operation, operations.operation_rhs, operations.xor, operations.mod, operations.rotl]
  },
  rw [params.max_bitvec, params.mod, params.word_len, bitvec.of_nat, bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num,
  refl,
end

/-- `qr3 (1, 0, 0, 0) = 542113792` -/
lemma example2_qr3 : qr3 0x00000001 0x00000000 0x00000000 0x00000000 = 0x20500000 :=
begin
  rw [qr3, qr1, qr2, qr1],
  -- TODO: This is the same as `example2_qr2`
  repeat {
    rw [operations.operation, operations.operation_rhs, operations.xor, operations.mod, operations.rotl]
  },
  rw [params.max_bitvec, params.mod, params.word_len, bitvec.of_nat, bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num,
  refl,
end

/-- `qr0 (1, 0, 0, 0) = 134250821` -/
lemma example2_qr0 : qr0 0x00000001 0x00000000 0x00000000 0x00000000 = 0x08008145 :=
begin
  rw [qr0, qr3, qr2, qr1],
  -- TODO: This is the same as `example2_qr2`
  repeat {
    rw [operations.operation, operations.operation_rhs, operations.xor, operations.mod, operations.rotl]
  },
  rw [params.max_bitvec, params.mod, params.word_len, bitvec.of_nat, bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num,
  refl,
end

/-- `quarterround (1, 0, 0, 0) = (134250821, 128, 66048, 542113792)` -/
lemma example2_quarterround : quarterround (0x00000001, 0x00000000, 0x00000000, 0x00000000) =
    (0x08008145, 0x00000080, 0x00010200, 0x20500000) :=
begin
  rw [quarterround, example2_qr0, example2_qr1, example2_qr2, example2_qr3],
end

/-!
## Example 3 :

> quarterround(0x00000000, 0x00000001, 0x00000000, 0x00000000) = (0x88000100, 0x00000001, 0x00000200, 0x00402000)

-/

/-- `qr1 (0, 1, 0, 0) = 1` -/
lemma example3_qr1 : qr1 0x00000000 0x00000001 0x00000000 0x00000000 = 0x00000001 :=
begin
  -- TODO: this is the exact same proof as `example2_qr1`.
  rw [qr1, operations.operation, operations.operation_rhs, operations.xor, operations.mod,
    operations.rotl, params.max_bitvec, params.mod, params.word_len, bitvec.of_nat,
    bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num1,
  refl,
end

/-- `qr2 (0, 1, 0, 0) = 512` -/
lemma example3_qr2 : qr2 0x00000000 0x00000001 0x00000000 0x00000000 = 0x00000200 :=
begin
  -- TODO: this is the exact same proof as `example2_qr2`.
  rw [qr2, qr1],
  repeat {
    rw [operations.operation, operations.operation_rhs, operations.xor, operations.mod, operations.rotl]
  },
  rw [params.max_bitvec, params.mod, params.word_len, bitvec.of_nat, bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num,
  refl,
end

/-- `qr3 (0, 1, 0, 0) = 4202496` -/
lemma example3_qr3 : qr3 0x00000000 0x00000001 0x00000000 0x00000000 = 0x00402000 :=
begin
  -- TODO: this is the exact same proof as `example2_qr3`.
  rw [qr3, qr1, qr2, qr1],
  repeat {
    rw [operations.operation, operations.operation_rhs, operations.xor, operations.mod, operations.rotl]
  },
  rw [params.max_bitvec, params.mod, params.word_len, bitvec.of_nat, bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num,
  refl,
end

/-- `qr0 (0, 1, 0, 0) = 2281701632` -/
lemma example3_qr0 : qr0 0x00000000 0x00000001 0x00000000 0x00000000 = 0x88000100 :=
begin
  -- TODO: This is the same as `example2_qr0`
  rw [qr0, qr3, qr2, qr1],
  repeat {
    rw [operations.operation, operations.operation_rhs, operations.xor, operations.mod, operations.rotl]
  },
  rw [params.max_bitvec, params.mod, params.word_len, bitvec.of_nat, bitvec.shl, bitvec.ushr, bitvec.fill_shr],
  dunfold bitvec.of_nat,
  norm_num,
  refl,
end

/-- `quarterround (0, 1, 0, 0) = (2281701632, 1, 512, 4202496)` -/
lemma example3_quarterround : quarterround (0x00000000, 0x00000001, 0x00000000, 0x00000000) =
    (0x88000100, 0x00000001, 0x00000200, 0x00402000) :=
begin
  rw [quarterround, example3_qr0, example3_qr1, example3_qr2, example3_qr3],
end

/-!
  ## TODO

  - find a way that can make this shorter.
  - continue the examples from the spec.
  - add inverse examples.
-/

end quarterround_examples


/-
Copyright (c) 2022 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving, Simon Hudon
-/

import Mathlib.Data.Array.Basic
import Mathlib.Testing.SlimCheck.Sampleable
import Lean

/-!
# `Testable` Class
Testable propositions have a procedure that can generate counter-examples
together with a proof that they invalidate the proposition.

This is a port of the Haskell QuickCheck library.

## Creating Customized Instances
The type classes `Testable`, `SampleableExt` and `Shrinkable` are the
means by which `SlimCheck` creates samples and tests them. For instance,
the proposition `∀ i j : ℕ, i ≤ j` has a `Testable` instance because `ℕ`
is sampleable and `i ≤ j` is decidable. Once `SlimCheck` finds the `Testable`
instance, it can start using the instance to repeatedly creating samples
and checking whether they satisfy the property. Once it has found a
counter-example it will then use a `Shrinkable` instance to reduce the
example. This allows the user to create new instances and apply
`SlimCheck` to new situations.

### What do I do if I'm testing a property about my newly defined type?
Let us consider a type made for a new formalization:
```lean
structure MyType where
  x : ℕ
  y : ℕ
  h : x ≤ y
  deriving Repr
```
How do we test a property about `MyType`? For instance, let us consider
`Testable.check $ ∀ a b : MyType, a.y ≤ b.x → a.x ≤ b.y`. Writing this
property as is will give us an error because we do not have an instance
of `Shrinkable MyType` and `SampleableExt MyType`. We can define one as follows:
```lean
instance : Shrinkable MyType where
  shrink := λ ⟨x,y,h⟩ =>
    let proxy := Shrinkable.shrink (x, y - x)
    proxy.map (λ ⟨⟨fst, snd⟩, ha⟩ => ⟨⟨fst, fst + snd, sorry⟩, sorry⟩)

instance : SampleableExt MyType :=
  SampleableExt.mkSelfContained do
    let x ← SampleableExt.interpSample Nat
    let xyDiff ← SampleableExt.interpSample Nat
    pure $ ⟨x, x + xyDiff, sorry⟩
```
Again, we take advantage of the fact that other types have useful
`Shrinkable` implementations, in this case `Prod`. Note that the second
proof is heavily based on `WellFoundedRelation` since its used for termination so
the first step you want to take is almost always to `simp_wf` in order to
get through the `WellFoundedRelation`.

## Main definitions
  * `Testable` class
  * `Testable.check`: a way to test a proposition using random examples

## Tags

random testing

## References
  * https://hackage.haskell.org/package/QuickCheck
-/

namespace SlimCheck

/-- Result of trying to disprove `p`
The constructors are:
  *  `success : (PSum Unit p) → TestResult p`
     succeed when we find another example satisfying `p`
     In `success h`, `h` is an optional proof of the proposition.
     Without the proof, all we know is that we found one example
     where `p` holds. With a proof, the one test was sufficient to
     prove that `p` holds and we do not need to keep finding examples.
   * `gaveUp : ℕ → TestResult p`
     give up when a well-formed example cannot be generated.
     `gaveUp n` tells us that `n` invalid examples were tried.
     Above 100, we give up on the proposition and report that we
     did not find a way to properly test it.
   * `failure : ¬ p → (List String) → ℕ → TestResult p`
     a counter-example to `p`; the strings specify values for the relevant variables.
     `failure h vs n` also carries a proof that `p` does not hold. This way, we can
     guarantee that there will be no false positive. The last component, `n`,
     is the number of times that the counter-example was shrunk.
-/
inductive TestResult (p : Prop) where
  | success : PSum Unit p → TestResult p
  | gaveUp : Nat → TestResult p
  | failure : ¬ p → List String → Nat → TestResult p
  deriving Inhabited

/-- Configuration for testing a property. -/
structure Configuration where
  numInst : Nat := 100
  maxSize : Nat := 100
  numRetries : Nat := 10
  traceDiscarded : Bool := false
  traceSuccesses : Bool := false
  traceShrink : Bool := false
  traceShrinkCandidates : Bool := false
  randomSeed : Option Nat := none
  quiet : Bool := false
  deriving Inhabited

/--
`PrintableProp p` allows one to print a proposition so that
`SlimCheck` can indicate how values relate to each other.
It's basically a poor man's delaborator.
-/
class PrintableProp (p : Prop) where
  printProp : String

export PrintableProp (printProp)

instance (priority := low) : PrintableProp p where
  printProp := "⋯"

/-- `Testable p` uses random examples to try to disprove `p`. -/
class Testable (p : Prop) where
  run (cfg : Configuration) (minimize : Bool) : Gen (TestResult p)

@[nolint unusedArguments]
def NamedBinder (_n : String) (p : Prop) : Prop := p

namespace TestResult

def toString : TestResult p → String
| success (PSum.inl _) => "success (no proof)"
| success (PSum.inr _) => "success (proof)"
| gaveUp n => s!"gave {n} times"
| failure _ counters _ => s!"failed {counters}"

instance : ToString (TestResult p) := ⟨toString⟩

/-- Applicative combinator proof carrying test results. -/
def combine {p q : Prop} : PSum Unit (p → q) → PSum Unit p → PSum Unit q
| PSum.inr f, PSum.inr proof => PSum.inr $ f proof
| _, _ => PSum.inl ()

/-- Combine the test result for properties `p` and `q` to create a test for their conjunction. -/
def and : TestResult p → TestResult q → TestResult (p ∧ q)
| failure h xs n, _ => failure (λ h2 => h h2.left) xs n
| _, failure h xs n => failure (λ h2 => h h2.right) xs n
| success h1, success h2 => success $ combine (combine (PSum.inr And.intro) h1) h2
| gaveUp n, gaveUp m => gaveUp $ n + m
| gaveUp n, _ => gaveUp n
| _, gaveUp n => gaveUp n

/-- Combine the test result for properties `p` and `q` to create a test for their disjunction. -/
def or : TestResult p → TestResult q → TestResult (p ∨ q)
| failure h1 xs n, failure h2 ys m =>
  let h3 := λ h =>
    match h with
    | Or.inl h3 => h1 h3
    | Or.inr h3 => h2 h3
  failure h3 (xs ++ ys) (n + m)
| success h, _ => success $ combine (PSum.inr Or.inl) h
| _, success h => success $ combine (PSum.inr Or.inr) h
| gaveUp n, gaveUp m => gaveUp $ n + m
| gaveUp n, _ => gaveUp n
| _, gaveUp n => gaveUp n

/-- If `q → p`, then `¬ p → ¬ q` which means that testing `p` can allow us
to find counter-examples to `q`. -/
def imp (h : q → p) (r : TestResult p)
    (p : PSum Unit (p → q) := PSum.inl ()) : TestResult q :=
  match r with
  | failure h2 xs n => failure (mt h h2) xs n
  | success h2 => success $ combine p h2
  | gaveUp n => gaveUp n

/-- Test `q` by testing `p` and proving the equivalence between the two. -/
def iff (h : q ↔ p) (r : TestResult p) : TestResult q :=
  imp h.mp r (PSum.inr h.mpr)

/-- When we assign a value to a universally quantified variable,
we record that value using this function so that our counter-examples
can be informative. -/
def addInfo (x : String) (h : q → p) (r : TestResult p)
    (p : PSum Unit (p → q) := PSum.inl ()) : TestResult q :=
  if let failure h2 xs n := r then
    failure (mt h h2) (x :: xs) n
  else
    imp h r p

/-- Add some formatting to the information recorded by `addInfo`. -/
def addVarInfo [Repr γ] (var : String) (x : γ) (h : q → p) (r : TestResult p)
    (p : PSum Unit (p → q) := PSum.inl ()) : TestResult q  :=
  addInfo s!"{var} := {repr x}" h r p

def isFailure : TestResult p → Bool
| failure _ _ _ => true
| _ => false

end TestResult

namespace Configuration

/-- A configuration with all the trace options enabled, useful for debugging. -/
def verbose : Configuration where
  traceDiscarded := true
  traceSuccesses := true
  traceShrink := true
  traceShrinkCandidates := true

end Configuration

namespace Testable

open TestResult

def runProp (p : Prop) [Testable p] : Configuration → Bool → Gen (TestResult p) := Testable.run

/-- A `dbgTrace` with special formatting -/
def slimTrace [Pure m] (s : String) : m PUnit := dbgTrace s!"[SlimCheck: {s}]" (λ _ => pure ())

instance andTestable [Testable p] [Testable q] : Testable (p ∧ q) where
  run := λ cfg min => do
    let xp ← runProp p cfg min
    let xq ← runProp q cfg min
    pure $ and xp xq

instance orTestable [Testable p] [Testable q] : Testable (p ∨ q) where
  run := λ cfg min => do
    let xp ← runProp p cfg min
    -- As a little performance optimization we can just not run the second
    -- test if the first succeeds
    match xp with
    | success (PSum.inl h) => pure $ success (PSum.inl h)
    | success (PSum.inr h) => pure $ success (PSum.inr $ Or.inl h)
    | _ =>
      let xq ← runProp q cfg min
      pure $ or xp xq

instance iffTestable [Testable ((p ∧ q) ∨ (¬ p ∧ ¬ q))] : Testable (p ↔ q) where
  run := λ cfg min => do
    let h ← runProp ((p ∧ q) ∨ (¬ p ∧ ¬ q)) cfg min
    pure $ iff iff_iff_and_or_not_and_not h

instance decGuardTestable [PrintableProp p] [Decidable p] {β : p → Prop} [∀ h, Testable (β h)] :
    Testable (NamedBinder var $ ∀ h, β h) where
  run := λ cfg min => do
    if h : p then
      let res := (runProp (β h) cfg min)
      let s := printProp p
      (λ r => addInfo s!"guard: {s}" (· $ h) r (PSum.inr $ λ q _ => q)) <$> res
    else if cfg.traceDiscarded || cfg.traceSuccesses then
      let res := (λ _ => pure $ gaveUp 1)
      let s := printProp p
      slimTrace s!"discard: Guard {s} does not hold"; res
    else
      pure $ gaveUp 1

instance forallTypesTestable {f : Type → Prop} [Testable (f Int)] :
    Testable (NamedBinder var $ ∀ x, f x) where
  run := λ cfg min => do
    let r ← runProp (f Int) cfg min
    pure $ addVarInfo var "ℤ" (· $ Int) r

/--
Format the counter-examples found in a test failure.
-/
def formatFailure (s : String) (xs : List String) (n : Nat) : String :=
  let counter := String.intercalate "\n" xs
  let parts := [
    "\n===================",
    s,
    counter,
    s!"({n} shrinks)",
    "-------------------"
  ]
  String.intercalate "\n" parts

/--
Increase the number of shrinking steps in a test result.
-/
def addShrinks (n : Nat) : TestResult p → TestResult p
| TestResult.failure p xs m => TestResult.failure p xs (m + n)
| p => p

/-- Shrink a counter-example `x` by using `Shrinkable.shrink x`, picking the first
candidate that falsifies a property and recursively shrinking that one.
The process is guaranteed to terminate because `shrink x` produces
a proof that all the values it produces are smaller (according to `SizeOf`)
than `x`. -/
def minimizeAux [SampleableExt α] {β : α → Prop} [∀ x, Testable (β x)] (cfg : Configuration)
    (var : String) (x : SampleableExt.proxy α) (n : Nat) :
    OptionT Gen (Σ x, TestResult (β (SampleableExt.interp x))) := do
  let candidates := SampleableExt.shrink.shrink x
  if cfg.traceShrinkCandidates then
    slimTrace s!"Candidates for {var} := {repr x}:\n  {repr candidates}"
  for ⟨candidate, h⟩ in candidates do
    if cfg.traceShrinkCandidates then
      slimTrace s!"Trying {var} := {repr candidate}"
    let res ← OptionT.lift $ Testable.runProp (β (SampleableExt.interp candidate)) cfg true
    if res.isFailure then
      if cfg.traceShrink then
        slimTrace s!"{var} shrunk to {repr candidate} from {repr x}"
      let currentStep := OptionT.lift $ pure $ Sigma.mk candidate (addShrinks (n + 1) res)
      let nextStep := minimizeAux cfg var candidate (n + 1)
      return ←(nextStep <|> currentStep)
  if cfg.traceShrink then
    slimTrace s!"No shrinking possible for {var} := {repr x}"
  failure
  termination_by minimizeAux cfg var x n => x

/-- Once a property fails to hold on an example, look for smaller counter-examples
to show the user. -/
def minimize [SampleableExt α] {β : α → Prop} [∀ x, Testable (β x)] (cfg : Configuration)
    (var : String) (x : SampleableExt.proxy α) (r : TestResult (β $ SampleableExt.interp x)) :
    Gen (Σ x, TestResult (β $ SampleableExt.interp x)) := do
  if cfg.traceShrink then
     slimTrace "Shrink"
     slimTrace s!"Attempting to shrink {var} := {repr x}"
  let res ← OptionT.run $ minimizeAux cfg var x 0
  pure $ res.getD ⟨x, r⟩

/-- Test a universal property by creating a sample of the right type and instantiating the
bound variable with it. -/
instance varTestable [SampleableExt α] {β : α → Prop} [∀ x, Testable (β x)] :
    Testable (NamedBinder var $ ∀ x : α, β x) where
  run := λ cfg min => do
    let x ← SampleableExt.sample
    if cfg.traceSuccesses || cfg.traceDiscarded then
      slimTrace s!"{var} := {repr x}"
    let r ← Testable.runProp (β $ SampleableExt.interp x) cfg false
    let ⟨finalX, finalR⟩ ←
      if isFailure r then
        if cfg.traceSuccesses then
          slimTrace s!"{var} := {repr x} is a failure"
        if min then
          minimize cfg var x r
        else
          pure $ ⟨x, r⟩
      else
        pure $ ⟨x, r⟩
    pure $ addVarInfo var finalX (· $ SampleableExt.interp finalX) finalR

/-- Test a universal property about propositions -/
instance propVarTestable {β : Prop → Prop} [∀ b : Bool, Testable (β b)] :
  Testable (NamedBinder var $ ∀ p : Prop, β p)
where
  run := λ cfg min =>
    imp (λ h (b : Bool) => h b) <$> Testable.runProp (NamedBinder var $ ∀ b : Bool, β b) cfg min

instance (priority := high) unusedVarTestable [Nonempty α] [Testable β] :
  Testable (NamedBinder var $ ∀ _x : α, β)
where
  run := λ cfg min => do
    if cfg.traceDiscarded || cfg.traceSuccesses then
      slimTrace s!"{var} is unused"
    let r ← Testable.runProp β cfg min
    let finalR := addInfo s!"{var} is irrelevant (unused)" id r
    pure $ imp (· $ Classical.ofNonempty) finalR (PSum.inr $ λ x _ => x)

instance (priority := low) decidableTestable {p : Prop} [PrintableProp p] [Decidable p] :
    Testable p where
  run := λ _ _ =>
    if h : p then
      pure $ success (PSum.inr h)
    else
      let s := printProp p
      pure $ failure h [s!"issue: {s} does not hold"] 0

end Testable

section PrintableProp

instance Eq.printableProp [Repr α] {x y : α} : PrintableProp (x = y) where
  printProp := s!"{repr x} = {repr y}"

instance Ne.printableProp [Repr α] {x y : α} : PrintableProp (x ≠ y) where
  printProp := s!"{repr x} ≠ {repr y}"

instance LE.printableProp [Repr α] [LE α] {x y : α} : PrintableProp (x ≤ y) where
  printProp := s!"{repr x} ≤ {repr y}"

instance LT.printableProp [Repr α] [LT α] {x y : α} : PrintableProp (x < y) where
  printProp := s!"{repr x} < {repr y}"

instance And.printableProp [PrintableProp x] [PrintableProp y]  : PrintableProp (x ∧ y) where
  printProp := s!"{printProp x} ∧ {printProp y}"

instance Or.printableProp [PrintableProp x] [PrintableProp y]  : PrintableProp (x ∨ y) where
  printProp := s!"{printProp x} ∨ {printProp y}"

instance Iff.printableProp [PrintableProp x] [PrintableProp y]  : PrintableProp (x ↔ y) where
  printProp := s!"{printProp x} ↔ {printProp y}"

instance Imp.printableProp [PrintableProp x] [PrintableProp y]  : PrintableProp (x → y) where
  printProp := s!"{printProp x} → {printProp y}"

instance Not.printableProp [PrintableProp x] : PrintableProp (¬x) where
  printProp := s!"¬{printProp x}"

instance True.printableProp : PrintableProp True where
  printProp := "True"

instance False.printableProp : PrintableProp False where
  printProp := "False"

instance Bool.printableProp {b : Bool} : PrintableProp b where
  printProp := if b then "true" else "false"

end PrintableProp

section IO
open TestResult

/-- Execute `cmd` and repeat every time the result is `gave_up` (at most `n` times). -/
def retry (cmd : Rand (TestResult p)) : Nat → Rand (TestResult p)
| 0 => pure $ TestResult.gaveUp 1
| n+1 => do
  let r ← cmd
  match r with
  | success hp => pure $ success hp
  | TestResult.failure h xs n => pure $ failure h xs n
  | gaveUp _ => retry cmd n

/-- Count the number of times the test procedure gave up. -/
def giveUp (x : Nat) : TestResult p → TestResult p
| success (PSum.inl ()) => gaveUp x
| success (PSum.inr p) => success $ (PSum.inr p)
| gaveUp n => gaveUp $ n + x
| TestResult.failure h xs n => failure h xs n

/-- Try `n` times to find a counter-example for `p`. -/
def Testable.runSuiteAux (p : Prop) [Testable p] (cfg : Configuration) :
  TestResult p → Nat → Rand (TestResult p)
| r, 0 => pure r
| r, n+1 => do
  let size := (cfg.numInst - n - 1) * cfg.maxSize / cfg.numInst
  if cfg.traceSuccesses then
    slimTrace s!"New sample"
    slimTrace s!"Retrying up to {cfg.numRetries} times until guards hold"
  let x ← retry (ReaderT.run (Testable.runProp p cfg true) ⟨size⟩) cfg.numRetries
  match x with
  | (success (PSum.inl ())) => runSuiteAux p cfg r n
  | (gaveUp g) => runSuiteAux p cfg (giveUp g r) n
  | _ => pure $ x

/-- Try to find a counter-example of `p`. -/
def Testable.runSuite (p : Prop) [Testable p] (cfg : Configuration := {}) : Rand (TestResult p) :=
  Testable.runSuiteAux p cfg (success $ PSum.inl ()) cfg.numInst

/-- Run a test suite for `p` in `BaseIO` using the global RNG in `stdGenRef`. -/
def Testable.checkIO (p : Prop) [Testable p] (cfg : Configuration := {}) : BaseIO (TestResult p) :=
  match cfg.randomSeed with
  | none => IO.runRand (Testable.runSuite p cfg)
  | some seed => IO.runRandWith seed (Testable.runSuite p cfg)

end IO

namespace Decorations

open Lean

/-- Traverse the syntax of a proposition to find universal quantifiers
quantifiers and add `NamedBinder` annotations next to them. -/
partial def addDecorations (e : Expr) : Expr :=
  e.replace $ λ expr =>
    match expr with
    | Expr.forallE name type body data =>
      let n := name.toString
      let newType := addDecorations type
      let newBody := addDecorations body
      let rest := Expr.forallE name newType newBody data
      some $ mkApp2 (mkConst `SlimCheck.NamedBinder) (mkStrLit n) rest
    | _ => none

/-- `DecorationsOf p` is used as a hint to `mk_decorations` to specify
that the goal should be satisfied with a proposition equivalent to `p`
with added annotations. -/
@[nolint unusedArguments]
abbrev DecorationsOf (_p : Prop) := Prop

open Elab.Tactic
open Meta

/-- In a goal of the shape `⊢ DecorationsOf p`, `mk_decoration` examines
the syntax of `p` and adds `NamedBinder` around universal quantifications
to improve error messages. This tool can be used in the declaration of a
function as follows:
```lean
def foo (p : Prop) (p' : Decorations.DecorationsOf p := by mk_decorations) [Testable p'] : ...
```
`p` is the parameter given by the user, `p'` is a definitionally equivalent
proposition where the quantifiers are annotated with `NamedBinder`.
-/
scoped elab "mk_decorations" : tactic => do
  let goal ← getMainGoal
  let goalType ← goal.getType
  if let .app (.const ``Decorations.DecorationsOf _) body := goalType then
    closeMainGoal (addDecorations body)

end Decorations

open Decorations in
/-- Run a test suite for `p` and throw an exception if `p` does not not hold.-/
def Testable.check (p : Prop) (cfg : Configuration := {})
    (p' : Decorations.DecorationsOf p := by mk_decorations) [Testable p'] : IO PUnit := do
  match ← Testable.checkIO p' cfg with
  | TestResult.success _ => if !cfg.quiet then IO.println "Success"
  | TestResult.gaveUp n => if !cfg.quiet then IO.println s!"Gave up {n} times"
  | TestResult.failure _ xs n => throw (IO.userError $ formatFailure "Found problems!" xs n)

-- #eval Testable.check (∀ (x y z a : Nat) (h1 : 3 < x) (h2 : 3 < y), x - y = y - x)
--   Configuration.verbose
-- #eval Testable.check (∀ x : Nat, ∀ y : Nat, x + y = y + x) Configuration.verbose
-- #eval Testable.check (∀ (x : (Nat × Nat)), x.fst - x.snd - 10 = x.snd - x.fst - 10)
--   Configuration.verbose
-- #eval Testable.check (∀ (x : Nat) (h : 10 < x), 5 < x) Configuration.verbose

end SlimCheck


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.preadditive.projective
import algebra.homology.single
import algebra.homology.homotopy_category

/-!
# Projective resolutions

A projective resolution `P : ProjectiveResolution Z` of an object `Z : C` consists of
a `ℕ`-indexed chain complex `P.complex` of projective objects,
along with a chain map `P.π` from `C` to the chain complex consisting just of `Z` in degree zero,
so that the augmented chain complex is exact.

When `C` is abelian, this exactness condition is equivalent to `π` being a quasi-isomorphism.
It turns out that this formulation allows us to set up the basic theory of derived functors
without even assuming `C` is abelian.

(Typically, however, to show `has_projective_resolutions C`
one will assume `enough_projectives C` and `abelian C`.
This construction appears in `category_theory.abelian.projectives`.)

We show that given `P : ProjectiveResolution X` and `Q : ProjectiveResolution Y`,
any morphism `X ⟶ Y` admits a lift to a chain map `P.complex ⟶ Q.complex`.
(It is a lift in the sense that
the projection maps `P.π` and `Q.π` intertwine the lift and the original morphism.)

Moreover, we show that any two such lifts are homotopic.

As a consequence, if every object admits a projective resolution,
we can construct a functor `projective_resolutions C : C ⥤ homotopy_category C`.
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v u

namespace category_theory
variables {C : Type u} [category.{v} C]

open projective

section
variables [has_zero_object C] [has_zero_morphisms C] [has_equalizers C] [has_images C]

/--
A `ProjectiveResolution Z` consists of a bundled `ℕ`-indexed chain complex of projective objects,
along with a quasi-isomorphism to the complex consisting of just `Z` supported in degree `0`.

(We don't actually ask here that the chain map is a quasi-iso, just exactness everywhere:
that `π` is a quasi-iso is a lemma when the category is abelian.
Should we just ask for it here?)

Except in situations where you want to provide a particular projective resolution
(for example to compute a derived functor),
you will not typically need to use this bundled object, and will instead use
* `projective_resolution Z`: the `ℕ`-indexed chain complex
  (equipped with `projective` and `exact` instances)
* `projective_resolution.π Z`: the chain map from `projective_resolution Z` to
  `(single C _ 0).obj Z` (all the components are equipped with `epi` instances,
  and when the category is `abelian` we will show `π` is a quasi-iso).
-/
@[nolint has_nonempty_instance]
structure ProjectiveResolution (Z : C) :=
(complex : chain_complex C ℕ)
(π : homological_complex.hom complex ((chain_complex.single₀ C).obj Z))
(projective : ∀ n, projective (complex.X n) . tactic.apply_instance)
(exact₀ : exact (complex.d 1 0) (π.f 0))
(exact : ∀ n, exact (complex.d (n+2) (n+1)) (complex.d (n+1) n))
(epi : epi (π.f 0) . tactic.apply_instance)

attribute [instance] ProjectiveResolution.projective ProjectiveResolution.epi

/--
An object admits a projective resolution.
-/
class has_projective_resolution (Z : C) : Prop :=
(out [] : nonempty (ProjectiveResolution Z))

section
variables (C)

/--
You will rarely use this typeclass directly: it is implied by the combination
`[enough_projectives C]` and `[abelian C]`.
By itself it's enough to set up the basic theory of derived functors.
-/
class has_projective_resolutions : Prop :=
(out : ∀ Z : C, has_projective_resolution Z)

attribute [instance, priority 100] has_projective_resolutions.out

end

namespace ProjectiveResolution

@[simp] lemma π_f_succ {Z : C} (P : ProjectiveResolution Z) (n : ℕ) :
  P.π.f (n+1) = 0 :=
begin
  apply zero_of_target_iso_zero,
  dsimp, refl,
end

@[simp] lemma complex_d_comp_π_f_zero {Z : C} (P : ProjectiveResolution Z) :
  P.complex.d 1 0 ≫ P.π.f 0 = 0 :=
P.exact₀.w

@[simp] lemma complex_d_succ_comp {Z : C} (P : ProjectiveResolution Z) (n : ℕ) :
  P.complex.d (n + 2) (n + 1) ≫ P.complex.d (n + 1) n = 0 :=
(P.exact _).w

instance {Z : C} (P : ProjectiveResolution Z) (n : ℕ) : category_theory.epi (P.π.f n) :=
by cases n; apply_instance

/-- A projective object admits a trivial projective resolution: itself in degree 0. -/
def self (Z : C) [category_theory.projective Z] : ProjectiveResolution Z :=
{ complex := (chain_complex.single₀ C).obj Z,
  π := 𝟙 ((chain_complex.single₀ C).obj Z),
  projective := λ n, begin
    cases n,
    { dsimp, apply_instance, },
    { dsimp, apply_instance, },
  end,
  exact₀ := by { dsimp, exact exact_zero_mono _ },
  exact := λ n, by { dsimp, exact exact_of_zero _ _ },
  epi := by { dsimp, apply_instance, }, }

/-- Auxiliary construction for `lift`. -/
def lift_f_zero {Y Z : C} (f : Y ⟶ Z) (P : ProjectiveResolution Y) (Q : ProjectiveResolution Z) :
  P.complex.X 0 ⟶ Q.complex.X 0 :=
factor_thru (P.π.f 0 ≫ f) (Q.π.f 0)

/-- Auxiliary construction for `lift`. -/
def lift_f_one {Y Z : C} (f : Y ⟶ Z) (P : ProjectiveResolution Y) (Q : ProjectiveResolution Z) :
  P.complex.X 1 ⟶ Q.complex.X 1 :=
exact.lift (P.complex.d 1 0 ≫ lift_f_zero f P Q) (Q.complex.d 1 0) (Q.π.f 0) Q.exact₀
  (by simp [lift_f_zero, P.exact₀.w_assoc])

/-- Auxiliary lemma for `lift`. -/
@[simp] lemma lift_f_one_zero_comm
  {Y Z : C} (f : Y ⟶ Z) (P : ProjectiveResolution Y) (Q : ProjectiveResolution Z) :
  lift_f_one f P Q ≫ Q.complex.d 1 0 = P.complex.d 1 0 ≫ lift_f_zero f P Q :=
begin
  dsimp [lift_f_zero, lift_f_one],
  simp,
end

/-- Auxiliary construction for `lift`. -/
def lift_f_succ {Y Z : C} (P : ProjectiveResolution Y) (Q : ProjectiveResolution Z)
  (n : ℕ) (g : P.complex.X n ⟶ Q.complex.X n) (g' : P.complex.X (n+1) ⟶ Q.complex.X (n+1))
  (w : g' ≫ Q.complex.d (n+1) n = P.complex.d (n+1) n ≫ g) :
  Σ' g'' : P.complex.X (n+2) ⟶ Q.complex.X (n+2),
    g'' ≫ Q.complex.d (n+2) (n+1) = P.complex.d (n+2) (n+1) ≫ g' :=
⟨exact.lift
  (P.complex.d (n+2) (n+1) ≫ g') ((Q.complex.d (n+2) (n+1))) (Q.complex.d (n+1) n) (Q.exact _)
  (by simp [w]), (by simp)⟩

/-- A morphism in `C` lifts to a chain map between projective resolutions. -/
def lift {Y Z : C} (f : Y ⟶ Z) (P : ProjectiveResolution Y) (Q : ProjectiveResolution Z) :
  P.complex ⟶ Q.complex :=
chain_complex.mk_hom _ _ (lift_f_zero f _ _) (lift_f_one f _ _) (lift_f_one_zero_comm f _ _)
  (λ n ⟨g, g', w⟩, lift_f_succ P Q n g g' w)

/-- The resolution maps intertwine the lift of a morphism and that morphism. -/
@[simp, reassoc]
lemma lift_commutes
  {Y Z : C} (f : Y ⟶ Z) (P : ProjectiveResolution Y) (Q : ProjectiveResolution Z) :
  lift f P Q ≫ Q.π = P.π ≫ (chain_complex.single₀ C).map f :=
by { ext, dsimp [lift, lift_f_zero], apply factor_thru_comp, }

-- Now that we've checked this property of the lift,
-- we can seal away the actual definition.
attribute [irreducible] lift

end ProjectiveResolution

end

namespace ProjectiveResolution

variables [has_zero_object C] [preadditive C] [has_equalizers C] [has_images C]

/-- An auxiliary definition for `lift_homotopy_zero`. -/
def lift_homotopy_zero_zero {Y Z : C} {P : ProjectiveResolution Y} {Q : ProjectiveResolution Z}
  (f : P.complex ⟶ Q.complex)
  (comm : f ≫ Q.π = 0) : P.complex.X 0 ⟶ Q.complex.X 1 :=
exact.lift (f.f 0) (Q.complex.d 1 0) (Q.π.f 0) Q.exact₀
  (congr_fun (congr_arg homological_complex.hom.f comm) 0)

/-- An auxiliary definition for `lift_homotopy_zero`. -/
def lift_homotopy_zero_one {Y Z : C} {P : ProjectiveResolution Y} {Q : ProjectiveResolution Z}
  (f : P.complex ⟶ Q.complex)
  (comm : f ≫ Q.π = 0) : P.complex.X 1 ⟶ Q.complex.X 2 :=
exact.lift
  (f.f 1 - P.complex.d 1 0 ≫ lift_homotopy_zero_zero f comm) (Q.complex.d 2 1) (Q.complex.d 1 0)
  (Q.exact _) (by simp [lift_homotopy_zero_zero])

/-- An auxiliary definition for `lift_homotopy_zero`. -/
def lift_homotopy_zero_succ {Y Z : C} {P : ProjectiveResolution Y} {Q : ProjectiveResolution Z}
  (f : P.complex ⟶ Q.complex) (n : ℕ)
  (g : P.complex.X n ⟶ Q.complex.X (n + 1)) (g' : P.complex.X (n + 1) ⟶ Q.complex.X (n + 2))
  (w : f.f (n + 1) = P.complex.d (n + 1) n ≫ g + g' ≫ Q.complex.d (n + 2) (n + 1)) :
  P.complex.X (n + 2) ⟶ Q.complex.X (n + 3) :=
exact.lift
  (f.f (n+2) - P.complex.d (n+2) (n+1) ≫ g') (Q.complex.d (n+3) (n+2)) (Q.complex.d (n+2) (n+1))
  (Q.exact _) (by simp [w])

/-- Any lift of the zero morphism is homotopic to zero. -/
def lift_homotopy_zero {Y Z : C} {P : ProjectiveResolution Y} {Q : ProjectiveResolution Z}
  (f : P.complex ⟶ Q.complex)
  (comm : f ≫ Q.π = 0) :
  homotopy f 0 :=
homotopy.mk_inductive _ (lift_homotopy_zero_zero f comm) (by simp [lift_homotopy_zero_zero])
  (lift_homotopy_zero_one f comm) (by simp [lift_homotopy_zero_one])
  (λ n ⟨g, g', w⟩, ⟨lift_homotopy_zero_succ f n g g' w, by simp [lift_homotopy_zero_succ, w]⟩)

/-- Two lifts of the same morphism are homotopic. -/
def lift_homotopy {Y Z : C} (f : Y ⟶ Z) {P : ProjectiveResolution Y} {Q : ProjectiveResolution Z}
  (g h : P.complex ⟶ Q.complex)
  (g_comm : g ≫ Q.π = P.π ≫ (chain_complex.single₀ C).map f)
  (h_comm : h ≫ Q.π = P.π ≫ (chain_complex.single₀ C).map f) :
  homotopy g h :=
homotopy.equiv_sub_zero.inv_fun (lift_homotopy_zero _ (by simp [g_comm, h_comm]))

/-- The lift of the identity morphism is homotopic to the identity chain map. -/
def lift_id_homotopy (X : C) (P : ProjectiveResolution X) :
  homotopy (lift (𝟙 X) P P) (𝟙 P.complex) :=
by { apply lift_homotopy (𝟙 X); simp, }

/-- The lift of a composition is homotopic to the composition of the lifts. -/
def lift_comp_homotopy {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  (P : ProjectiveResolution X) (Q : ProjectiveResolution Y) (R : ProjectiveResolution Z) :
  homotopy (lift (f ≫ g) P R) (lift f P Q ≫ lift g Q R) :=
by { apply lift_homotopy (f ≫ g); simp, }

-- We don't care about the actual definitions of these homotopies.
attribute [irreducible] lift_homotopy_zero lift_homotopy lift_id_homotopy lift_comp_homotopy

/-- Any two projective resolutions are homotopy equivalent. -/
def homotopy_equiv {X : C} (P Q : ProjectiveResolution X) :
  homotopy_equiv P.complex Q.complex :=
{ hom := lift (𝟙 X) P Q,
  inv := lift (𝟙 X) Q P,
  homotopy_hom_inv_id := begin
    refine (lift_comp_homotopy (𝟙 X) (𝟙 X) P Q P).symm.trans _,
    simp [category.id_comp],
    apply lift_id_homotopy,
  end,
  homotopy_inv_hom_id := begin
    refine (lift_comp_homotopy (𝟙 X) (𝟙 X) Q P Q).symm.trans _,
    simp [category.id_comp],
    apply lift_id_homotopy,
  end, }

@[simp, reassoc] lemma homotopy_equiv_hom_π {X : C} (P Q : ProjectiveResolution X) :
  (homotopy_equiv P Q).hom ≫ Q.π = P.π :=
by simp [homotopy_equiv]

@[simp, reassoc] lemma homotopy_equiv_inv_π {X : C} (P Q : ProjectiveResolution X) :
  (homotopy_equiv P Q).inv ≫ P.π = Q.π :=
by simp [homotopy_equiv]

end ProjectiveResolution

section

variables [has_zero_morphisms C] [has_zero_object C] [has_equalizers C] [has_images C]

/-- An arbitrarily chosen projective resolution of an object. -/
abbreviation projective_resolution (Z : C) [has_projective_resolution Z] : chain_complex C ℕ :=
(has_projective_resolution.out Z).some.complex

/-- The chain map from the arbitrarily chosen projective resolution `projective_resolution Z`
back to the chain complex consisting of `Z` supported in degree `0`. -/
abbreviation projective_resolution.π (Z : C) [has_projective_resolution Z] :
  projective_resolution Z ⟶ (chain_complex.single₀ C).obj Z :=
(has_projective_resolution.out Z).some.π

/-- The lift of a morphism to a chain map between the arbitrarily chosen projective resolutions. -/
abbreviation projective_resolution.lift {X Y : C} (f : X ⟶ Y)
  [has_projective_resolution X] [has_projective_resolution Y] :
  projective_resolution X ⟶ projective_resolution Y :=
ProjectiveResolution.lift f _ _

end

variables (C) [preadditive C] [has_zero_object C] [has_equalizers C] [has_images C]
  [has_projective_resolutions C]

/--
Taking projective resolutions is functorial,
if considered with target the homotopy category
(`ℕ`-indexed chain complexes and chain maps up to homotopy).
-/
def projective_resolutions : C ⥤ homotopy_category C (complex_shape.down ℕ) :=
{ obj := λ X, (homotopy_category.quotient _ _).obj (projective_resolution X),
  map := λ X Y f, (homotopy_category.quotient _ _).map (projective_resolution.lift f),
  map_id' := λ X, begin
    rw ←(homotopy_category.quotient _ _).map_id,
    apply homotopy_category.eq_of_homotopy,
    apply ProjectiveResolution.lift_id_homotopy,
  end,
  map_comp' := λ X Y Z f g, begin
    rw ←(homotopy_category.quotient _ _).map_comp,
    apply homotopy_category.eq_of_homotopy,
    apply ProjectiveResolution.lift_comp_homotopy,
  end, }

end category_theory