import ..library.src_real_field_lemmas
import ..library.src_ordered_field_lemmas
import data.set.basic
import tactic

/-
There are no explicit exercises in this file, though you may choose to prove examples yourself.
The aim of this file is to prove that there is a real number whose square is 2.
-/

namespace mth1001

namespace myreal

section auxiliary

open myreal_field classical myordered_field

open_locale classical

variables {R : Type} [myreal_field R]

lemma difference_of_two_squares (x y : R) : x*x - y*y = (x - y)*(x+y) :=
begin
  rw mul_add,
  repeat { rw sub_eq_add_neg' <|> rw add_mul },
  rw [←neg_neg (x*y), neg_mul_eq_mul_neg x y, mul_comm x (-y), add_assoc, ←add_assoc (-y*x) _ _],
  rw [add_neg', zero_add, neg_mul_eq_mul_neg, mul_comm y (-y)],
end

lemma square_le_square_iff_le_of_non_neg_of_non_neg (a b : R) (h₁ : 0 ≤ a) (h₂ : 0 ≤ b)
: a*a ≤ b*b ↔ a ≤ b :=
begin
  split,
  { intro aalebb,
    have h₃ : 0 ≤ b*b - a*a, linarith,
    rw difference_of_two_squares b a at h₃,
    rw non_neg_mul_iff_non_neg_and_non_neg_or_non_pos_and_non_pos at h₃,
    cases h₃; linarith },
  { intro aleb,
    exact mul_le_mul aleb aleb h₁ h₂, },
end

lemma pos_mul_iff_pos_and_pos_or_neg_and_neg (a b : R)
  : 0 < a * b ↔ (0 < a ∧ 0 < b) ∨ (a < 0 ∧ b < 0) :=
begin
  split,
  { intro h,
    by_cases h₂ : 0 ≤ a,
    { by_cases h₃ : a = 0,
      { rw h₃ at h, linarith, },
      { have h₄ : 0 < a, from or.elim h₂ id (λ aeq0, absurd aeq0.symm h₃),
        have h₅ : 0 < b, from (zero_lt_mul_left h₄).mp h,
        exact or.inl ⟨h₄, h₅⟩, }, },
    { have h₄ : a < 0, linarith,
      have h₅ : b < 0,
      { by_contra p,
        rw not_lt_iff_le at p,
        rw ←neg_pos at h₄,
        have h₅ : 0 ≤ (-a) * b, from (zero_le_mul_left h₄).mpr p,
        have h₆ : -a * b = -(a*b),
        { rw [mul_comm (-a), ←neg_mul_eq_mul_neg, mul_comm], },
        rw h₆ at h₅,
        linarith, },
        exact or.inr ⟨h₄, h₅⟩, }, },
  { rintro (⟨apos, bpos⟩ | ⟨aneg, bneg⟩),
    { exact gt_zero_mul_of_gt_zero_of_gt_zero apos bpos },
    { rw ←neg_mul_neg a b,
      rw ←neg_pos at aneg bneg,
      exact gt_zero_mul_of_gt_zero_of_gt_zero aneg bneg, }, },
end

lemma square_lt_square_iff_lt_of_pos_of_pos (a b : R) (h₁ : 0 < a) (h₂ : 0 < b)
: a*a < b*b ↔ a < b :=
begin
  split,
  { intro aalebb,
    have h₃ : 0 < b*b - a*a, linarith,
    rw difference_of_two_squares b a at h₃,
    rw pos_mul_iff_pos_and_pos_or_neg_and_neg at h₃,
    rcases h₃ with ⟨h₃_left, h₃_right⟩ | ⟨h₃_left, h₃_right⟩,
    { linarith, },
    { have h₄ : a < -b, linarith,
      have h₅ : -b < 0, linarith,
      have h₆ : a < 0, from lt_trans h₄ h₅,
      have : (0 : R) < 0, from lt_trans h₁ h₆,
      linarith, }, },
  { intro aleb,
    apply mul_lt_mul,
    { exact aleb, },
    { exact le_of_lt aleb, },
    { exact h₁ },
    { exact le_of_lt h₂ }, },
end

lemma zero_eq_zero : (0 : R) = ↑0 := rfl

lemma one_eq_one : ↑1 = (1 : R) :=
by rw [coe_nat_succ, ←zero_eq_zero, zero_add]

lemma pos_iff_gt_zero (x : R) : pos x ↔ 0 < x :=
by rw [lt_iff_pos_sub, sub_zero]

lemma non_zero_of_pos {x : R} (h : 0 < x) : x ≠ 0 :=
begin
  intro k,
  rw k at h,
  exact lt_irrefl h,
end

lemma coe_zero_inj {m : ℕ} (h : (m : R) = 0) : m = 0 :=
begin
  by_contra k,
  have h₂ : pos(m : R), from pos_nat m k,
  rw [h, pos_iff_gt_zero (0 : R)] at h₂,
  exact lt_irrefl h₂,
end

lemma coe_non_zero_of_non_zero {m : ℕ} (h : m ≠ 0) : (m : R) ≠ 0 :=
begin
  contrapose! h,
  exact coe_zero_inj h,
end

lemma gt_zero_of_ne_zero_nat (n : ℕ) (h : n ≠ 0) : (0 : R) < n :=
begin
  rw [←pos_iff_gt_zero],
  exact pos_nat n h,
end

lemma coe_pred (n : ℕ) (h : n ≠ 0) : (↑(n-1) : R) = ↑n - 1 :=
begin
  induction n with k hk,
  { exfalso, apply h, refl, },
  { have : nat.succ k - 1 = k := rfl,
    rw [this, coe_nat_succ, sub_eq_add_neg', add_assoc, add_neg', add_zero ], },
end

lemma coe_pred_eq_of_coe_succ_eq {x k : ℕ} (h : ↑x = ↑k + (1 : R)) : (↑(x-1) : R)= ↑k :=
begin
  by_cases xeq0 : x = 0,
  { exfalso, rw xeq0 at h,
    change 0 = ↑k + (1:R) at h,
    have h₂ : ↑k = -(1 : R),
    { rw [←zero_add (-1: R), h, add_assoc, add_neg', add_zero], },
    have h₃ : (0 : R) ≤ ↑k,
    { rw le_iff_lt_or_eq,
      by_cases h₄ : k = 0,
      { rw h₄, right, refl, },
      { left, rw ←pos_iff_gt_zero, exact pos_nat k h₄, }, },
    rw h₂ at h₃,
    linarith, },
  { change x ≠ 0 at xeq0,
    rw coe_pred _ xeq0,
    linarith, }
end

lemma coe_inj (m n : ℕ) (h : (m : R) = (n : R)) : m = n :=
begin
  revert m,
  induction n with k hk,
  { intro m, exact coe_zero_inj, },
  { intros x hx,
    rw coe_nat_succ at hx,
    specialize hk (x-1),
    by_cases h₂ : x = 0,
    { rw [h₂, ←zero_eq_zero] at hx,
      have h₂ : ↑k = -(1 : R),
      { rw [←zero_add (-1: R), hx, add_assoc, add_neg', add_zero], },
      have h₃ : (0 : R) ≤ ↑k,
      { rw le_iff_lt_or_eq,
        by_cases h₄ : k = 0,
        { rw h₄, right, refl, },
        { left, rw ←pos_iff_gt_zero, exact pos_nat k h₄, }, },
      rw h₂ at h₃,
      linarith, },
    { rw coe_pred x h₂ at hk,
      have h₃ : ↑x - (1 : R) = ↑k, linarith,
      have h₄ : x - 1 = k, from hk h₃,
      rw ←h₄,
      cases nat.eq_zero_or_eq_succ_pred x with x0 xsp,
      { exact absurd x0 h₂, },
      { assumption, }, }, },
end

lemma coe_monotone (m n : ℕ) (h : m ≤ n) : (m : R) ≤ (n : R) :=
begin
  revert n,
  induction m with k hk,
  { intros n h,
    rw [←zero_eq_zero,le_iff_lt_or_eq],
    by_cases h₂ : n = 0,
    { right, rw [h₂, zero_eq_zero], },
    { left, exact gt_zero_of_ne_zero_nat n h₂, }, },
  { intros x hx,
    specialize hk (x-1),
    by_cases h₂ : x = 0,
    { exfalso,
      rw [h₂, ←not_lt] at hx,
      exact hx (nat.succ_pos k), },
    { rcases nat.exists_eq_succ_of_ne_zero h₂ with ⟨w, h⟩,
      rw coe_nat_succ,
      rw coe_pred x h₂ at hk,
      rw h at hx hk,
      suffices h₃ : ↑k ≤ ↑(nat.succ w) - (1 : R),
      { rw h, linarith, },
      have h₃ : nat.succ w - 1 = w := rfl,
      rw h₃ at hk,
      rw ←nat.pred_le_iff at hx,
      change k ≤ w at hx,
      exact hk hx, }, },
end

lemma coe_monotone' (m n : ℕ) (h : m < n) : (m : R) < (n : R) :=
begin
  have h₂ : m ≤ n, linarith,
  have h₃ : (m : R) ≤ n, from coe_monotone _ _ h₂,
  rw le_iff_lt_or_eq at h₃,
  cases h₃ with mltn meqn,
  { exact mltn, },
  { have h₃ : m = n, from coe_inj m n meqn,
    linarith, },
end

lemma non_neg_of_non_neg (n : ℕ) (h : 0 ≤ n) : (0 : R) ≤ ↑n :=
begin
  rw le_iff_lt_or_eq,
  by_cases h₂ : n = 0,
  { right, rw [h₂, zero_eq_zero], },
  { left, exact gt_zero_of_ne_zero_nat n h₂, }
end

lemma ge_one_of_non_zero (k : ℕ) (h : k ≠ 0): (1 : R) ≤ k :=
begin
  induction k with m hm,
  { exfalso,
    apply h, refl, },
  { rw coe_nat_succ m,
    conv {to_lhs, rw ←add_zero (1 : R)},
    by_cases h₂ : m = 1,
    { rw [h₂, add_zero, one_eq_one],
      change (1 : R) ≤ 2,
      rw le_iff_lt_or_eq,
      left,
      linarith, },
    { rw add_comm,
      apply add_le_add,
      { rw le_iff_lt_or_eq,
        by_cases h₃ : m = 0,
        { right, rw h₃, refl, },
        { left, exact gt_zero_of_ne_zero_nat m h₃, }, },
      { exact le_refl 1, }, }, },
end

lemma pos_inv_nat_of_non_zero {n : ℕ} (h : n ≠ 0) : (0 : R) < (↑n)⁻¹ :=
begin
  have h₂ : (0 : R) < ↑n, from gt_zero_of_ne_zero_nat n h,
  have h₃ : ↑n ≠ (0 : R), from non_zero_of_pos h₂,
  rwa inv_pos h₃,
end

theorem inv_le_inv {a b : R} (h₁ : 0 < a) (h₂ : 0 < b) : a⁻¹ ≤ b⁻¹ ↔ b ≤ a :=
begin
  have k₁ : a ≠ (0 : R), from non_zero_of_pos h₁,
  have k₂ : b ≠ 0, from non_zero_of_pos h₂,
  repeat {rw le_iff_lt_or_eq },
  split,
  { rintro (hlt | heq),
    { left,
      rwa ←inv_lt_inv h₁ h₂, },
    { right,
      rw [←inv_inv' a k₁, ←inv_inv' b k₂, heq], }, },
  { rintro (hlt | heq),
    { left,
      rwa inv_lt_inv h₁ h₂, },
    { rw heq, right, refl, }, },
end

lemma pos_add_inv_nat_of_pos {u : R} {n : ℕ} (h : (0 : R) < u) (h₂ : n ≠ 0)
: (0 : R) < u + (↑n)⁻¹ :=
begin
  rw ←add_zero (0 : R),
  apply add_lt_add h,
  rw inv_pos (coe_non_zero_of_non_zero h₂),
  exact gt_zero_of_ne_zero_nat n h₂,
end

lemma pos_sub_inv_nat_of_pos {u : R} {n : ℕ} (k₄ : (0 : R) < u) (ne0 : n ≠ 0) (k₅ : 2 < u*u)
: (0 : R) < u - (↑n)⁻¹ :=
begin
  by_contra p,
  have : u ≤ (↑n)⁻¹, linarith,
  have h₂ : (1 : R) ≤ (↑n), from ge_one_of_non_zero n ne0,
  have h₃ : (0 : R) < ↑n, {rw ←pos_iff_gt_zero, exact pos_nat n ne0},
  have h₄ : (↑n)⁻¹ ≤ (1 : R)⁻¹, { rwa inv_le_inv h₃ zero_lt_one, },
  have h₅ : u ≤ (1 : R)⁻¹, linarith,
  rw one_inv at h₅,
  have : u * u ≤ 1 * 1, from mul_le_mul h₅ h₅ (le_of_lt k₄) zero_le_one,
  linarith,
end

lemma lt_sub_inv_nat {u : R} {n : ℕ} (h₂ : n ≠ 0)
: u - (↑n)⁻¹ < u:=
begin
  rw [sub_eq_add_neg', add_lt_iff_neg_left, neg_lt_zero, inv_pos (coe_non_zero_of_non_zero h₂)],
  exact gt_zero_of_ne_zero_nat n h₂,
end

end auxiliary

namespace sqrt_two

open myreal_field classical myordered_field

open_locale classical

variables {R : Type} [myreal_field R]

lemma has_upper_bound_S : has_upper_bound ({x : R | (0 < x) ∧ (x*x < 2)} : set R) :=
begin
  use (2 : R),
  intros s hs,
  cases hs with h₁ h₂, -- `h₁ : 0 < s`, `h₂ : s * s < 2`,
  have h₄ : (2 : R) < 2 * 2, linarith,
  have h₅ : s * s < 2*2,
  { apply lt_trans h₂ h₄, },
  have : s * s ≤ 2*2, from le_of_lt h₅,
  have h₆ : 0 < (2 : R), linarith,
  have h₇ : 0 ≤ (2 : R), from le_of_lt h₆,
  rwa ←square_le_square_iff_le_of_non_neg_of_non_neg _ _ (le_of_lt h₁) h₇,
end

lemma one_in_S : (1 : R) ∈ {x : R | (0 < x) ∧ (x*x < 2)} :=
⟨by linarith, by linarith⟩

lemma non_empty_S : ({x : R | (0 < x) ∧ (x*x < 2)} : set R) ≠ ∅ :=
begin
  have h : (1 : R) ∈ {x : R | (0 < x) ∧ (x*x < 2)}, from one_in_S,
  intro h₂,
  rw h₂ at h,
  exact h,
end

lemma not_upper_bound_of_exists_nat {u : R} {S : set R} (h : ∃ n : ℕ, n ≠ 0 ∧ (u + (↑n)⁻¹ ∈ S))
: ¬(upper_bound u S) :=
begin
  rcases h with ⟨n, ne0, hn⟩,
  unfold upper_bound,
  push_neg,
  use (u + (↑n)⁻¹),
  apply and.intro hn,
  suffices h : (0 : R) + u< (↑n)⁻¹ + u,
  { rwa [zero_add, add_comm] at h,},
  apply add_lt_add_iff_right_mpr,
  have h₂ : (0 : R) < n, from gt_zero_of_ne_zero_nat n ne0,
  rwa inv_pos (coe_non_zero_of_non_zero ne0),
end

lemma not_lub_of_exists_nat {u : R} {S : set R} (h : ∃ n : ℕ, n ≠ 0 ∧ (upper_bound (u - (↑n)⁻¹) S))
: ¬(∀ v : R, upper_bound v S → u ≤ v) :=
begin
  rcases h with ⟨n, ne0, hn⟩,
  push_neg,
  use (u - (↑n)⁻¹),
  exact and.intro hn (lt_sub_inv_nat ne0),
end

def S : set R := {x : R | (0 < x) ∧ (x*x < 2)}

section lemmas_for_ub_contra

lemma pos_sub_inv_nat_of_pos {u : R} {n : ℕ} (k₄ : (0 : R) < u) (ne0 : n ≠ 0) (k₅ : 2 < u*u)
: (0 : R) < u - (↑n)⁻¹ :=
begin
  by_contra p,
  have : u ≤ (↑n)⁻¹, linarith,
  have h₂ : (1 : R) ≤ (↑n), from ge_one_of_non_zero n ne0,
  have h₃ : (0 : R) < ↑n, {rw ←pos_iff_gt_zero, exact pos_nat n ne0},
  have h₄ : (↑n)⁻¹ ≤ (1 : R)⁻¹, { rwa inv_le_inv h₃ zero_lt_one, },
  have h₅ : u ≤ (1 : R)⁻¹, linarith,
  rw one_inv at h₅,
  have : u * u ≤ 1 * 1, from mul_le_mul h₅ h₅ (le_of_lt k₄) zero_le_one,
  linarith,
end

lemma sq_add_inv_ub {u : R} {k : ℕ} (h : k ≠ 0)
: (u + (↑k)⁻¹)*(u + (↑k)⁻¹) ≤ u*u + (2*u+1)*(↑k)⁻¹ :=
begin
  rw [add_mul, add_mul, mul_add, mul_add, mul_comm (↑k)⁻¹ u, one_mul, add_assoc],
  apply add_le_add (le_refl (u* u)),
  rw [←add_assoc, ←two_mul, ←mul_assoc],
  apply add_le_add (le_refl _),
  have h₂ : (k : R) ≠ 0, from coe_non_zero_of_non_zero h,
  suffices h : (↑k)⁻¹ * (↑k)⁻¹ ≤ (↑k)⁻¹ * (1 : R),
  { rwa mul_one at h, },
  have h₃ : (1 : R) ≤ (↑k), from ge_one_of_non_zero k h,
  have h₄ : (↑k)⁻¹ ≤ (1 : R),
  { rwa [←one_inv, inv_le_inv (gt_zero_of_ne_zero_nat k h) (zero_lt_one : (0 : R) < 1)], },
  have h₅ : (0 : R) < (↑k)⁻¹, from pos_inv_nat_of_non_zero h,
  exact mul_le_mul (le_refl (↑k)⁻¹) h₄ (le_of_lt h₅) (le_of_lt h₅),
end

lemma inequ1 {u : R} (h₁ : 0 < u) (h₂ : u*u < 2) : (0 : R) < (2*u + 1)⁻¹ * (2 - u*u) :=
begin
  have h₃ : 0 < 2 - u * u, linarith,
  have h₄ : 0 < 2 * u + 1, from add_pos (by linarith) (by linarith),
  have h₅ : 2*u+ 1 ≠ 0, linarith,
  have h₆ : 0 < (2*u + 1)⁻¹, from (inv_pos h₅).mpr h₄,
  exact mul_pos _ _ h₆ h₃,
end

lemma inequ2 {u : R} {n : ℕ} (h₁ : 0 < u) (h₂ : (↑n)⁻¹ < (2 * u + 1)⁻¹ * (2 - u * u))
: u * u +  (2 * u + 1) * (↑n)⁻¹ < 2:=
begin
  suffices h : ((2 : R)*u+1) * (↑n)⁻¹ < (2- u * u), linarith,
  have h₄ : 0 < 2 * u + 1, from add_pos (by linarith) (by linarith),
  have h₅ : 2*u+ 1 ≠ 0, linarith,
  suffices h : (2 * u + 1) * (↑n)⁻¹ < (2 * u + 1) * ((2*u + 1)⁻¹ * (2 - u * u)),
  { rwa [←mul_assoc, mul_inv _ h₅, one_mul] at h, },
  exact mul_lt_mul_left_mpr h₄ h₂,
end

lemma ub_contra {u : R} (k₃ : upper_bound u S) (k₄ : (0 : R) < u) (k₅ : u * u < 2) : u * u = 2 :=
begin
  suffices h : ¬(upper_bound u S), from absurd k₃ h,
  suffices h : ∃ n : ℕ, (n ≠ 0) ∧ u + (↑n)⁻¹ ∈ S, from not_upper_bound_of_exists_nat h,
  suffices h : ∃ n : ℕ, (n ≠ 0) ∧ ((u + (n : R)⁻¹) * (u + (↑n)⁻¹) < 2),
  { rcases h with ⟨n, ne0, hn⟩,
    exact ⟨n, ne0, pos_add_inv_nat_of_pos k₄ ne0, hn⟩, },
  suffices h : ∃ n : ℕ, n ≠ 0 ∧ (u*u + ((2 : R)*u + 1)*(↑n)⁻¹) < 2,
  { rcases h with ⟨n, ne0, hn⟩,
    exact ⟨n, ne0, (lt_of_le_of_lt) (sq_add_inv_ub ne0) hn⟩, },
  have k₆ : (0 : R) < (2*u + 1)⁻¹ * (2 - u*u) := inequ1 k₄ k₅,
  rcases (inv_lt_of_pos _ k₆) with ⟨n, ne0, h₂⟩,
  exact ⟨n, ne0, (inequ2 k₄ h₂)⟩,
end

end  lemmas_for_ub_contra

section lemmas_for_lub_contra

lemma sq_sub_inv_ub {u : R} {k : ℕ} (h₁ : 0 < u) (h₂ : k ≠ 0)
: (u - (↑k)⁻¹) * (u - (↑k)⁻¹) > u*u - 2*u*(↑k)⁻¹ :=
begin
  repeat {rw sub_eq_add_neg},
  rw [mul_add, add_mul, add_mul, mul_comm (-(↑k)⁻¹) u, add_assoc],
  apply add_lt_add_of_le_of_lt(le_refl (u* u)),
  rw [←add_assoc, ←two_mul, neg_mul_eq_mul_neg, mul_assoc, lt_add_iff_pos_right, neg_mul_neg_self],
  exact mul_pos _ _ (pos_inv_nat_of_non_zero h₂) (pos_inv_nat_of_non_zero h₂),
end

lemma lub_contra_subproof1 {u : R} (k₄ : (0 : R) < u) (k₅ : 2 < u * u)
(h : ∃ n : ℕ, (n ≠ 0) ∧ (2 < (u - (n : R)⁻¹) * (u - (↑n)⁻¹)))
: ∃ (n : ℕ), n ≠ 0 ∧ upper_bound (u - (↑n)⁻¹) S :=
begin
  rcases h with ⟨n, ne0, hn⟩,
  use n,
  apply and.intro ne0,
  intros x hx,
  cases hx with xpos xsqlt2,
  have h₃ : x * x < (u - (n : R)⁻¹) * (u - (↑n)⁻¹), from lt_trans xsqlt2 hn,
  rw le_iff_lt_or_eq,
  left,
  exact (square_lt_square_iff_lt_of_pos_of_pos _ _ xpos (pos_sub_inv_nat_of_pos k₄ ne0 k₅)).mp h₃,
end

lemma inequ3 {u : R} {n : ℕ} (h₁ : 0 < u) (h₂ : (↑n)⁻¹ < (2*u)⁻¹ * (u*u - 2))
: 2 < u * u - 2 * u * (↑n)⁻¹ :=
begin
  suffices h : 2 * u * (↑n)⁻¹  < u * u - 2, linarith,
  have h₄ : 0 < (2 * u), linarith,
  have h₅ : 2 * u ≠ 0, linarith,
  suffices h : (2 * u) * (↑n)⁻¹ < (2 * u) * ( (2*u)⁻¹ *(u*u -2)),
  { rwa [←mul_assoc, mul_inv _ h₅, one_mul] at h, },
  exact mul_lt_mul_left_mpr h₄ h₂,
end

lemma inequ4 {u : R} (h₁ : 0 < u) (h₂ : 2 < u * u) : 0 < (2*u)⁻¹ * (u * u - 2):=
begin
  have h₃ : 0 < u * u - 2, linarith,
  have h₄ : 0 < 2 * u, linarith,
  have h₅ : 2*u  ≠ 0, linarith,
  have h₆ : 0 < (2*u)⁻¹, from (inv_pos h₅).mpr h₄,
  exact mul_pos _ _ h₆ h₃,
end

lemma lub_contra {u : R} (k₃ : ∀ v : R, upper_bound v S → u ≤ v) (k₄ : (0 : R) < u)
(k₅ : 2 < u * u)
: u * u = 2 :=
begin
  suffices h : ¬(∀ v : R, upper_bound v S → u ≤ v), from absurd k₃ h,
  suffices h : ∃ n : ℕ, n ≠ 0 ∧ (upper_bound (u - (↑n)⁻¹) S), from not_lub_of_exists_nat h,
  suffices h : ∃ n : ℕ, (n ≠ 0) ∧ (2 < (u - (n : R)⁻¹) * (u - (↑n)⁻¹)),
  from lub_contra_subproof1 k₄ k₅ h,
  suffices h : ∃ n : ℕ, n ≠ 0 ∧ 2  < u * u - 2 * u * (↑n)⁻¹,
  { rcases h with ⟨n, ne0, hn⟩,
    exact ⟨n, ne0, lt_trans hn (sq_sub_inv_ub k₄ ne0)⟩ },
  suffices h : ∃ n : ℕ, n ≠ 0 ∧ (↑n)⁻¹ < (2*u)⁻¹ * (u*u - 2),
  { rcases h with ⟨n, ne0, hn⟩,
    exact ⟨n, ne0, inequ3 k₄ hn⟩, },
  have k₆ : 0 < (2*u)⁻¹ * (u * u - 2):= inequ4 k₄ k₅,
  exact inv_lt_of_pos _ k₆,
end

end lemmas_for_lub_contra

lemma sqrt_two_exists : (sup S)*(sup S) = (2 : R) :=
begin
  have k₂ : ({x : R | (0 < x) ∧ (x*x < 2)} : set R) ≠ ∅, from non_empty_S,
  have k₃ : is_sup (sup S) S, from  sup_is_sup has_upper_bound_S k₂,
  have k₄ : ↑0 < sup S,
  { suffices h : (1 : R) ≤ sup S,
    { change (0 : R) < sup S,
      exact lt_of_lt_of_le zero_lt_one h, },
    exact k₃.left (1 : R) one_in_S, },
  rcases trichotomy' ((sup S)*(sup S)) (2 : R) with ub | sq_eq | lub,
  { exact ub_contra k₃.left k₄ ub.left, },
  { exact sq_eq.right.left, },
  { exact lub_contra k₃.right k₄ lub.right.right, },
end

end sqrt_two

end myreal

end mth1001


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

-- NOTE: This file contains examples for, and therefore should be kept in sync
-- with, the README.

import Aesop

set_option aesop.check.all true

inductive MyList (α : Type _)
  | nil
  | cons (hd : α) (tl : MyList α)

namespace MyList

protected def append : (_ _ : MyList α) → MyList α
  | nil, ys => ys
  | cons x xs, ys => cons x (MyList.append xs ys)

instance : Append (MyList α) :=
  ⟨MyList.append⟩

@[simp]
theorem nil_append : nil ++ xs = xs := rfl

@[simp]
theorem cons_append : cons x xs ++ ys = cons x (xs ++ ys) := rfl

@[aesop safe [constructors, cases]]
inductive NonEmpty : MyList α → Prop
  | cons : NonEmpty (cons x xs)

@[aesop 50%]
theorem nonEmpty_append₁ {xs : MyList α} ys :
    NonEmpty xs → NonEmpty (xs ++ ys) := by
  aesop

theorem nonEmpty_append₁' {xs : MyList α} ys :
    NonEmpty xs → NonEmpty (xs ++ ys) := by
  -- This is the script generated by aesop?.
  intro a
  unhygienic aesop_cases a
  simp_all only [cons_append]
  apply MyList.NonEmpty.cons

example {α : Type _} {xs : MyList α} ys zs :
    NonEmpty xs → NonEmpty (xs ++ ys ++ zs) := by
  aesop

theorem nil_not_nonEmpty (xs : MyList α) : xs = nil → ¬ NonEmpty xs := by
  aesop (add unsafe 10% cases MyList, norm simp Not)

@[simp]
theorem append_nil {xs : MyList α} :
    xs ++ nil = xs := by
  induction xs <;> aesop

theorem append_assoc {xs ys zs : MyList α} :
    (xs ++ ys) ++ zs = xs ++ (ys ++ zs) := by
  induction xs <;> aesop

end MyList


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.locally_finite
import data.dfinsupp.order

/-!
# Finite intervals of finitely supported functions

This file provides the `locally_finite_order` instance for `Π₀ i, α i` when `α` itself is locally
finite and calculates the cardinality of its finite intervals.
-/

open dfinsupp finset
open_locale big_operators pointwise

variables {ι : Type*} {α : ι → Type*}

namespace finset
variables [decidable_eq ι] [Π i, has_zero (α i)] {s : finset ι} {f : Π₀ i, α i}
  {t : Π i, finset (α i)}

/-- Finitely supported product of finsets. -/
def dfinsupp (s : finset ι) (t : Π i, finset (α i)) : finset (Π₀ i, α i) :=
(s.pi t).map ⟨λ f, dfinsupp.mk s $ λ i, f i i.2, begin
  refine (mk_injective _).comp (λ f g h, _),
  ext i hi,
  convert congr_fun h ⟨i, hi⟩,
  end⟩

@[simp] lemma card_dfinsupp (s : finset ι) (t : Π i, finset (α i)) :
  (s.dfinsupp t).card = ∏ i in s, (t i).card :=
(card_map _).trans $ card_pi _ _

variables [Π i, decidable_eq (α i)]

lemma mem_dfinsupp_iff : f ∈ s.dfinsupp t ↔ f.support ⊆ s ∧ ∀ i ∈ s, f i ∈ t i :=
begin
  refine mem_map.trans ⟨_, _⟩,
  { rintro ⟨f, hf, rfl⟩,
    refine ⟨support_mk_subset, λ i hi, _⟩,
    convert mem_pi.1 hf i hi,
    exact mk_of_mem hi },
  { refine λ h, ⟨λ i _, f i, mem_pi.2 h.2, _⟩,
    ext i,
    dsimp,
    exact ite_eq_left_iff.2 (λ hi, (not_mem_support_iff.1 $ λ H, hi $ h.1 H).symm) }
end

/-- When `t` is supported on `s`, `f ∈ s.dfinsupp t` precisely means that `f` is pointwise in `t`.
-/
@[simp] lemma mem_dfinsupp_iff_of_support_subset {t : Π₀ i, finset (α i)} (ht : t.support ⊆ s) :
  f ∈ s.dfinsupp t ↔ ∀ i, f i ∈ t i :=
begin
  refine mem_dfinsupp_iff.trans (forall_and_distrib.symm.trans $ forall_congr $ λ i, ⟨λ h, _,
    λ h, ⟨λ hi, ht $ mem_support_iff.2 $ λ H, mem_support_iff.1 hi _, λ _, h⟩⟩),
  { by_cases hi : i ∈ s,
    { exact h.2 hi },
    { rw [not_mem_support_iff.1 (mt h.1 hi), not_mem_support_iff.1 (not_mem_mono ht hi)],
      exact zero_mem_zero } },
  { rwa [H, mem_zero] at h }
end

end finset

open finset

namespace dfinsupp
variables [decidable_eq ι] [Π i, decidable_eq (α i)]

section bundled_singleton
variables [Π i, has_zero (α i)] {f : Π₀ i, α i} {i : ι} {a : α i}

/-- Pointwise `finset.singleton` bundled as a `dfinsupp`. -/
def singleton (f : Π₀ i, α i) : Π₀ i, finset (α i) :=
⟦{ to_fun := λ i, {f i},
  pre_support := f.support.1,
  zero := λ i, (ne_or_eq (f i) 0).imp mem_support_iff.2 (congr_arg _) }⟧

lemma mem_singleton_apply_iff : a ∈ f.singleton i ↔ a = f i := mem_singleton

end bundled_singleton

section bundled_Icc
variables [Π i, has_zero (α i)] [Π i, partial_order (α i)] [Π i, locally_finite_order (α i)]
  {f g : Π₀ i, α i} {i : ι} {a : α i}

/-- Pointwise `finset.Icc` bundled as a `dfinsupp`. -/
def range_Icc (f g : Π₀ i, α i) : Π₀ i, finset (α i) :=
⟦{ to_fun := λ i, Icc (f i) (g i),
  pre_support := f.support.1 + g.support.1,
  zero := λ i, begin
    refine or_iff_not_imp_left.2 (λ h, _),
    rw [not_mem_support_iff.1 (multiset.not_mem_mono (multiset.le_add_right _ _).subset h),
      not_mem_support_iff.1 (multiset.not_mem_mono (multiset.le_add_left _ _).subset h)],
    exact Icc_self _,
  end }⟧

@[simp] lemma range_Icc_apply (f g : Π₀ i, α i) (i : ι) : f.range_Icc g i = Icc (f i) (g i) := rfl

lemma mem_range_Icc_apply_iff : a ∈ f.range_Icc g i ↔ f i ≤ a ∧ a ≤ g i := mem_Icc

lemma support_range_Icc_subset : (f.range_Icc g).support ⊆ f.support ∪ g.support :=
begin
  refine λ x hx, _,
  by_contra,
  refine not_mem_support_iff.2 _ hx,
  rw [range_Icc_apply,
    not_mem_support_iff.1 (not_mem_mono (subset_union_left _ _) h),
      not_mem_support_iff.1 (not_mem_mono (subset_union_right _ _) h)],
  exact Icc_self _,
end

end bundled_Icc

section pi
variables [Π i, has_zero (α i)]

/-- Given a finitely supported function `f : Π₀ i, finset (α i)`, one can define the finset
`f.pi` of all finitely supported functions whose value at `i` is in `f i` for all `i`. -/
def pi (f : Π₀ i, finset (α i)) : finset (Π₀ i, α i) := f.support.dfinsupp f

@[simp] lemma mem_pi {f : Π₀ i, finset (α i)} {g : Π₀ i, α i} : g ∈ f.pi ↔ ∀ i, g i ∈ f i :=
mem_dfinsupp_iff_of_support_subset $ subset.refl _

@[simp] lemma card_pi (f : Π₀ i, finset (α i)) : f.pi.card = f.prod (λ i, (f i).card) :=
begin
  rw [pi, card_dfinsupp],
  exact finset.prod_congr rfl (λ i _, by simp only [pi.nat_apply, nat.cast_id]),
end

end pi

section locally_finite
variables [Π i, partial_order (α i)] [Π i, has_zero (α i)] [Π i, locally_finite_order (α i)]

instance : locally_finite_order (Π₀ i, α i) :=
locally_finite_order.of_Icc (Π₀ i, α i)
  (λ f g, (f.support ∪ g.support).dfinsupp $ f.range_Icc g)
  (λ f g x, begin
    refine (mem_dfinsupp_iff_of_support_subset $ support_range_Icc_subset).trans _,
    simp_rw [mem_range_Icc_apply_iff, forall_and_distrib],
    refl,
  end)

variables (f g : Π₀ i, α i)

lemma card_Icc : (Icc f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card :=
card_dfinsupp _ _

lemma card_Ico : (Ico f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card - 1 :=
by rw [card_Ico_eq_card_Icc_sub_one, card_Icc]

lemma card_Ioc : (Ioc f g).card = ∏ i in f.support ∪ g.support, (Icc (f i) (g i)).card - 1 :=
by rw [card_Ioc_eq_card_Icc_sub_one, card_Icc]

end locally_finite
end dfinsupp


/-  An alternative take on the definition of a minor, where we take a quotient. Very much WIP. -/

import ftype.basic set_tactic.solver
import .rankfun .dual

--noncomputable theory
open_locale classical
noncomputable theory

open ftype

variables {U₀ U V W: ftype}--[nonempty U₀]

--def img (emb : U₀ ↪ U) :=
--  λ (X : set U₀), emb.to_fun '' X

/- given an injection emb, and a set equal to the range of emb, outputs an equivalence between the
domain and the subtype corresponding to the range.
def subtype_inv_inj (emb : U₀ ↪ U){E : set U} (hE : E = set.range emb) : E ≃ U₀ :=
let h : Π (y : E), (∃ x : U₀, emb x = y) :=
  by {rintros ⟨y,hy⟩, rw [hE, set.mem_range] at hy, cases hy with x hx, from ⟨x, by simp [hx]⟩},
 desc : Π (y : E), {x : U₀ // emb x = y} :=
  λ y, classical.indefinite_description _ (h y) in
{
  to_fun := λ y, (desc y).val,
  inv_fun := λ x, ⟨emb x, by {rw [hE, set.mem_range], from ⟨x, rfl⟩} ⟩,
  left_inv := by {intros y, simp_rw (desc y).property, simp},
  right_inv := λ x, by {cases emb with f h_inj, from h_inj (desc ⟨f x,_⟩).property},
}
-/

def subset_embed (X : set U) : X ↪ U :=
{ to_fun := λ x, x.val,
  inj' := λ x y hxy, subtype.ext hxy}

def subset_to_subtype {X Y : set U} (hXY : X ⊆ Y) : set Y :=
  λ y, y.val ∈ X

/-- (invisible) equivalence between the class of subsets of R and the class of
 sets in the ftype corresponding to R -/
def subset_equiv {R : set U} : {X : set U // X ⊆ R} ≃ set (⟨R⟩ : ftype) :=
{ to_fun := λ X, {y | y.val ∈ X.val},
  inv_fun := λ Y, ⟨coe '' Y,by {intros y hy, cases hy with x hx, rw ←hx.2, exact x.2,} ⟩,
  left_inv := begin
    intro X, ext x, simp only [set.mem_image, subtype.coe_mk],
    refine ⟨λ h, _, λ h, ⟨⟨x,_⟩,⟨_,_⟩⟩⟩,
    { rcases h with ⟨x',h₁,h₂⟩, rw ←h₂, convert h₁,},
    { cases X, tauto, },
    { tauto, },
    simp,
  end,
  right_inv := begin
    intro X, ext x, cases x with x xp,  simp only [set.mem_set_of_eq],
    refine ⟨λ h, _, λ h, _⟩,
    {unfold_projs at h, rcases h with ⟨a,h1,h2⟩, simp_rw ←h2, convert h1, simp},
    exact ⟨⟨x,xp⟩, ⟨h,by simp⟩⟩,
  end, }

/-- bundled isomorphism between two matroids -/
structure isom (M : matroid U) (N : matroid V) :=
  (bij: U ≃ V)
  (rank_preserving : M.r =  N.r ∘ (set.image bij))

instance coe_iso_to_fun {M : matroid U} {N : matroid V} : has_coe_to_fun (isom M N) :=
{F := λ (i : isom M N), (U → V), coe := λ i, i.bij}

/-- inverse of a matroid isomorphism -/
def inv{M: matroid U} {N: matroid V} (iso : isom M N) : isom N M :=
{
  bij := iso.bij.symm,
  rank_preserving :=
  by {rw iso.rank_preserving, ext X, convert rfl, convert rfl, ext x, simp},
}

def compose {M : matroid U} {N : matroid V} {O : matroid W} (i₁ : isom M N) (i₂ : isom N O) : isom M O :=
{
  bij := equiv.trans i₁.bij i₂.bij,
  rank_preserving :=
  begin
    ext X, rw [i₁.rank_preserving, i₂.rank_preserving],
    simp only [equiv.to_fun_as_coe, ftype.ftype_coe, function.comp_app, equiv.coe_trans],
    apply congr_arg, ext x,  simp,
  end
}

-- making a hash of this one!
@[simp] lemma compose_inv_on_set {M: matroid U} {N: matroid V} (iso : isom M N) (X : set U) :
  ((inv iso).bij '' (iso.bij '' X)) = X :=
begin
  --unfold equiv.img,
  convert rfl, ext,
  rw set.mem_image,
  refine ⟨λ h, ⟨iso.bij x,⟨_,_⟩⟩,λ h, _⟩,
    {simp only [equiv.to_fun_as_coe, equiv.apply_eq_iff_eq, set.mem_image, exists_eq_right], from h },
    {simp[inv]},
    {rcases h with ⟨y,h1,h2⟩, rw set.mem_image at h1, rcases h1 with ⟨x', ⟨hx'1, hx'2⟩⟩, rw [←h2,←hx'2] , convert hx'1, rw inv, simp,}
end

variable {M : matroid U}

/-- structure describing a matroid and an embedding of its elements into U -/
@[ext] structure emb_mat (U : ftype) :=
  {U₀ : ftype}
  (mat : matroid U₀)
  (emb : U₀ ↪ U)

namespace emb_mat

def groundset (N : emb_mat U) : set U :=
  set.range N.emb

def strongly_iso (N₁ N₂ : emb_mat U) : Prop :=
  (∃ (φ : isom (N₁.mat) (N₂.mat)), ∀ x, N₁.emb x = N₂.emb (φ x))

lemma strong_iso_equiv :
  equivalence (λ (N₁ N₂ : emb_mat U), strongly_iso N₁ N₂) :=
begin
  refine ⟨λ N, _, λ N₁ N₂ hab, _, λ N₁ N₂ N₃ hab hbc, _⟩,
    {refine ⟨⟨equiv.refl _,_⟩,λ X, _⟩,
      {ext X, simp,},
      {apply congr_arg, unfold_coes, simp} },
    {cases hab with φ, refine ⟨inv φ, λ X, _⟩, rw [hab_h ((inv φ) X), inv], unfold_coes, simp},
  cases hab with i₁ h₁, cases hbc with i₂ h₂,
  from ⟨compose i₁ i₂, λ X, by {unfold_coes at *, simp [h₁,h₂,congr_arg, compose]}⟩,
end

lemma strong_iso_same_groundset (N N' : emb_mat U) :
  strongly_iso N N' → N.groundset = N'.groundset  :=
begin
  rintros ⟨h₁,h₂⟩, ext,
  simp only [groundset, set.mem_range],
  simp_rw h₂,
  refine ⟨λ h, _, λ h, _⟩,
    {cases h with y hy, from ⟨_, hy⟩},
  cases h with y hy, use h₁.bij.inv_fun y, unfold_coes, simp [hy],
end

--def pullback_r (N : emb_mat U) : set (N.ground) → ℤ :=
--  λ X, N.mat.r ((N.emb.subtype_inv_inj (rfl : N.ground = set.range N.emb))'' X)

/-- mapped rank function of N, but defined on all subsets of U (elements not in image are ignored)-/
def pullback_r (N : emb_mat U) : set U → ℤ :=
  λ X, N.mat.r ({x : N.U₀ | N.emb x ∈ X })

lemma pullback_r_eq (N : emb_mat U) (X : set N.U₀) :
  N.mat.r X = N.pullback_r (N.emb.to_fun '' X) :=
begin
  unfold pullback_r, congr', ext x,
  simp only [set.mem_image, function.embedding.to_fun_eq_coe, set.mem_set_of_eq],
  refine ⟨λ h, _, λ h, _⟩,
    {use x, simp, from h},
  cases h with x' hx',
  convert hx'.1,
  from (N.emb.inj' hx'.2).symm,
end
  --ite (X ⊆ N.ground) (some 0 : option ℤ) (none : option ℤ)

  --N.mat.r ((N.emb.subtype_inv_inj (rfl : N.ground = set.range N.emb))'' X)

lemma strong_iso_same_pullback_r (N N' : emb_mat U) :
  strongly_iso N N' → N.pullback_r = N'.pullback_r :=
begin
  rintros ⟨⟨φ,hφ₁⟩, hφ₂⟩, ext X,
  unfold pullback_r, rw hφ₁,
  dsimp, congr', ext x',
  simp only [set.mem_image, set.mem_set_of_eq],
  simp_rw hφ₂,
  refine ⟨λ h, _, λ h, ⟨φ.inv_fun x',⟨_,by simp⟩⟩⟩,
    {rcases h with ⟨x, ⟨hx₁,hx₂⟩⟩, rw ←hx₂, from hx₁,},
  rw ←hφ₂,
  convert h,
  rw hφ₂,
  congr', unfold_coes, simp,
end

/-- if E is equal to the groundset of N, then there is a natural equivalence between E and U₀ -/
def groundset_equiv (N : emb_mat U){E : set U} (hE : N.groundset = E) :
  N.U₀ ≃ (⟨E⟩ : ftype) :=
  ((equiv.set.range N.emb N.emb.inj').trans (equiv.set.of_eq hE))

--def pullback_r' (N : emb_mat U){E : set U} (hE : N.ground = E) : set E → ℤ :=

instance strong_iso_setoid (U : ftype) : setoid (emb_mat U) := ⟨strongly_iso, strong_iso_equiv⟩

end emb_mat

/-- a matroid_in U is a matroid embedded into some set of ements of U, modulo the range of the embedding-/
def matroid_in (U : ftype) := quot (λ (N N' : emb_mat U), N.strongly_iso N')

namespace matroid_in

/-- the groundset of N, viewed as a (set U)-/
def groundset : matroid_in U → set U := quotient.lift
  (λ (N : emb_mat U), N.groundset) emb_mat.strong_iso_same_groundset

/-- the groundset of N, viewed as an ftype -/
def ground (N : matroid_in U) : ftype := ⟨N.groundset⟩

/-- the rank function of N as a function on set U (elements outside the groundset of N
are ignored)-/
def r : matroid_in U → (set U → ℤ) := quotient.lift
  (λ (N : emb_mat U), N.pullback_r) emb_mat.strong_iso_same_pullback_r

/-- the rank function of N as a function on sets of the ground ftype of N-/
def r_ftype (N : matroid_in U) : (set N.ground → ℤ) :=
  λ X, N.r ((λ x : N.ground, x.val)'' X )

/-- an equivalence class representative for N -/
def rep_spec (N : matroid_in U) : {N₀ : emb_mat U // ⟦N₀⟧ = N} :=
  classical.indefinite_description _ (quot.exists_rep N)

/-- the ground set of a representative is the ground set of a matroid_in -/
lemma ground_rep {N : matroid_in U} {N₀ : emb_mat U} (h : ⟦N₀⟧ = N) :
   N₀.groundset = N.groundset  :=
by {dsimp only [quotient.mk] at h, rw ←h, refl}

lemma r_eq_r_inter_groundset (N : matroid_in U) (X : set U) :
  N.r X = N.r (X ∩ N.groundset) :=
begin
  unfold matroid_in.groundset r emb_mat.pullback_r emb_mat.groundset,
  rcases rep_spec N with ⟨N₀,h⟩,
  simp [←h],
end

section preimages

variables {N : matroid_in U} {N₀ : emb_mat U}

/-- given an equivalence class representative N₀, pulls a set X back to the
ftype on which N₀ is defined -/
def rep_preimage (hN : ⟦N₀⟧ = N) (X : set N.ground) :=
  N₀.groundset_equiv (ground_rep hN) ⁻¹' X

lemma rep_preimage_on_size (hN : ⟦N₀⟧ = N) (X : set N.ground) :
  size (rep_preimage hN X) = size X :=
by {apply size_preimage_equiv}

lemma rep_preimage_on_subset (hN : ⟦N₀⟧ = N){X Y : set N.ground} :
  X ⊆ Y → rep_preimage hN X ⊆ rep_preimage hN Y :=
λ h, set.preimage_mono h

lemma r_rep (hN : ⟦N₀⟧ = N) (X : set N.ground) :
  r_ftype N X = N₀.mat.r (rep_preimage hN X) :=
begin
  unfold r_ftype r,
  simp_rw ←hN,
  simp only [quotient.lift_mk],
  unfold emb_mat.pullback_r, apply congr_arg, ext x,
  rw [rep_preimage],
  simp only [set.mem_set_of_eq, emb_mat.groundset_equiv ], simp,
  refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨y,h,h'⟩, simp_rw ←h', convert h, simp,},
  use N₀.emb x,
  { unfold matroid_in.groundset, rw ←hN, simp only [quotient.lift_mk], unfold emb_mat.groundset, simp,},
  exact ⟨h, by simp⟩,
end

end preimages

def as_matroid (N : matroid_in U) : matroid N.ground :=
{
  r := N.r_ftype,
  R0 := λ X, let ⟨N₀,h⟩ := rep_spec N in by
  {rw r_rep h X, apply N₀.mat.R0, },
  R1 := λ X, let ⟨N₀,h⟩ := rep_spec N in by
  {rw [r_rep h X, ←rep_preimage_on_size h], apply N₀.mat.R1,},
  R2 := λ X Y hXY, let ⟨N₀,h⟩ := rep_spec N in by
  {repeat {rw r_rep h}, apply N₀.mat.R2, exact (rep_preimage_on_subset _ hXY),} ,
  R3 := λ X Y, let ⟨N₀,h⟩ := rep_spec N in by
  {repeat {rw r_rep h}, apply N₀.mat.R3,  }
}

lemma as_matroid_r_eq (N : matroid_in U) :
  ∀ X, N.r X = N.as_matroid.r (subset_equiv ⟨X ∩ N.groundset, by tidy⟩) :=
begin
  intro X,
  unfold matroid_in.as_matroid matroid_in.r_ftype subset_equiv,
  simp only [equiv.coe_fn_mk, subtype.coe_mk],
  rw r_eq_r_inter_groundset, congr',
  ext x, simp only [set.mem_image, set.mem_inter_eq,set.mem_set_of_eq,subtype.coe_mk],
  refine ⟨λ h, ⟨⟨x,h.2⟩,⟨⟨h.1,h.2⟩,by simp⟩⟩, λ h, _⟩,
  rcases h with ⟨x',⟨h,rfl⟩⟩,
  exact h,
end

/-- as_matroid is the canonical representative for a matroid_in -/
lemma as_matroid_is_rep (M : matroid_in U) :
  M = ⟦{mat := M.as_matroid, emb := function.embedding.subtype _ }⟧ :=
begin
  rcases M.rep_spec with ⟨M₀,h⟩, rw ←h, apply quotient.sound,

  simp only [has_equiv.equiv, setoid.r, emb_mat.strongly_iso, as_matroid, r_ftype],
  dsimp only [ftype.ftype_coe],
  refine ⟨⟨_,_⟩,λ x, _⟩,
  { refine emb_mat.groundset_equiv _ _, refl, },
  begin
    ext X, simp only [function.comp_app, r, emb_mat.pullback_r], unfold emb_mat.groundset_equiv, congr', ext x,
    simp only [set.mem_set_of_eq, set.image_congr, set.mem_image, exists_exists_and_eq_and, subtype.val_eq_coe],
    refine ⟨λ h, ⟨x,h, by simp⟩, λ h, _⟩,
    rcases h with ⟨a,ha,h⟩, simp at h,
    rw ←M₀.emb.inj' h, exact ha,
  end,
  refl,
end

/- lemma as_matroid_r_eq_subset (N : matroid_in U) :
  ∀ X : {X : set U // X ⊆ N.groundset}, N.r X.val = N.as_matroid.r (subset_equiv X) :=
begin
  intro X,
  convert as_matroid_r_eq N X.val,

end -/

--lemma iso_to (M₀ : emb_mat U) :

def as_matroid_in (M : matroid U) : matroid_in U :=
  ⟦{U₀ := U, emb := function.embedding.refl U, mat := M}⟧

instance coe_to_matroid_in : has_coe (matroid U) (matroid_in U) := ⟨λ M, as_matroid_in M⟩

def embed (M : matroid_in U) : M.ground ↪ U := subset_embed M.groundset

def subset_embed {M : matroid_in U} {R : set U} (hR : R ⊆ M.groundset) : R ↪ M.ground :=
{to_fun  := λ x, ⟨x.val, by {cases x, tauto}⟩,
 inj'    := λ x y hxy, by {simp only [subtype.mk_eq_mk] at hxy, exact subtype.eq hxy, } }

def nested_embed (M' M : matroid_in U) (hMM' : M'.groundset ⊆ M.groundset) : M'.ground ↪ M'.ground :=
{to_fun  := λ x, ⟨x.val, by simp⟩,
 inj'    := λ x y hxy, by {convert hxy; simp,} }

--set_option pp.proofs true

def matroid_in_ext (M M' : matroid_in U) :
  M.groundset = M'.groundset → M.r = M'.r → M = M' :=
begin
  intros h h',
  rw [as_matroid_is_rep M, as_matroid_is_rep M', quotient.sound],
  refine ⟨⟨_,_⟩,λ x, _⟩,
  {exact {to_fun := λ x, ⟨x.val, by {rw ←h, exact x.property,}⟩ ,
          inv_fun := λ x, ⟨x.val, by {rw h, exact x.property,}⟩,
          left_inv := λ x, by {dsimp only, simp,},
          right_inv := λ x, by {dsimp only, simp,}}, },
  begin
    simp_rw h',
    simp only [as_matroid, r_ftype], --simp_rw h',
    ext X, simp only [set.image_congr, function.comp_app, subtype.val_eq_coe], rw h',
    apply congr_arg, ext x, dsimp only [ftype.ftype_coe],
    simp only [set.image_congr, set.mem_image, exists_exists_and_eq_and, subtype.val_eq_coe],
    refine ⟨λ hx,_, λ hx, _⟩,
    { rcases hx with ⟨y,h₁,rfl⟩, exact ⟨y,h₁, by simp⟩,  },
    rcases hx with ⟨⟨y, hy⟩, hy', rfl⟩, refine ⟨⟨y,hy⟩,⟨hy',_⟩⟩, simp,
  end,
  refl,
end

def from_matroid_on_subtype {E : set U} (M : matroid ⟨E⟩) :  matroid_in U :=
⟦{mat := M, emb := function.embedding.subtype _}⟧

lemma groundset_correct {E : set U} (M : matroid ⟨E⟩) :
  (from_matroid_on_subtype M).groundset = E :=
by {unfold from_matroid_on_subtype groundset emb_mat.groundset, simp}

lemma rank_correct {E : set U} (M : matroid ⟨E⟩) (X : set U) :
  (from_matroid_on_subtype M).r X = M.r ((λ x, x.val) '' X) ∩ {e}   :=
by {unfold from_matroid_on_subtype groundset emb_mat.groundset, simp}

end matroid_in

section minor

/-- minor relation between two matroid_in U-/
def is_minor (N M : matroid_in U) : Prop :=
  (N.groundset ⊆ M.groundset) ∧
  ∃ C ⊆ M.groundset \ N.groundset, (∀ X ⊆ N.groundset, N.r X = M.r (X ∪ C) - M.r C)

/-- minor relation between a matroid_in U and a matroid U -/
def is_minor_of (N : matroid_in U) (M : matroid U) :=
  is_minor N M

/-- N is isomorphic to a minor of M -/
def is_emb_minor (N : matroid U₀) (M : matroid U) :=
  ∃ emb : U₀ ↪ U, is_minor_of ⟦(⟨N,emb⟩:emb_mat U)⟧ M

lemma minor_trans: transitive (λ (M₁ M₂ : matroid_in U), is_minor M₁ M₂) :=
begin
  rintros M₁ M₂ M₃ ⟨h1,⟨C₁,hC₁,h1'⟩⟩ ⟨h2,⟨C₂,hC₂,h2'⟩⟩,
  refine ⟨subset.trans h1 h2,⟨C₁ ∪ C₂,⟨_,λ X hX, _⟩⟩⟩,
  ----
  { convert set.union_subset_union hC₁ hC₂, ext,
    simp only [ftype.diff_eq, set.mem_inter_eq, set.mem_union_eq, set.mem_compl_eq],
    tauto, },
  -- set_solver should work for the goal above, but it is glacial
  have hC₁M₂: C₁ ⊆ M₂.groundset := by
  { intros x hx, simp only [ftype.diff_eq, set.subset_inter_iff] at hC₁, tauto,},
  rw [h1' X hX, h2' (X ∪ C₁) _, h2' C₁ hC₁M₂, ←union_assoc],  ring,
  exact union_of_subsets (subset.trans hX h1) hC₁M₂,
end

 def contract_to_matroid (M : matroid_in U) (C : set U) : matroid ⟨(M.groundset \ C : set U)⟩ :=
let mtype : ftype := ⟨(M.groundset \ C : set U)⟩,
φ : mtype → U := λ x, x.val  in
{ r := λ X, M.r (φ '' X ∪ C) - M.r C,
  R0 :=
  begin
    intro X, dsimp only,
    repeat {rw matroid_in.as_matroid_r_eq},
    simp only [sub_nonneg],
    apply M.as_matroid.R2,
    unfold subset_equiv,
    simp, tauto,
  end,
  R1 :=
  begin
    sorry,
  end,
  R2 := sorry,
  R3 := sorry }

def contract_to_matroid_in (M : matroid_in U) (C : set U) : matroid_in U :=
  matroid_in_from_matroid_on_subtype (contract_to_matroid M C)

def delete_to_matroid (M: matroid_in U) (D : set U) : matroid ⟨(M.groundset \ D : set U)⟩  :=
let mtype : ftype := ⟨(M.groundset \ D : set U)⟩,
φ : mtype → U := λ x, x.val  in
{ r := λ X, M.r (φ '' X),
  R0 := sorry,
  R1 :=
  begin
    sorry,
  end,
  R2 := sorry,
  R3 := sorry }

def delete_to_matroid_in (M : matroid_in U) (D : set U) : matroid_in U :=
  matroid_in_from_matroid_on_subtype (delete_to_matroid M D)

lemma foo (M : matroid_in U){C D : set U} (hi : C ∩ D = ∅) (hu : C ∪ D ⊆ M.groundset) :
  delete_to_matroid_in (contract_to_matroid_in M C) D =  contract_to_matroid_in (delete_to_matroid_in M D) C :=
begin
  apply matroid_in.matroid_in_ext,
  unfold delete_to_matroid_in contract_to_matroid_in, repeat {rw groundset_correct}, set_solver,
  --simp, sorry,
end

/-- returns the contraction of C in M as a minor on a subtype-/
def contract_to_emb (M : matroid_in U) (C : set M.ground) : emb_mat U :=
{
  U₀ := ⟨(Cᶜ : set M.ground)⟩,
  mat := sorry,
  emb := (function.embedding.subtype (λ x, x ∈ Cᶜ)).trans M.embed,
}

end minor

/- the rank function given by N when applied to a subset of the embedded ground set of N.  -/

--def is_minor (N : emb_mat U) (M : matroid U) :=
  --∃ C, C ∩ N.ground = ∅ ∧ ∀ X : set U₀, N.mat.r

--def is_minor {U : ftype} (N : emb_mat U) (M : matroid U) :=
--  ∃ C : set U, C ∩ N.ground = ∅ ∧ ∀

/-structure emb_minor' (M : matroid U) :=
  {U₀ : ftype}
  (mat : matroid U₀)
  (emb : U₀ ↪ U)
  (C : set U)
  (C_disj : C ∩ set.range emb = ∅)
  (minor_rank : mat.r = λ X, M.r (emb '' X ∪ C) - M.r C)-/

/-

/- the ground set of an emb_minor, expressed as a set of elements of M -/
def ground (N : emb_minor M) : set U := set.range N.emb

--def C (N : emb_minor M) : set U := classical.some N.minor_rank

def D (N : emb_minor M) : set U := (N.ground ∪ N.C)ᶜ

lemma def_ground (N : emb_minor M) : N.ground = set.range N.emb  := rfl

lemma C_ground_inter_empty (N : emb_minor M) :
  N.C ∩ N.ground = ∅ :=
by {rw ground, from N.C_disj,}

lemma D_ground_inter_empty (N : emb_minor M) :
  N.D ∩ N.ground = ∅ :=
by {rw [D], have := C_ground_inter_empty N, set_solver,}

lemma C_D_inter_empty (N : emb_minor M) :
  N.C ∩ N.D = ∅ :=
by {rw D, have := C_ground_inter_empty N, set_solver,}

lemma C_union_D_eq_ground_compl (N : emb_minor M) :
  (N.C ∪ N.D) = N.groundᶜ :=
by {rw [D], have := N.C_ground_inter_empty, set_solver,}

lemma emb_minor_r (N : emb_minor M) (X : set N.U₀) :
  N.mat.r X = M.r (N.emb '' X ∪ N.C) - M.r N.C :=
by rw N.minor_rank

/- the rank function given by N when applied to a subset of the embedded ground set of N.  -/
def pullback_r (N : emb_minor M) : set (N.ground) → ℤ :=
  λ X, N.mat.r ((N.emb.subtype_inv_inj (rfl : N.ground = set.range N.emb))'' X)

/- two embedded minors of M are strongly isomorphic if the associated matroids are related
by an isomorphism that commutes with the respective embeddings into M. -/
def strongly_iso (N₁ N₂ : emb_minor M) : Prop :=
  (∃ (φ : isom (N₁.mat) (N₂.mat)), ∀ x, N₁.emb x = N₂.emb (φ x))

/- existence of a strong isomorphism is an equivalence relation on embedded minors of M.
    Equivalence classes of this relation correspond to actual 'labelled' minors of M    -/
lemma strong_iso_equiv :
  equivalence (λ (N₁ N₂ : emb_minor M), strongly_iso N₁ N₂) :=
begin
  refine ⟨λ N, _, λ N₁ N₂ hab, _, λ N₁ N₂ N₃ hab hbc, _⟩,
    {refine ⟨⟨equiv.refl _,_⟩,λ X, _⟩,
      {simp [equiv.img], },
      {apply congr_arg, unfold_coes, simp} },
    {cases hab with φ, refine ⟨inv φ, λ X, _⟩, rw [hab_h ((inv φ) X), inv], unfold_coes, simp},
  cases hab with i₁ h₁, cases hbc with i₂ h₂,
  from ⟨compose i₁ i₂, λ X, by {unfold_coes at *, simp [h₁,h₂,congr_arg, compose]}⟩,
end

/- the ground set is an invariant of equivalence classes under strong isomorphism -/
lemma strong_iso_same_groundset (N N' : emb_minor M) :
  strongly_iso N N' → N.ground = N'.ground  :=
begin
  rintros ⟨h₁,h₂⟩, ext,
  simp only [ground, set.mem_range],
  simp_rw h₂,
  refine ⟨λ h, _, λ h, _⟩,
    {cases h with y hy, from ⟨_, hy⟩},
  cases h with y hy, use h₁.bij.inv_fun y, unfold_coes, simp [hy],
end

instance strong_iso_setoid : setoid (emb_minor M) := ⟨strongly_iso, strong_iso_equiv⟩

end emb_minor

--variables {M : matroid U} [setoid (emb_minor_of M)]
def minor (M : matroid U) := quot (λ (N N' : emb_minor M), N.strongly_iso N')

namespace minor

def emb_to_minor (M : matroid U) := @quotient.mk (emb_minor M) _

/- returns the ground set of a minor of M (as a subset of the ftype for M) -/
def ground {M : matroid U} : minor M → set U := quotient.lift
  (λ (N : emb_minor M), N.ground )
  (λ N N' hNN', emb_minor.strong_iso_same_groundset N N' hNN' )

end minor

-/


/-
CS 2120 HOMEWORK #3
OUT: SUN, SEP 25
DUE: MON, OCT 3

PURPOSE: The purpose of this homework is to help you understand
the material covered up to now on first- and higher-order predicate
logic. There are four questions. Each samples your understanding of
multiple concepts. You might have to put different ideas from our
work together to fully answer the questions. Give yourself time to
think about this material.

INSTRUCTIONS: Read and follow the instructions for each question,
below. Edit all of your answers into this file. That's what you'll
turn in.

COLLABORATION: You may communicate with each other in general terms
about the material we've covered but you are NOT to give or receive
specific answers, or hints strong enough to essentially give away any
answers, on this homework. Please, do yourselves and your colleagues
a favor and don't tell or take answers. This homework is a key check
on, via preparation for, an upcoming midterm exam.

NEED HELP: Please don't post answers or partial answers on Piazza or
any other forum that would substantially give away any part of the
answer to any of these questions. That said, freely post any questions
you might have, and feel free to offer general answers to questions
from others, on Piazza. TAs answer at least several times a day.
Attend office hours: Wednesday and Sunday night 7-10. Talk to Sullivan.
If you feel deeply lost, email Prof. Sullivan ASAP to for help on how
best to proceed.
-/

/- #1: Logic to English

Read through the new material in 09_20_22_inference_rules.lean, which
starts on line 264. After reviewing our all balls blue example, it then
presents an English-language rendition of our "demonstration" that if
all balls are blue and if b1 and b2 are balls then b1 is blue and b2
is blue. Compare the English language proof with the formal version,
paying attention to how we named and specified the proof that all balls
are blue.

Continue reading through our formalized version of the story that
everyone is mortal and so is Socrates so Socrates is mortal. Now
write an English-language version of the proof, using the model from
the earlier case of "all balls blue." Don't just do it mindlessly:
really think about what you're saying with each word in your proof.
See how the English presents the "story" of the formal proof in more
natural, human, terms.

ANSWER HERE:

Here's the formal proof:
-/

variable Person : Type
variable Socrates : Person
variable isMortal : Person → Prop
variable everyoneIsMortal : ∀ (p : Person), isMortal p
#check (everyoneIsMortal Socrates)   -- ∀ elimination!

/-
Suppose that Socrates is a person and that isMortal is
a predicate taking a person, p, as an argument and
yielding a proposition, (Mortal p), that we interpret
as meaning that P is mortal. Next assume that everyone
is mortal. Our goal is to prove that Socrates is mortal.
But this follows simplying by applying the universal
generalization, that everyone is mortal, to the specific
person, Socrates, to conclude that Socrates is mortal.

KS: Review arrow and ∀ elimination.
-/

-- ∀ elimination example
example :
  ∀
    (P : Type)
    (S : P → Prop)
    (ug : ∀ (p : P), S p)
    (p : P),
  S p :=
begin
assume P S ug p,  -- assume we're given arguments
exact (ug p),     -- universal elimination proves (S p)
end

-- → elimination example
example :
  ∀
    (P Q : Prop)
    (i : P → Q)
    (p : P),
  Q :=
begin
  assume P Q i p, -- assume we're given arguments
  exact (i p),    -- arrow elimination proves Q
end

/- #2: English to Logic
Formally model this natural-language "logic story" in Lean, using
the material we covered in the lecture notes as a model. Here's the
story.

If one person likes a second, and the second likes a third,
then the first is jealous of the third. Hint: model "likes" and
"isJealousOf" as two two-place predicates.

Now suppose Ed, Hannah, and Mel are people, and that Ed likes
Hannah, and Hannah likes Mel. Write, and use #check to check, an
expression that proves that Ed is jealous of Mel. Uncomment the
following block of expressions then fill in blanks to complete
this task.
-/

-- variable Person : Type                      -- already defined
variable Likes : Person → Person → Prop        -- a predicate with two Person arguments
variable Jealous : Person → Person → Prop      -- same thing here
variable Triangle :                            -- note definition extends to next line
  ∀ (p1 p2 p3 : Person), Likes p1 p2 → Likes p2 p3 → Jealous p1 p3
variables ed hannah mel : Person
variable likes_ed_hannah : Likes ed hannah
variable likes_hannah_mel : Likes hannah mel
-- Finally write and use #check to check an expression that proves that ed is
-- jealous of mel.
-- TO ANSWER WRITE YOUR EXPRESSION IN PLACE OF THE _ THAT COMES NEXT.

#check Triangle             -- we'll work out the rest in class review

/- #3: Proofing a propositions involving ∀ and ∨

Write an English-language  proof of the following proposition, using
the methods of inference we've covered. ∀ (P Q : Prop), P ∧ Q → Q ∨ P.
Do read that proposition carefully, please.

PROOF: LET P AND Q BE ARBITRARY BUT SPECIFIC PROPOSITIONS. TO PROVE
P ∧ Q → Q ∨ P, ASSUME P ∧ Q AS A HYPOTHESIS. BY AND ELIMINATION WE
DEDUCE P AND Q. WE NOW PROVE Q ∨ P BY OR INTRODUCTION ON EITHER SIDE.
Note that there are two ways to prove the result! We treat any proof
as equally as good as any other.
-/

/-
Express the following proposition formally. Introduce whatever types, values,
predicates, etc., you need as in the several examples in the classwork. If you
have already defined a term above, don't repeat it here. Here's the claim you
are to formalize: Everyone knows someone who knows someone who knows everyone.
-/

-- variable Person : Type                 -- defined above
variable Knows : Person → Person → Prop
def foo : Prop :=
    ∀ (P : Person),
      (∃ (Q : Person),
        (Knows P Q ∧
          ∃ (R : Person),
            (Knows Q R ∧
              (∀ (T : Person),
                Knows R T
              )
            )
        )
      )


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Asta H. From, Jannis Limperg
-/

import Aesop

set_option aesop.check.all true

attribute [-simp] List.all_cons List.all_nil List.all_eq_true

theorem all_cons (P : α → Bool) (x : α) (xs : List α) (h : (x :: xs).all P)
  : P x ∧ xs.all P := by
  aesop


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Jeremy Avigad, Simon Hudon

! This file was ported from Lean 3 source module data.pfun
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Part
import Mathlib.Data.Rel

/-!
# Partial functions

This file defines partial functions. Partial functions are like functions, except they can also be
"undefined" on some inputs. We define them as functions `α → Part β`.

## Definitions

* `PFun α β`: Type of partial functions from `α` to `β`. Defined as `α → Part β` and denoted
  `α →. β`.
* `PFun.Dom`: Domain of a partial function. Set of values on which it is defined. Not to be confused
  with the domain of a function `α → β`, which is a type (`α` presently).
* `PFun.fn`: Evaluation of a partial function. Takes in an element and a proof it belongs to the
  partial function's `Dom`.
* `PFun.asSubtype`: Returns a partial function as a function from its `Dom`.
* `PFun.toSubtype`: Restricts the codomain of a function to a subtype.
* `PFun.evalOpt`: Returns a partial function with a decidable `Dom` as a function `a → Option β`.
* `PFun.lift`: Turns a function into a partial function.
* `PFun.id`: The identity as a partial function.
* `PFun.comp`: Composition of partial functions.
* `PFun.restrict`: Restriction of a partial function to a smaller `Dom`.
* `PFun.res`: Turns a function into a partial function with a prescribed domain.
* `PFun.fix` : First return map of a partial function `f : α →. β ⊕ α`.
* `PFun.fix_induction`: A recursion principle for `PFun.fix`.

### Partial functions as relations

Partial functions can be considered as relations, so we specialize some `Rel` definitions to `PFun`:
* `PFun.image`: Image of a set under a partial function.
* `PFun.ran`: Range of a partial function.
* `PFun.preimage`: Preimage of a set under a partial function.
* `PFun.core`: Core of a set under a partial function.
* `PFun.graph`: Graph of a partial function `a →. β`as a `Set (α × β)`.
* `PFun.graph'`: Graph of a partial function `a →. β`as a `Rel α β`.

### `PFun α` as a monad

Monad operations:
* `PFun.pure`: The monad `pure` function, the constant `x` function.
* `PFun.bind`: The monad `bind` function, pointwise `Part.bind`
* `PFun.map`: The monad `map` function, pointwise `Part.map`.
-/

open Function

/-- `PFun α β`, or `α →. β`, is the type of partial functions from
  `α` to `β`. It is defined as `α → part β`. -/
def PFun (α β : Type _) :=
  α → Part β
#align pfun PFun

-- mathport name: «expr →. »
/-- `α  →. β` is notation for the type `PFun α β` of partial functions from `α` to `β`.  -/
infixr:25 " →. " => PFun

namespace PFun

variable {α β γ δ ε ι : Type _}

instance : Inhabited (α →. β) :=
  ⟨fun _ => Part.none⟩

/-- The domain of a partial function -/
def Dom (f : α →. β) : Set α :=
  { a | (f a).Dom }
#align pfun.dom PFun.Dom

@[simp]
theorem mem_dom (f : α →. β) (x : α) : x ∈ Dom f ↔ ∃ y, y ∈ f x := by simp [Dom, Part.dom_iff_mem]
#align pfun.mem_dom PFun.mem_dom

@[simp]
theorem dom_mk (p : α → Prop) (f : ∀ a, p a → β) : (PFun.Dom fun x => ⟨p x, f x⟩) = { x | p x } :=
  rfl
#align pfun.dom_mk PFun.dom_mk

theorem dom_eq (f : α →. β) : Dom f = { x | ∃ y, y ∈ f x } :=
  Set.ext (mem_dom f)
#align pfun.dom_eq PFun.dom_eq

/-- Evaluate a partial function -/
def fn (f : α →. β) (a : α) : Dom f a → β :=
  (f a).get
#align pfun.fn PFun.fn

@[simp]
theorem fn_apply (f : α →. β) (a : α) : f.fn a = (f a).get :=
  rfl
#align pfun.fn_apply PFun.fn_apply

/-- Evaluate a partial function to return an `Option` -/
def evalOpt (f : α →. β) [D : DecidablePred (· ∈ Dom f)] (x : α) : Option β :=
  @Part.toOption _ _ (D x)
#align pfun.eval_opt PFun.evalOpt

/-- Partial function extensionality -/
theorem ext' {f g : α →. β} (H1 : ∀ a, a ∈ Dom f ↔ a ∈ Dom g) (H2 : ∀ a p q, f.fn a p = g.fn a q) :
    f = g :=
  funext fun a => Part.ext' (H1 a) (H2 a)
#align pfun.ext' PFun.ext'

theorem ext {f g : α →. β} (H : ∀ a b, b ∈ f a ↔ b ∈ g a) : f = g :=
  funext fun a => Part.ext (H a)
#align pfun.ext PFun.ext

/-- Turns a partial function into a function out of its domain. -/
def asSubtype (f : α →. β) (s : f.Dom) : β :=
  f.fn s s.2
#align pfun.as_subtype PFun.asSubtype

/-- The type of partial functions `α →. β` is equivalent to
the type of pairs `(p : α → Prop, f : subtype p → β)`. -/
def equivSubtype : (α →. β) ≃ Σp : α → Prop, Subtype p → β :=
  ⟨fun f => ⟨fun a => (f a).Dom, asSubtype f⟩, fun f x => ⟨f.1 x, fun h => f.2 ⟨x, h⟩⟩, fun f =>
    funext fun a => Part.eta _, fun ⟨p, f⟩ => by dsimp ; congr ⟩
#align pfun.equiv_subtype PFun.equivSubtype

theorem asSubtype_eq_of_mem {f : α →. β} {x : α} {y : β} (fxy : y ∈ f x) (domx : x ∈ f.Dom) :
    f.asSubtype ⟨x, domx⟩ = y :=
  Part.mem_unique (Part.get_mem _) fxy
#align pfun.as_subtype_eq_of_mem PFun.asSubtype_eq_of_mem

/-- Turn a total function into a partial function. -/
protected def lift (f : α → β) : α →. β := fun a => Part.some (f a)
#align pfun.lift PFun.lift

instance : Coe (α → β) (α →. β) :=
  ⟨PFun.lift⟩

@[simp]
theorem coe_val (f : α → β) (a : α) : (f : α →. β) a = Part.some (f a) :=
  rfl
#align pfun.coe_val PFun.coe_val

@[simp]
theorem dom_coe (f : α → β) : (f : α →. β).Dom = Set.univ :=
  rfl
#align pfun.dom_coe PFun.dom_coe

theorem lift_injective : Injective (PFun.lift : (α → β) → α →. β) := fun _ _ h =>
  funext fun a => Part.some_injective <| congr_fun h a
#align pfun.coe_injective PFun.lift_injective

/-- Graph of a partial function `f` as the set of pairs `(x, f x)` where `x` is in the domain of
`f`. -/
def graph (f : α →. β) : Set (α × β) :=
  { p | p.2 ∈ f p.1 }
#align pfun.graph PFun.graph

/-- Graph of a partial function as a relation. `x` and `y` are related iff `f x` is defined and
"equals" `y`. -/
def graph' (f : α →. β) : Rel α β := fun x y => y ∈ f x
#align pfun.graph' PFun.graph'

/-- The range of a partial function is the set of values
  `f x` where `x` is in the domain of `f`. -/
def ran (f : α →. β) : Set β :=
  { b | ∃ a, b ∈ f a }
#align pfun.ran PFun.ran

/-- Restrict a partial function to a smaller domain. -/
def restrict (f : α →. β) {p : Set α} (H : p ⊆ f.Dom) : α →. β := fun x =>
  (f x).restrict (x ∈ p) (@H x)
#align pfun.restrict PFun.restrict

@[simp]
theorem mem_restrict {f : α →. β} {s : Set α} (h : s ⊆ f.Dom) (a : α) (b : β) :
    b ∈ f.restrict h a ↔ a ∈ s ∧ b ∈ f a := by simp [restrict]
#align pfun.mem_restrict PFun.mem_restrict

/-- Turns a function into a partial function with a prescribed domain. -/
def res (f : α → β) (s : Set α) : α →. β :=
  (PFun.lift f).restrict s.subset_univ
#align pfun.res PFun.res

theorem mem_res (f : α → β) (s : Set α) (a : α) (b : β) : b ∈ res f s a ↔ a ∈ s ∧ f a = b := by
  simp [res, @eq_comm _ b]
#align pfun.mem_res PFun.mem_res

theorem res_univ (f : α → β) : PFun.res f Set.univ = f :=
  rfl
#align pfun.res_univ PFun.res_univ

theorem dom_iff_graph (f : α →. β) (x : α) : x ∈ f.Dom ↔ ∃ y, (x, y) ∈ f.graph :=
  Part.dom_iff_mem
#align pfun.dom_iff_graph PFun.dom_iff_graph

theorem lift_graph {f : α → β} {a b} : (a, b) ∈ (f : α →. β).graph ↔ f a = b :=
  show (∃ _ : True, f a = b) ↔ f a = b by simp
#align pfun.lift_graph PFun.lift_graph

/-- The monad `pure` function, the total constant `x` function -/
protected def pure (x : β) : α →. β := fun _ => Part.some x
#align pfun.pure PFun.pure

/-- The monad `bind` function, pointwise `part.bind` -/
def bind (f : α →. β) (g : β → α →. γ) : α →. γ := fun a => (f a).bind fun b => g b a
#align pfun.bind PFun.bind

@[simp]
theorem bind_apply (f : α →. β) (g : β → α →. γ) (a : α) : f.bind g a = (f a).bind fun b => g b a :=
  rfl
#align pfun.bind_apply PFun.bind_apply

/-- The monad `map` function, pointwise `part.map` -/
def map (f : β → γ) (g : α →. β) : α →. γ := fun a => (g a).map f
#align pfun.map PFun.map

instance : Monad (PFun α) where
  pure := @PFun.pure _
  bind := @PFun.bind _
  map := @PFun.map _

instance : LawfulMonad (PFun α) := LawfulMonad.mk'
  (bind_pure_comp := fun f x => funext fun a => Part.bind_some_eq_map _ _)
  (id_map := fun f => by funext a ; dsimp [Functor.map, PFun.map] ; cases f a; rfl)
  (pure_bind := fun x f => funext fun a => Part.bind_some _ (f x))
  (bind_assoc := fun f g k => funext fun a => (f a).bind_assoc (fun b => g b a) fun b => k b a)

theorem pure_defined (p : Set α) (x : β) : p ⊆ (@PFun.pure α _ x).Dom :=
  p.subset_univ
#align pfun.pure_defined PFun.pure_defined

theorem bind_defined {α β γ} (p : Set α) {f : α →. β} {g : β → α →. γ} (H1 : p ⊆ f.Dom)
    (H2 : ∀ x, p ⊆ (g x).Dom) : p ⊆ (f >>= g).Dom := fun a ha =>
  (⟨H1 ha, H2 _ ha⟩ : (f >>= g).Dom a)
#align pfun.bind_defined PFun.bind_defined

/-- First return map. Transforms a partial function `f : α →. β ⊕ α` into the partial function
`α →. β` which sends `a : α` to the first value in `β` it hits by iterating `f`, if such a value
exists. By abusing notation to illustrate, either `f a` is in the `β` part of `β ⊕ α` (in which
case `f.fix a` returns `f a`), or it is undefined (in which case `f.fix a` is undefined as well), or
it is in the `α` part of `β ⊕ α` (in which case we repeat the procedure, so `f.fix a` will return
`f.fix (f a)`). -/
-- Porting note: had to mark `noncomputable`
noncomputable def fix (f : α →. Sum β α) : α →. β := fun a =>
  Part.assert (Acc (fun x y => Sum.inr x ∈ f y) a) $ fun h =>
    @WellFounded.fixF _ (fun x y => Sum.inr x ∈ f y) _
      (fun a IH =>
        Part.assert (f a).Dom $ fun hf =>
          match e : (f a).get hf with
          | Sum.inl b => Part.some b
          | Sum.inr a' => IH a' ⟨hf, e⟩)
      a h
#align pfun.fix PFun.fix

theorem dom_of_mem_fix {f : α →. Sum β α} {a : α} {b : β} (h : b ∈ f.fix a) : (f a).Dom := by
  let ⟨h₁, h₂⟩ := Part.mem_assert_iff.1 h
  rw [WellFounded.fixFEq] at h₂ ; exact h₂.fst.fst
#align pfun.dom_of_mem_fix PFun.dom_of_mem_fix

theorem mem_fix_iff {f : α →. Sum β α} {a : α} {b : β} :
    b ∈ f.fix a ↔ Sum.inl b ∈ f a ∨ ∃ a', Sum.inr a' ∈ f a ∧ b ∈ f.fix a' :=
  ⟨fun h => by
    let ⟨h₁, h₂⟩ := Part.mem_assert_iff.1 h
    rw [WellFounded.fixFEq] at h₂
    simp at h₂
    cases' h₂ with h₂ h₃
    split at h₃ <;> simp at h₃
    next e => subst b; refine' Or.inl ⟨h₂, e⟩
    next e => exact Or.inr ⟨_, ⟨_, e⟩, Part.mem_assert _ h₃⟩,
   fun h => by
    simp [fix]
    rcases h with (⟨h₁, h₂⟩ | ⟨a', h, h₃⟩)
    · refine' ⟨⟨_, fun y h' => _⟩, _⟩
      · injection Part.mem_unique ⟨h₁, h₂⟩ h'
      · rw [WellFounded.fixFEq]
        -- Porting note: used to be simp [h₁, h₂]
        apply Part.mem_assert h₁
        split
        next e =>
          injection h₂.symm.trans e with h; simp [h]
        next e =>
          injection h₂.symm.trans e
    · simp [fix] at h₃
      cases' h₃ with h₃ h₄
      refine' ⟨⟨_, fun y h' => _⟩, _⟩
      · injection Part.mem_unique h h' with e
        exact e ▸ h₃
      · cases' h with h₁ h₂
        rw [WellFounded.fixFEq]
        -- Porting note: used to be simp [h₁, h₂, h₄]
        apply Part.mem_assert h₁
        split
        next e =>
          injection h₂.symm.trans e
        next e =>
          injection h₂.symm.trans e; subst a'; exact h₄⟩
#align pfun.mem_fix_iff PFun.mem_fix_iff

/-- If advancing one step from `a` leads to `b : β`, then `f.fix a = b` -/
theorem fix_stop {f : α →. Sum β α} {b : β} {a : α} (hb : Sum.inl b ∈ f a) : b ∈ f.fix a := by
  rw [PFun.mem_fix_iff]
  exact Or.inl hb
#align pfun.fix_stop PFun.fix_stop

/-- If advancing one step from `a` on `f` leads to `a' : α`, then `f.fix a = f.fix a'` -/
theorem fix_fwd_eq {f : α →. Sum β α} {a a' : α} (ha' : Sum.inr a' ∈ f a) : f.fix a = f.fix a' := by
  ext b; constructor
  · intro h
    obtain h' | ⟨a, h', e'⟩ := mem_fix_iff.1 h <;> cases Part.mem_unique ha' h'
    exact e'
  · intro h
    rw [PFun.mem_fix_iff]
    exact Or.inr ⟨a', ha', h⟩
#align pfun.fix_fwd_eq PFun.fix_fwd_eq

theorem fix_fwd {f : α →. Sum β α} {b : β} {a a' : α} (hb : b ∈ f.fix a) (ha' : Sum.inr a' ∈ f a) :
    b ∈ f.fix a' := by rwa [← fix_fwd_eq ha']
#align pfun.fix_fwd PFun.fix_fwd

/-- A recursion principle for `PFun.fix`. -/
-- Porting note: had to add `noncomputable`
@[elab_as_elim]
noncomputable def fixInduction {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α} (h : b ∈ f.fix a)
    (H : ∀ a', b ∈ f.fix a' → (∀ a'', Sum.inr a'' ∈ f a' → C a'') → C a') : C a := by
  have h₂ := (Part.mem_assert_iff.1 h).snd;
  -- Porting note: revert/intro trick required to address `generalize_proofs` bug
  revert h₂
  generalize_proofs h₁;
  intro h₂; clear h
  induction' h₁ with a ha IH
  have h : b ∈ f.fix a := Part.mem_assert_iff.2 ⟨⟨a, ha⟩, h₂⟩
  exact H a h fun a' fa' => IH a' fa' (Part.mem_assert_iff.1 (fix_fwd h fa')).snd
#align pfun.fix_induction PFun.fixInduction

theorem fixInduction_spec {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α} (h : b ∈ f.fix a)
    (H : ∀ a', b ∈ f.fix a' → (∀ a'', Sum.inr a'' ∈ f a' → C a'') → C a') :
    @fixInduction _ _ C _ _ _ h H = H a h fun a' h' => fixInduction (fix_fwd h h') H := by
  unfold fixInduction
  -- Porting note: `generalize` required to address `generalize_proofs` bug
  generalize (Part.mem_assert_iff.1 h).fst = ha
  induction ha
  rfl
#align pfun.fix_induction_spec PFun.fixInduction_spec

/-- Another induction lemma for `b ∈ f.fix a` which allows one to prove a predicate `P` holds for
`a` given that `f a` inherits `P` from `a` and `P` holds for preimages of `b`.
-/
@[elab_as_elim]
noncomputable def fixInduction' {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α}
    (h : b ∈ f.fix a) (hbase : ∀ a_final : α, Sum.inl b ∈ f a_final → C a_final)
    (hind : ∀ a₀ a₁ : α, b ∈ f.fix a₁ → Sum.inr a₁ ∈ f a₀ → C a₁ → C a₀) : C a := by
  refine' fixInduction h fun a' h ih => _
  rcases e : (f a').get (dom_of_mem_fix h) with b' | a'' <;> replace e : _ ∈ f a' := ⟨_, e⟩
  · apply hbase
    convert e
    exact Part.mem_unique h (fix_stop e)
  · exact hind _ _ (fix_fwd h e) e (ih _ e)
#align pfun.fix_induction' PFun.fixInduction'

theorem fixInduction'_stop {C : α → Sort _} {f : α →. Sum β α} {b : β} {a : α} (h : b ∈ f.fix a)
    (fa : Sum.inl b ∈ f a) (hbase : ∀ a_final : α, Sum.inl b ∈ f a_final → C a_final)
    (hind : ∀ a₀ a₁ : α, b ∈ f.fix a₁ → Sum.inr a₁ ∈ f a₀ → C a₁ → C a₀) :
    @fixInduction' _ _ C _ _ _ h hbase hind = hbase a fa := by
  unfold fixInduction'
  rw [fixInduction_spec]
  -- Porting note: the explicit motive required because `simp` behaves differently
  refine' Eq.rec (motive := fun x e =>
      Sum.casesOn (motive := fun y => (f a).get (dom_of_mem_fix h) = y → C a) x _ _
      (Eq.trans (Part.get_eq_of_mem fa (dom_of_mem_fix h)) e) = hbase a fa) _
    (Part.get_eq_of_mem fa (dom_of_mem_fix h)).symm
  simp
#align pfun.fix_induction'_stop PFun.fixInduction'_stop

theorem fixInduction'_fwd {C : α → Sort _} {f : α →. Sum β α} {b : β} {a a' : α} (h : b ∈ f.fix a)
    (h' : b ∈ f.fix a') (fa : Sum.inr a' ∈ f a)
    (hbase : ∀ a_final : α, Sum.inl b ∈ f a_final → C a_final)
    (hind : ∀ a₀ a₁ : α, b ∈ f.fix a₁ → Sum.inr a₁ ∈ f a₀ → C a₁ → C a₀) :
    @fixInduction' _ _ C _ _ _ h hbase hind = hind a a' h' fa (fixInduction' h' hbase hind) := by
  unfold fixInduction'
  rw [fixInduction_spec]
  -- Porting note: the explicit motive required because `simp` behaves differently
  refine' Eq.rec (motive := fun x e =>
      Sum.casesOn (motive := fun y => (f a).get (dom_of_mem_fix h) = y → C a) x _ _
      (Eq.trans (Part.get_eq_of_mem fa (dom_of_mem_fix h)) e) = _) _
    (Part.get_eq_of_mem fa (dom_of_mem_fix h)).symm
  simp
#align pfun.fix_induction'_fwd PFun.fixInduction'_fwd

variable (f : α →. β)

/-- Image of a set under a partial function. -/
def image (s : Set α) : Set β :=
  f.graph'.image s
#align pfun.image PFun.image

theorem image_def (s : Set α) : f.image s = { y | ∃ x ∈ s, y ∈ f x } :=
  rfl
#align pfun.image_def PFun.image_def

theorem mem_image (y : β) (s : Set α) : y ∈ f.image s ↔ ∃ x ∈ s, y ∈ f x :=
  Iff.rfl
#align pfun.mem_image PFun.mem_image

theorem image_inter (s t : Set α) : f.image (s ∩ t) ⊆ f.image s ∩ f.image t :=
  Rel.image_inter _ s t
#align pfun.image_inter PFun.image_inter

theorem image_union (s t : Set α) : f.image (s ∪ t) = f.image s ∪ f.image t :=
  Rel.image_union _ s t
#align pfun.image_union PFun.image_union

/-- Preimage of a set under a partial function. -/
def preimage (s : Set β) : Set α :=
  Rel.image (fun x y => x ∈ f y) s
#align pfun.preimage PFun.preimage

theorem Preimage_def (s : Set β) : f.preimage s = { x | ∃ y ∈ s, y ∈ f x } :=
  rfl
#align pfun.preimage_def PFun.Preimage_def

@[simp]
theorem mem_preimage (s : Set β) (x : α) : x ∈ f.preimage s ↔ ∃ y ∈ s, y ∈ f x :=
  Iff.rfl
#align pfun.mem_preimage PFun.mem_preimage

theorem preimage_subset_dom (s : Set β) : f.preimage s ⊆ f.Dom := fun _ ⟨y, _, fxy⟩ =>
  Part.dom_iff_mem.mpr ⟨y, fxy⟩
#align pfun.preimage_subset_dom PFun.preimage_subset_dom

theorem preimage_mono {s t : Set β} (h : s ⊆ t) : f.preimage s ⊆ f.preimage t :=
  Rel.preimage_mono _ h
#align pfun.preimage_mono PFun.preimage_mono

theorem preimage_inter (s t : Set β) : f.preimage (s ∩ t) ⊆ f.preimage s ∩ f.preimage t :=
  Rel.preimage_inter _ s t
#align pfun.preimage_inter PFun.preimage_inter

theorem preimage_union (s t : Set β) : f.preimage (s ∪ t) = f.preimage s ∪ f.preimage t :=
  Rel.preimage_union _ s t
#align pfun.preimage_union PFun.preimage_union

theorem preimage_univ : f.preimage Set.univ = f.Dom := by ext ; simp [mem_preimage, mem_dom]
#align pfun.preimage_univ PFun.preimage_univ

theorem coe_preimage (f : α → β) (s : Set β) : (f : α →. β).preimage s = f ⁻¹' s := by ext ; simp
#align pfun.coe_preimage PFun.coe_preimage

/-- Core of a set `s : set β` with respect to a partial function `f : α →. β`. Set of all `a : α`
such that `f a ∈ s`, if `f a` is defined. -/
def core (s : Set β) : Set α :=
  f.graph'.core s
#align pfun.core PFun.core

theorem core_def (s : Set β) : f.core s = { x | ∀ y, y ∈ f x → y ∈ s } :=
  rfl
#align pfun.core_def PFun.core_def

@[simp]
theorem mem_core (x : α) (s : Set β) : x ∈ f.core s ↔ ∀ y, y ∈ f x → y ∈ s :=
  Iff.rfl
#align pfun.mem_core PFun.mem_core

theorem compl_dom_subset_core (s : Set β) : f.Domᶜ ⊆ f.core s := fun x hx y fxy =>
  absurd ((mem_dom f x).mpr ⟨y, fxy⟩) hx
#align pfun.compl_dom_subset_core PFun.compl_dom_subset_core

theorem core_mono {s t : Set β} (h : s ⊆ t) : f.core s ⊆ f.core t :=
  Rel.core_mono _ h
#align pfun.core_mono PFun.core_mono

theorem core_inter (s t : Set β) : f.core (s ∩ t) = f.core s ∩ f.core t :=
  Rel.core_inter _ s t
#align pfun.core_inter PFun.core_inter

theorem mem_core_res (f : α → β) (s : Set α) (t : Set β) (x : α) :
    x ∈ (res f s).core t ↔ x ∈ s → f x ∈ t := by simp [mem_core, mem_res]
#align pfun.mem_core_res PFun.mem_core_res

section

open Classical

theorem core_res (f : α → β) (s : Set α) (t : Set β) : (res f s).core t = sᶜ ∪ f ⁻¹' t := by
  ext x
  rw [mem_core_res]
  by_cases h : x ∈ s <;> simp [h]
#align pfun.core_res PFun.core_res

end

theorem core_restrict (f : α → β) (s : Set β) : (f : α →. β).core s = s.preimage f := by
  ext x ; simp [core_def]
#align pfun.core_restrict PFun.core_restrict

theorem preimage_subset_core (f : α →. β) (s : Set β) : f.preimage s ⊆ f.core s :=
  fun _ ⟨y, ys, fxy⟩ y' fxy' =>
  have : y = y' := Part.mem_unique fxy fxy'
  this ▸ ys
#align pfun.preimage_subset_core PFun.preimage_subset_core

theorem preimage_eq (f : α →. β) (s : Set β) : f.preimage s = f.core s ∩ f.Dom :=
  Set.eq_of_subset_of_subset (Set.subset_inter (f.preimage_subset_core s) (f.preimage_subset_dom s))
    fun x ⟨xcore, xdom⟩ =>
    let y := (f x).get xdom
    have ys : y ∈ s := xcore _ (Part.get_mem _)
    show x ∈ f.preimage s from ⟨(f x).get xdom, ys, Part.get_mem _⟩
#align pfun.preimage_eq PFun.preimage_eq

theorem core_eq (f : α →. β) (s : Set β) : f.core s = f.preimage s ∪ f.Domᶜ := by
  rw [preimage_eq, Set.union_distrib_right, Set.union_comm (Dom f), Set.compl_union_self,
    Set.inter_univ, Set.union_eq_self_of_subset_right (f.compl_dom_subset_core s)]
#align pfun.core_eq PFun.core_eq

theorem preimage_as_subtype (f : α →. β) (s : Set β) :
    f.asSubtype ⁻¹' s = Subtype.val ⁻¹' f.preimage s := by
  ext x
  simp only [Set.mem_preimage, Set.mem_setOf_eq, PFun.asSubtype, PFun.mem_preimage]
  show f.fn x.val _ ∈ s ↔ ∃ y ∈ s, y ∈ f x.val
  exact
    Iff.intro (fun h => ⟨_, h, Part.get_mem _⟩) fun ⟨y, ys, fxy⟩ =>
      have : f.fn x.val x.property ∈ f x.val := Part.get_mem _
      Part.mem_unique fxy this ▸ ys
#align pfun.preimage_as_subtype PFun.preimage_as_subtype

/-- Turns a function into a partial function to a subtype. -/
def toSubtype (p : β → Prop) (f : α → β) : α →. Subtype p := fun a => ⟨p (f a), Subtype.mk _⟩
#align pfun.to_subtype PFun.toSubtype

@[simp]
theorem dom_to_subtype (p : β → Prop) (f : α → β) : (toSubtype p f).Dom = { a | p (f a) } :=
  rfl
#align pfun.dom_to_subtype PFun.dom_to_subtype

@[simp]
theorem to_subtype_apply (p : β → Prop) (f : α → β) (a : α) :
    toSubtype p f a = ⟨p (f a), Subtype.mk _⟩ :=
  rfl
#align pfun.to_subtype_apply PFun.to_subtype_apply

theorem dom_to_subtype_apply_iff {p : β → Prop} {f : α → β} {a : α} :
    (toSubtype p f a).Dom ↔ p (f a) :=
  Iff.rfl
#align pfun.dom_to_subtype_apply_iff PFun.dom_to_subtype_apply_iff

theorem mem_to_subtype_iff {p : β → Prop} {f : α → β} {a : α} {b : Subtype p} :
    b ∈ toSubtype p f a ↔ ↑b = f a := by
  rw [to_subtype_apply, Part.mem_mk_iff, exists_subtype_mk_eq_iff, eq_comm]
#align pfun.mem_to_subtype_iff PFun.mem_to_subtype_iff

/-- The identity as a partial function -/
protected def id (α : Type _) : α →. α :=
  Part.some
#align pfun.id PFun.id

@[simp]
theorem coe_id (α : Type _) : ((id : α → α) : α →. α) = PFun.id α :=
  rfl
#align pfun.coe_id PFun.coe_id

@[simp]
theorem id_apply (a : α) : PFun.id α a = Part.some a :=
  rfl
#align pfun.id_apply PFun.id_apply

/-- Composition of partial functions as a partial function. -/
def comp (f : β →. γ) (g : α →. β) : α →. γ := fun a => (g a).bind f
#align pfun.comp PFun.comp

@[simp]
theorem comp_apply (f : β →. γ) (g : α →. β) (a : α) : f.comp g a = (g a).bind f :=
  rfl
#align pfun.comp_apply PFun.comp_apply

@[simp]
theorem id_comp (f : α →. β) : (PFun.id β).comp f = f :=
  ext fun _ _ => by simp
#align pfun.id_comp PFun.id_comp

@[simp]
theorem comp_id (f : α →. β) : f.comp (PFun.id α) = f :=
  ext fun _ _ => by simp
#align pfun.comp_id PFun.comp_id

@[simp]
theorem dom_comp (f : β →. γ) (g : α →. β) : (f.comp g).Dom = g.preimage f.Dom := by
  ext
  simp_rw [mem_preimage, mem_dom, comp_apply, Part.mem_bind_iff, exists_prop, ← exists_and_right]
  rw [exists_comm]
  simp_rw [and_comm]
#align pfun.dom_comp PFun.dom_comp

@[simp]
theorem preimage_comp (f : β →. γ) (g : α →. β) (s : Set γ) :
    (f.comp g).preimage s = g.preimage (f.preimage s) := by
  ext
  simp_rw [mem_preimage, comp_apply, Part.mem_bind_iff, exists_prop, ← exists_and_right, ←
    exists_and_left]
  rw [exists_comm]
  simp_rw [and_assoc, and_comm]
#align pfun.preimage_comp PFun.preimage_comp

@[simp]
theorem Part.bind_comp (f : β →. γ) (g : α →. β) (a : Part α) :
    a.bind (f.comp g) = (a.bind g).bind f := by
  ext c
  simp_rw [Part.mem_bind_iff, comp_apply, Part.mem_bind_iff, exists_prop, ← exists_and_right, ←
    exists_and_left]
  rw [exists_comm]
  simp_rw [and_assoc]
#align part.bind_comp PFun.Part.bind_comp

@[simp]
theorem comp_assoc (f : γ →. δ) (g : β →. γ) (h : α →. β) : (f.comp g).comp h = f.comp (g.comp h) :=
  ext fun _ _ => by simp only [comp_apply, Part.bind_comp]
#align pfun.comp_assoc PFun.comp_assoc

-- This can't be `simp`
theorem coe_comp (g : β → γ) (f : α → β) : ((g ∘ f : α → γ) : α →. γ) = (g : β →. γ).comp f :=
  ext fun _ _ => by simp only [coe_val, comp_apply, Function.comp, Part.bind_some]
#align pfun.coe_comp PFun.coe_comp

/-- Product of partial functions. -/
def prodLift (f : α →. β) (g : α →. γ) : α →. β × γ := fun x =>
  ⟨(f x).Dom ∧ (g x).Dom, fun h => ((f x).get h.1, (g x).get h.2)⟩
#align pfun.prod_lift PFun.prodLift

@[simp]
theorem dom_prodLift (f : α →. β) (g : α →. γ) :
    (f.prodLift g).Dom = { x | (f x).Dom ∧ (g x).Dom } :=
  rfl
#align pfun.dom_prod_lift PFun.dom_prodLift

theorem get_prodLift (f : α →. β) (g : α →. γ) (x : α) (h) :
    (f.prodLift g x).get h = ((f x).get h.1, (g x).get h.2) :=
  rfl
#align pfun.get_prod_lift PFun.get_prodLift

@[simp]
theorem prodLift_apply (f : α →. β) (g : α →. γ) (x : α) :
    f.prodLift g x = ⟨(f x).Dom ∧ (g x).Dom, fun h => ((f x).get h.1, (g x).get h.2)⟩ :=
  rfl
#align pfun.prod_lift_apply PFun.prodLift_apply

theorem mem_prodLift {f : α →. β} {g : α →. γ} {x : α} {y : β × γ} :
    y ∈ f.prodLift g x ↔ y.1 ∈ f x ∧ y.2 ∈ g x := by
  trans ∃ hp hq, (f x).get hp = y.1 ∧ (g x).get hq = y.2
  · simp only [prodLift, Part.mem_mk_iff, And.exists, Prod.ext_iff]
  -- Porting note: was just `[exists_and_left, exists_and_right]`
  · simp only [exists_and_left, exists_and_right, (· ∈ ·), Part.Mem]
#align pfun.mem_prod_lift PFun.mem_prodLift

/-- Product of partial functions. -/
def prodMap (f : α →. γ) (g : β →. δ) : α × β →. γ × δ := fun x =>
  ⟨(f x.1).Dom ∧ (g x.2).Dom, fun h => ((f x.1).get h.1, (g x.2).get h.2)⟩
#align pfun.prod_map PFun.prodMap

@[simp]
theorem dom_prodMap (f : α →. γ) (g : β →. δ) :
    (f.prodMap g).Dom = { x | (f x.1).Dom ∧ (g x.2).Dom } :=
  rfl
#align pfun.dom_prod_map PFun.dom_prodMap

theorem get_prodMap (f : α →. γ) (g : β →. δ) (x : α × β) (h) :
    (f.prodMap g x).get h = ((f x.1).get h.1, (g x.2).get h.2) :=
  rfl
#align pfun.get_prod_map PFun.get_prodMap

@[simp]
theorem prodMap_apply (f : α →. γ) (g : β →. δ) (x : α × β) :
    f.prodMap g x = ⟨(f x.1).Dom ∧ (g x.2).Dom, fun h => ((f x.1).get h.1, (g x.2).get h.2)⟩ :=
  rfl
#align pfun.prod_map_apply PFun.prodMap_apply

theorem mem_prodMap {f : α →. γ} {g : β →. δ} {x : α × β} {y : γ × δ} :
    y ∈ f.prodMap g x ↔ y.1 ∈ f x.1 ∧ y.2 ∈ g x.2 := by
  trans ∃ hp hq, (f x.1).get hp = y.1 ∧ (g x.2).get hq = y.2
  · simp only [prodMap, Part.mem_mk_iff, And.exists, Prod.ext_iff]
  · simp only [exists_and_left, exists_and_right, (· ∈ ·), Part.Mem]
#align pfun.mem_prod_map PFun.mem_prodMap

@[simp]
theorem prodLift_fst_comp_snd_comp (f : α →. γ) (g : β →. δ) :
    prodLift (f.comp ((Prod.fst : α × β → α) : α × β →. α))
        (g.comp ((Prod.snd : α × β → β) : α × β →. β)) =
      prodMap f g :=
  ext fun a => by simp
#align pfun.prod_lift_fst_comp_snd_comp PFun.prodLift_fst_comp_snd_comp

@[simp]
theorem prodMap_id_id : (PFun.id α).prodMap (PFun.id β) = PFun.id _ :=
  ext fun _ _ => by simp [eq_comm]
#align pfun.prod_map_id_id PFun.prodMap_id_id

@[simp]
theorem prodMap_comp_comp (f₁ : α →. β) (f₂ : β →. γ) (g₁ : δ →. ε) (g₂ : ε →. ι) :
    (f₂.comp f₁).prodMap (g₂.comp g₁) = (f₂.prodMap g₂).comp (f₁.prodMap g₁) := -- by
  -- Porting note: was `by tidy`, below is a golf'd verson of the `tidy?` proof
  ext $ λ ⟨_, _⟩ ⟨_, _⟩ =>
  ⟨λ ⟨⟨⟨h1l1, h1l2⟩, ⟨h1r1, h1r2⟩⟩, h2⟩ => ⟨⟨⟨h1l1, h1r1⟩, ⟨h1l2, h1r2⟩⟩, h2⟩,
   λ ⟨⟨⟨h1l1, h1r1⟩, ⟨h1l2, h1r2⟩⟩, h2⟩ => ⟨⟨⟨h1l1, h1l2⟩, ⟨h1r1, h1r2⟩⟩, h2⟩⟩
#align pfun.prod_map_comp_comp PFun.prodMap_comp_comp

end PFun


universe u v

--
-- Model of Dijkstra monads, which combine a base monad (usually representing code) with a second
-- monad that is a predicate or prop/proof about the monad behavior.  This monad product is represented by
-- "MonadWithPredicate"
--

structure BaseMonad (α : Type) where
  (output : α)

inductive MonadResultIs {α : Type} : α → Type where
| mk : (mz : BaseMonad α) → MonadResultIs (mz.output)

def MRret {α : Type} (a : α) := MonadResultIs.mk (BaseMonad.mk a)

def MRbind {α : Type} {a b : α} {ma mb : BaseMonad α} : MonadResultIs a → (α → MonadResultIs b) → MonadResultIs b :=
  fun m1 m2 => match m1 with
               | MonadResultIs.mk mz => m2 (mz.output)

def MRrun {α : Type} {z : α} {mz : BaseMonad α} (d : MonadResultIs z) : α :=
  match d with
  | MonadResultIs.mk mz => mz.output

#check MRret 3
#reduce MRrun (MRret 3)
#reduce MRrun (MRbind (MRret 2) (fun _ => MRret 3))
-- here we try to run the monad and enforce a return value (4) that is wrong (actually returns 3).  This should produce and error
#check @MRrun Nat 4 _ (MRret 4)

def dPred (α : Type) : Type := α → Prop

def retEqPred {α : Type} (v : α) : dPred α := fun y => y = v
def retEqProof {α : Type} (v : α) : retEqPred v v := show v = v by rfl

def bindPred {α β : Type} (p : dPred α) (f : α → dPred β) : dPred β := fun b => ∃ (a:α), p a ∧ f a b

inductive MonadWithPredicate (α : Type) : dPred α → Type where
| mk : (mz : BaseMonad α) → (pf : p mz.output) → MonadWithPredicate α p

def retMW {α : Type} {p : dPred α} (v : α) (pf : p v) := MonadWithPredicate.mk (BaseMonad.mk v) pf

-- bind that just uses the predicate of the most recent monad. All monads need to use the same predicate here.
def bindMW {α : Type} {p : dPred α} {a b : α} {ma mb : BaseMonad α} : MonadWithPredicate α p → (α → MonadWithPredicate α p) → MonadWithPredicate α p :=
  fun m1 m2 => match m1 with
               | MonadWithPredicate.mk mz1 pf1 => m2 mz1.output

-- bind that combines (using AND) the predicates of both monads
def bindMWAnd {α : Type} {p₁ p₂ : dPred α} : MonadWithPredicate α p₁ → (α → MonadWithPredicate α p₂) → MonadWithPredicate α (fun b => ∃x, p₁ x ∧ (p₂ b)) :=
  fun m1 m2 => match m1 with
               | MonadWithPredicate.mk mz1 pf1 =>
                 match (m2 mz1.output) with
                 | MonadWithPredicate.mk mz2 pf2 =>
                     MonadWithPredicate.mk mz2 (show ∃ x, p₁ x ∧ p₂ mz2.output from Exists.intro mz1.output (And.intro pf1 pf2))

def runPred {α : Type} (p : dPred α) (m : MonadWithPredicate α p) : ∃ x, p x :=
  match m with
  | MonadWithPredicate.mk b pf => Exists.intro b.output pf

#check show ∃ x, x=3 from Exists.intro 3 (_ : 3=3)
#reduce (retMW 3 _ : MonadWithPredicate Nat (retEqPred 3))
#reduce (retMW 3 (retEqProof 3) : MonadWithPredicate Nat (retEqPred 3))
#reduce (runPred (retEqPred 3) (retMW 3 _))
#reduce (runPred _ (bindMW (retMW 3 (retEqProof 3)) (fun _ => retMW 3 (retEqProof 3))))
#reduce (runPred _ (bindMWAnd (retMW 3 (retEqProof 3)) (fun _ => retMW 4 (retEqProof 4))))

def runProg := runPred (retEqPred 3) (retMW 3 (retEqProof 3))
def runProg2 := (runPred _ (bindMWAnd (retMW 3 (retEqProof 3)) (fun (x : Nat) => retMW 4 (retEqProof 4))))

#check @runProg2
#check Exists.intro 3 rfl
#check (show (∃ x, x = 3) from (Exists.intro 3 rfl))
#check (show (∀ a, a = 3 → retEqPred 3 3) from (fun a (_:a=3) => _))
#check Exists.elim (show (∃ x, x = 3) from (Exists.intro 3 rfl)) (show (∀ a, a = 3 → retEqPred 3 3) from (fun a (_:a=3) => _))

example (h: ∃ x, retEqPred 3 x ∧ retEqPred 4 4) : retEqPred 3 3 := by
  let hx : ∀ a, retEqPred 3 a ∧ retEqPred 4 4 → retEqPred 3 3 := show ∀a, retEqPred 3 a ∧ retEqPred 4 4 → retEqPred 3 3 from (fun a x => show _ from rfl)
  apply Exists.elim h hx

-- forward transforming predicate

def fPred (α : Type) : Type := Prop → α → Prop

def simpleFP {α : Type} (v : α) : fPred α := fun (pre:Prop) (a : α) => pre ∧ a = v

inductive MonadFwdPredicate {α : Type} : Prop → fPred α → Type where
| mk : (mz : BaseMonad α) → (pf : ∀ (hpre : pre), p pre mz.output) → MonadFwdPredicate pre p

def retFP {α : Type} (v : α) {pre :Prop} : MonadFwdPredicate pre (@simpleFP α v) :=
  let bm := BaseMonad.mk v
  MonadFwdPredicate.mk bm (fun (hpre : pre) => show simpleFP v pre bm.output from (And.intro hpre rfl))

def bindFP {α :Type} {pre1 : Prop} {p₁ p₂ : fPred α} :
  MonadFwdPredicate pre1 p₁ → (α → MonadFwdPredicate (∃a, p₁ pre1 a) p₂) → MonadFwdPredicate pre1 (fun pre z => p₂ (∃a, p₁ pre a) z) :=
    fun m f => match m with
               | MonadFwdPredicate.mk z1 pf1 =>
                   match (f z1.output) with
                   | MonadFwdPredicate.mk z2 pf2 =>
                       MonadFwdPredicate.mk z2 (fun pre => (pf2 (Exists.intro z1.output (pf1 pre))))

def runFP {α : Type} {pre1 :Prop} {p₁ : fPred α} (m : MonadFwdPredicate pre1 p₁) : pre1 → ∃ a, p₁ pre1 a :=
  fun p1 => match m with
            | MonadFwdPredicate.mk ma pf => Exists.intro ma.output (pf p1)

def sampleProg := runFP (bindFP (retFP 3) (fun _ => bindFP (retFP 5) (fun _ => retFP 4))) (rfl : 2=2)

-- backward transforming predicate

def bPred (α : Type) : Type := (α → Prop) → Prop

-- for backward transformers we need to map pointwise under the transformer when binding monads.
-- This also restricts transformers to be monotonic
class MonoBackward (w : bPred α) where
  monoMap {p₁ p₂ : α → Prop} : (∀ a , p₁ a → p₂ a) → w p₁ → w p₂

def simpleBP {α : Type} (v : α) : bPred α := fun (post : α → Prop) => post v

instance {α : Type} {v : α}: MonoBackward (simpleBP v) where
  monoMap  {p₁ p₂ : α → Prop} :=  fun f wp1 => f v wp1

inductive MonadBwdPredicate {α : Type} : bPred α → (α → Prop) → Type where
| mk : (mz : BaseMonad α) → (pf : p post) → MonadBwdPredicate p post

def retBP {α : Type} (v : α) {post : α → Prop} {postpf: post v} : MonadBwdPredicate (@simpleBP α v) post:=
  let bm := BaseMonad.mk v
  MonadBwdPredicate.mk bm postpf

def bindBP {α : Type} {post1 post2 : α → Prop} {p₁ p₂ p₃ : bPred α} [MonoBackward p₁] :
  MonadBwdPredicate p₁ post1 → (α → MonadBwdPredicate p₂ post2) → MonadBwdPredicate (fun (p : α → Prop) => p₁ (fun a => post1 a ∧ p₂ post2)) post2 :=
    fun m f => match m with
               | MonadBwdPredicate.mk z1 pf1 =>
                 match (f z1.output) with
                 | MonadBwdPredicate.mk z2 pf2 =>
                     MonadBwdPredicate.mk z2 (let hx : ∀ a, post1 a → post1 a ∧ p₂ post2 := fun a p1 => And.intro p1 pf2
                                              MonoBackward.monoMap hx pf1)

def runBP {α : Type} {post1 : α → Prop} {p₁ : bPred α} (m : MonadBwdPredicate p₁ post1) : p₁ post1 :=
  match m with | MonadBwdPredicate.mk ma pf => pf

#check retBP 3

def sampleBack := @runBP Nat (fun x => 3 = x → Eq 3 3) (simpleBP 3) (@retBP Nat 3 _ id)
def sampleBack2 : simpleBP 3 fun x => 3 = x → 3 = 3 := runBP (@retBP Nat 3 _ id)

-- backward predicate for state monad

def Top {x : Type} : x → Prop  := fun _ => True

def bSPred (s α : Type) : Type := (α × s → Prop) → s → Prop

def StatePM (s : Type) (α : Type) : Type := s → (α × s)

inductive MonadBwdState (s : Type) (α: Type) (p : bSPred s α) : Type where
| mk : (ms : StatePM s α) → (pf : ∀ post s, p post s → post (ms s)) → MonadBwdState s α p

def retBS {s α : Type} (a : α) : MonadBwdState s α (fun post s0 => post ⟨a, s0⟩) :=
  let md : StatePM s α := fun s => ⟨a,s⟩
  MonadBwdState.mk md (fun post s_1 => by
                          intro pst
                          let (h : md s_1 = (a, s_1)) := by simp
                          rw [h]
                          assumption
                       )

-- monadic bind of backward state transformers
def bindWBS {s α β : Type} (wc : bSPred s α) (wf : α → bSPred s β) : bSPred s β :=
  fun p s0 => wc (fun ⟨a,s1⟩ => wf a p s1) s0

def bindBS {s α β : Type} {wc : bSPred s α} {wf : α → bSPred s β} :
           MonadBwdState s α wc → ((x : α) → MonadBwdState s β (wf x)) → MonadBwdState s β (bindWBS wc wf) :=
  fun m1 f =>
    match m1 with
    | MonadBwdState.mk ms1 pf1 =>
        let mm  := fun s₁ =>
                        let mo1:= ms1 s₁
                        let m2 := f mo1.1
                        match m2 with
                        | MonadBwdState.mk ms2 pf2 => ms2 mo1.2
        let pf3 := fun post s₁ bindW =>
                        let mo1 := ms1 s₁
                        let m2 := f mo1.1
                        let ms2 := m2.1
                        let pf2 := m2.2
                        let ⟨a₂,s₃⟩ := mm s₁  -- actual results from monad running
                        let postX := fun (a,s) => wf a post s
                        let postXrfl : postX = (fun (a,s) => wf a post s) := by simp
                        let postT₁ := pf1 postX s₁
                        let postT₂ := pf2 post mo1.2
                        let hh : wc postX s₁ := by unfold bindWBS at bindW; assumption
                        let pf12 := postT₁ hh
                        let hpf12 : postX (ms1 s₁) = wf mo1.1 post mo1.2 := by simp
                        let hh2 : wf mo1.1 post mo1.2 := by rw [hpf12] at pf12; assumption
                        let pf3 := postT₂ hh2
                        let hme : ms2 = (f (ms1 s₁).fst).1 := by simp
                        let hh3 : ms2 mo1.2 = mm s₁:= by simp
                        by rewrite [←hh3]; assumption
        MonadBwdState.mk mm pf3