/-
Copyright (c) 2022 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta

! This file was ported from Lean 3 source module combinatorics.simple_graph.regularity.equitabilise
! leanprover-community/mathlib commit b6da1a0b3e7cd83b1f744c49ce48ef8c6307d2f6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Partition.Equipartition

/-!
# Equitabilising a partition

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

This file allows to blow partitions up into parts of controlled size. Given a partition `P` and
`a b m : ℕ`, we want to find a partition `Q` with `a` parts of size `m` and `b` parts of size
`m + 1` such that all parts of `P` are "as close as possible" to unions of parts of `Q`. By
"as close as possible", we mean that each part of `P` can be written as the union of some parts of
`Q` along with at most `m` other elements.

## Main declarations

* `finpartition.equitabilise`: `P.equitabilise h` where `h : a * m + b * (m + 1)` is a partition
  with `a` parts of size `m` and `b` parts of size `m + 1` which almost refines `P`.
* `finpartition.exists_equipartition_card_eq`: We can find equipartitions of arbitrary size.
-/

open Finset Nat

namespace Finpartition

variable {α : Type _} [DecidableEq α] {s t : Finset α} {m n a b : ℕ} {P : Finpartition s}

/- warning: finpartition.equitabilise_aux -> Finpartition.equitabilise_aux is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s), (Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)) -> (Exists.{succ u1} (Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) (fun (Q : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) => And (forall (x : Finset.{u1} α), (Membership.Mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.hasMem.{u1} (Finset.{u1} α)) x (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s Q)) -> (Or (Eq.{1} Nat (Finset.card.{u1} α x) m) (Eq.{1} Nat (Finset.card.{u1} α x) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))))) (And (forall (x : Finset.{u1} α), (Membership.Mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.hasMem.{u1} (Finset.{u1} α)) x (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s P)) -> (LE.le.{0} Nat Nat.hasLe (Finset.card.{u1} α (SDiff.sdiff.{u1} (Finset.{u1} α) (Finset.hasSdiff.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) x (Finset.bunionᵢ.{u1, u1} (Finset.{u1} α) α (fun (a : α) (b : α) => _inst_1 a b) (Finset.filter.{u1} (Finset.{u1} α) (fun (y : Finset.{u1} α) => HasSubset.Subset.{u1} (Finset.{u1} α) (Finset.hasSubset.{u1} α) y x) (fun (a : Finset.{u1} α) => Finset.decidableDforallFinset.{u1} α a (fun (a_1 : α) (ᾰ : Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a_1 a) => Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a_1 x) (fun (a_1 : α) (h : Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a_1 a) => Finset.decidableMem.{u1} α (fun (a : α) (b : α) => _inst_1 a b) a_1 x)) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s Q)) (id.{succ u1} (Finset.{u1} α))))) m)) (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finset.filter.{u1} (Finset.{u1} α) (fun (i : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α i) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (fun (a : Finset.{u1} α) => Nat.decidableEq (Finset.card.{u1} α a) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s Q))) b))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} {P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s}, (Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)) -> (Exists.{succ u1} (Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) (fun (Q : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) => And (forall (x : Finset.{u1} α), (Membership.mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.instMembershipFinset.{u1} (Finset.{u1} α)) x (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s Q)) -> (Or (Eq.{1} Nat (Finset.card.{u1} α x) m) (Eq.{1} Nat (Finset.card.{u1} α x) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))))) (And (forall (x : Finset.{u1} α), (Membership.mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.instMembershipFinset.{u1} (Finset.{u1} α)) x (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s P)) -> (LE.le.{0} Nat instLENat (Finset.card.{u1} α (SDiff.sdiff.{u1} (Finset.{u1} α) (Finset.instSDiffFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) x (Finset.bunionᵢ.{u1, u1} (Finset.{u1} α) α (fun (a : α) (b : α) => _inst_1 a b) (Finset.filter.{u1} (Finset.{u1} α) (fun (y : Finset.{u1} α) => HasSubset.Subset.{u1} (Finset.{u1} α) (Finset.instHasSubsetFinset.{u1} α) y x) (fun (a : Finset.{u1} α) => Finset.decidableSubsetFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b) a x) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s Q)) (id.{succ u1} (Finset.{u1} α))))) m)) (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finset.filter.{u1} (Finset.{u1} α) (fun (i : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α i) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (fun (a : Finset.{u1} α) => instDecidableEqNat (Finset.card.{u1} α a) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s Q))) b))))
Case conversion may be inaccurate. Consider using '#align finpartition.equitabilise_aux Finpartition.equitabilise_auxₓ'. -/
/-- Given a partition `P` of `s`, as well as a proof that `a * m + b * (m + 1) = s.card`, we can
find a new partition `Q` of `s` where each part has size `m` or `m + 1`, every part of `P` is the
union of parts of `Q` plus at most `m` extra elements, there are `b` parts of size `m + 1` and
(provided `m > 0`, because a partition does not have parts of size `0`) there are `a` parts of size
`m` and hence `a + b` parts in total. -/
theorem equitabilise_aux (P : Finpartition s) (hs : a * m + b * (m + 1) = s.card) :
    ∃ Q : Finpartition s,
      (∀ x : Finset α, x ∈ Q.parts → x.card = m ∨ x.card = m + 1) ∧
        (∀ x, x ∈ P.parts → (x \ (Q.parts.filterₓ fun y => y ⊆ x).bunionᵢ id).card ≤ m) ∧
          (Q.parts.filterₓ fun i => card i = m + 1).card = b :=
  by
  -- Get rid of the easy case `m = 0`
  obtain rfl | m_pos := m.eq_zero_or_pos
  · refine' ⟨⊥, by simp, _, by simpa using hs.symm⟩
    simp only [le_zero_iff, card_eq_zero, mem_bUnion, exists_prop, mem_filter, id.def, and_assoc',
      sdiff_eq_empty_iff_subset, subset_iff]
    exact fun x hx a ha =>
      ⟨{a}, mem_map_of_mem _ (P.le hx ha), singleton_subset_iff.2 ha, mem_singleton_self _⟩
  -- Prove the case `m > 0` by strong induction on `s`
  induction' s using Finset.strongInduction with s ih generalizing P a b
  -- If `a = b = 0`, then `s = ∅` and we can partition into zero parts
  by_cases hab : a = 0 ∧ b = 0
  · simp only [hab.1, hab.2, add_zero, MulZeroClass.zero_mul, eq_comm, card_eq_zero] at hs
    subst hs
    exact ⟨Finpartition.empty _, by simp, by simp [Unique.eq_default P], by simp [hab.2]⟩
  simp_rw [not_and_or, ← Ne.def, ← pos_iff_ne_zero] at hab
  -- `n` will be the size of the smallest part
  set n := if 0 < a then m else m + 1 with hn
  -- Some easy facts about it
  obtain ⟨hn₀, hn₁, hn₂, hn₃⟩ :
    0 < n ∧
      n ≤ m + 1 ∧
        n ≤ a * m + b * (m + 1) ∧
          ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = s.card - n :=
    by
    rw [hn, ← hs]
    split_ifs <;> rw [tsub_mul, one_mul]
    · refine' ⟨m_pos, le_succ _, le_add_right (le_mul_of_pos_left ‹0 < a›), _⟩
      rw [tsub_add_eq_add_tsub (le_mul_of_pos_left h)]
    · refine' ⟨succ_pos', le_rfl, le_add_left (le_mul_of_pos_left <| hab.resolve_left ‹¬0 < a›), _⟩
      rw [← add_tsub_assoc_of_le (le_mul_of_pos_left <| hab.resolve_left ‹¬0 < a›)]
  /- We will call the inductive hypothesis on a partition of `s \ t` for a carefully chosen `t ⊆ s`.
    To decide which, however, we must distinguish the case where all parts of `P` have size `m` (in
    which case we take `t` to be an arbitrary subset of `s` of size `n`) from the case where at least
    one part `u` of `P` has size `m + 1` (in which case we take `t` to be an arbitrary subset of `u`
    of size `n`). The rest of each branch is just tedious calculations to satisfy the induction
    hypothesis. -/
  by_cases ∀ u ∈ P.parts, card u < m + 1
  · obtain ⟨t, hts, htn⟩ := exists_smaller_set s n (hn₂.trans_eq hs)
    have ht : t.nonempty := by rwa [← card_pos, htn]
    have hcard : ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = (s \ t).card := by
      rw [card_sdiff ‹t ⊆ s›, htn, hn₃]
    obtain ⟨R, hR₁, hR₂, hR₃⟩ :=
      @ih (s \ t) (sdiff_ssubset hts ‹t.nonempty›) (P.avoid t) (if 0 < a then a - 1 else a)
        (if 0 < a then b else b - 1) hcard
    refine' ⟨R.extend ht.ne_empty sdiff_disjoint (sdiff_sup_cancel hts), _, _, _⟩
    · simp only [extend_parts, mem_insert, forall_eq_or_imp, and_iff_left hR₁, htn, hn]
      exact ite_eq_or_eq _ _ _
    · exact fun x hx => (card_le_of_subset <| sdiff_subset _ _).trans (lt_succ_iff.1 <| h _ hx)
    simp_rw [extend_parts, filter_insert, htn, hn, m.succ_ne_self.symm.ite_eq_right_iff]
    split_ifs with ha
    · rw [hR₃, if_pos ha]
    rw [card_insert_of_not_mem fun H => _, hR₃, if_neg ha, tsub_add_cancel_of_le]
    · exact hab.resolve_left ha
    · exact ht.ne_empty (le_sdiff_iff.1 <| R.le <| filter_subset _ _ H)
  push_neg  at h
  obtain ⟨u, hu₁, hu₂⟩ := h
  obtain ⟨t, htu, htn⟩ := exists_smaller_set _ _ (hn₁.trans hu₂)
  have ht : t.nonempty := by rwa [← card_pos, htn]
  have hcard : ite (0 < a) (a - 1) a * m + ite (0 < a) b (b - 1) * (m + 1) = (s \ t).card := by
    rw [card_sdiff (htu.trans <| P.le hu₁), htn, hn₃]
  obtain ⟨R, hR₁, hR₂, hR₃⟩ :=
    @ih (s \ t) (sdiff_ssubset (htu.trans <| P.le hu₁) ht) (P.avoid t) (if 0 < a then a - 1 else a)
      (if 0 < a then b else b - 1) hcard
  refine' ⟨R.extend ht.ne_empty sdiff_disjoint (sdiff_sup_cancel <| htu.trans <| P.le hu₁), _, _, _⟩
  · simp only [mem_insert, forall_eq_or_imp, extend_parts, and_iff_left hR₁, htn, hn]
    exact ite_eq_or_eq _ _ _
  · conv in _ ∈ _ => rw [← insert_erase hu₁]
    simp only [and_imp, mem_insert, forall_eq_or_imp, Ne.def, extend_parts]
    refine' ⟨_, fun x hx => (card_le_of_subset _).trans <| hR₂ x _⟩
    · simp only [filter_insert, if_pos htu, bUnion_insert, mem_erase, id.def]
      obtain rfl | hut := eq_or_ne u t
      · rw [sdiff_eq_empty_iff_subset.2 (subset_union_left _ _)]
        exact bot_le
      refine'
        (card_le_of_subset fun i => _).trans
          (hR₂ (u \ t) <| P.mem_avoid.2 ⟨u, hu₁, fun i => hut <| i.antisymm htu, rfl⟩)
      simp only [not_exists, mem_bUnion, and_imp, mem_union, mem_filter, mem_sdiff, id.def, not_or]
      exact fun hi₁ hi₂ hi₃ =>
        ⟨⟨hi₁, hi₂⟩, fun x hx hx' => hi₃ _ hx <| hx'.trans <| sdiff_subset _ _⟩
    · apply sdiff_subset_sdiff subset.rfl (bUnion_subset_bUnion_of_subset_left _ _)
      exact filter_subset_filter _ (subset_insert _ _)
    simp only [avoid, of_erase, mem_erase, mem_image, bot_eq_empty]
    exact
      ⟨(nonempty_of_mem_parts _ <| mem_of_mem_erase hx).ne_empty, _, mem_of_mem_erase hx,
        (disjoint_of_subset_right htu <|
            P.disjoint (mem_of_mem_erase hx) hu₁ <| ne_of_mem_erase hx).sdiff_eq_left⟩
  simp only [extend_parts, filter_insert, htn, hn, m.succ_ne_self.symm.ite_eq_right_iff]
  split_ifs
  · rw [hR₃, if_pos h]
  · rw [card_insert_of_not_mem fun H => _, hR₃, if_neg h, Nat.sub_add_cancel (hab.resolve_left h)]
    exact ht.ne_empty (le_sdiff_iff.1 <| R.le <| filter_subset _ _ H)
#align finpartition.equitabilise_aux Finpartition.equitabilise_aux

variable (P) (h : a * m + b * (m + 1) = s.card)

/- warning: finpartition.equitabilise -> Finpartition.equitabilise is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat}, (Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) -> (Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)) -> (Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} {P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s}, (Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)) -> (Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s)
Case conversion may be inaccurate. Consider using '#align finpartition.equitabilise Finpartition.equitabiliseₓ'. -/
/-- Given a partition `P` of `s`, as well as a proof that `a * m + b * (m + 1) = s.card`, build a
new partition `Q` of `s` where each part has size `m` or `m + 1`, every part of `P` is the union of
parts of `Q` plus at most `m` extra elements, there are `b` parts of size `m + 1` and (provided
`m > 0`, because a partition does not have parts of size `0`) there are `a` parts of size `m` and
hence `a + b` parts in total. -/
noncomputable def equitabilise : Finpartition s :=
  (P.equitabilise_aux h).some
#align finpartition.equitabilise Finpartition.equitabilise

variable {P h}

/- warning: finpartition.card_eq_of_mem_parts_equitabilise -> Finpartition.card_eq_of_mem_parts_equitabilise is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {t : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} {P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s} {h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)}, (Membership.Mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.hasMem.{u1} (Finset.{u1} α)) t (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h))) -> (Or (Eq.{1} Nat (Finset.card.{u1} α t) m) (Eq.{1} Nat (Finset.card.{u1} α t) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {t : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} {P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s} {h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)}, (Membership.mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.instMembershipFinset.{u1} (Finset.{u1} α)) t (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h))) -> (Or (Eq.{1} Nat (Finset.card.{u1} α t) m) (Eq.{1} Nat (Finset.card.{u1} α t) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))))
Case conversion may be inaccurate. Consider using '#align finpartition.card_eq_of_mem_parts_equitabilise Finpartition.card_eq_of_mem_parts_equitabiliseₓ'. -/
theorem card_eq_of_mem_parts_equitabilise :
    t ∈ (P.equitabilise h).parts → t.card = m ∨ t.card = m + 1 :=
  (P.equitabilise_aux h).choose_spec.1 _
#align finpartition.card_eq_of_mem_parts_equitabilise Finpartition.card_eq_of_mem_parts_equitabilise

/- warning: finpartition.equitabilise_is_equipartition -> Finpartition.equitabilise_isEquipartition is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} {P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s} {h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)}, Finpartition.IsEquipartition.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} {P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s} {h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)}, Finpartition.IsEquipartition.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h)
Case conversion may be inaccurate. Consider using '#align finpartition.equitabilise_is_equipartition Finpartition.equitabilise_isEquipartitionₓ'. -/
theorem equitabilise_isEquipartition : (P.equitabilise h).IsEquipartition :=
  Set.equitableOn_iff_exists_eq_eq_add_one.2 ⟨m, fun u => card_eq_of_mem_parts_equitabilise⟩
#align finpartition.equitabilise_is_equipartition Finpartition.equitabilise_isEquipartition

variable (P h)

/- warning: finpartition.card_filter_equitabilise_big -> Finpartition.card_filter_equitabilise_big is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)), Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finset.filter.{u1} (Finset.{u1} α) (fun (u : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α u) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (fun (a : Finset.{u1} α) => Nat.decidableEq (Finset.card.{u1} α a) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h)))) b
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)), Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finset.filter.{u1} (Finset.{u1} α) (fun (u : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α u) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (fun (a : Finset.{u1} α) => instDecidableEqNat (Finset.card.{u1} α a) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h)))) b
Case conversion may be inaccurate. Consider using '#align finpartition.card_filter_equitabilise_big Finpartition.card_filter_equitabilise_bigₓ'. -/
theorem card_filter_equitabilise_big :
    ((P.equitabilise h).parts.filterₓ fun u : Finset α => u.card = m + 1).card = b :=
  (P.equitabilise_aux h).choose_spec.2.2
#align finpartition.card_filter_equitabilise_big Finpartition.card_filter_equitabilise_big

/- warning: finpartition.card_filter_equitabilise_small -> Finpartition.card_filter_equitabilise_small is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)), (Ne.{1} Nat m (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero)))) -> (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finset.filter.{u1} (Finset.{u1} α) (fun (u : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α u) m) (fun (a : Finset.{u1} α) => Nat.decidableEq (Finset.card.{u1} α a) m) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h)))) a)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)), (Ne.{1} Nat m (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0))) -> (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finset.filter.{u1} (Finset.{u1} α) (fun (u : Finset.{u1} α) => Eq.{1} Nat (Finset.card.{u1} α u) m) (fun (a : Finset.{u1} α) => instDecidableEqNat (Finset.card.{u1} α a) m) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h)))) a)
Case conversion may be inaccurate. Consider using '#align finpartition.card_filter_equitabilise_small Finpartition.card_filter_equitabilise_smallₓ'. -/
theorem card_filter_equitabilise_small (hm : m ≠ 0) :
    ((P.equitabilise h).parts.filterₓ fun u : Finset α => u.card = m).card = a :=
  by
  refine' (mul_eq_mul_right_iff.1 <| (add_left_inj (b * (m + 1))).1 _).resolve_right hm
  rw [h, ← (P.equitabilise h).sum_card_parts]
  have hunion :
    (P.equitabilise h).parts =
      ((P.equitabilise h).parts.filterₓ fun u => u.card = m) ∪
        (P.equitabilise h).parts.filterₓ fun u => u.card = m + 1 :=
    by
    rw [← filter_or, filter_true_of_mem]
    exact fun x => card_eq_of_mem_parts_equitabilise
  nth_rw 2 [hunion]
  rw [sum_union, sum_const_nat fun x hx => (mem_filter.1 hx).2,
    sum_const_nat fun x hx => (mem_filter.1 hx).2, P.card_filter_equitabilise_big]
  refine' disjoint_filter_filter' _ _ _
  intro x ha hb i h
  apply succ_ne_self m _
  exact (hb i h).symm.trans (ha i h)
#align finpartition.card_filter_equitabilise_small Finpartition.card_filter_equitabilise_small

/- warning: finpartition.card_parts_equitabilise -> Finpartition.card_parts_equitabilise is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)), (Ne.{1} Nat m (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero)))) -> (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h))) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) a b))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)), (Ne.{1} Nat m (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0))) -> (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h))) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) a b))
Case conversion may be inaccurate. Consider using '#align finpartition.card_parts_equitabilise Finpartition.card_parts_equitabiliseₓ'. -/
theorem card_parts_equitabilise (hm : m ≠ 0) : (P.equitabilise h).parts.card = a + b :=
  by
  rw [← filter_true_of_mem fun x => card_eq_of_mem_parts_equitabilise, filter_or, card_union_eq,
    P.card_filter_equitabilise_small _ hm, P.card_filter_equitabilise_big]
  exact disjoint_filter.2 fun x _ h₀ h₁ => Nat.succ_ne_self m <| h₁.symm.trans h₀
  infer_instance
#align finpartition.card_parts_equitabilise Finpartition.card_parts_equitabilise

/- warning: finpartition.card_parts_equitabilise_subset_le -> Finpartition.card_parts_equitabilise_subset_le is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {t : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) m (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (Finset.card.{u1} α s)), (Membership.Mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.hasMem.{u1} (Finset.{u1} α)) t (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s P)) -> (LE.le.{0} Nat Nat.hasLe (Finset.card.{u1} α (SDiff.sdiff.{u1} (Finset.{u1} α) (Finset.hasSdiff.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) t (Finset.bunionᵢ.{u1, u1} (Finset.{u1} α) α (fun (a : α) (b : α) => _inst_1 a b) (Finset.filter.{u1} (Finset.{u1} α) (fun (u : Finset.{u1} α) => HasSubset.Subset.{u1} (Finset.{u1} α) (Finset.hasSubset.{u1} α) u t) (fun (a : Finset.{u1} α) => Finset.decidableDforallFinset.{u1} α a (fun (a_1 : α) (ᾰ : Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a_1 a) => Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a_1 t) (fun (a_1 : α) (h : Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a_1 a) => Finset.decidableMem.{u1} α (fun (a : α) (b : α) => _inst_1 a b) a_1 t)) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h))) (id.{succ u1} (Finset.{u1} α))))) m)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] {s : Finset.{u1} α} {t : Finset.{u1} α} {m : Nat} {a : Nat} {b : Nat} (P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) (h : Eq.{1} Nat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) b (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) m (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (Finset.card.{u1} α s)), (Membership.mem.{u1, u1} (Finset.{u1} α) (Finset.{u1} (Finset.{u1} α)) (Finset.instMembershipFinset.{u1} (Finset.{u1} α)) t (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s P)) -> (LE.le.{0} Nat instLENat (Finset.card.{u1} α (SDiff.sdiff.{u1} (Finset.{u1} α) (Finset.instSDiffFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) t (Finset.bunionᵢ.{u1, u1} (Finset.{u1} α) α (fun (a : α) (b : α) => _inst_1 a b) (Finset.filter.{u1} (Finset.{u1} α) (fun (u : Finset.{u1} α) => HasSubset.Subset.{u1} (Finset.{u1} α) (Finset.instHasSubsetFinset.{u1} α) u t) (fun (a : Finset.{u1} α) => Finset.decidableSubsetFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b) a t) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s (Finpartition.equitabilise.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s m a b P h))) (id.{succ u1} (Finset.{u1} α))))) m)
Case conversion may be inaccurate. Consider using '#align finpartition.card_parts_equitabilise_subset_le Finpartition.card_parts_equitabilise_subset_leₓ'. -/
theorem card_parts_equitabilise_subset_le :
    t ∈ P.parts → (t \ ((P.equitabilise h).parts.filterₓ fun u => u ⊆ t).bunionᵢ id).card ≤ m :=
  (Classical.choose_spec <| P.equitabilise_aux h).2.1 t
#align finpartition.card_parts_equitabilise_subset_le Finpartition.card_parts_equitabilise_subset_le

variable (s)

/- warning: finpartition.exists_equipartition_card_eq -> Finpartition.exists_equipartition_card_eq is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] (s : Finset.{u1} α) {n : Nat}, (Ne.{1} Nat n (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero)))) -> (LE.le.{0} Nat Nat.hasLe n (Finset.card.{u1} α s)) -> (Exists.{succ u1} (Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) (fun (P : Finpartition.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s) => And (Finpartition.IsEquipartition.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s P) (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.lattice.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.orderBot.{u1} α) s P)) n)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] (s : Finset.{u1} α) {n : Nat}, (Ne.{1} Nat n (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0))) -> (LE.le.{0} Nat instLENat n (Finset.card.{u1} α s)) -> (Exists.{succ u1} (Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) (fun (P : Finpartition.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s) => And (Finpartition.IsEquipartition.{u1} α (fun (a : α) (b : α) => _inst_1 a b) s P) (Eq.{1} Nat (Finset.card.{u1} (Finset.{u1} α) (Finpartition.parts.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_1 a b)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) s P)) n)))
Case conversion may be inaccurate. Consider using '#align finpartition.exists_equipartition_card_eq Finpartition.exists_equipartition_card_eqₓ'. -/
/-- We can find equipartitions of arbitrary size. -/
theorem exists_equipartition_card_eq (hn : n ≠ 0) (hs : n ≤ s.card) :
    ∃ P : Finpartition s, P.IsEquipartition ∧ P.parts.card = n :=
  by
  rw [← pos_iff_ne_zero] at hn
  have : (n - s.card % n) * (s.card / n) + s.card % n * (s.card / n + 1) = s.card := by
    rw [tsub_mul, mul_add, ← add_assoc,
      tsub_add_cancel_of_le (Nat.mul_le_mul_right _ (mod_lt _ hn).le), mul_one, add_comm,
      mod_add_div]
  refine'
    ⟨(indiscrete (card_pos.1 <| hn.trans_le hs).ne_empty).equitabilise this,
      equitabilise_is_equipartition, _⟩
  rw [card_parts_equitabilise _ _ (Nat.div_pos hs hn).ne', tsub_add_cancel_of_le (mod_lt _ hn).le]
#align finpartition.exists_equipartition_card_eq Finpartition.exists_equipartition_card_eq

end Finpartition


import littleendian
import category_theory.category.basic
import data.nat.digits

open littleendian

open category_theory
open nat

namespace littleendian_examples

variables [category (bitvec params.word_len)] [semiring (list ℕ)]

/-
  Examples from the spec.

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

  ## Straight examples
-/

/-- `littleendian(0, 0, 0, 0) = 0x00000000` -/
lemma example1 : littleendian [0, 0, 0, 0] = 0 :=
begin
  unfold littleendian,
  unfold of_digits,
  norm_num,
end

/-- `littleendian(86, 75, 30, 9) = 0x091e4b56` -/
lemma example2 : littleendian [86, 75, 30, 9] = 0x091e4b56 :=
begin
  unfold littleendian,
  unfold of_digits,
  norm_num,
end

/-- `littleendian(255, 255, 255, 250) = 0xfaffffff` -/
lemma example3 : littleendian [255, 255, 255, 250] = 0xfaffffff :=
begin
  unfold littleendian,
  unfold of_digits,
  norm_num,
end

/-
  ## Inverse examples
-/

/-- `littleendian⁻¹ 0 = (0, 0, 0, 0)` -/
lemma example1_inv : littleendian_inv [0] = list.nil :=
begin
  unfold littleendian_inv,
  norm_num,
end

/-- `littleendian⁻¹ 152980310 = (86, 75, 30, 9)` -/
lemma example2_inv : littleendian_inv [0x091e4b56] = [86, 75, 30, 9] :=
begin
  unfold littleendian_inv,
  norm_num,
end

/-- `littleendian⁻¹ 4211081215 = (255, 255, 255, 250)` -/
lemma example3_inv : littleendian_inv [0xfaffffff] = [255, 255, 255, 250] :=
begin
  unfold littleendian_inv,
  norm_num,
end

end littleendian_examples


/-
## `arith` dialect

This file formalises part of the `arith` dialect. The goal is to showcase
operations on multiple types (with overloading) and basic reasoning. `arith`
does not have new datatypes, but it supports operations on tensors and vectors,
which are some of the most complex builtin types.

TODO: This file uses shorter operation names (without "arith.") to work around
      a normalization performance issue that is affected by the string length
See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/unfold.20essentially.20loops
-/

import MLIR.Semantics.Fitree
import MLIR.Semantics.Semantics
import MLIR.Semantics.SSAEnv
import MLIR.Semantics.UB
import MLIR.Dialects.BuiltinModel
import MLIR.Util.Metagen
import MLIR.AST
import MLIR.EDSL
import MLIR.Semantics.Rewriting
open MLIR.AST

/-
### Dialect extensions

`arith` has no extended types or attributes.
-/

instance arith: Dialect Void Void (fun _ => Unit) where
  name := "arith"
  iα := inferInstance
  iε := inferInstance

/-
### Dialect operations

In order to support type overloads while keeping reasonably-strong typing on
operands and disallowing incorrect types in the operation arguments, we define
scalar, tensor, and vector overloads of each operation.
-/

inductive ComparisonPred :=
  | eq  | ne
  | slt | sle | sgt | sge
  | ult | ule | ugt | uge

def ComparisonPred.ofInt: Int → Option ComparisonPred
  | 0 => some eq
  | 1 => some ne
  | 2 => some slt
  | 3 => some sle
  | 4 => some sgt
  | 5 => some sge
  | 6 => some ult
  | 7 => some ule
  | 8 => some ugt
  | 9 => some uge
  | _ => none

-- inductive ArithE: Type → Type :=
--   | CmpI: (sz: Nat) → (pred: ComparisonPred) → (lhs rhs: FinInt sz) →
--           ArithE (FinInt 1)
--   | CmpIndex: (pred: ComparisonPred) → (lhs rhs: Int) →
--           ArithE (FinInt 1)
--   | AddI: (sz: Nat) → (lhs rhs: FinInt sz) →
--           ArithE (FinInt sz)
--   | AddT: (sz: Nat) → (D: DimList) → (lhs rhs: RankedTensor D (.int sgn sz)) →
--           ArithE (RankedTensor D (.int sgn sz))
--   | AddV: (sz: Nat) → (sc fx: List Nat) →
--           (lhs rhs: Vector sc fx (.int sgn sz)) →
--           ArithE (Vector sc fx (.int sgn sz))
--   | SubI: (sz: Nat) → (lhs rhs: FinInt sz) →
--           ArithE (FinInt sz)
--   | NegI: (sz: Nat) → (op: FinInt sz) →
--           ArithE (FinInt sz)
--   | AndI: (sz: Nat) → (lhs rhs: FinInt sz) →
--           ArithE (FinInt sz)
--   | OrI: (sz: Nat) → (lhs rhs: FinInt sz) →
--           ArithE (FinInt sz)
--   | XorI: (sz: Nat) → (lhs rhs: FinInt sz) →
--           ArithE (FinInt sz)
--   | Zext: (sz₁: Nat) → (sz₂: Nat) → (FinInt sz₁) →
--           ArithE (FinInt sz₂)
--   | Select: (sz: Nat) → (b: FinInt 1) → (lhs rhs: FinInt sz) →
--           ArithE (FinInt sz)

def unary_semantics_op (op: IOp Δ)
      (ctor: {sz: Nat} → FinInt sz → FinInt sz): OpM Δ (TypedArgs Δ) :=
  match op with
  | IOp.mk _ _ [⟨.int sgn sz, arg⟩]  [] _ => do
      let r := ctor arg
      return [⟨.int sgn sz, r⟩]
  | IOp.mk name .. =>  OpM.Unhandled s!"unary_semantics_op: unhandled {name}"

def binary_semantics_op {Δ: Dialect α' σ' ε'}
      (name: String) (args: List ((τ: MLIRType Δ) × τ.eval))
      (ctor: {sz: Nat} → FinInt sz → FinInt sz → FinInt sz): OpM Δ (TypedArgs Δ) :=
  match args with
  | [⟨.int sgn sz, lhs⟩, ⟨.int sgn' sz', rhs⟩] =>
      if EQ: sgn = sgn' /\ sz = sz' then  do
        let r := ctor lhs (EQ.2 ▸ rhs)
        return [⟨.int sgn sz, r⟩]
      else OpM.Unhandled s!"binary_semantics_op: sgn != sgn' || sz != sz': {name}"
  | _ => OpM.Unhandled s!"binary_semantics_op: unhandled {name}"

def cmpIndex (pred : ComparisonPred) (lhs rhs: Int): FinInt 1 :=
      let b: Bool :=
        match pred with
        | .eq  => lhs = rhs
        | .ne  => lhs != rhs
        | .slt => lhs <  rhs
        | .sle => lhs <= rhs
        | .sgt => lhs >  rhs
        | .sge => lhs >= rhs
        | .ult => lhs <  rhs
        | .ule => lhs <= rhs
        | .ugt => lhs >  rhs
        | .uge => lhs >= rhs
      FinInt.ofInt 1 (if b then 1 else 0)

def cmpI (sz : ℕ) (pred : ComparisonPred) (lhs: FinInt sz) (rhs: FinInt sz): FinInt 1 :=
      let b: Bool :=
        match pred with
        | .eq  => lhs = rhs
        | .ne  => lhs != rhs
        | .slt => lhs.toSint <  rhs.toSint
        | .sle => lhs.toSint <= rhs.toSint
        | .sgt => lhs.toSint >  rhs.toSint
        | .sge => lhs.toSint >= rhs.toSint
        | .ult => lhs.toUint <  rhs.toUint
        | .ule => lhs.toUint <= rhs.toUint
        | .ugt => lhs.toUint >  rhs.toUint
        | .uge => lhs.toUint >= rhs.toUint
      FinInt.ofInt 1 (if b then 1 else 0)

def arith_semantics_op (o: IOp Δ): OpM Δ (TypedArgs Δ) :=
  match o with
  | IOp.mk "arith.constant" [τ₁] [] [] attrs =>
      match AttrDict.find attrs "value" with
      | some (.int value τ₂) =>
          if τ₁ = τ₂ then
            match τ₂ with
            | .int sgn sz => do
                -- TODO: Check range of constants
                let v := FinInt.ofInt sz value
                return [⟨.int sgn sz, v⟩]
            | .index => do
                return [⟨.index, value⟩]
            | _ => OpM.Error s! "arith.constant: unknown type {τ₂}"
          else OpM.Error "arith.constant: retty not equal to value ty"
      | some _
      | nofne => OpM.Error "arith.constant: cannot find value"

  | IOp.mk "arith.cmpi" _ [ ⟨(.int sgn sz), lhs⟩, ⟨(.int sgn' sz'), rhs⟩ ] []
    attrs =>
      if EQ: sgn = sgn' /\ sz = sz' then
            match attrs.find "predicate" with
            | some (.int n (.int .Signless 64)) =>
                match (ComparisonPred.ofInt n) with
                | some pred => do
                  let r := cmpI sz pred lhs (EQ.2 ▸ rhs)
                  return [⟨.i1, r⟩]
                | none => OpM.Unhandled "arith.cmpi"
            | some _
            | none => OpM.Unhandled "arith.cmpi"
      else OpM.Unhandled "arith.cmpi"

  | IOp.mk "arith.cmpi" _ [ ⟨.index, lhs⟩, ⟨.index, rhs⟩ ] [] attrs =>
      match attrs.find "predicate" with
      | some (.int n (.int .Signless 64)) =>
          match (ComparisonPred.ofInt n) with
          | some pred => do
            let r := cmpIndex pred lhs rhs
            return [⟨.i1, r⟩]
          | none => OpM.Unhandled "arith.cmpi"
      | some _
      | none => OpM.Unhandled "arith.cmpi"

  | IOp.mk "arith.zext" [.int sgn₂ sz₂] [⟨.int sgn₁ sz₁, value⟩]  [] _ =>
      if sgn₁ = sgn₂ then do
        let r :=  FinInt.zext sz₂ value
        return [⟨.int sgn₂ sz₂, r⟩]
      else OpM.Unhandled "arith.zext"

  | IOp.mk "arith.select" _ [⟨.i1, b⟩, ⟨.int sgn sz, lhs⟩, ⟨.int sgn' sz', rhs⟩]  [] _ =>
      if EQ: sgn = sgn' /\ sz = sz' then  do
        let r := if b.toUint = 1 then lhs else (EQ.2 ▸ rhs)
        return [⟨.int sgn sz, r⟩]
      else OpM.Unhandled "arith.select"
  | IOp.mk "arith.negi" .. =>
      unary_semantics_op o FinInt.neg
  | IOp.mk name _ args _ _  =>
      if name = "arith.addi" then
        binary_semantics_op name args FinInt.add
      else if name = "arith.subi" then
        binary_semantics_op name args FinInt.sub
      else if name = "arith.andi" then
        binary_semantics_op name args FinInt.and
      else if name = "arith.ori" then
        binary_semantics_op name args FinInt.or
      else if name = "arith.xori" then
        binary_semantics_op name args FinInt.xor
      else
        OpM.Unhandled (s!"generic_check {name}")

instance: Semantics arith where
  semantics_op := arith_semantics_op

/-
### Semantics of individual operations

In principle we would compute the semantics of entire programs simply by
unfolding the definitions. But simp and dsimp have many problems which makes
this extremely slow, buggy, or infeasible even for programs with only a couple
of operations. We work around this issue by precomputing the semantics of
individual operations and then substituting them as needed.
-/

private abbrev ops.constant (output: SSAVal) (value: Int):
    Op arith :=
  Op.mk "arith.constant" [⟨output, .i32⟩] [] [] (.mk [.mk "value" (.int value .i32)])

private abbrev ops.negi (output input: SSAVal): Op arith :=
  .mk "arith.negi" [⟨output, .i32⟩] [⟨input, .i32⟩] [] (.mk [])

private abbrev ops.zext (sz₁ sz₂: Nat) (output input: SSAVal): Op arith :=
  .mk "arith.zext" [⟨output, .int .Signless sz₂⟩] [⟨input, .int .Signless sz₁⟩] [] (.mk [])

private abbrev ops.select (output cond t f: SSAVal): Op arith :=
  .mk "arith.select" [⟨output, .i32⟩] [⟨cond, .i1⟩, ⟨t, .i32⟩, ⟨f, .i32⟩] [] (.mk [])

private abbrev ops._binary (name: String) (output lhs rhs: SSAVal):
    Op arith :=
  .mk name [⟨output, .i32⟩] [⟨lhs, .i32⟩, ⟨rhs, .i32⟩] [] (.mk [])

private abbrev ops.addi := ops._binary "arith.addi"
private abbrev ops.subi := ops._binary "arith.subi"
private abbrev ops.andi := ops._binary "arith.andi"
private abbrev ops.ori  := ops._binary "arith.ori"
private abbrev ops.xori := ops._binary "arith.xori"

/-

The great Commenting
====================

Everything below assumes we have a handle + semantics, which makes
things quite complex. Now that we have removed the handle, the hope
is that we can recover the semantics proofs in a much easier fashion.

private theorem ops.constant.sem output value:
    denoteOp arith (ops.constant output value) =
  Fitree.Vis (E := SSAEnvE arith +' Semantics.E arith +' UBE)
    (Sum.inl <| SSAEnvE.Set .i32 output (FinInt.ofInt 32 value)) fun _ =>
  Fitree.ret (TypedArgs.Next (δ := arith)
    ⟨.i32, FinInt.ofInt 32 value⟩) := by
  simp [ops.constant, denoteOp, denoteOpBase, Semantics.semantics_op]
  simp_itree
  simp [arith_semantics_op]
  simp [List.map]

private theorem ops.negi.sem output input:
    denoteOp arith (ops.negi output input) =
  Fitree.Vis (E := SSAEnvE arith +' Semantics.E arith +' UBE)
    (Sum.inl <| SSAEnvE.Get .i32 input) fun r =>
  Fitree.Vis (Sum.inr <| Sum.inl <| ArithE.NegI 32 r) fun r =>
  Fitree.Vis (Sum.inl <| SSAEnvE.Set .i32 output r) fun _ =>
  Fitree.ret (TypedArgs.Next ⟨.i32, r⟩) := by
  simp [ops.negi, denoteOp, denoteOpBase, Semantics.semantics_op]
  simp_itree

private theorem ops.zext.sem sz₁ sz₂ output input:
    denoteOp arith (ops.zext sz₁ sz₂ output input) =
  Fitree.Vis (E := SSAEnvE arith +' Semantics.E arith +' UBE)
    (Sum.inl <| @SSAEnvE.Get _ _ _ _ (.int .Signless sz₁) (instInhabitedEval _) input) fun r =>
  Fitree.Vis (Sum.inr <| Sum.inl <| ArithE.Zext sz₁ sz₂ r) fun r =>
  Fitree.Vis (Sum.inl <| SSAEnvE.Set (.int .Signless sz₂) output r) fun _ =>
  Fitree.ret (TypedArgs.Next ⟨.int .Signless sz₂, r⟩) := by
  simp [ops.zext, denoteOp, denoteOpBase, Semantics.semantics_op]
  simp_itree

private theorem ops.select.sem output cond t f:
    denoteOp arith (ops.select output cond t f) =
  Fitree.Vis (E := SSAEnvE arith +' UBE)
    (Sum.inl <| SSAEnvE.Get .i1 cond) fun cond =>
  Fitree.Vis (E := SSAEnvE arith +' UBE)
    (Sum.inl <| SSAEnvE.Get .i32 t) fun t =>
  Fitree.Vis (E := SSAEnvE arith +' UBE)
    (Sum.inl <| SSAEnvE.Get .i32 f) fun f =>
  Fitree.Vis (Sum.inr <| Sum.inl <| ArithE.Select 32 cond t f) fun r =>
  Fitree.Vis (Sum.inl <| SSAEnvE.Set .i32 output r) fun _ =>
  Fitree.ret (TypedArgs.Next ⟨.i32, r⟩) := by
  simp [ops.select, denoteOp, denoteOpBase, Semantics.semantics_op]
  simp_itree

private theorem ops._binary.sem name ctor output lhs rhs:
    (forall (n m: FinInt 32),
      arith_semantics_op (Δ := arith)
        (IOp.mk name [.i32] [⟨.i32, n⟩, ⟨.i32, m⟩] [] 0 (.mk []))  =
      binary_semantics_op name [⟨.i32, n⟩, ⟨.i32, m⟩] ctor) →
    denoteOp arith (ops._binary name output lhs rhs) =
  Fitree.Vis (E := SSAEnvE arith +' Semantics.E arith +' UBE)
    (Sum.inl <| SSAEnvE.Get .i32 lhs) fun lhs =>
  Fitree.Vis (Sum.inl <| SSAEnvE.Get .i32 rhs) fun rhs =>
  Fitree.Vis (Sum.inr <| Sum.inl <| ctor 32 lhs rhs) fun r =>
  Fitree.Vis (Sum.inl <| SSAEnvE.Set .i32 output r) fun _ =>
  Fitree.ret (TypedArgs.Next ⟨.i32, r⟩) := by
  intro h
  simp [denoteOp, denoteOpBase, Semantics.semantics_op]
  simp [List.zip, List.zipWith, List.mapM, List.map]
  simp [h];
  sorry -- the proof broke when updating to the new Lean version.

private abbrev ops.addi.sem output lhs rhs :=
  ops._binary.sem "arith.addi" ArithE.AddI output lhs rhs (fun _ _ => rfl)
private abbrev ops.subi.sem output lhs rhs :=
  ops._binary.sem "arith.subi" ArithE.SubI output lhs rhs (fun _ _ => rfl)
private abbrev ops.andi.sem output lhs rhs :=
  ops._binary.sem "arith.andi" ArithE.AndI output lhs rhs (fun _ _ => rfl)
private abbrev ops.ori.sem output lhs rhs :=
  ops._binary.sem "arith.ori" ArithE.OrI output lhs rhs (fun _ _ => rfl)
private abbrev ops.xori.sem output lhs rhs :=
  ops._binary.sem "arith.xori" ArithE.XorI output lhs rhs (fun _ _ => rfl)

/-
### Basic examples
-/

private def cst1: BasicBlock arith := [mlir_bb|
  ^bb:
    %true = "arith.constant" () {value = 1: i1}: () -> i1
    %false = "arith.constant" () {value = 0: i1}: () -> i1
    %r1 = "arith.constant" () {value = 25: i32}: () -> i32
    %r2 = "arith.constant" () {value = 17: i32}: () -> i32
    %r = "arith.addi" (%r1, %r2): (i32, i32) -> i32
    %s = "arith.subi" (%r2, %r): (i32, i32) -> i32
    %b1 = "arith.cmpi" (%r, %r1) {predicate = 5 /- sge -/}: (i32, i32) -> i1
    %b2 = "arith.cmpi" (%r2, %r) {predicate = 8 /- ugt -/}: (i32, i32) -> i1
]

#eval run (Δ := arith) ⟦cst1⟧ (SSAEnv.empty (δ := arith))
-/

/-
### Rewriting heorems
-/

/- Commutativity of addition -/

namespace th1
def LHS: Op arith := [mlir_op|
  %r = "arith.addi"(%n, %m): (i32, i32) -> i32
]
def RHS: Op arith := [mlir_op|
  %r = "arith.addi"(%m, %n): (i32, i32) -> i32
]

theorem equivalent (n m: FinInt 32):
    run ⟦LHS⟧ (SSAEnv.One [ ("n", ⟨.i32, n⟩), ("m", ⟨.i32, m⟩) ]) =
    run ⟦RHS⟧ (SSAEnv.One [ ("n", ⟨.i32, n⟩), ("m", ⟨.i32, m⟩) ]) := by
  simp [LHS, RHS,
        run, StateT.run,
        denoteOp, bind, List.mapM, StateT.bind, denoteOpArgs, List.mapM,
        List.mapM.loop, Except.bind, TopM.get, StateT.get, pure, Except.pure,
        StateT.pure, TopM.mapDenoteRegion, OpM.toTopM, TopM.set, StateT.set, MLIRType.eval,
        SSAEnv.get, SSAEnv.getT, cast];
  simp [FinInt.add_comm']

def th1 : PeepholeRewriteOp arith :=
{
  findRoot := MTerm.buildOp "arith.addi"
        [MTerm.buildOperand "n" .i32, MTerm.buildOperand "m" .i32]
        [MTerm.buildOperand "r" .i32]
  , findSubtree := []
  , replaceSubtree := [MTerm.buildOp "arith.addi"
        [MTerm.buildOperand "m" .i32, MTerm.buildOperand "n" .i32]
        [MTerm.buildOperand "r" .i32]]
  , wellformed := by {
     intros toplevelProg _prog matchCtx replacedProg matchctx domctx
     intros MATCH FIND SUBST DOMFIND
     simp [List.append] at *;
     sorry
  }
  , correct := by {
     intros toplevelProg _prog matchCtx replacedProg matchctx domctx
     intros MATCH FIND SUBST DOMFIND
     simp [List.append] at *;
     simp [MTerm.concretizeProg, List.mapM, List.mapM.loop] at FIND;
     simp [MTerm.concretizeOp, MTerm.buildOp, MTerm.concretizeOperands, MTerm.concretizeOperand, MTerm.buildOperand,
        MTerm.concretizeVariable, List.mapM, List.mapM.loop] at FIND;
      -- cases on the MTerm.getVariable and show that we must have such a variable.
      -- then generalize on this.
      sorry

  }
}

end th1

/- LLVM InstCombine: `C-(X+C2) --> (C-C2)-X`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L1794 -/

theorem FinInt.sub_add_dist: forall (C X C2: FinInt sz),
    C - (X + C2) = (C - C2) - X := by
  intros C X C2
  apply eq_of_toUint_cong2
  simp [cong2, FinInt.sub_toUint, FinInt.add_toUint]
  apply FinInt.mod2_fequal
  simp [Int.sub_add_dist, Int.sub_assoc]

/-

namespace th2
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %t = "arith.addi"(%X, %C2): (i32, i32) -> i32
    %r = "arith.subi"(%C, %t): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %t = "arith.subi"(%C, %C2): (i32, i32) -> i32
    %r = "arith.subi"(%t, %X): (i32, i32) -> i32
]
def INPUT (C X C2: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("C", ⟨.i32, C⟩), ("X", ⟨.i32, X⟩), ("C2", ⟨.i32, C2⟩)
]

theorem equivalent (C X C2: FinInt 32):
    semanticPostCondition₂
      (run ⟦LHS⟧ (INPUT C X C2))
      (run ⟦RHS⟧ (INPUT C X C2))
    fun _ env₁ _ env₂ =>
      env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [LHS, RHS, INPUT]
  simp [run, denoteBB, denoteOps, denoteOp, denoteOpBase]; simp_itree
  apply FinInt.sub_add_dist

/-
-- This proof works, but triggers a Lean performance issue and basically loops.
-- During testing, the trigger was unfolding `denoteTypedArgs`, though the
-- culprit is specifically the combination of conditions that led to reducing
-- WF-induction proofs within the terms. Changing `denoteTypedArgs` to a simple
-- event `SSAEnvE.SetMultiple` did not eliminate the problem.
theorem equivalent2 (C X C2: FinInt 32):
    (run ⟦LHS⟧ (INPUT C X C2) |>.snd.get "r" .i32) =
    (run ⟦RHS⟧ (INPUT C X C2) |>.snd.get "r" .i32) := by
  simp [LHS, RHS, INPUT, run, Semantics.handle]
  simp [denoteBB, denoteBBStmts]
  rw [ops.addi.sem]
  rw [ops.subi.sem]
  rw [ops.subi.sem]
  rw [ops.subi.sem]
  simp [interpUB'_bind]
  simp [interpSSA'_bind]
  repeat conv in SSAEnvE.handle _ _ => simp [SSAEnvE.handle]
  simp [Fitree.interp_bind]
  repeat conv in ArithE.handle _ _ => simp [ArithE.handle]
  simp [cast_eq]
  repeat conv in SSAEnvE.handle _ _ => simp [SSAEnvE.handle]
  simp [cast_eq]
  apply FinInt.sub_add_dist
-/
end th2

/- LLVM InstCombine: `~X + C --> (C-1) - X`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L882 -/

theorem FinInt.comp_add: sz > 0 → forall (X C: FinInt sz),
    (X ^^^ -1) + C = (C - 1) - X := by
  intros h_sz X C
  simp [←FinInt.comp_eq_xor_minusOne]
  apply eq_of_toUint_cong2
  simp [cong2, FinInt.add_toUint, FinInt.comp_toUint, FinInt.sub_toUint]
  simp [toUint_ofNat]
  have h: Int.ofNat 1 = 1 := by decide
  simp [h, mod2_idem ⟨by decide, Int.one_lt_two_pow h_sz⟩]
  simp [Int.sub_eq_add_neg, Int.add_assoc, FinInt.mod2_add_left]
  rw [←@Int.add_assoc _ (-1) _, @Int.add_comm _ (-1)]
  simp [@Int.add_comm (-X.toUint), Int.add_assoc]

namespace th3
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.negi"(%_1): (i32) -> i32
    %_3 = "arith.xori"(%X, %_2): (i32, i32) -> i32
    %r = "arith.addi"(%_3, %C): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %o = "arith.constant"() {value = 1: i32}: () -> i32
    %t = "arith.subi"(%C, %o): (i32, i32) -> i32
    %r = "arith.subi"(%t, %X): (i32, i32) -> i32
]
def INPUT (C X: FinInt 32): SSAEnv arith := SSAEnv.One [
    ("C", ⟨.i32, C⟩), ("X", ⟨.i32, X⟩)
]

theorem equivalent (C X: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT C X))
    (run ⟦RHS⟧ (INPUT C X))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  -- TODO: If we could simplify `denoteTypedArgs` we could save a lot of work
  -- TODO: here. But it triggers the WF-induction bug, so we instead we unfold
  -- TODO: the SSA stuff later. Investigate.
  simp [INPUT, LHS, RHS, run, denoteOps, denoteBB]
  rw [ops.constant.sem]
  rw [ops.negi.sem]
  rw [ops.xori.sem]
  rw [ops.addi.sem]
  rw [ops.constant.sem]
  rw [ops.subi.sem]
  rw [ops.subi.sem]
  simp [interpSSA', Fitree.interpState, SSAEnvE.handle]; simp_itree
  apply FinInt.comp_add (by decide)
end th3

/- LLVM InstCombine: `-A + -B --> -(A + B)`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L1316 -/

theorem FinInt.neg_add_dist (A B: FinInt sz):
    -(A + B) = -A + -B := by
  apply eq_of_toUint_cong2
  simp [cong2, neg_toUint, add_toUint]
  apply mod2_fequal
  simp [Int.neg_add]

namespace th4
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.negi"(%A): (i32) -> i32
    %_2 = "arith.negi"(%B): (i32) -> i32
    %r = "arith.addi"(%_1, %_2): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.addi"(%A, %B): (i32, i32) -> i32
    %r = "arith.negi"(%_1): (i32) -> i32
]
def INPUT (A B: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("A", ⟨.i32, A⟩), ("B", ⟨.i32, B⟩)
]

theorem equivalent (A B: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT A B))
    (run ⟦RHS⟧ (INPUT A B))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [LHS, RHS, INPUT]
  simp [run, denoteBB, denoteOps, denoteOp, denoteOpBase]; simp_itree
  rw [FinInt.neg_add_dist]
end th4

/- LLVM InstCombine: `-(X - Y) --> (Y - X)`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L2290 -/

theorem FinInt.neg_sub_dist (X Y: FinInt sz):
    -(X - Y) = Y - X := by
  apply eq_of_toUint_cong2
  simp [cong2, neg_toUint, sub_toUint]
  apply mod2_fequal
  simp [Int.neg_sub]

namespace th5
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.subi"(%X, %Y): (i32, i32) -> i32
    %r = "arith.negi"(%_1): (i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %r = "arith.subi"(%Y, %X): (i32, i32) -> i32
]
def INPUT (X Y: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("X", ⟨.i32, X⟩), ("Y", ⟨.i32, Y⟩)
]

theorem equivalent (X Y: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT X Y))
    (run ⟦RHS⟧ (INPUT X Y))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [LHS, RHS, INPUT]
  simp [run, denoteBB, denoteOps, denoteOp, denoteOpBase]; simp_itree
  apply FinInt.neg_sub_dist
end th5

/- LLVM InstCombine: `(A + 1) + ~B --> A - B`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L1331 -/

theorem FinInt.plus_one_plus_comp (A B: FinInt sz):
    (A + 1) + (B ^^^ -1) = A - B := by
  simp [←FinInt.comp_eq_xor_minusOne]
  apply eq_of_toUint_cong2
  simp [cong2, neg_toUint, add_toUint, sub_toUint, comp_toUint]
  simp [toUint_ofNat, (by decide: Int.ofNat 1 = 1)]
  -- Rearranging terms without the powerful Mathlib tactics is quite tedious
  simp [Int.add_comm _ (mod2 _ _), Int.add_assoc]
  simp [Int.sub_eq_add_neg]
  simp [←@Int.add_assoc A.toUint _, Int.add_comm A.toUint _]
  simp [←@Int.add_assoc 1 _, Int.add_comm 1 _]
  simp [Int.add_assoc, mod2_add_left]
  simp [Int.add_comm _ 1, ←Int.add_assoc _ 1 _, Int.add_assoc 1 _ _]
  simp [←Int.add_assoc, Int.add_right_neg, Int.zero_add]

namespace th6
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.addi"(%A, %_1): (i32, i32) -> i32
    %_3 = "arith.negi"(%_1): (i32) -> i32
    %_4 = "arith.xori"(%B, %_3): (i32, i32) -> i32
    %r = "arith.addi"(%_2, %_4): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %r = "arith.subi"(%A, %B): (i32, i32) -> i32
]
def INPUT (A B: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("A", ⟨.i32, A⟩), ("B", ⟨.i32, B⟩)
]

theorem equivalent (A B: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT A B))
    (run ⟦RHS⟧ (INPUT A B))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [INPUT, LHS, RHS, run, denoteOps, denoteBB]
  rw [ops.constant.sem]
  rw [ops.addi.sem]
  rw [ops.negi.sem]
  rw [ops.xori.sem]
  rw [ops.addi.sem]
  rw [ops.subi.sem]
  simp [interpSSA', Fitree.interpState, SSAEnvE.handle]; simp_itree
  apply FinInt.plus_one_plus_comp
end th6

/- LLVM InstCombine: `(~X) - (~Y) --> Y - X`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L1867 -/

theorem FinInt.comp_sub_comp (X Y: FinInt sz):
    (X ^^^ -1) - (Y ^^^ -1) = Y - X := by
  simp [←FinInt.comp_eq_xor_minusOne]
  apply eq_of_toUint_cong2
  simp [cong2, sub_toUint, comp_toUint]
  simp [Int.sub_eq_add_neg, Int.add_assoc, Int.neg_add, Int.neg_neg]
  simp [mod2_add_left]
  simp [←Int.add_assoc]
  rw [Int.add_comm _ (-_)]
  have h x: mod2 (-(2^sz) + x) sz = mod2 x sz := by sorry_arith
  simp [Int.add_assoc, h]
  rw [←Int.add_assoc (-1) _ _, Int.add_comm (-1) _]
  rw [Int.add_assoc _ (-1) _, ←Int.add_assoc _ 1 _]
  rw [Int.add_left_neg, Int.zero_add, Int.add_comm]

namespace th7
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.negi"(%_1): (i32) -> i32
    %_3 = "arith.xori"(%X, %_2): (i32, i32) -> i32
    %_4 = "arith.xori"(%Y, %_2): (i32, i32) -> i32
    %r = "arith.subi"(%_3, %_4): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %r = "arith.subi"(%Y, %X): (i32, i32) -> i32
]
def INPUT (X Y: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("X", ⟨.i32, X⟩), ("Y", ⟨.i32, Y⟩)
]

theorem equivalent (X Y: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT X Y))
    (run ⟦RHS⟧ (INPUT X Y))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [INPUT, LHS, RHS, run, denoteBB, denoteOps]
  rw [ops.constant.sem]
  rw [ops.negi.sem]
  rw [ops.xori.sem]
  rw [ops.xori.sem]
  rw [ops.subi.sem]
  rw [ops.subi.sem]
  simp [interpSSA', Fitree.interpState, SSAEnvE.handle]; simp_itree
  apply FinInt.comp_sub_comp
end th7

/- LLVM InstCombine: `(add (xor A, B) (and A, B)) --> (or A, B)`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L1411 -/

theorem FinInt.addfull_xor_and (A B: FinInt sz):
    addfull (A ^^^ B) (A &&& B) = .next false (A ||| B) := by
  induction sz with
  | zero => cases A; cases B; decide
  | succ sz ih =>
    match A, B with
    | next bA A', next bB B' =>
      simp [HXor.hXor, HAnd.hAnd, HOr.hOr, xor, and, or, logic2] at *
      simp [addfull, ih]
      cases bA <;> cases bB <;> decide;

theorem FinInt.add_xor_and (A B: FinInt sz):
    (A ^^^ B) + (A &&& B) = (A ||| B) := by
  simp [HAdd.hAdd, add, addfull_xor_and]

namespace th8
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.xori"(%A, %B): (i32, i32) -> i32
    %_2 = "arith.andi"(%A, %B): (i32, i32) -> i32
    %r = "arith.addi"(%_1, %_2): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %r = "arith.ori"(%A, %B): (i32, i32) -> i32
]
def INPUT (A B: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("A", ⟨.i32, A⟩), ("B", ⟨.i32, B⟩)
]

theorem equivalent (A B: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT A B))
    (run ⟦RHS⟧ (INPUT A B))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [LHS, RHS, INPUT]
  simp [run, denoteBB, denoteOps, denoteOp, denoteOpBase]; simp_itree
  apply FinInt.add_xor_and
end th8

/- LLVM InstCombine: `zext(bool) + C --> bool ? C + 1 : C`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAddSub.cpp#L873 -/

theorem FinInt.add_bool_eq_select (B: FinInt 1) (C: FinInt 32):
    zext 32 B + C = select B (C + 1) C := by
  apply eq_of_toUint_cong2
  simp [cong2, add_toUint]
  rw [zext_toUint' (by decide)]
  cases bool_cases B <;> subst B <;> simp [select, Int.add_assoc, Int.zero_add]
  rw [add_toUint]
  simp [toUint, (by decide: 2^0 = 1), Int.add_zero]
  simp [Int.add_comm]

namespace th9
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.zext"(%B): (i1) -> i32
    %r = "arith.addi"(%_1, %C): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.addi"(%C, %_1): (i32, i32) -> i32
    %r = "arith.select"(%B, %_2, %C): (i1, i32, i32) -> i32
]
def INPUT (B: FinInt 1) (C: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("B", ⟨.i1, B⟩), ("C", ⟨.i32, C⟩)
]

theorem equivalent (B: FinInt 1) (C: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT B C))
    (run ⟦RHS⟧ (INPUT B C))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [LHS, RHS, INPUT]
  simp [run, denoteBB, denoteOps, denoteOp, denoteOpBase]; simp_itree
  simp [List.map, Semantics.semantics_op, arith_semantics_op]; simp_itree
  apply FinInt.add_bool_eq_select
end th9

/- LLVM InstCombine: `(A & ~B) & ~C --> A & ~(B | C)`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAndOrXor.cpp#L1340 -/

theorem FinInt.and_not_and_not (A B C: FinInt sz):
    (A &&& (B ^^^ -1)) &&& (C ^^^ -1) = A &&& ((B ||| C) ^^^ -1) := by
  simp [←comp_eq_xor_minusOne]
  induction sz with
  | zero => cases A; cases B; cases C; decide
  | succ sz ih =>
      match A, B, C with
      | .next bA A', .next bB B', .next bC C' =>
          simp [HAnd.hAnd, HOr.hOr, and, or, comp] at *
          simp [logic2, ih]
          cases bA <;> cases bB <;> cases bC <;> decide

namespace th10
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.negi"(%_1): (i32) -> i32
    %_3 = "arith.xori"(%B, %_2): (i32, i32) -> i32
    %_4 = "arith.andi"(%A, %_3): (i32, i32) -> i32
    %_5 = "arith.xori"(%C, %_2): (i32, i32) -> i32
    %r = "arith.andi"(%_4, %_5): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.negi"(%_1): (i32) -> i32
    %_3 = "arith.ori"(%B, %C): (i32, i32) -> i32
    %_4 = "arith.xori"(%_3, %_2): (i32, i32) -> i32
    %r = "arith.andi"(%A, %_4): (i32, i32) -> i32
]
def INPUT (A B C: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("A", ⟨.i32, A⟩), ("B", ⟨.i32, B⟩), ("C", ⟨.i32, C⟩)
]

theorem equivalent (A B C: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT A B C))
    (run ⟦RHS⟧ (INPUT A B C))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [INPUT, LHS, RHS, run, denoteBB, denoteOps]
  rw [ops.constant.sem]
  rw [ops.negi.sem]
  rw [ops.xori.sem]
  rw [ops.andi.sem]
  rw [ops.xori.sem]
  rw [ops.andi.sem]
  rw [ops.ori.sem]
  rw [ops.xori.sem]
  rw [ops.andi.sem]
  simp [interpSSA', Fitree.interpState, SSAEnvE.handle]; simp_itree
  apply FinInt.and_not_and_not
end th10

/- LLVM InstCombine: `(A & B) | ~(A | B) --> ~(A ^ B)`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAndOrXor.cpp#L1510 -/

theorem FinInt.and_or_not_or (A B: FinInt sz):
    (A &&& B) ||| ((A ||| B) ^^^ -1) = ((A ^^^ B) ^^^ -1) := by
  simp [←comp_eq_xor_minusOne]
  induction sz with
  | zero => cases A; cases B; decide
  | succ sz ih =>
      match A, B with
      | .next bA A', .next bB B' =>
          simp [HXor.hXor, HAnd.hAnd, HOr.hOr, xor, and, or, comp] at *
          simp [logic1, logic2, ih]
          cases bA <;> cases bB <;> decide

namespace th11
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.negi"(%_1): (i32) -> i32
    %_3 = "arith.ori"(%A, %B): (i32, i32) -> i32
    %_4 = "arith.xori"(%_3, %_2): (i32, i32) -> i32
    %_5 = "arith.andi"(%A, %B): (i32, i32) -> i32
    %r = "arith.ori"(%_5, %_4): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.constant"() {value = 1: i32}: () -> i32
    %_2 = "arith.negi"(%_1): (i32) -> i32
    %_3 = "arith.xori"(%A, %B): (i32, i32) -> i32
    %r = "arith.xori"(%_3, %_2): (i32, i32) -> i32
]
def INPUT (A B: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("A", ⟨.i32, A⟩), ("B", ⟨.i32, B⟩)
]

theorem equivalent (A B: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT A B))
    (run ⟦RHS⟧ (INPUT A B))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [INPUT, LHS, RHS, run, denoteBB, denoteOps]
  rw [ops.constant.sem]
  rw [ops.negi.sem]
  rw [ops.ori.sem]
  rw [ops.xori.sem]
  rw [ops.andi.sem]
  rw [ops.ori.sem]
  rw [ops.xori.sem]
  rw [ops.xori.sem]
  simp [interpSSA', Fitree.interpState, SSAEnvE.handle]; simp_itree
  apply FinInt.and_or_not_or
end th11

/- LLVM InstCombine: `(X ^ C1) & C2 --> (X & C2) ^ (C1&C2)`
   https://github.com/llvm/llvm-project/blob/291e3a85658e264a2918298e804972bd68681af8/llvm/lib/Transforms/InstCombine/InstCombineAndOrXor.cpp#L1778 -/

theorem FinInt.xor_and (X C₁ C₂: FinInt sz):
    (X ^^^ C₁) &&& C₂ = (X &&& C₂) ^^^ (C₁ &&& C₂) := by
  induction sz with
  | zero => cases X; cases C₁; cases C₂; decide
  | succ sz ih =>
      match X, C₁, C₂ with
      | .next bX X', .next bC₁ C₁', .next bC₂ C₂' =>
          simp [HXor.hXor, HAnd.hAnd, HOr.hOr, xor, and, or] at *
          simp [logic2, ih]
          cases bX <;> cases bC₁ <;> cases bC₂ <;> decide

namespace th12
def LHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.xori"(%X, %C1): (i32, i32) -> i32
    %r = "arith.andi"(%_1, %C2): (i32, i32) -> i32
]
def RHS: BasicBlock arith := [mlir_bb|
  ^bb:
    %_1 = "arith.andi"(%X, %C2): (i32, i32) -> i32
    %_2 = "arith.andi"(%C1, %C2): (i32, i32) -> i32
    %r = "arith.xori"(%_1, %_2): (i32, i32) -> i32
]
def INPUT (X C₁ C₂: FinInt 32): SSAEnv arith := SSAEnv.One [
  ("X", ⟨.i32, X⟩), ("C1", ⟨.i32, C₁⟩), ("C2", ⟨.i32, C₂⟩)
]

theorem equivalent (X C₁ C₂: FinInt 32):
  semanticPostCondition₂
    (run ⟦LHS⟧ (INPUT X C₁ C₂))
    (run ⟦RHS⟧ (INPUT X C₁ C₂))
  fun _ env₁ _ env₂ =>
    env₁.get "r" .i32 = env₂.get "r" .i32 := by
  simp [LHS, RHS, INPUT]
  simp [run, denoteBB, denoteOps, denoteOp, denoteOpBase]; simp_itree
  apply FinInt.xor_and
end th12
-/


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

import for_mathlib.algebraic_topology.homotopical_algebra.model_category
import category_theory.limits.comma

noncomputable theory

namespace category_theory

namespace limits

variables {C J : Type*} [category C] [category J]

namespace under

@[simp]
def nat_trans {X : C} (F : J ⥤ under X) : (functor.const J).obj X ⟶ F ⋙ under.forget X :=
nat_trans.hcomp (𝟙 F) (comma.nat_trans _ _)

@[simp]
def arrow₁ {X : C} (F : J ⥤ under X) [has_colimit (F ⋙ under.forget _)]
  [has_colimit ((functor.const J).obj X)] : colimit ((functor.const J).obj X) ⟶ colimit (F ⋙ under.forget _) :=
colim_map (under.nat_trans F)

@[simp]
def arrow₂ {X : C} (F : J ⥤ under X) [has_colimit ((functor.const J).obj X)] :
  colimit ((functor.const J).obj X) ⟶ X := colimit.desc _ (cocone.mk X (𝟙 _))

@[simps]
def cocone {X : C} (F : J ⥤ under X) [has_colimit (F ⋙ under.forget _)]
  [has_colimit ((functor.const J).obj X)] [has_pushout (under.arrow₁ F) (under.arrow₂ F)] : cocone F :=
begin
  apply cocone.mk (under.mk (pushout.inr : X ⟶ pushout (under.arrow₁ F) (under.arrow₂ F))),
  exact
  { app := λ j, under.hom_mk ((colimit.ι (F ⋙ under.forget X) j) ≫ pushout.inl) begin
      dsimp,
      have eq : (F.obj j).hom = (under.nat_trans F).app j := (category.comp_id _).symm,
      erw [eq, ← category.assoc, ← ι_colim_map, category.assoc, pushout.condition, ← category.assoc,
        colimit.ι_desc, nat_trans.id_app, category.id_comp],
    end,
    naturality' := λ j j' f, begin
      ext,
      simp only [category.assoc, under.comp_right, under.hom_mk_right, functor.const_obj_map],
      erw [category.comp_id, ← category.assoc],
      congr,
      exact colimit.w (F ⋙ under.forget X) f,
    end },
end

def cocone_is_colimit {X : C} (F : J ⥤ under X) [has_colimit (F ⋙ under.forget _)]
  [has_colimit ((functor.const J).obj X)] [has_pushout (under.arrow₁ F) (under.arrow₂ F)] :
  is_colimit (under.cocone F) :=
{ desc := λ s, begin
    refine under.hom_mk (pushout.desc (colimit.desc _ (cocone.mk s.X.right (s.ι ◫ (𝟙 (under.forget X))))) s.X.hom _) _,
    { ext j,
      simp only [under.arrow₁, under.arrow₂, under.nat_trans, ι_colim_map_assoc,
        nat_trans.hcomp_app, comma.nat_trans_app, nat_trans.id_app, functor.comp_map,
        comma.snd_map, under.id_right, functor.id_map, colimit.ι_desc, category.id_comp,
        nat_trans.hcomp_id_app, under.forget_map, category.assoc, colimit.ι_desc_assoc],
      erw [category.id_comp, under.w],
      refl, },
    { dsimp,
      simp only [pushout.inr_desc], },
  end,
  fac' := λ s j, begin
    ext,
    simp only [colimit.ι_desc, nat_trans.hcomp_id_app, under.forget_map, category.assoc,
      colimit.ι_desc_assoc, category.id_comp, under.w, pushout.inr_desc, under.cocone_ι_app,
      under.comp_right, under.hom_mk_right, pushout.inl_desc],
  end,
  uniq' := λ s m h, begin
    ext j,
    { simp only [colimit.ι_desc, nat_trans.hcomp_id_app, under.forget_map, category.assoc,
        colimit.ι_desc_assoc, category.id_comp, under.w, pushout.inr_desc, under.hom_mk_right,
        pushout.inl_desc, ← h j, under.cocone_ι_app, under.comp_right], },
    { simpa only [pushout.inr_desc, under.hom_mk_right] using under.w m, },
  end, }

def colimit_cocone {X : C} (F : J ⥤ under X) [has_colimit (F ⋙ under.forget _)]
  [has_colimit ((functor.const J).obj X)] [has_pushout (under.arrow₁ F) (under.arrow₂ F)] : colimit_cocone F :=
{ cocone := under.cocone F,
  is_colimit := under.cocone_is_colimit F, }

instance {X : C} (F : J ⥤ under X) [has_colimit (F ⋙ under.forget _)]
  [has_colimit ((functor.const J).obj X)] [has_pushout (under.arrow₁ F) (under.arrow₂ F)] : has_colimit F :=
⟨nonempty.intro (under.colimit_cocone F)⟩

lemma has_colimits_of_shape (X : C) [has_colimits_of_shape J C] [has_pushouts C] :
  has_colimits_of_shape J (under X) := {}

instance (X : C) [has_finite_colimits C] : has_finite_colimits (under X) :=
⟨by { introsI J hJ hJ', apply under.has_colimits_of_shape, }⟩

instance (X : C) [has_finite_limits C] : has_finite_limits (under X) :=
⟨by { introsI J hJ hJ', apply comma.has_limits_of_shape, }⟩

end under

end limits

end category_theory

open category_theory
.
namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C]

instance model_category_under [M : model_category C] (X : C) : model_category (under X) :=
{ to_category_with_fib_cof_weq := M.to_category_with_fib_cof_weq.inverse_image (under.forget X),
  CM1axiom := ⟨infer_instance, infer_instance⟩,
  CM2axiom := CM2axiom.inverse_image (under.forget _),
  CM3axiom := CM3.inverse_image (under.forget _),
  CM4axiom := ⟨CM4a.under X, CM4b.under X⟩,
  CM5axiom := ⟨CM5a.under X, CM5b.under X⟩, }

end model_category

end algebraic_topology


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro
-/
import data.list.join

/-!
# Permutations of a list

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

In this file we prove properties about `list.permutations`, a list of all permutations of a list. It
is defined in `data.list.defs`.

## Order of the permutations

Designed for performance, the order in which the permutations appear in `list.permutations` is
rather intricate and not very amenable to induction. That's why we also provide `list.permutations'`
as a less efficient but more straightforward way of listing permutations.

### `list.permutations`

TODO. In the meantime, you can try decrypting the docstrings.

### `list.permutations'`

The list of partitions is built by recursion. The permutations of `[]` are `[[]]`. Then, the
permutations of `a :: l` are obtained by taking all permutations of `l` in order and adding `a` in
all positions. Hence, to build `[0, 1, 2, 3].permutations'`, it does
* `[[]]`
* `[[3]]`
* `[[2, 3], [3, 2]]]`
* `[[1, 2, 3], [2, 1, 3], [2, 3, 1], [1, 3, 2], [3, 1, 2], [3, 2, 1]]`
* `[[0, 1, 2, 3], [1, 0, 2, 3], [1, 2, 0, 3], [1, 2, 3, 0],`
   `[0, 2, 1, 3], [2, 0, 1, 3], [2, 1, 0, 3], [2, 1, 3, 0],`
   `[0, 2, 3, 1], [2, 0, 3, 1], [2, 3, 0, 1], [2, 3, 1, 0],`
   `[0, 1, 3, 2], [1, 0, 3, 2], [1, 3, 0, 2], [1, 3, 2, 0],`
   `[0, 3, 1, 2], [3, 0, 1, 2], [3, 1, 0, 2], [3, 1, 2, 0],`
   `[0, 3, 2, 1], [3, 0, 2, 1], [3, 2, 0, 1], [3, 2, 1, 0]]`

## TODO

Show that `l.nodup → l.permutations.nodup`. See `data.fintype.list`.
-/

open nat

variables {α β : Type*}

namespace list

lemma permutations_aux2_fst (t : α) (ts : list α) (r : list β) : ∀ (ys : list α) (f : list α → β),
  (permutations_aux2 t ts r ys f).1 = ys ++ ts
| []      f := rfl
| (y::ys) f := match _, permutations_aux2_fst ys _ : ∀ o : list α × list β, o.1 = ys ++ ts →
      (permutations_aux2._match_1 t y f o).1 = y :: ys ++ ts with
  | ⟨_, zs⟩, rfl := rfl
  end

@[simp] lemma permutations_aux2_snd_nil (t : α) (ts : list α) (r : list β) (f : list α → β) :
  (permutations_aux2 t ts r [] f).2 = r := rfl

@[simp] lemma permutations_aux2_snd_cons (t : α) (ts : list α) (r : list β) (y : α) (ys : list α)
  (f : list α → β) :
  (permutations_aux2 t ts r (y::ys) f).2 = f (t :: y :: ys ++ ts) ::
    (permutations_aux2 t ts r ys (λx : list α, f (y::x))).2 :=
match _, permutations_aux2_fst t ts r _ _ : ∀ o : list α × list β, o.1 = ys ++ ts →
   (permutations_aux2._match_1 t y f o).2 = f (t :: y :: ys ++ ts) :: o.2 with
| ⟨_, zs⟩, rfl := rfl
end

/-- The `r` argument to `permutations_aux2` is the same as appending. -/
lemma permutations_aux2_append (t : α) (ts : list α) (r : list β) (ys : list α) (f : list α → β) :
  (permutations_aux2 t ts nil ys f).2 ++ r = (permutations_aux2 t ts r ys f).2 :=
by induction ys generalizing f; simp *

/-- The `ts` argument to `permutations_aux2` can be folded into the `f` argument. -/
lemma permutations_aux2_comp_append {t : α} {ts ys : list α} {r : list β} (f : list α → β) :
  (permutations_aux2 t [] r ys $ λ x, f (x ++ ts)).2 = (permutations_aux2 t ts r ys f).2 :=
begin
  induction ys generalizing f,
  { simp },
  { simp [ys_ih (λ xs, f (ys_hd :: xs))] },
end

lemma map_permutations_aux2' {α β α' β'} (g : α → α') (g' : β → β')
  (t : α) (ts ys : list α) (r : list β) (f : list α → β) (f' : list α' → β')
  (H : ∀ a, g' (f a) = f' (map g a)) :
  map g' (permutations_aux2 t ts r ys f).2 =
  (permutations_aux2 (g t) (map g ts) (map g' r) (map g ys) f').2 :=
begin
  induction ys generalizing f f'; simp *,
  apply ys_ih, simp [H],
end

/-- The `f` argument to `permutations_aux2` when `r = []` can be eliminated. -/
lemma map_permutations_aux2 (t : α) (ts : list α) (ys : list α) (f : list α → β) :
  (permutations_aux2 t ts [] ys id).2.map f = (permutations_aux2 t ts [] ys f).2 :=
begin
  rw [map_permutations_aux2' id, map_id, map_id], refl,
  simp
end

/-- An expository lemma to show how all of `ts`, `r`, and `f` can be eliminated from
`permutations_aux2`.

`(permutations_aux2 t [] [] ys id).2`, which appears on the RHS, is a list whose elements are
produced by inserting `t` into every non-terminal position of `ys` in order. As an example:
```lean
#eval permutations_aux2 1 [] [] [2, 3, 4] id
-- [[1, 2, 3, 4], [2, 1, 3, 4], [2, 3, 1, 4]]
```
-/
lemma permutations_aux2_snd_eq (t : α) (ts : list α) (r : list β) (ys : list α) (f : list α → β) :
  (permutations_aux2 t ts r ys f).2 =
    (permutations_aux2 t [] [] ys id).2.map (λ x, f (x ++ ts)) ++ r :=
by rw [← permutations_aux2_append, map_permutations_aux2, permutations_aux2_comp_append]

lemma map_map_permutations_aux2 {α α'} (g : α → α') (t : α) (ts ys : list α) :
  map (map g) (permutations_aux2 t ts [] ys id).2 =
  (permutations_aux2 (g t) (map g ts) [] (map g ys) id).2 :=
map_permutations_aux2' _ _ _ _ _ _ _ _ (λ _, rfl)

lemma map_map_permutations'_aux (f : α → β) (t : α) (ts : list α) :
  map (map f) (permutations'_aux t ts) = permutations'_aux (f t) (map f ts) :=
by induction ts with a ts ih; [refl, {simp [← ih], refl}]

lemma permutations'_aux_eq_permutations_aux2 (t : α) (ts : list α) :
  permutations'_aux t ts = (permutations_aux2 t [] [ts ++ [t]] ts id).2 :=
begin
  induction ts with a ts ih, {refl},
  simp [permutations'_aux, permutations_aux2_snd_cons, ih],
  simp only [← permutations_aux2_append] {single_pass := tt},
  simp [map_permutations_aux2],
end

lemma mem_permutations_aux2 {t : α} {ts : list α} {ys : list α} {l l' : list α} :
  l' ∈ (permutations_aux2 t ts [] ys (append l)).2 ↔
    ∃ l₁ l₂, l₂ ≠ [] ∧ ys = l₁ ++ l₂ ∧ l' = l ++ l₁ ++ t :: l₂ ++ ts :=
begin
  induction ys with y ys ih generalizing l,
  { simp {contextual := tt} },
  rw [permutations_aux2_snd_cons, show (λ (x : list α), l ++ y :: x) = append (l ++ [y]),
      by funext; simp, mem_cons_iff, ih], split,
  { rintro (rfl | ⟨l₁, l₂, l0, rfl, rfl⟩),
    { exact ⟨[], y::ys, by simp⟩ },
    { exact ⟨y::l₁, l₂, l0, by simp⟩ } },
  { rintro ⟨_ | ⟨y', l₁⟩, l₂, l0, ye, rfl⟩,
    { simp [ye] },
    { simp only [cons_append] at ye, rcases ye with ⟨rfl, rfl⟩,
      exact or.inr ⟨l₁, l₂, l0, by simp⟩ } }
end

lemma mem_permutations_aux2' {t : α} {ts : list α} {ys : list α} {l : list α} :
  l ∈ (permutations_aux2 t ts [] ys id).2 ↔
    ∃ l₁ l₂, l₂ ≠ [] ∧ ys = l₁ ++ l₂ ∧ l = l₁ ++ t :: l₂ ++ ts :=
by rw [show @id (list α) = append nil, by funext; refl]; apply mem_permutations_aux2

lemma length_permutations_aux2 (t : α) (ts : list α) (ys : list α) (f : list α → β) :
  length (permutations_aux2 t ts [] ys f).2 = length ys :=
by induction ys generalizing f; simp *

lemma foldr_permutations_aux2 (t : α) (ts : list α) (r L : list (list α)) :
  foldr (λy r, (permutations_aux2 t ts r y id).2) r L =
    L.bind (λ y, (permutations_aux2 t ts [] y id).2) ++ r :=
by induction L with l L ih; [refl, {simp [ih], rw ← permutations_aux2_append}]

lemma mem_foldr_permutations_aux2 {t : α} {ts : list α} {r L : list (list α)} {l' : list α} :
  l' ∈ foldr (λy r, (permutations_aux2 t ts r y id).2) r L ↔
    l' ∈ r ∨ ∃ l₁ l₂, l₁ ++ l₂ ∈ L ∧ l₂ ≠ [] ∧ l' = l₁ ++ t :: l₂ ++ ts :=
have (∃ (a : list α), a ∈ L ∧
    ∃ (l₁ l₂ : list α), ¬l₂ = nil ∧ a = l₁ ++ l₂ ∧ l' = l₁ ++ t :: (l₂ ++ ts)) ↔
    ∃ (l₁ l₂ : list α), ¬l₂ = nil ∧ l₁ ++ l₂ ∈ L ∧ l' = l₁ ++ t :: (l₂ ++ ts),
from ⟨λ ⟨a, aL, l₁, l₂, l0, e, h⟩, ⟨l₁, l₂, l0, e ▸ aL, h⟩,
      λ ⟨l₁, l₂, l0, aL, h⟩, ⟨_, aL, l₁, l₂, l0, rfl, h⟩⟩,
by rw foldr_permutations_aux2; simp [mem_permutations_aux2', this,
  or.comm, or.left_comm, or.assoc, and.comm, and.left_comm, and.assoc]

lemma length_foldr_permutations_aux2 (t : α) (ts : list α) (r L : list (list α)) :
  length (foldr (λy r, (permutations_aux2 t ts r y id).2) r L) = sum (map length L) + length r :=
by simp [foldr_permutations_aux2, (∘), length_permutations_aux2]

lemma length_foldr_permutations_aux2' (t : α) (ts : list α) (r L : list (list α))
  (n) (H : ∀ l ∈ L, length l = n) :
  length (foldr (λy r, (permutations_aux2 t ts r y id).2) r L) = n * length L + length r :=
begin
  rw [length_foldr_permutations_aux2, (_ : sum (map length L) = n * length L)],
  induction L with l L ih, {simp},
  have sum_map : sum (map length L) = n * length L :=
    ih (λ l m, H l (mem_cons_of_mem _ m)),
  have length_l : length l = n := H _ (mem_cons_self _ _),
  simp [sum_map, length_l, mul_add, add_comm]
end

@[simp] lemma permutations_aux_nil (is : list α) : permutations_aux [] is = [] :=
by rw [permutations_aux, permutations_aux.rec]

@[simp] lemma permutations_aux_cons (t : α) (ts is : list α) :
  permutations_aux (t :: ts) is = foldr (λy r, (permutations_aux2 t ts r y id).2)
    (permutations_aux ts (t::is)) (permutations is) :=
by rw [permutations_aux, permutations_aux.rec]; refl

@[simp] lemma permutations_nil : permutations ([] : list α) = [[]] :=
by rw [permutations, permutations_aux_nil]

lemma map_permutations_aux (f : α → β) : ∀ (ts is : list α),
  map (map f) (permutations_aux ts is) = permutations_aux (map f ts) (map f is) :=
begin
  refine permutations_aux.rec (by simp) _,
  introv IH1 IH2, rw map at IH2,
  simp only [foldr_permutations_aux2, map_append, map, map_map_permutations_aux2, permutations,
    bind_map, IH1, append_assoc, permutations_aux_cons, cons_bind, ← IH2, map_bind],
end

lemma map_permutations (f : α → β) (ts : list α) :
  map (map f) (permutations ts) = permutations (map f ts) :=
by rw [permutations, permutations, map, map_permutations_aux, map]

lemma map_permutations' (f : α → β) (ts : list α) :
  map (map f) (permutations' ts) = permutations' (map f ts) :=
by induction ts with t ts ih; [refl, simp [← ih, map_bind, ← map_map_permutations'_aux, bind_map]]

lemma permutations_append (is ts : list α) :
  permutations (is ++ ts) = (permutations is).map (++ ts) ++ permutations_aux ts is.reverse :=
by simp [permutations, permutations_aux_append]

end list


import for_mathlib.derived.les_facts
import laurent_measures.ses2
import invpoly.ses
import Lbar.ses
import Lbar.ext
import free_pfpng.acyclic
import challenge_notations

.

universe u

open category_theory
open_locale nnreal

namespace laurent_measures

variables (p' p : ℝ≥0) [fact (0 < p')] [fact (p' < p)] [fact (p ≤ 1)]
variables (S : Profinite.{0})

local notation `r'` := @r p'
local notation `r` := @r p

-- move me
instance fact_half_pos : fact ((0:ℝ≥0) < 2⁻¹) := ⟨by simp⟩

lemma epi_and_is_iso
  (V : SemiNormedGroup.{0}) [normed_with_aut r V] [complete_space V] [separated_space V]
  (hV : ∀ (v : V), (normed_with_aut.T.inv v) = 2 • v) :
  epi (((Ext' 0).map ((condensify_Tinv2 (Fintype_LaurentMeasures r')).app S).op).app
    (Condensed.of_top_ab V)) ∧
  ∀ i > 0, is_iso (((Ext' i).map ((condensify_Tinv2 (Fintype_LaurentMeasures r')).app S).op).app
    (Condensed.of_top_ab V)) :=
begin
  have SES := Lbar.short_exact.{0 0} r' S,
  haveI : fact (r < r'),
  { refine ⟨nnreal.rpow_lt_rpow_of_exponent_gt _ _ _⟩,
    { exact fact.out _ },
    { apply nnreal.two_inv_lt_one },
    { norm_cast, exact fact.out _ },
  },
  haveI : fact (r < 1) := ⟨(fact.out _ : r < r').trans (fact.out _)⟩,
  haveI : fact (p' ≤ 1) := ⟨(fact.out _ : p' < p).le.trans (fact.out _)⟩,
  haveI : fact (p' < 1) := ⟨lt_of_lt_of_le (fact.out _ : p' < p) (fact.out _ : p ≤ 1)⟩,
  rw ← epi_and_is_iso_iff_of_is_iso _ _ _ _
    ((condensify_Tinv2 _).app S) ((condensify_Tinv2 _).app S) ((condensify_Tinv2 _).app S)
    _ _ (Condensed.of_top_ab V) SES SES (Lbar.is_iso_Tinv2 r r' S V hV),
  { rw ← is_zero_iff_epi_and_is_iso _ _ (Condensed.of_top_ab V) (invpoly.short_exact p' S),
    intros i hi,
    apply (free_pfpng_acyclic S V i hi).of_iso _,
    apply iso.app _ _,
    refine (Ext' i).map_iso _,
    exact (as_iso ((cond_free_pfpng_to_normed_free_pfpng.{0 0} p').app S)).op, },
  { rw [← nat_trans.comp_app, condensify_map_comp_Tinv2, nat_trans.comp_app], },
  { rw [← nat_trans.comp_app, condensify_map_comp_Tinv2, nat_trans.comp_app], }
end

end laurent_measures


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.natural_isomorphism
import category_theory.equivalence
import category_theory.eq_to_hom

/-!
# Quotient category

Constructs the quotient of a category by an arbitrary family of relations on its hom-sets,
by introducing a type synonym for the objects, and identifying homs as necessary.

This is analogous to 'the quotient of a group by the normal closure of a subset', rather
than 'the quotient of a group by a normal subgroup'. When taking the quotient by a congruence
relation, `functor_map_eq_iff` says that no unnecessary identifications have been made.
-/

/-- A `hom_rel` on `C` consists of a relation on every hom-set. -/
@[derive inhabited]
def hom_rel (C) [quiver C] := Π ⦃X Y : C⦄, (X ⟶ Y) → (X ⟶ Y) → Prop

namespace category_theory

variables {C : Type*} [category C] (r : hom_rel C)

include r

/-- A `hom_rel` is a congruence when it's an equivalence on every hom-set, and it can be composed
from left and right. -/
class congruence : Prop :=
(is_equiv : ∀ {X Y}, is_equiv _ (@r X Y))
(comp_left : ∀ {X Y Z} (f : X ⟶ Y) {g g' : Y ⟶ Z}, r g g' → r (f ≫ g) (f ≫ g'))
(comp_right : ∀ {X Y Z} {f f' : X ⟶ Y} (g : Y ⟶ Z), r f f' → r (f ≫ g) (f' ≫ g))

attribute [instance] congruence.is_equiv

/-- A type synonym for `C`, thought of as the objects of the quotient category. -/
@[ext]
structure quotient := (as : C)

instance [inhabited C] : inhabited (quotient r) := ⟨ { as := default C } ⟩

namespace quotient

/-- Generates the closure of a family of relations w.r.t. composition from left and right. -/
inductive comp_closure ⦃s t : C⦄ : (s ⟶ t) → (s ⟶ t) → Prop
| intro {a b} (f : s ⟶ a) (m₁ m₂ : a ⟶ b) (g : b ⟶ t) (h : r m₁ m₂) :
  comp_closure (f ≫ m₁ ≫ g) (f ≫ m₂ ≫ g)

lemma comp_left {a b c : C} (f : a ⟶ b) : Π (g₁ g₂ : b ⟶ c) (h : comp_closure r g₁ g₂),
  comp_closure r (f ≫ g₁) (f ≫ g₂)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro (f ≫ x) m₁ m₂ y h

lemma comp_right {a b c : C} (g : b ⟶ c) : Π (f₁ f₂ : a ⟶ b) (h : comp_closure r f₁ f₂),
  comp_closure r (f₁ ≫ g) (f₂ ≫ g)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro x m₁ m₂ (y ≫ g) h

/-- Hom-sets of the quotient category. -/
def hom (s t : quotient r) := quot $ @comp_closure C _ r s.as t.as

instance (a : quotient r) : inhabited (hom r a a) := ⟨quot.mk _ (𝟙 a.as)⟩

/-- Composition in the quotient category. -/
def comp ⦃a b c : quotient r⦄ : hom r a b → hom r b c → hom r a c :=
λ hf hg, quot.lift_on hf ( λ f, quot.lift_on hg (λ g, quot.mk _ (f ≫ g))
  (λ g₁ g₂ h, quot.sound $ comp_left r f g₁ g₂ h) )
  (λ f₁ f₂ h, quot.induction_on hg $ λ g, quot.sound $ comp_right r g f₁ f₂ h)

@[simp]
lemma comp_mk {a b c : quotient r} (f : a.as ⟶ b.as) (g : b.as ⟶ c.as) :
  comp r (quot.mk _ f) (quot.mk _ g) = quot.mk _ (f ≫ g) := rfl

instance category : category (quotient r) :=
{ hom := hom r,
  id := λ a, quot.mk _ (𝟙 a.as),
  comp := comp r }

/-- The functor from a category to its quotient. -/
@[simps]
def functor : C ⥤ quotient r :=
{ obj := λ a, { as := a },
  map := λ _ _ f, quot.mk _ f }

noncomputable instance : full (functor r) :=
{ preimage := λ X Y f, quot.out f, }

instance : ess_surj (functor r) :=
{ mem_ess_image := λ Y, ⟨Y.as, ⟨eq_to_iso (by { ext, refl, })⟩⟩ }

protected lemma induction {P : Π {a b : quotient r}, (a ⟶ b) → Prop}
  (h : ∀ {x y : C} (f : x ⟶ y), P ((functor r).map f)) :
  ∀ {a b : quotient r} (f : a ⟶ b), P f :=
by { rintros ⟨x⟩ ⟨y⟩ ⟨f⟩, exact h f, }

protected lemma sound {a b : C} {f₁ f₂ : a ⟶ b} (h : r f₁ f₂) :
  (functor r).map f₁ = (functor r).map f₂ :=
by simpa using quot.sound (comp_closure.intro (𝟙 a) f₁ f₂ (𝟙 b) h)

variables {D : Type*} [category D]
  (F : C ⥤ D)
  (H : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂)
include H

/-- The induced functor on the quotient category. -/
@[simps]
def lift : quotient r ⥤ D :=
{ obj := λ a, F.obj a.as,
  map := λ a b hf, quot.lift_on hf (λ f, F.map f)
    (by { rintros _ _ ⟨_, _, _, _, _, _, h⟩, simp [H _ _ _ _ h], }),
  map_id' := λ a, F.map_id a.as,
  map_comp' := by { rintros a b c ⟨f⟩ ⟨g⟩, exact F.map_comp f g, } }

/-- The original functor factors through the induced functor. -/
def lift.is_lift : (functor r) ⋙ lift r F H ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma lift.is_lift_hom (X : C) : (lift.is_lift r F H).hom.app X = 𝟙 (F.obj X) :=
rfl
@[simp]
lemma lift.is_lift_inv (X : C) : (lift.is_lift r F H).inv.app X = 𝟙 (F.obj X) :=
rfl

lemma lift_map_functor_map {X Y : C} (f : X ⟶ Y) :
  (lift r F H).map ((functor r).map f) = F.map f :=
by { rw ←(nat_iso.naturality_1 (lift.is_lift r F H)), dsimp, simp, }

end quotient

end category_theory