/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
-/
--import data.list.bag_inter
--import data.list.erase_dup
--import data.list.zip
--import logic.relation
--import data.nat.factorial

import mathlib4_experiments.Data.List.Defs

namespace List

/-!
# List permutations
-/

/-- `perm l₁ l₂` or `l₁ ~ l₂` asserts that `l₁` and `l₂` are permutations
  of each other. This is defined by induction using pairwise swaps. -/
inductive perm : List α → List α → Prop
| nil   : perm [] []
| cons  : ∀ (x : α) {l₁ l₂ : List α}, perm l₁ l₂ → perm (x::l₁) (x::l₂)
| swap  : ∀ (x y : α) (l : List α), perm (y::x::l) (x::y::l)
| trans : ∀ {l₁ l₂ l₃ : List α}, perm l₁ l₂ → perm l₂ l₃ → perm l₁ l₃

open perm (swap)

infix:50 " ~ " => perm

--@[refl]
protected theorem perm.refl : ∀ (l : List α), l ~ l
| []      => perm.nil
| (x::xs) => (perm.refl xs).cons x

-- TODO: whinge that I have to provide the motive in Lean 4
--@[symm]
protected theorem perm.symm {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₂ ~ l₁ :=
perm.recOn (motive := λ x y p => y ~ x) p
  perm.nil
  (λ x l₁ l₂ p₁ r₁ => r₁.cons x)
  (λ x y l => swap y x l)
  (λ p₁ p₂ r₁ r₂ => r₂.trans r₁)

theorem perm_comm {l₁ l₂ : List α} : l₁ ~ l₂ ↔ l₂ ~ l₁ := ⟨perm.symm, perm.symm⟩

theorem perm.swap'
  (x y : α) {l₁ l₂ : List α} (p : l₁ ~ l₂) : y::x::l₁ ~ x::y::l₂ :=
(swap _ _ _).trans ((p.cons _).cons _)

--attribute [trans] perm.trans

theorem perm.eqv (α) : Equivalence (perm (α := α)) where
  refl := perm.refl
  symm := perm.symm
  trans := perm.trans

-- TODO: whinge about how `#print Setoid` doesn't tell me constructor names

instance is_setoid (α) : Setoid (List α) where
  r := perm
  iseqv := perm.eqv α

theorem perm.subset {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁ ⊆ l₂ :=
by intro a; induction p with
| nil => exact id;
| cons x p₁ r₁ => intro i; match i with
  | Or.inl ax => simp [ax];
  | Or.inr al₁ => exact Or.inr (r₁ al₁)
| swap x y l => intro ayxl; match ayxl with
  | Or.inl ay => simp [ay];
  | Or.inr axl => match axl with
    | Or.inl ax => simp [ax]
    | Or.inr al => exact Or.inr (Or.inr al)
| trans _ _ r₁ r₂ => intro ainl₁; exact r₂ (r₁ ainl₁);

theorem perm.length_eq {l₁ l₂ : List α} (p : l₁ ~ l₂) : length l₁ = length l₂ := by
induction p with
| nil => rfl
| cons x p r => simp [r];
| swap x y l => simp;
| trans p₁ p₂ r₁ r₂ => exact r₁.trans r₂

theorem perm.eq_nil {l : List α} (p : l ~ []) : l = [] :=
eq_nil_of_length_eq_zero p.length_eq

theorem perm.nil_eq {l : List α} (p : [] ~ l) : [] = l :=
p.symm.eq_nil.symm

theorem perm_nil {l₁ : List α} : l₁ ~ [] ↔ l₁ = [] :=
⟨λ p => p.eq_nil, λ e => e ▸ perm.refl _⟩

theorem not_perm_nil_cons (x : α) (l : List α) : ¬ [] ~ x::l
| p => by injection p.symm.eq_nil

theorem perm.pairwise_iff {R : α → α → Prop} (S : symmetric R) :
  ∀ {l₁ l₂ : List α} (p : l₁ ~ l₂), pairwise R l₁ ↔ pairwise R l₂ :=
suffices ∀ {l₁ l₂}, l₁ ~ l₂ → pairwise R l₁ → pairwise R l₂ from λ p => ⟨this p, this p.symm⟩ by
  intros l₁ l₂ p d;
--  revert l₂;
  induction d generalizing l₂ with
  | nil => { rw ← p.nil_eq; exact pairwise.nil }
  | @cons a l₁ h d IH => {
    have this : a ∈ l₂ := p.subset (mem_cons_self _ _);
    skip;
    admit;
    }

#exit
    rcases mem_split this with ⟨s₂, t₂, rfl⟩,
    have p' := (p.trans perm_middle).cons_inv,
    refine (pairwise_middle S).2 (pairwise_cons.2 ⟨λ b m, _, IH _ p'⟩),
    exact h _ (p'.symm.subset m) }
end

theorem perm.nodup_iff {l₁ l₂ : list α} : l₁ ~ l₂ → (nodup l₁ ↔ nodup l₂) :=
perm.pairwise_iff $ @ne.symm α

end List

/-

TO BE PORTED

open_locale nat

universe variables uu vv
variables {α : Type uu} {β : Type vv}

theorem perm.mem_iff {a : α} {l₁ l₂ : list α} (h : l₁ ~ l₂) : a ∈ l₁ ↔ a ∈ l₂ :=
iff.intro (λ m, h.subset m) (λ m, h.symm.subset m)

theorem perm.append_right {l₁ l₂ : list α} (t₁ : list α) (p : l₁ ~ l₂) : l₁++t₁ ~ l₂++t₁ :=
perm.rec_on p
  (perm.refl ([] ++ t₁))
  (λ x l₁ l₂ p₁ r₁, r₁.cons x)
  (λ x y l, swap x y _)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, r₁.trans r₂)

theorem perm.append_left {t₁ t₂ : list α} : ∀ (l : list α), t₁ ~ t₂ → l++t₁ ~ l++t₂
| []      p := p
| (x::xs) p := (perm.append_left xs p).cons x

theorem perm.append {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁++t₁ ~ l₂++t₂ :=
(p₁.append_right t₁).trans (p₂.append_left l₂)

theorem perm.append_cons (a : α) {h₁ h₂ t₁ t₂ : list α}
  (p₁ : h₁ ~ h₂) (p₂ : t₁ ~ t₂) : h₁ ++ a::t₁ ~ h₂ ++ a::t₂ :=
p₁.append (p₂.cons a)

@[simp] theorem perm_middle {a : α} : ∀ {l₁ l₂ : list α}, l₁++a::l₂ ~ a::(l₁++l₂)
| []      l₂ := perm.refl _
| (b::l₁) l₂ := ((@perm_middle l₁ l₂).cons _).trans (swap a b _)

@[simp] theorem perm_append_singleton (a : α) (l : list α) : l ++ [a] ~ a::l :=
perm_middle.trans $ by rw [append_nil]

theorem perm_append_comm : ∀ {l₁ l₂ : list α}, (l₁++l₂) ~ (l₂++l₁)
| []     l₂ := by simp
| (a::t) l₂ := (perm_append_comm.cons _).trans perm_middle.symm

theorem concat_perm (l : list α) (a : α) : concat l a ~ a :: l :=
by simp

-- kmb ported perm.length_eq and perm.eq_nil and perm.nil_eq and perm_nil and not_perm_nil_cons

@[simp] theorem reverse_perm : ∀ (l : list α), reverse l ~ l
| []     := perm.nil
| (a::l) := by { rw reverse_cons,
  exact (perm_append_singleton _ _).trans ((reverse_perm l).cons a) }

theorem perm_cons_append_cons {l l₁ l₂ : list α} (a : α) (p : l ~ l₁++l₂) :
  a::l ~ l₁++(a::l₂) :=
(p.cons a).trans perm_middle.symm

@[simp] theorem perm_repeat {a : α} {n : ℕ} {l : list α} : l ~ repeat a n ↔ l = repeat a n :=
⟨λ p, (eq_repeat.2
  ⟨p.length_eq.trans $ length_repeat _ _,
   λ b m, eq_of_mem_repeat $ p.subset m⟩),
 λ h, h ▸ perm.refl _⟩

@[simp] theorem repeat_perm {a : α} {n : ℕ} {l : list α} : repeat a n ~ l ↔ repeat a n = l :=
(perm_comm.trans perm_repeat).trans eq_comm

@[simp] theorem perm_singleton {a : α} {l : list α} : l ~ [a] ↔ l = [a] :=
@perm_repeat α a 1 l

@[simp] theorem singleton_perm {a : α} {l : list α} : [a] ~ l ↔ [a] = l :=
@repeat_perm α a 1 l

theorem perm.eq_singleton {a : α} {l : list α} (p : l ~ [a]) : l = [a] :=
perm_singleton.1 p

theorem perm.singleton_eq {a : α} {l : list α} (p : [a] ~ l) : [a] = l :=
p.symm.eq_singleton.symm

theorem singleton_perm_singleton {a b : α} : [a] ~ [b] ↔ a = b :=
by simp

theorem perm_cons_erase [decidable_eq α] {a : α} {l : list α} (h : a ∈ l) :
  l ~ a :: l.erase a :=
let ⟨l₁, l₂, _, e₁, e₂⟩ := exists_erase_eq h in
e₂.symm ▸ e₁.symm ▸ perm_middle

@[elab_as_eliminator] theorem perm_induction_on
    {P : list α → list α → Prop} {l₁ l₂ : list α} (p : l₁ ~ l₂)
    (h₁ : P [] [])
    (h₂ : ∀ x l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (x::l₁) (x::l₂))
    (h₃ : ∀ x y l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (y::x::l₁) (x::y::l₂))
    (h₄ : ∀ l₁ l₂ l₃, l₁ ~ l₂ → l₂ ~ l₃ → P l₁ l₂ → P l₂ l₃ → P l₁ l₃) :
  P l₁ l₂ :=
have P_refl : ∀ l, P l l, from
  assume l,
  list.rec_on l h₁ (λ x xs ih, h₂ x xs xs (perm.refl xs) ih),
perm.rec_on p h₁ h₂ (λ x y l, h₃ x y l l (perm.refl l) (P_refl l)) h₄

@[congr] theorem perm.filter_map (f : α → option β) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  filter_map f l₁ ~ filter_map f l₂ :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂,
  { simp },
  { simp only [filter_map], cases f x with a; simp [filter_map, IH, perm.cons] },
  { simp only [filter_map], cases f x with a; cases f y with b; simp [filter_map, swap] },
  { exact IH₁.trans IH₂ }
end

@[congr] theorem perm.map (f : α → β) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  map f l₁ ~ map f l₂ :=
filter_map_eq_map f ▸ p.filter_map _

theorem perm.pmap {p : α → Prop} (f : Π a, p a → β)
  {l₁ l₂ : list α} (p : l₁ ~ l₂) {H₁ H₂} : pmap f l₁ H₁ ~ pmap f l₂ H₂ :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂,
  { simp },
  { simp [IH, perm.cons] },
  { simp [swap] },
  { refine IH₁.trans IH₂,
    exact λ a m, H₂ a (p₂.subset m) }
end

theorem perm.filter (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} (s : l₁ ~ l₂) : filter p l₁ ~ filter p l₂ :=
by rw ← filter_map_eq_filter; apply s.filter_map _

theorem exists_perm_sublist {l₁ l₂ l₂' : list α}
  (s : l₁ <+ l₂) (p : l₂ ~ l₂') : ∃ l₁' ~ l₁, l₁' <+ l₂' :=
begin
  induction p with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂ generalizing l₁ s,
  { exact ⟨[], eq_nil_of_sublist_nil s ▸ perm.refl _, nil_sublist _⟩ },
  { cases s with _ _ _ s l₁ _ _ s,
    { exact let ⟨l₁', p', s'⟩ := IH s in ⟨l₁', p', s'.cons _ _ _⟩ },
    { exact let ⟨l₁', p', s'⟩ := IH s in ⟨x::l₁', p'.cons x, s'.cons2 _ _ _⟩ } },
  { cases s with _ _ _ s l₁ _ _ s; cases s with _ _ _ s l₁ _ _ s,
    { exact ⟨l₁, perm.refl _, (s.cons _ _ _).cons _ _ _⟩ },
    { exact ⟨x::l₁, perm.refl _, (s.cons _ _ _).cons2 _ _ _⟩ },
    { exact ⟨y::l₁, perm.refl _, (s.cons2 _ _ _).cons _ _ _⟩ },
    { exact ⟨x::y::l₁, perm.swap _ _ _, (s.cons2 _ _ _).cons2 _ _ _⟩ } },
  { exact let ⟨m₁, pm, sm⟩ := IH₁ s, ⟨r₁, pr, sr⟩ := IH₂ sm in
          ⟨r₁, pr.trans pm, sr⟩ }
end

theorem perm.sizeof_eq_sizeof [has_sizeof α] {l₁ l₂ : list α} (h : l₁ ~ l₂) :
  l₁.sizeof = l₂.sizeof :=
begin
  induction h with hd l₁ l₂ h₁₂ h_sz₁₂ a b l l₁ l₂ l₃ h₁₂ h₂₃ h_sz₁₂ h_sz₂₃,
  { refl },
  { simp only [list.sizeof, h_sz₁₂] },
  { simp only [list.sizeof, add_left_comm] },
  { simp only [h_sz₁₂, h_sz₂₃] }
end

section rel
open relator
variables {γ : Type*} {δ : Type*} {r : α → β → Prop} {p : γ → δ → Prop}

local infixr ` ∘r ` : 80 := relation.comp

lemma perm_comp_perm : (perm ∘r perm : list α → list α → Prop) = perm :=
begin
  funext a c, apply propext,
  split,
  { exact assume ⟨b, hab, hba⟩, perm.trans hab hba },
  { exact assume h, ⟨a, perm.refl a, h⟩ }
end

lemma perm_comp_forall₂ {l u v} (hlu : perm l u) (huv : forall₂ r u v) : (forall₂ r ∘r perm) l v :=
begin
  induction hlu generalizing v,
  case perm.nil { cases huv, exact ⟨[], forall₂.nil, perm.nil⟩ },
  case perm.cons : a l u hlu ih {
    cases huv with _ b _ v hab huv',
    rcases ih huv' with ⟨l₂, h₁₂, h₂₃⟩,
    exact ⟨b::l₂, forall₂.cons hab h₁₂, h₂₃.cons _⟩
  },
  case perm.swap : a₁ a₂ l₁ l₂ h₂₃ {
    cases h₂₃ with _ b₁ _ l₂ h₁ hr_₂₃,
    cases hr_₂₃ with _ b₂ _ l₂ h₂ h₁₂,
    exact ⟨b₂::b₁::l₂, forall₂.cons h₂ (forall₂.cons h₁ h₁₂), perm.swap _ _ _⟩
  },
  case perm.trans : la₁ la₂ la₃ _ _ ih₁ ih₂ {
    rcases ih₂ huv with ⟨lb₂, hab₂, h₂₃⟩,
    rcases ih₁ hab₂ with ⟨lb₁, hab₁, h₁₂⟩,
    exact ⟨lb₁, hab₁, perm.trans h₁₂ h₂₃⟩
  }
end

lemma forall₂_comp_perm_eq_perm_comp_forall₂ : forall₂ r ∘r perm = perm ∘r forall₂ r :=
begin
  funext l₁ l₃, apply propext,
  split,
  { assume h, rcases h with ⟨l₂, h₁₂, h₂₃⟩,
    have : forall₂ (flip r) l₂ l₁, from h₁₂.flip ,
    rcases perm_comp_forall₂ h₂₃.symm this with ⟨l', h₁, h₂⟩,
    exact ⟨l', h₂.symm, h₁.flip⟩ },
  { exact assume ⟨l₂, h₁₂, h₂₃⟩, perm_comp_forall₂ h₁₂ h₂₃ }
end

lemma rel_perm_imp (hr : right_unique r) : (forall₂ r ⇒ forall₂ r ⇒ implies) perm perm :=
assume a b h₁ c d h₂ h,
have (flip (forall₂ r) ∘r (perm ∘r forall₂ r)) b d, from ⟨a, h₁, c, h, h₂⟩,
have ((flip (forall₂ r) ∘r forall₂ r) ∘r perm) b d,
  by rwa [← forall₂_comp_perm_eq_perm_comp_forall₂, ← relation.comp_assoc] at this,
let ⟨b', ⟨c', hbc, hcb⟩, hbd⟩ := this in
have b' = b, from right_unique_forall₂' hr hcb hbc,
this ▸ hbd

lemma rel_perm (hr : bi_unique r) : (forall₂ r ⇒ forall₂ r ⇒ (↔)) perm perm :=
assume a b hab c d hcd, iff.intro
  (rel_perm_imp hr.2 hab hcd)
  (rel_perm_imp (left_unique_flip hr.1) hab.flip hcd.flip)

end rel

section subperm

/-- `subperm l₁ l₂`, denoted `l₁ <+~ l₂`, means that `l₁` is a sublist of
  a permutation of `l₂`. This is an analogue of `l₁ ⊆ l₂` which respects
  multiplicities of elements, and is used for the `≤` relation on multisets. -/
def subperm (l₁ l₂ : list α) : Prop := ∃ l ~ l₁, l <+ l₂

infix ` <+~ `:50 := subperm

theorem nil_subperm {l : list α} : [] <+~ l :=
⟨[], perm.nil, by simp⟩

theorem perm.subperm_left {l l₁ l₂ : list α} (p : l₁ ~ l₂) : l <+~ l₁ ↔ l <+~ l₂ :=
suffices ∀ {l₁ l₂ : list α}, l₁ ~ l₂ → l <+~ l₁ → l <+~ l₂,
from ⟨this p, this p.symm⟩,
λ l₁ l₂ p ⟨u, pu, su⟩,
  let ⟨v, pv, sv⟩ := exists_perm_sublist su p in
  ⟨v, pv.trans pu, sv⟩

theorem perm.subperm_right {l₁ l₂ l : list α} (p : l₁ ~ l₂) : l₁ <+~ l ↔ l₂ <+~ l :=
⟨λ ⟨u, pu, su⟩, ⟨u, pu.trans p, su⟩,
 λ ⟨u, pu, su⟩, ⟨u, pu.trans p.symm, su⟩⟩

theorem sublist.subperm {l₁ l₂ : list α} (s : l₁ <+ l₂) : l₁ <+~ l₂ :=
⟨l₁, perm.refl _, s⟩

theorem perm.subperm {l₁ l₂ : list α} (p : l₁ ~ l₂) : l₁ <+~ l₂ :=
⟨l₂, p.symm, sublist.refl _⟩

@[refl] theorem subperm.refl (l : list α) : l <+~ l := (perm.refl _).subperm

@[trans] theorem subperm.trans {l₁ l₂ l₃ : list α} : l₁ <+~ l₂ → l₂ <+~ l₃ → l₁ <+~ l₃
| s ⟨l₂', p₂, s₂⟩ :=
  let ⟨l₁', p₁, s₁⟩ := p₂.subperm_left.2 s in ⟨l₁', p₁, s₁.trans s₂⟩

theorem subperm.length_le {l₁ l₂ : list α} : l₁ <+~ l₂ → length l₁ ≤ length l₂
| ⟨l, p, s⟩ := p.length_eq ▸ length_le_of_sublist s

theorem subperm.perm_of_length_le {l₁ l₂ : list α} : l₁ <+~ l₂ → length l₂ ≤ length l₁ → l₁ ~ l₂
| ⟨l, p, s⟩ h :=
  suffices l = l₂, from this ▸ p.symm,
  eq_of_sublist_of_length_le s $ p.symm.length_eq ▸ h

theorem subperm.antisymm {l₁ l₂ : list α} (h₁ : l₁ <+~ l₂) (h₂ : l₂ <+~ l₁) : l₁ ~ l₂ :=
h₁.perm_of_length_le h₂.length_le

theorem subperm.subset {l₁ l₂ : list α} : l₁ <+~ l₂ → l₁ ⊆ l₂
| ⟨l, p, s⟩ := subset.trans p.symm.subset s.subset

end subperm

theorem sublist.exists_perm_append : ∀ {l₁ l₂ : list α}, l₁ <+ l₂ → ∃ l, l₂ ~ l₁ ++ l
| ._ ._ sublist.slnil            := ⟨nil, perm.refl _⟩
| ._ ._ (sublist.cons l₁ l₂ a s) :=
  let ⟨l, p⟩ := sublist.exists_perm_append s in
  ⟨a::l, (p.cons a).trans perm_middle.symm⟩
| ._ ._ (sublist.cons2 l₁ l₂ a s) :=
  let ⟨l, p⟩ := sublist.exists_perm_append s in
  ⟨l, p.cons a⟩

theorem perm.countp_eq (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} (s : l₁ ~ l₂) : countp p l₁ = countp p l₂ :=
by rw [countp_eq_length_filter, countp_eq_length_filter];
   exact (s.filter _).length_eq

theorem subperm.countp_le (p : α → Prop) [decidable_pred p]
  {l₁ l₂ : list α} : l₁ <+~ l₂ → countp p l₁ ≤ countp p l₂
| ⟨l, p', s⟩ := p'.countp_eq p ▸ countp_le_of_sublist p s

theorem perm.count_eq [decidable_eq α] {l₁ l₂ : list α}
  (p : l₁ ~ l₂) (a) : count a l₁ = count a l₂ :=
p.countp_eq _

theorem subperm.count_le [decidable_eq α] {l₁ l₂ : list α}
  (s : l₁ <+~ l₂) (a) : count a l₁ ≤ count a l₂ :=
s.countp_le _

theorem perm.foldl_eq' {f : β → α → β} {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  (∀ (x ∈ l₁) (y ∈ l₁) z, f (f z x) y = f (f z y) x) → ∀ b, foldl f b l₁ = foldl f b l₂ :=
perm_induction_on p
  (λ H b, rfl)
  (λ x t₁ t₂ p r H b, r (λ x hx y hy, H _ (or.inr hx) _ (or.inr hy)) _)
  (λ x y t₁ t₂ p r H b,
    begin
      simp only [foldl],
      rw [H x (or.inr $ or.inl rfl) y (or.inl rfl)],
      exact r (λ x hx y hy, H _ (or.inr $ or.inr hx) _ (or.inr $ or.inr hy)) _
    end)
  (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ H b, eq.trans (r₁ H b)
    (r₂ (λ x hx y hy, H _ (p₁.symm.subset hx) _ (p₁.symm.subset hy)) b))

theorem perm.foldl_eq {f : β → α → β} {l₁ l₂ : list α} (rcomm : right_commutative f) (p : l₁ ~ l₂) :
  ∀ b, foldl f b l₁ = foldl f b l₂ :=
p.foldl_eq' $ λ x hx y hy z, rcomm z x y

theorem perm.foldr_eq {f : α → β → β} {l₁ l₂ : list α} (lcomm : left_commutative f) (p : l₁ ~ l₂) :
  ∀ b, foldr f b l₁ = foldr f b l₂ :=
perm_induction_on p
  (λ b, rfl)
  (λ x t₁ t₂ p r b, by simp; rw [r b])
  (λ x y t₁ t₂ p r b, by simp; rw [lcomm, r b])
  (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ a, eq.trans (r₁ a) (r₂ a))

lemma perm.rec_heq {β : list α → Sort*} {f : Πa l, β l → β (a::l)} {b : β []} {l l' : list α}
  (hl : perm l l')
  (f_congr : ∀{a l l' b b'}, perm l l' → b == b' → f a l b == f a l' b')
  (f_swap : ∀{a a' l b}, f a (a'::l) (f a' l b) == f a' (a::l) (f a l b)) :
  @list.rec α β b f l == @list.rec α β b f l' :=
begin
  induction hl,
  case list.perm.nil { refl },
  case list.perm.cons : a l l' h ih { exact f_congr h ih },
  case list.perm.swap : a a' l { exact f_swap },
  case list.perm.trans : l₁ l₂ l₃ h₁ h₂ ih₁ ih₂ { exact heq.trans ih₁ ih₂ }
end

section
variables {op : α → α → α} [is_associative α op] [is_commutative α op]
local notation a * b := op a b
local notation l <*> a := foldl op a l

lemma perm.fold_op_eq {l₁ l₂ : list α} {a : α} (h : l₁ ~ l₂) : l₁ <*> a = l₂ <*> a :=
h.foldl_eq (right_comm _ is_commutative.comm is_associative.assoc) _
end

section comm_monoid

/-- If elements of a list commute with each other, then their product does not
depend on the order of elements-/
@[to_additive]
lemma perm.prod_eq' [monoid α] {l₁ l₂ : list α} (h : l₁ ~ l₂)
  (hc : l₁.pairwise (λ x y, x * y = y * x)) :
  l₁.prod = l₂.prod :=
h.foldl_eq' (forall_of_forall_of_pairwise (λ x y h z, (h z).symm) (λ x hx z, rfl) $
  hc.imp $ λ x y h z, by simp only [mul_assoc, h]) _

variable [comm_monoid α]

@[to_additive]
lemma perm.prod_eq {l₁ l₂ : list α} (h : perm l₁ l₂) : prod l₁ = prod l₂ :=
h.fold_op_eq

@[to_additive]
lemma prod_reverse (l : list α) : prod l.reverse = prod l :=
(reverse_perm l).prod_eq

end comm_monoid

theorem perm_inv_core {a : α} {l₁ l₂ r₁ r₂ : list α} : l₁++a::r₁ ~ l₂++a::r₂ → l₁++r₁ ~ l₂++r₂ :=
begin
  generalize e₁ : l₁++a::r₁ = s₁, generalize e₂ : l₂++a::r₂ = s₂,
  intro p, revert l₁ l₂ r₁ r₂ e₁ e₂,
  refine perm_induction_on p _ (λ x t₁ t₂ p IH, _) (λ x y t₁ t₂ p IH, _)
    (λ t₁ t₂ t₃ p₁ p₂ IH₁ IH₂, _); intros l₁ l₂ r₁ r₂ e₁ e₂,
  { apply (not_mem_nil a).elim, rw ← e₁, simp },
  { cases l₁ with y l₁; cases l₂ with z l₂;
      dsimp at e₁ e₂; injections; subst x,
    { substs t₁ t₂,     exact p },
    { substs z t₁ t₂,   exact p.trans perm_middle },
    { substs y t₁ t₂,   exact perm_middle.symm.trans p },
    { substs z t₁ t₂,   exact (IH rfl rfl).cons y } },
  { rcases l₁ with _|⟨y, _|⟨z, l₁⟩⟩; rcases l₂ with _|⟨u, _|⟨v, l₂⟩⟩;
      dsimp at e₁ e₂; injections; substs x y,
    { substs r₁ r₂,     exact p.cons a },
    { substs r₁ r₂,     exact p.cons u },
    { substs r₁ v t₂,   exact (p.trans perm_middle).cons u },
    { substs r₁ r₂,     exact p.cons y },
    { substs r₁ r₂ y u, exact p.cons a },
    { substs r₁ u v t₂, exact ((p.trans perm_middle).cons y).trans (swap _ _ _) },
    { substs r₂ z t₁,   exact (perm_middle.symm.trans p).cons y },
    { substs r₂ y z t₁, exact (swap _ _ _).trans ((perm_middle.symm.trans p).cons u) },
    { substs u v t₁ t₂, exact (IH rfl rfl).swap' _ _ } },
  { substs t₁ t₃,
    have : a ∈ t₂ := p₁.subset (by simp),
    rcases mem_split this with ⟨l₂, r₂, e₂⟩,
    subst t₂, exact (IH₁ rfl rfl).trans (IH₂ rfl rfl) }
end

theorem perm.cons_inv {a : α} {l₁ l₂ : list α} : a::l₁ ~ a::l₂ → l₁ ~ l₂ :=
@perm_inv_core _ _ [] [] _ _

@[simp] theorem perm_cons (a : α) {l₁ l₂ : list α} : a::l₁ ~ a::l₂ ↔ l₁ ~ l₂ :=
⟨perm.cons_inv, perm.cons a⟩

theorem perm_append_left_iff {l₁ l₂ : list α} : ∀ l, l++l₁ ~ l++l₂ ↔ l₁ ~ l₂
| []     := iff.rfl
| (a::l) := (perm_cons a).trans (perm_append_left_iff l)

theorem perm_append_right_iff {l₁ l₂ : list α} (l) : l₁++l ~ l₂++l ↔ l₁ ~ l₂ :=
⟨λ p, (perm_append_left_iff _).1 $ perm_append_comm.trans $ p.trans perm_append_comm,
 perm.append_right _⟩

theorem perm_option_to_list {o₁ o₂ : option α} : o₁.to_list ~ o₂.to_list ↔ o₁ = o₂ :=
begin
  refine ⟨λ p, _, λ e, e ▸ perm.refl _⟩,
  cases o₁ with a; cases o₂ with b, {refl},
  { cases p.length_eq },
  { cases p.length_eq },
  { exact option.mem_to_list.1 (p.symm.subset $ by simp) }
end

theorem subperm_cons (a : α) {l₁ l₂ : list α} : a::l₁ <+~ a::l₂ ↔ l₁ <+~ l₂ :=
⟨λ ⟨l, p, s⟩, begin
  cases s with _ _ _ s' u _ _ s',
  { exact (p.subperm_left.2 $ (sublist_cons _ _).subperm).trans s'.subperm },
  { exact ⟨u, p.cons_inv, s'⟩ }
end, λ ⟨l, p, s⟩, ⟨a::l, p.cons a, s.cons2 _ _ _⟩⟩

theorem cons_subperm_of_mem {a : α} {l₁ l₂ : list α} (d₁ : nodup l₁) (h₁ : a ∉ l₁) (h₂ : a ∈ l₂)
 (s : l₁ <+~ l₂) : a :: l₁ <+~ l₂ :=
begin
  rcases s with ⟨l, p, s⟩,
  induction s generalizing l₁,
  case list.sublist.slnil { cases h₂ },
  case list.sublist.cons : r₁ r₂ b s' ih {
    simp at h₂,
    cases h₂ with e m,
    { subst b, exact ⟨a::r₁, p.cons a, s'.cons2 _ _ _⟩ },
    { rcases ih m d₁ h₁ p with ⟨t, p', s'⟩, exact ⟨t, p', s'.cons _ _ _⟩ } },
  case list.sublist.cons2 : r₁ r₂ b s' ih {
    have bm : b ∈ l₁ := (p.subset $ mem_cons_self _ _),
    have am : a ∈ r₂ := h₂.resolve_left (λ e, h₁ $ e.symm ▸ bm),
    rcases mem_split bm with ⟨t₁, t₂, rfl⟩,
    have st : t₁ ++ t₂ <+ t₁ ++ b :: t₂ := by simp,
    rcases ih am (nodup_of_sublist st d₁)
      (mt (λ x, st.subset x) h₁)
      (perm.cons_inv $ p.trans perm_middle) with ⟨t, p', s'⟩,
    exact ⟨b::t, (p'.cons b).trans $ (swap _ _ _).trans (perm_middle.symm.cons a), s'.cons2 _ _ _⟩ }
end

theorem subperm_append_left {l₁ l₂ : list α} : ∀ l, l++l₁ <+~ l++l₂ ↔ l₁ <+~ l₂
| []     := iff.rfl
| (a::l) := (subperm_cons a).trans (subperm_append_left l)

theorem subperm_append_right {l₁ l₂ : list α} (l) : l₁++l <+~ l₂++l ↔ l₁ <+~ l₂ :=
(perm_append_comm.subperm_left.trans perm_append_comm.subperm_right).trans (subperm_append_left l)

theorem subperm.exists_of_length_lt {l₁ l₂ : list α} :
  l₁ <+~ l₂ → length l₁ < length l₂ → ∃ a, a :: l₁ <+~ l₂
| ⟨l, p, s⟩ h :=
  suffices length l < length l₂ → ∃ (a : α), a :: l <+~ l₂, from
  (this $ p.symm.length_eq ▸ h).imp (λ a, (p.cons a).subperm_right.1),
  begin
    clear subperm.exists_of_length_lt p h l₁, rename l₂ u,
    induction s with l₁ l₂ a s IH _ _ b s IH; intro h,
    { cases h },
    { cases lt_or_eq_of_le (nat.le_of_lt_succ h : length l₁ ≤ length l₂) with h h,
      { exact (IH h).imp (λ a s, s.trans (sublist_cons _ _).subperm) },
      { exact ⟨a, eq_of_sublist_of_length_eq s h ▸ subperm.refl _⟩ } },
    { exact (IH $ nat.lt_of_succ_lt_succ h).imp
        (λ a s, (swap _ _ _).subperm_right.1 $ (subperm_cons _).2 s) }
  end

theorem subperm_of_subset_nodup
  {l₁ l₂ : list α} (d : nodup l₁) (H : l₁ ⊆ l₂) : l₁ <+~ l₂ :=
begin
  induction d with a l₁' h d IH,
  { exact ⟨nil, perm.nil, nil_sublist _⟩ },
  { cases forall_mem_cons.1 H with H₁ H₂,
    simp at h,
    exact cons_subperm_of_mem d h H₁ (IH H₂) }
end

theorem perm_ext {l₁ l₂ : list α} (d₁ : nodup l₁) (d₂ : nodup l₂) :
  l₁ ~ l₂ ↔ ∀a, a ∈ l₁ ↔ a ∈ l₂ :=
⟨λ p a, p.mem_iff, λ H, subperm.antisymm
  (subperm_of_subset_nodup d₁ (λ a, (H a).1))
  (subperm_of_subset_nodup d₂ (λ a, (H a).2))⟩

theorem nodup.sublist_ext {l₁ l₂ l : list α} (d : nodup l)
  (s₁ : l₁ <+ l) (s₂ : l₂ <+ l) : l₁ ~ l₂ ↔ l₁ = l₂ :=
⟨λ h, begin
  induction s₂ with l₂ l a s₂ IH l₂ l a s₂ IH generalizing l₁,
  { exact h.eq_nil },
  { simp at d,
    cases s₁ with _ _ _ s₁ l₁ _ _ s₁,
    { exact IH d.2 s₁ h },
    { apply d.1.elim,
      exact subperm.subset ⟨_, h.symm, s₂⟩ (mem_cons_self _ _) } },
  { simp at d,
    cases s₁ with _ _ _ s₁ l₁ _ _ s₁,
    { apply d.1.elim,
      exact subperm.subset ⟨_, h, s₁⟩ (mem_cons_self _ _) },
    { rw IH d.2 s₁ h.cons_inv } }
end, λ h, by rw h⟩

section
variable [decidable_eq α]

-- attribute [congr]
theorem perm.erase (a : α) {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  l₁.erase a ~ l₂.erase a :=
if h₁ : a ∈ l₁ then
have h₂ : a ∈ l₂, from p.subset h₁,
perm.cons_inv $ (perm_cons_erase h₁).symm.trans $ p.trans (perm_cons_erase h₂)
else
have h₂ : a ∉ l₂, from mt p.mem_iff.2 h₁,
by rw [erase_of_not_mem h₁, erase_of_not_mem h₂]; exact p

theorem subperm_cons_erase (a : α) (l : list α) : l <+~ a :: l.erase a :=
begin
  by_cases h : a ∈ l,
  { exact (perm_cons_erase h).subperm },
  { rw [erase_of_not_mem h],
    exact (sublist_cons _ _).subperm }
end

theorem erase_subperm (a : α) (l : list α) : l.erase a <+~ l :=
(erase_sublist _ _).subperm

theorem subperm.erase {l₁ l₂ : list α} (a : α) (h : l₁ <+~ l₂) : l₁.erase a <+~ l₂.erase a :=
let ⟨l, hp, hs⟩ := h in ⟨l.erase a, hp.erase _, hs.erase _⟩

theorem perm.diff_right {l₁ l₂ : list α} (t : list α) (h : l₁ ~ l₂) : l₁.diff t ~ l₂.diff t :=
by induction t generalizing l₁ l₂ h; simp [*, perm.erase]

theorem perm.diff_left (l : list α) {t₁ t₂ : list α} (h : t₁ ~ t₂) : l.diff t₁ = l.diff t₂ :=
by induction h generalizing l; simp [*, perm.erase, erase_comm]
  <|> exact (ih_1 _).trans (ih_2 _)

theorem perm.diff {l₁ l₂ t₁ t₂ : list α} (hl : l₁ ~ l₂) (ht : t₁ ~ t₂) :
  l₁.diff t₁ ~ l₂.diff t₂ :=
ht.diff_left l₂ ▸ hl.diff_right _

theorem subperm.diff_right {l₁ l₂ : list α} (h : l₁ <+~ l₂) (t : list α) :
  l₁.diff t <+~ l₂.diff t :=
by induction t generalizing l₁ l₂ h; simp [*, subperm.erase]

theorem erase_cons_subperm_cons_erase (a b : α) (l : list α) :
  (a :: l).erase b <+~ a :: l.erase b :=
begin
  by_cases h : a = b,
  { subst b,
    rw [erase_cons_head],
    apply subperm_cons_erase },
  { rw [erase_cons_tail _ h] }
end

theorem subperm_cons_diff {a : α} : ∀ {l₁ l₂ : list α}, (a :: l₁).diff l₂ <+~ a :: l₁.diff l₂
| l₁ []      := ⟨a::l₁, by simp⟩
| l₁ (b::l₂) :=
begin
  simp only [diff_cons],
  refine ((erase_cons_subperm_cons_erase a b l₁).diff_right l₂).trans _,
  apply subperm_cons_diff
end

theorem subset_cons_diff {a : α} {l₁ l₂ : list α} : (a :: l₁).diff l₂ ⊆ a :: l₁.diff l₂ :=
subperm_cons_diff.subset

theorem perm.bag_inter_right {l₁ l₂ : list α} (t : list α) (h : l₁ ~ l₂) :
  l₁.bag_inter t ~ l₂.bag_inter t :=
begin
  induction h with x _ _ _ _ x y _ _ _ _ _ _ ih_1 ih_2 generalizing t, {simp},
  { by_cases x ∈ t; simp [*, perm.cons] },
  { by_cases x = y, {simp [h]},
    by_cases xt : x ∈ t; by_cases yt : y ∈ t,
    { simp [xt, yt, mem_erase_of_ne h, mem_erase_of_ne (ne.symm h), erase_comm, swap] },
    { simp [xt, yt, mt mem_of_mem_erase, perm.cons] },
    { simp [xt, yt, mt mem_of_mem_erase, perm.cons] },
    { simp [xt, yt] } },
  { exact (ih_1 _).trans (ih_2 _) }
end

theorem perm.bag_inter_left (l : list α) {t₁ t₂ : list α} (p : t₁ ~ t₂) :
  l.bag_inter t₁ = l.bag_inter t₂ :=
begin
  induction l with a l IH generalizing t₁ t₂ p, {simp},
  by_cases a ∈ t₁,
  { simp [h, p.subset h, IH (p.erase _)] },
  { simp [h, mt p.mem_iff.2 h, IH p] }
end

theorem perm.bag_inter {l₁ l₂ t₁ t₂ : list α} (hl : l₁ ~ l₂) (ht : t₁ ~ t₂) :
  l₁.bag_inter t₁ ~ l₂.bag_inter t₂ :=
ht.bag_inter_left l₂ ▸ hl.bag_inter_right _

theorem cons_perm_iff_perm_erase {a : α} {l₁ l₂ : list α} : a::l₁ ~ l₂ ↔ a ∈ l₂ ∧ l₁ ~ l₂.erase a :=
⟨λ h, have a ∈ l₂, from h.subset (mem_cons_self a l₁),
      ⟨this, (h.trans $ perm_cons_erase this).cons_inv⟩,
 λ ⟨m, h⟩, (h.cons a).trans (perm_cons_erase m).symm⟩

theorem perm_iff_count {l₁ l₂ : list α} : l₁ ~ l₂ ↔ ∀ a, count a l₁ = count a l₂ :=
⟨perm.count_eq, λ H, begin
  induction l₁ with a l₁ IH generalizing l₂,
  { cases l₂ with b l₂, {refl},
    specialize H b, simp at H, contradiction },
  { have : a ∈ l₂ := count_pos.1 (by rw ← H; simp; apply nat.succ_pos),
    refine ((IH $ λ b, _).cons a).trans (perm_cons_erase this).symm,
    specialize H b,
    rw (perm_cons_erase this).count_eq at H,
    by_cases b = a; simp [h] at H ⊢; assumption }
end⟩

instance decidable_perm : ∀ (l₁ l₂ : list α), decidable (l₁ ~ l₂)
| []      []      := is_true $ perm.refl _
| []      (b::l₂) := is_false $ λ h, by have := h.nil_eq; contradiction
| (a::l₁) l₂      := by haveI := decidable_perm l₁ (l₂.erase a);
                        exact decidable_of_iff' _ cons_perm_iff_perm_erase

-- @[congr]
theorem perm.erase_dup {l₁ l₂ : list α} (p : l₁ ~ l₂) :
  erase_dup l₁ ~ erase_dup l₂ :=
perm_iff_count.2 $ λ a,
if h : a ∈ l₁
then by simp [nodup_erase_dup, h, p.subset h]
else by simp [h, mt p.mem_iff.2 h]

-- attribute [congr]
theorem perm.insert (a : α)
  {l₁ l₂ : list α} (p : l₁ ~ l₂) : insert a l₁ ~ insert a l₂ :=
if h : a ∈ l₁
then by simpa [h, p.subset h] using p
else by simpa [h, mt p.mem_iff.2 h] using p.cons a

theorem perm_insert_swap (x y : α) (l : list α) :
  insert x (insert y l) ~ insert y (insert x l) :=
begin
  by_cases xl : x ∈ l; by_cases yl : y ∈ l; simp [xl, yl],
  by_cases xy : x = y, { simp [xy] },
  simp [not_mem_cons_of_ne_of_not_mem xy xl,
        not_mem_cons_of_ne_of_not_mem (ne.symm xy) yl],
  constructor
end

theorem perm_insert_nth {α} (x : α) (l : list α) {n} (h : n ≤ l.length) :
  insert_nth n x l ~ x :: l :=
begin
  induction l generalizing n,
  { cases n, refl, cases h },
  cases n,
  { simp [insert_nth] },
  { simp only [insert_nth, modify_nth_tail],
    transitivity,
    { apply perm.cons, apply l_ih,
      apply nat.le_of_succ_le_succ h },
    { apply perm.swap } }
end

theorem perm.union_right {l₁ l₂ : list α} (t₁ : list α) (h : l₁ ~ l₂) : l₁ ∪ t₁ ~ l₂ ∪ t₁ :=
begin
  induction h with a _ _ _ ih _ _ _ _ _ _ _ _ ih_1 ih_2; try {simp},
  { exact ih.insert a },
  { apply perm_insert_swap },
  { exact ih_1.trans ih_2 }
end

theorem perm.union_left (l : list α) {t₁ t₂ : list α} (h : t₁ ~ t₂) : l ∪ t₁ ~ l ∪ t₂ :=
by induction l; simp [*, perm.insert]

-- @[congr]
theorem perm.union {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∪ t₁ ~ l₂ ∪ t₂ :=
(p₁.union_right t₁).trans (p₂.union_left l₂)

theorem perm.inter_right {l₁ l₂ : list α} (t₁ : list α) : l₁ ~ l₂ → l₁ ∩ t₁ ~ l₂ ∩ t₁ :=
perm.filter _

theorem perm.inter_left (l : list α) {t₁ t₂ : list α} (p : t₁ ~ t₂) : l ∩ t₁ = l ∩ t₂ :=
by { dsimp [(∩), list.inter], congr, funext a, rw [p.mem_iff] }

-- @[congr]
theorem perm.inter {l₁ l₂ t₁ t₂ : list α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∩ t₁ ~ l₂ ∩ t₂ :=
p₂.inter_left l₂ ▸ p₁.inter_right t₁

theorem perm.inter_append {l t₁ t₂ : list α} (h : disjoint t₁ t₂) :
  l ∩ (t₁ ++ t₂) ~ l ∩ t₁ ++ l ∩ t₂ :=
begin
  induction l,
  case list.nil
  { simp },
  case list.cons : x xs l_ih
  { by_cases h₁ : x ∈ t₁,
    { have h₂ : x ∉ t₂ := h h₁,
      simp * },
    by_cases h₂ : x ∈ t₂,
    { simp only [*, inter_cons_of_not_mem, false_or, mem_append, inter_cons_of_mem, not_false_iff],
      transitivity,
      { apply perm.cons _ l_ih, },
      change [x] ++ xs ∩ t₁ ++ xs ∩ t₂ ~ xs ∩ t₁ ++ ([x] ++ xs ∩ t₂),
      rw [← list.append_assoc],
      solve_by_elim [perm.append_right, perm_append_comm] },
    { simp * } },
end

end

-- kmb ported perm.pairwise_iff

theorem perm.bind_right {l₁ l₂ : list α} (f : α → list β) (p : l₁ ~ l₂) :
  l₁.bind f ~ l₂.bind f :=
begin
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { simp, exact IH.append_left _ },
  { simp, rw [← append_assoc, ← append_assoc], exact perm_append_comm.append_right _ },
  { exact IH₁.trans IH₂ }
end

theorem perm.bind_left (l : list α) {f g : α → list β} (h : ∀ a, f a ~ g a) :
  l.bind f ~ l.bind g :=
by induction l with a l IH; simp; exact (h a).append IH

theorem perm.product_right {l₁ l₂ : list α} (t₁ : list β) (p : l₁ ~ l₂) :
  product l₁ t₁ ~ product l₂ t₁ :=
p.bind_right _

theorem perm.product_left (l : list α) {t₁ t₂ : list β} (p : t₁ ~ t₂) :
  product l t₁ ~ product l t₂ :=
perm.bind_left _ $ λ a, p.map _

@[congr] theorem perm.product {l₁ l₂ : list α} {t₁ t₂ : list β}
  (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : product l₁ t₁ ~ product l₂ t₂ :=
(p₁.product_right t₁).trans (p₂.product_left l₂)

theorem sublists_cons_perm_append (a : α) (l : list α) :
  sublists (a :: l) ~ sublists l ++ map (cons a) (sublists l) :=
begin
  simp only [sublists, sublists_aux_cons_cons, cons_append, perm_cons],
  refine (perm.cons _ _).trans perm_middle.symm,
  induction sublists_aux l cons with b l IH; simp,
  exact (IH.cons _).trans perm_middle.symm
end

theorem sublists_perm_sublists' : ∀ l : list α, sublists l ~ sublists' l
| []     := perm.refl _
| (a::l) := let IH := sublists_perm_sublists' l in
  by rw sublists'_cons; exact
  (sublists_cons_perm_append _ _).trans (IH.append (IH.map _))

theorem revzip_sublists (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  apply list.reverse_rec_on l,
  { intros l₁ l₂ h, simp at h, simp [h] },
  { intros l a IH l₁ l₂ h,
    rw [sublists_concat, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [skip, {simp}],
    simp only [prod.mk.inj_iff, mem_map, mem_append, prod.map_mk, prod.exists] at h,
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', l₂, h, rfl, rfl⟩,
    { rw ← append_assoc,
      exact (IH _ _ h).append_right _ },
    { rw append_assoc,
      apply (perm_append_comm.append_left _).trans,
      rw ← append_assoc,
      exact (IH _ _ h).append_right _ } }
end

theorem revzip_sublists' (l : list α) :
  ∀ l₁ l₂, (l₁, l₂) ∈ revzip l.sublists' → l₁ ++ l₂ ~ l :=
begin
  rw revzip,
  induction l with a l IH; intros l₁ l₂ h,
  { simp at h, simp [h] },
  { rw [sublists'_cons, reverse_append, zip_append, ← map_reverse,
        zip_map_right, zip_map_left] at h; [simp at h, simp],
    rcases h with ⟨l₁, l₂', h, rfl, rfl⟩ | ⟨l₁', h, rfl⟩,
    { exact perm_middle.trans ((IH _ _ h).cons _) },
    { exact (IH _ _ h).cons _ } }
end

theorem perm_lookmap (f : α → option α) {l₁ l₂ : list α}
  (H : pairwise (λ a b, ∀ (c ∈ f a) (d ∈ f b), a = b ∧ c = d) l₁)
  (p : l₁ ~ l₂) : lookmap f l₁ ~ lookmap f l₂ :=
begin
  let F := λ a b, ∀ (c ∈ f a) (d ∈ f b), a = b ∧ c = d,
  change pairwise F l₁ at H,
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { cases h : f a,
    { simp [h], exact IH (pairwise_cons.1 H).2 },
    { simp [lookmap_cons_some _ _ h, p] } },
  { cases h₁ : f a with c; cases h₂ : f b with d,
    { simp [h₁, h₂], apply swap },
    { simp [h₁, lookmap_cons_some _ _ h₂], apply swap },
    { simp [lookmap_cons_some _ _ h₁, h₂], apply swap },
    { simp [lookmap_cons_some _ _ h₁, lookmap_cons_some _ _ h₂],
      rcases (pairwise_cons.1 H).1 _ (or.inl rfl) _ h₂ _ h₁ with ⟨rfl, rfl⟩,
      refl } },
  { refine (IH₁ H).trans (IH₂ ((p₁.pairwise_iff _).1 H)),
    exact λ a b h c h₁ d h₂, (h d h₂ c h₁).imp eq.symm eq.symm }
end

theorem perm.erasep (f : α → Prop) [decidable_pred f] {l₁ l₂ : list α}
  (H : pairwise (λ a b, f a → f b → false) l₁)
  (p : l₁ ~ l₂) : erasep f l₁ ~ erasep f l₂ :=
begin
  let F := λ a b, f a → f b → false,
  change pairwise F l₁ at H,
  induction p with a l₁ l₂ p IH a b l l₁ l₂ l₃ p₁ p₂ IH₁ IH₂, {simp},
  { by_cases h : f a,
    { simp [h, p] },
    { simp [h], exact IH (pairwise_cons.1 H).2 } },
  { by_cases h₁ : f a; by_cases h₂ : f b; simp [h₁, h₂],
    { cases (pairwise_cons.1 H).1 _ (or.inl rfl) h₂ h₁ },
    { apply swap } },
  { refine (IH₁ H).trans (IH₂ ((p₁.pairwise_iff _).1 H)),
    exact λ a b h h₁ h₂, h h₂ h₁ }
end

lemma perm.take_inter {α} [decidable_eq α] {xs ys : list α} (n : ℕ)
  (h : xs ~ ys) (h' : ys.nodup) :
  xs.take n ~ ys.inter (xs.take n) :=
begin
  simp only [list.inter] at *,
  induction h generalizing n,
  case list.perm.nil : n
  { simp only [not_mem_nil, filter_false, take_nil] },
  case list.perm.cons : h_x h_l₁ h_l₂ h_a h_ih n
  { cases n; simp only [mem_cons_iff, true_or, eq_self_iff_true, filter_cons_of_pos,
                        perm_cons, take, not_mem_nil, filter_false],
    cases h' with _ _ h₁ h₂,
    convert h_ih h₂ n using 1,
    apply filter_congr,
    introv h, simp only [(h₁ x h).symm, false_or], },
  case list.perm.swap : h_x h_y h_l n
  { cases h' with _ _ h₁ h₂,
    cases h₂ with _ _ h₂ h₃,
    have := h₁ _ (or.inl rfl),
    cases n; simp only [mem_cons_iff, not_mem_nil, filter_false, take],
    cases n; simp only [mem_cons_iff, false_or, true_or, filter, *, nat.nat_zero_eq_zero, if_true,
                        not_mem_nil, eq_self_iff_true, or_false, if_false, perm_cons, take],
    { rw filter_eq_nil.2, intros, solve_by_elim [ne.symm], },
    { convert perm.swap _ _ _, rw @filter_congr _ _ (∈ take n h_l),
      { clear h₁, induction n generalizing h_l; simp only [not_mem_nil, filter_false, take],
        cases h_l; simp only [mem_cons_iff, true_or, eq_self_iff_true, filter_cons_of_pos,
                              true_and, take, not_mem_nil, filter_false, take_nil],
        cases h₃ with _ _ h₃ h₄,
        rwa [@filter_congr _ _ (∈ take n_n h_l_tl), n_ih],
        { introv h, apply h₂ _ (or.inr h), },
        { introv h, simp only [(h₃ x h).symm, false_or], }, },
      { introv h, simp only [(h₂ x h).symm, (h₁ x (or.inr h)).symm, false_or], } } },
  case list.perm.trans : h_l₁ h_l₂ h_l₃ h₀ h₁ h_ih₀ h_ih₁ n
  { transitivity,
    { apply h_ih₀, rwa h₁.nodup_iff },
    { apply perm.filter _ h₁, } },
end

lemma perm.drop_inter {α} [decidable_eq α] {xs ys : list α} (n : ℕ)
  (h : xs ~ ys) (h' : ys.nodup) :
  xs.drop n ~ ys.inter (xs.drop n) :=
begin
  by_cases h'' : n ≤ xs.length,
  { let n' := xs.length - n,
    have h₀ : n = xs.length - n',
    { dsimp [n'], rwa nat.sub_sub_self, } ,
    have h₁ : n' ≤ xs.length,
    { apply nat.sub_le_self },
    have h₂ : xs.drop n = (xs.reverse.take n').reverse,
    { rw [reverse_take _ h₁, h₀, reverse_reverse], },
    rw [h₂],
    apply (reverse_perm _).trans,
    rw inter_reverse,
    apply perm.take_inter _ _ h',
    apply (reverse_perm _).trans; assumption, },
  { have : drop n xs = [],
    { apply eq_nil_of_length_eq_zero,
      rw [length_drop, nat.sub_eq_zero_iff_le],
      apply le_of_not_ge h'' },
    simp [this, list.inter], }
end

lemma perm.slice_inter {α} [decidable_eq α] {xs ys : list α} (n m : ℕ)
  (h : xs ~ ys) (h' : ys.nodup) :
  list.slice n m xs ~ ys ∩ (list.slice n m xs) :=
begin
  simp only [slice_eq],
  have : n ≤ n + m := nat.le_add_right _ _,
  have := h.nodup_iff.2 h',
  apply perm.trans _ (perm.inter_append _).symm;
  solve_by_elim [perm.append, perm.drop_inter, perm.take_inter, disjoint_take_drop, h, h']
      { max_depth := 7 },
end

/- enumerating permutations -/

section permutations

theorem 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] theorem permutations_aux2_snd_nil (t : α) (ts : list α) (r : list β) (f : list α → β) :
  (permutations_aux2 t ts r [] f).2 = r := rfl

@[simp] theorem 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

theorem 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 *

theorem 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; intro h,
    { rcases h with e | ⟨l₁, l₂, l0, ye, _⟩,
      { subst l', exact ⟨[], y::ys, by simp⟩ },
      { substs l' ys, exact ⟨y::l₁, l₂, l0, by simp⟩ } },
    { rcases h with ⟨_ | ⟨y', l₁⟩, l₂, l0, ye, rfl⟩,
      { simp [ye] },
      { simp at ye, rcases ye with ⟨rfl, rfl⟩,
        exact or.inr ⟨l₁, l₂, l0, by simp⟩ } } }
end

theorem 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

theorem 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 *

theorem 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}]

theorem 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]

theorem 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]

theorem 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

theorem perm_of_mem_permutations_aux :
  ∀ {ts is l : list α}, l ∈ permutations_aux ts is → l ~ ts ++ is :=
begin
  refine permutations_aux.rec (by simp) _,
  introv IH1 IH2 m,
  rw [permutations_aux_cons, permutations, mem_foldr_permutations_aux2] at m,
  rcases m with m | ⟨l₁, l₂, m, _, e⟩,
  { exact (IH1 m).trans perm_middle },
  { subst e,
    have p : l₁ ++ l₂ ~ is,
    { simp [permutations] at m,
      cases m with e m, {simp [e]},
      exact is.append_nil ▸ IH2 m },
    exact ((perm_middle.trans (p.cons _)).append_right _).trans (perm_append_comm.cons _) }
end

theorem perm_of_mem_permutations {l₁ l₂ : list α}
  (h : l₁ ∈ permutations l₂) : l₁ ~ l₂ :=
(eq_or_mem_of_mem_cons h).elim (λ e, e ▸ perm.refl _)
  (λ m, append_nil l₂ ▸ perm_of_mem_permutations_aux m)

theorem length_permutations_aux : ∀ ts is : list α,
  length (permutations_aux ts is) + is.length! = (length ts + length is)! :=
begin
  refine permutations_aux.rec (by simp) _,
  intros t ts is IH1 IH2,
  have IH2 : length (permutations_aux is nil) + 1 = is.length!,
  { simpa using IH2 },
  simp [-add_comm, nat.factorial, nat.add_succ, mul_comm] at IH1,
  rw [permutations_aux_cons,
      length_foldr_permutations_aux2' _ _ _ _ _
        (λ l m, (perm_of_mem_permutations m).length_eq),
      permutations, length, length, IH2,
      nat.succ_add, nat.factorial_succ, mul_comm (nat.succ _), ← IH1,
      add_comm (_*_), add_assoc, nat.mul_succ, mul_comm]
end

theorem length_permutations (l : list α) : length (permutations l) = (length l)! :=
length_permutations_aux l []

theorem mem_permutations_of_perm_lemma {is l : list α}
  (H : l ~ [] ++ is → (∃ ts' ~ [], l = ts' ++ is) ∨ l ∈ permutations_aux is [])
  : l ~ is → l ∈ permutations is :=
by simpa [permutations, perm_nil] using H

theorem mem_permutations_aux_of_perm :
  ∀ {ts is l : list α}, l ~ is ++ ts → (∃ is' ~ is, l = is' ++ ts) ∨ l ∈ permutations_aux ts is :=
begin
  refine permutations_aux.rec (by simp) _,
  intros t ts is IH1 IH2 l p,
  rw [permutations_aux_cons, mem_foldr_permutations_aux2],
  rcases IH1 (p.trans perm_middle) with ⟨is', p', e⟩ | m,
  { clear p, subst e,
    rcases mem_split (p'.symm.subset (mem_cons_self _ _)) with ⟨l₁, l₂, e⟩,
    subst is',
    have p := (perm_middle.symm.trans p').cons_inv,
    cases l₂ with a l₂',
    { exact or.inl ⟨l₁, by simpa using p⟩ },
    { exact or.inr (or.inr ⟨l₁, a::l₂',
        mem_permutations_of_perm_lemma IH2 p, by simp⟩) } },
  { exact or.inr (or.inl m) }
end

@[simp] theorem mem_permutations (s t : list α) : s ∈ permutations t ↔ s ~ t :=
⟨perm_of_mem_permutations, mem_permutations_of_perm_lemma mem_permutations_aux_of_perm⟩

end permutations

end list
-/


example : 0 * x = 0 := by simp
example : 1 * x = x := by simp
example : 2 * x = x + x := by simp [Nat.succ_mul]
example : 3 * x = x + x + x := by simp [Nat.succ_mul]


def alwaysTrue : ℕ → Prop := λ n, n ≥ 0

def alwaysFalse : ℕ → Prop := λ n, n < 0

inductive day : Type
| Monday
| Tuesday
| Wednesday
| Thursday
| Friday
| Saturday
| Sunday

#check day.Tuesday

open day -- no longer need to day. prefix

#check Tuesday

-- Answer

def isWeekend : day → Prop :=
    λ d, d = Saturday ∨ d = Sunday

theorem satIsWeekend : isWeekend Saturday :=
begin
    unfold isWeekend,
    apply or.inl,
    apply rfl
end

theorem satIsWeekend' : isWeekend Saturday := or.inl (eq.refl Saturday)

def set01 : ℕ → Prop := λ n, n = 0 ∨ n = 1

def set215 : ℕ → Prop := λ n, 2 ≤ n ∧ n ≤ 15

def setpos : ℕ → Prop := λ n, n > 0

def haha : (ℕ × ℕ) → Prop := λ ⟨a, b⟩, a = b

def isSquare : ℕ → ℕ → Prop := λ a b, a ^2 = b

lemma true39 : isSquare 3 9 := eq.refl 9

def sHasLengthN : string → ℕ → Prop := λ s n, string.length s = n


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_numbertheory_64 :
  is_least { x : ℕ | 30 * x ≡ 42 [MOD 47] } 39 :=
begin
  fsplit,
  norm_num,
  dec_trivial!,
  rintro ⟨n, hn⟩,
  simp,
  dec_trivial,
  intros h,
  norm_num,
  contrapose! h,
  dec_trivial!,
end


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad
-/
import .order

variable {A : Type}

/- lattices (we could split this to upper- and lower-semilattices, if needed) -/

structure lattice [class] (A : Type) extends weak_order A :=
(inf : A → A → A)
(sup : A → A → A)
(inf_le_left : ∀ a b, le (inf a b) a)
(inf_le_right : ∀ a b, le (inf a b) b)
(le_inf : ∀a b c, le c a → le c b → le c (inf a b))
(le_sup_left : ∀ a b, le a (sup a b))
(le_sup_right : ∀ a b, le b (sup a b))
(sup_le : ∀ a b c, le a c → le b c → le (sup a b) c)

definition inf := @lattice.inf
definition sup := @lattice.sup
infix ` ⊓ `:70 := inf
infix ` ⊔ `:65 := sup

section
  variable [s : lattice A]
  include s

  theorem inf_le_left (a b : A) : a ⊓ b ≤ a := !lattice.inf_le_left

  theorem inf_le_right (a b : A) : a ⊓ b ≤ b := !lattice.inf_le_right

  theorem le_inf {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) : c ≤ a ⊓ b := !lattice.le_inf H₁ H₂

  theorem le_sup_left (a b : A) : a ≤ a ⊔ b := !lattice.le_sup_left

  theorem le_sup_right (a b : A) : b ≤ a ⊔ b := !lattice.le_sup_right

  theorem sup_le {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) : a ⊔ b ≤ c := !lattice.sup_le H₁ H₂

  /- inf -/

  theorem eq_inf {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) (H₃ : ∀{d}, d ≤ a → d ≤ b → d ≤ c) :
    c = a ⊓ b :=
  le.antisymm (le_inf H₁ H₂) (H₃ !inf_le_left !inf_le_right)

  theorem inf.comm (a b : A) : a ⊓ b = b ⊓ a :=
  eq_inf !inf_le_right !inf_le_left (λ c H₁ H₂, le_inf H₂ H₁)

  theorem inf.assoc (a b c : A) : (a ⊓ b) ⊓ c = a ⊓ (b ⊓ c) :=
  begin
    apply eq_inf,
    { apply le.trans, apply inf_le_left, apply inf_le_left },
    { apply le_inf, apply le.trans, apply inf_le_left, apply inf_le_right, apply inf_le_right },
    { intros [d, H₁, H₂], apply le_inf, apply le_inf H₁, apply le.trans H₂, apply inf_le_left,
      apply le.trans H₂, apply inf_le_right }
  end

  theorem inf.left_comm (a b c : A) : a ⊓ (b ⊓ c) = b ⊓ (a ⊓ c) :=
  binary.left_comm (@inf.comm A s) (@inf.assoc A s) a b c

  theorem inf.right_comm (a b c : A) : (a ⊓ b) ⊓ c = (a ⊓ c) ⊓ b :=
  binary.right_comm (@inf.comm A s) (@inf.assoc A s) a b c

  theorem inf_self (a : A) : a ⊓ a = a :=
  by apply eq.symm; apply eq_inf (le.refl a) !le.refl; intros; assumption

  theorem inf_eq_left {a b : A} (H : a ≤ b) : a ⊓ b = a :=
  by apply eq.symm; apply eq_inf !le.refl H; intros; assumption

  theorem inf_eq_right {a b : A} (H : b ≤ a) : a ⊓ b = b :=
  eq.subst !inf.comm (inf_eq_left H)

  /- sup -/

  theorem eq_sup {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) (H₃ : ∀{d}, a ≤ d → b ≤ d → c ≤ d) :
    c = a ⊔ b :=
  le.antisymm (H₃ !le_sup_left !le_sup_right) (sup_le H₁ H₂)

  theorem sup.comm (a b : A) : a ⊔ b = b ⊔ a :=
  eq_sup !le_sup_right !le_sup_left (λ c H₁ H₂, sup_le H₂ H₁)

  theorem sup.assoc (a b c : A) : (a ⊔ b) ⊔ c = a ⊔ (b ⊔ c) :=
  begin
    apply eq_sup,
    { apply le.trans, apply le_sup_left a b, apply le_sup_left },
    { apply sup_le, apply le.trans, apply le_sup_right a b, apply le_sup_left, apply le_sup_right },
    { intros [d, H₁, H₂], apply sup_le, apply sup_le H₁, apply le.trans !le_sup_left H₂,
      apply le.trans !le_sup_right H₂}
  end

  theorem sup.left_comm (a b c : A) : a ⊔ (b ⊔ c) = b ⊔ (a ⊔ c) :=
  binary.left_comm (@sup.comm A s) (@sup.assoc A s) a b c

  theorem sup.right_comm (a b c : A) : (a ⊔ b) ⊔ c = (a ⊔ c) ⊔ b :=
  binary.right_comm (@sup.comm A s) (@sup.assoc A s) a b c

  theorem sup_self (a : A) : a ⊔ a = a :=
  by apply eq.symm; apply eq_sup (le.refl a) !le.refl; intros; assumption

  theorem sup_eq_left {a b : A} (H : b ≤ a) : a ⊔ b = a :=
  by apply eq.symm; apply eq_sup !le.refl H; intros; assumption

  theorem sup_eq_right {a b : A} (H : a ≤ b) : a ⊔ b = b :=
  eq.subst !sup.comm (sup_eq_left H)
end

/- lattice instances  -/

definition lattice_Prop [instance] : lattice Prop :=
⦃ lattice, weak_order_Prop,
  inf          := and,
  le_inf       := take a b c Ha Hb Hc, and.intro (Ha Hc) (Hb Hc),
  inf_le_left  := @and.elim_left,
  inf_le_right := @and.elim_right,
  sup          := or,
  sup_le       := @or.rec,
  le_sup_left  := @or.intro_left,
  le_sup_right := @or.intro_right
⦄

definition lattice_fun [instance] (A B : Type) [lattice B] : lattice (A → B) :=
⦃ lattice, weak_order_fun A B,
  inf          := λf g x, inf (f x) (g x),
  le_inf       := take f g h Hf Hg x, le_inf (Hf x) (Hg x),
  inf_le_left  := take f g x, !inf_le_left,
  inf_le_right := take f g x, !inf_le_right,
  sup          := λf g x, sup (f x) (g x),
  sup_le       := take f g h Hf Hg x, sup_le (Hf x) (Hg x),
  le_sup_left  := take f g x, !le_sup_left,
  le_sup_right := take t g x, !le_sup_right
⦄

/-
  Should we add a trans-instance from total orders to lattices?
  If we added we should add it with lower priority:
    Prop is added as a lattice, but in the classical case it is a total order!
-/


import lib.m154

namespace m154
open nat
/-
# Implications et équivalences

Ce fichier aborde l'étude des connecteurs logiques `↔` (équivalence logique, notée ⇔ sur papier)
et `→` (implication, notée `⇒` sur papier). Les exercices proposés, basés purement sur
ces connecteurs et les outils du fichier 01 sont un peu artificiels. Il s'agit d'être patient,
les exercices naturels arriveront dans le fichier suivant avec le quantificateur universel.

Dans la suite, on pourra utiliser les énoncés suivants.

`inferieur_ssi (x y : ℝ) : x ≤ y ↔ 0 ≤ y - x`

`inferieur_ssi' (x y : ℝ) : x ≤ y ↔ x - y ≤ 0`

`pos_pos (x y : ℝ) (hx : 0 ≤ x) (hy : 0 ≤ y) : 0 ≤ x*y`

`neg_neg (x y : ℝ) (hx : x ≤ 0) (hy : y ≤ 0) : 0 ≤ x*y`

Pour utiliser une équivalence, on peut réécrire comme avec une égalité,
à l'aide de `On réécrit via` et `On réécrit via ←`.

Pour démontrer une équivalence par double implication on utilise
`Montrons que` suivi de l'implication directe.
Une fois celle-ci démontrée, on utilise
`Montrons que` suivi de l'implication inverse.

Pour démontrer une implication P → Q, la commande
`Supposons hyp,`
permet de remplacer le but par Q et d'inclure P
dans nos hypothèses sous le nom hyp.

Pour introduire un énoncé intermédiaire, on utilise
`Fait nom : énoncé,`
Cela entraîne l'apparition d'un nouveau but à démontrer
avant de reprendre le fil de la démonstration principale.
-/

-- Dans toute la suite, a, b, c et d désignent des nombres réels.
variables {a b c d : ℝ}

/-
Commençons par une rédaction qui ne serait pas naturelle sur papier
mais qui montre bien comment l'opération de remplacement en utilisant
une équivalence permet de transformer le but ou une hypothèse.
On notera que la démonstration utilise aussi le remplacement en
utilisant une égalité comme dans le fichier 01.
-/

lemma inferieur_add_gauche : a ≤ b ↔ c + a ≤ c + b :=
begin
  -- On commence par s'équiper d'un fait intermédiaire qui servira
  -- pour les deux implications
  Fait clef : c + b - (c + a) = b - a,
    On calcule,
  -- On peut maintenant montrer la première implication
  Montrons que a ≤ b → c + a ≤ c + b,
    Supposons hab : a ≤ b,
    On réécrit via inferieur_ssi,   -- Ici On réécrit via en utilisant une équivalence
    On réécrit via clef,            -- Ici il s'agit d'une égalité
    On réécrit via ← inferieur_ssi, -- et ici de nouveau une équivalence
    On conclut par hab,
  -- On passe à l'implication réciproque
  Montrons que c + a ≤ c + b → a ≤ b,
  Supposons h : c + a ≤ c + b,
  On réécrit via inferieur_ssi,
  On réécrit via ← clef,
  On réécrit via inferieur_ssi dans h,
  On conclut par h,
end

/-
Comme dans le cas des manipulations d'égalité, on peut
obtenir une rédaction plus familière à l'aide de la commande `calc`.

Là encore, chaque justification doit faire le lien avec la ligne précédente
(ou avec le membre de gauche sur la première ligne).
-/

example : a ≤ b ↔ c + a ≤ c + b :=
begin
  Fait clef : c + b - (c + a) = b - a,
    On calcule,
  calc
  a ≤ b ↔ 0 ≤ b - a              : by On réécrit via inferieur_ssi
    ... ↔ 0 ≤ (c + b) - (c + a)  : by On réécrit via clef
    ... ↔ c + a ≤ c + b          : by On réécrit via ← inferieur_ssi,
end

/-
Remarque : la commande `On calcule` est en fait capable de faire le
remplacement de la deuxième ligne directement, on peut donc écrire :
-/

example : a ≤ b ↔ c + a ≤ c + b :=
begin
  calc
  a ≤ b ↔ 0 ≤ b - a              : by On réécrit via inferieur_ssi
    ... ↔ 0 ≤ (c + b) - (c + a)  : by On calcule
    ... ↔ c + a ≤ c + b          : by On réécrit via ← inferieur_ssi,
end

lemma inferieur_add_droite : a ≤ b ↔ a + c ≤ b + c :=
begin
  sorry
end

/-
Dans l'exemple suivant, on utilise un remplacement d'énoncé à
l'intérieur d'un calcul sur des nombres. En effet, la justification
de la deuxième ligne doit démontrer `0 + b ≤ a + b`. On commence par
transformer ce but en `0 ≤ a` en invoquant le lemme
`inferieur_add_droite` démontré ci-dessus, puis on conclut par l'hypothèse `hb`.
-/

lemma inferieur_add_pos_gauche (hb : 0 ≤ a) : b ≤ a + b :=
begin
  calc b = 0 + b : by On calcule
     ... ≤ a + b : by { On réécrit via ← inferieur_add_droite, On conclut par hb }
end

lemma inferieur_add_pos_droite (hb : 0 ≤ b) : a ≤ a + b :=
begin
  sorry
end

lemma inferieur_add_pos (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a + b :=
begin
  sorry
end

lemma inferieur_add (hab : a ≤ b) (hcd : c ≤ d) : a + c ≤ b + d :=
begin
  sorry
end

/-
Pour utiliser une implication on peut raisonner vers l'arrière : si P implique Q alors
pour montrer Q, il suffit de montrer P. La commande Lean pour faire cela avec une implication
`imp` dont la prémisse est `hyp`, est :
`Par imp il suffit de montrer que hyp,`
S'il y a plusieurs choses à montrer, disons `hyp₁` et `hyp₂`, on utilise
`Par imp il suffit de montrer que [hyp₁, hyp₂]`
-/

lemma inferieur_mul_droite (hc : 0 ≤ c) (hab : a ≤ b) : a*c ≤ b*c :=
begin
  On réécrit via inferieur_ssi,
  Fait clef : b*c - a*c = (b - a)*c,
    On calcule,
  On réécrit via clef,
  Par pos_pos il suffit de montrer que [0 ≤ b-a, 0 ≤ c],
    -- Noter que Lean comprend tout seul à quels nombres appliquer le lemme pos_pos
  On réécrit via ← inferieur_ssi,
  On conclut par hab,
  On conclut par hc,
end

/-
On peut aussi raisonner vers l'avant, en énonçant une succession de faits intermédiaires.
La commande `On conclut par ...` peut être complétée en fournissant un
argument ou une liste d'arguments, comme dans :
`On conclut par pos_pos appliqué à [hab', hc],`
de la démonstration suivante (du même énoncé que `inferieur_mul_droite`).
-/
example (hc : 0 ≤ c) (hab : a ≤ b) : a*c ≤ b*c :=
begin
  Fait hab' : 0 ≤ b - a,
    On réécrit via ← inferieur_ssi,
    On conclut par hab,
  Fait h₁ : 0 ≤ (b - a)*c,
    On conclut par pos_pos appliqué à [hab', hc],
  Fait h₂ : (b - a)*c = b*c - a*c,
    On calcule,
  Fait h₃ : 0 ≤ b*c - a*c,
    On réécrit via ← h₂,
    On conclut par h₁,
  On réécrit via inferieur_ssi,
  On conclut par h₃,
end

-- Encore une variante avec un calc
example (hc : 0 ≤ c) (hab : a ≤ b) : a*c ≤ b*c :=
begin
  Fait hab' : 0 ≤ b - a,
    On réécrit via ← inferieur_ssi,
    On conclut par hab,
  On réécrit via inferieur_ssi,
  calc 0 ≤ (b - a)*c  : by On conclut par pos_pos appliqué à [hab', hc]
     ... =  b*c - a*c : by On calcule,
end

example (hc : c ≤ 0) (hab :  a ≤ b) : b*c ≤ a*c :=
begin
  sorry
end

-- Essayer maintenant un autre style pour démontrer le même énoncé
example (hc : c ≤ 0) (hab :  a ≤ b) : b*c ≤ a*c :=
begin
  sorry
end

/-
Beaucoup d'énoncés ci-dessus cachent en fait des implications.
Par exemple, l'énoncé
`inferieur_add_pos_gauche (hb : 0 ≤ a) : b ≤ a + b`
se lit « Supposons que 0 ≤ a. Montrons que b ≤ a + b ». Mais on peut le réécrire
`inferieur_add_pos_gauche' : 0 ≤ a → b ≤ a + b`
qui se lit « Si 0 ≤ a alors b ≤ a + b ». Le contenu mathématique de ces deux énoncés est le même,
la différence est purement stylistique.

Vérifions qu'on peut ramener se ramener à la première version.
-/
lemma inferieur_add_pos_gauche' : 0 ≤ a → b ≤ a + b :=
begin
  Supposons ha,
  On conclut par inferieur_add_pos_gauche appliqué à ha,
end

/-
En fait Lean ne fait aucune différence entre les deux versions de ce lemme, comme on peut le voir
dans la version suivante.
-/
lemma inferieur_add_pos_gauche'' : 0 ≤ a → b ≤ a + b :=
begin
  On conclut par inferieur_add_pos_gauche,
end

/-
On se demande alors naturellement comment reformuler les énoncés faisant *deux* hypothèses, comme
`inferieur_add_pos (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a + b`

La solution la plus intuitive est de faire appel au connecteur logique « et », noté `∧`.
Une hypothèse hyp du contexte local qui est constituée de plusieurs morceaux peut être scindée
à l'aide de la commande
`Par hyp on obtient (h₁ : énoncé₁) (h₂ : énoncé₂)` (si hyp contient 2 morceaux)
comme dans l'exemple suivant.
-/
lemma inferieur_add_pos' : (0 ≤ a ∧ 0 ≤ b) → 0 ≤ a + b :=
begin
  Supposons hyp : 0 ≤ a ∧ 0 ≤ b,
  Par hyp on obtient (ha : 0 ≤ a) (hb : 0 ≤ b),
  On conclut par inferieur_add_pos appliqué à [ha, hb],
end

/-
La nécessité de passer par une ligne intermédiaire qui scinde la conjonction `hyp` en `ha` et `hb`
montre que cette reformulation comme implication n'est pas celle que Lean utilise.
Lean reformule l'énoncé comme deux implications emboîtées, ce qui est plus commode à l'usage.

On hésitera pas à utiliser la commande `parentheses` si ces suites d'implications posent des problèmes
de lecture.
-/
lemma inferieur_add_pos'' : 0 ≤ a → (0 ≤ b → 0 ≤ a + b) :=
begin
  On conclut par inferieur_add_pos,
end

/-
Montrons que la version utilisant une conjonction permet de retrouver la version de Lean.
Pour cela il faut savoir démontrer un énoncé de la forme `P ∧ Q` à l'aide de la commande
`Montrons que P,`
qui annonce la démonstration de `P` et incite Lean à créer un second but qui est de démontrer `Q`.
-/
lemma inferieur_add_pos''' : 0 ≤ a → (0 ≤ b → 0 ≤ a + b) :=
begin
  Supposons ha : 0 ≤ a,
  Supposons hb : 0 ≤ b,
  Par inferieur_add_pos' il suffit de montrer que 0 ≤ a ∧ 0 ≤ b,
  Montrons que 0 ≤ a,
    On conclut par ha,
  Montrons que 0 ≤ b,
  On conclut par hb,
end

/-
L'équivalence entre les deux reformulations est un fait complètement général.
Avant de démontrer ce fait, voici un exemple plus simple pour manipuler
`Par ... on obtient` et `Montrons que`.
Dans cet exercice, `P`, `Q` et `R` désignent des énoncés mathématiques quelconques.

Bien sûr Lean est parfaitement capable de démontrer automatiquement un tel énoncé,
mais ce n'est pas le but ici.
-/

example (P Q R : Prop): P ∧ Q → Q ∧ P :=
begin
  sorry
end

/-
Revenons maintenant aux deux façons de formuler des énoncés faisant deux hypothèses.
Si l'enchaînement des `Supposons ...` vous pèse, vous pouvez indiquer plusieurs
hypothèses sur la même ligne. Par exemple si le but est de la forme `P → Q → ...`,
vous pouvez commencer par :
`Supposons (hP : P) (hQ : Q),`
-/
example (P Q R : Prop) : (P ∧ Q → R) ↔ (P → (Q → R)) :=
begin
  sorry
end

/-
## Final

On a la relation de divisibilité sur les entiers naturels :
`a ∣ b` si `b` est un multiple de `a`. Attention la barre verticale n'est pas celle du
clavier mais s'obtient par ,|

Cette relation est réflexive et antisymétrique, c'est à dire qu'on a les deux énoncés :
`divise_refl (a : ℕ) : a ∣ a`
et
`divise_antisym {a b : ℕ} : a ∣ b → b ∣ a → a = b`

De plus on a une fonction `pgcd` qui, à deux entiers naturels associde un troisième entier
(leur plus grand diviseur commun). Cette fonction est liée à la relation
de divisibilité par :

`divise_pgcd_ssi {a b c : ℕ} : c ∣ pgcd a b ↔ c ∣ a ∧ c ∣ b`

Dans l'exercice suivant, le jeu est de n'utiliser que ces trois énoncés, sans essayer
de faire avouer à Lean la définition de la divisibilité ou du pgcd.
-/

example (a b : ℕ) : a ∣ b ↔ pgcd a b = a :=
begin
  sorry
end
end m154


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import algebra.hom.aut
import group_theory.group_action.units

/-!
# Group actions applied to various types of group

This file contains lemmas about `smul` on `group_with_zero`, and `group`.
-/

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

section mul_action

/-- `monoid.to_mul_action` is faithful on cancellative monoids. -/
@[to_additive /-" `add_monoid.to_add_action` is faithful on additive cancellative monoids. "-/]
instance right_cancel_monoid.to_has_faithful_smul [right_cancel_monoid α] :
  has_faithful_smul α α :=
⟨λ x y h, mul_right_cancel (h 1)⟩

section group
variables [group α] [mul_action α β]

@[simp, to_additive] lemma inv_smul_smul (c : α) (x : β) : c⁻¹ • c • x = x :=
by rw [smul_smul, mul_left_inv, one_smul]

@[simp, to_additive] lemma smul_inv_smul (c : α) (x : β) : c • c⁻¹ • x = x :=
by rw [smul_smul, mul_right_inv, one_smul]

/-- Given an action of a group `α` on `β`, each `g : α` defines a permutation of `β`. -/
@[to_additive, simps] def mul_action.to_perm (a : α) : equiv.perm β :=
⟨λ x, a • x, λ x, a⁻¹ • x, inv_smul_smul a, smul_inv_smul a⟩

/-- Given an action of an additive group `α` on `β`, each `g : α` defines a permutation of `β`. -/
add_decl_doc add_action.to_perm

/-- `mul_action.to_perm` is injective on faithful actions. -/
@[to_additive] lemma mul_action.to_perm_injective [has_faithful_smul α β] :
  function.injective (mul_action.to_perm : α → equiv.perm β) :=
(show function.injective (equiv.to_fun ∘ mul_action.to_perm), from smul_left_injective').of_comp

variables (α) (β)

/-- Given an action of a group `α` on a set `β`, each `g : α` defines a permutation of `β`. -/
@[simps]
def mul_action.to_perm_hom : α →* equiv.perm β :=
{ to_fun := mul_action.to_perm,
  map_one' := equiv.ext $ one_smul α,
  map_mul' := λ u₁ u₂, equiv.ext $ mul_smul (u₁:α) u₂ }

/-- Given an action of a additive group `α` on a set `β`, each `g : α` defines a permutation of
`β`. -/
@[simps]
def add_action.to_perm_hom (α : Type*) [add_group α] [add_action α β] :
  α →+ additive (equiv.perm β) :=
{ to_fun := λ a, additive.of_mul $ add_action.to_perm a,
  map_zero' := equiv.ext $ zero_vadd α,
  map_add' := λ a₁ a₂, equiv.ext $ add_vadd a₁ a₂ }

/-- The tautological action by `equiv.perm α` on `α`.

This generalizes `function.End.apply_mul_action`.-/
instance equiv.perm.apply_mul_action (α : Type*) : mul_action (equiv.perm α) α :=
{ smul := λ f a, f a,
  one_smul := λ _, rfl,
  mul_smul := λ _ _ _, rfl }

@[simp] protected lemma equiv.perm.smul_def {α : Type*} (f : equiv.perm α) (a : α) : f • a = f a :=
rfl

/-- `equiv.perm.apply_mul_action` is faithful. -/
instance equiv.perm.apply_has_faithful_smul (α : Type*) : has_faithful_smul (equiv.perm α) α :=
⟨λ x y, equiv.ext⟩

variables {α} {β}

@[to_additive] lemma inv_smul_eq_iff {a : α} {x y : β} : a⁻¹ • x = y ↔ x = a • y :=
(mul_action.to_perm a).symm_apply_eq

@[to_additive] lemma eq_inv_smul_iff {a : α} {x y : β} : x = a⁻¹ • y ↔ a • x = y :=
(mul_action.to_perm a).eq_symm_apply

lemma smul_inv [group β] [smul_comm_class α β β] [is_scalar_tower α β β] (c : α) (x : β) :
  (c • x)⁻¹ = c⁻¹ • x⁻¹  :=
by rw [inv_eq_iff_mul_eq_one, smul_mul_smul, mul_right_inv, mul_right_inv, one_smul]

lemma smul_zpow [group β] [smul_comm_class α β β] [is_scalar_tower α β β]
  (c : α) (x : β) (p : ℤ) :
  (c • x) ^ p = c ^ p • x ^ p :=
by { cases p; simp [smul_pow, smul_inv] }

@[simp] lemma commute.smul_right_iff [has_mul β] [smul_comm_class α β β] [is_scalar_tower α β β]
  {a b : β} (r : α) :
  commute a (r • b) ↔ commute a b :=
⟨λ h, inv_smul_smul r b ▸ h.smul_right r⁻¹, λ h, h.smul_right r⟩

@[simp] lemma commute.smul_left_iff [has_mul β] [smul_comm_class α β β] [is_scalar_tower α β β]
  {a b : β} (r : α) :
  commute (r • a) b ↔ commute a b :=
by rw [commute.symm_iff, commute.smul_right_iff, commute.symm_iff]

@[to_additive] protected lemma mul_action.bijective (g : α) : function.bijective (λ b : β, g • b) :=
(mul_action.to_perm g).bijective

@[to_additive] protected lemma mul_action.injective (g : α) : function.injective (λ b : β, g • b) :=
(mul_action.bijective g).injective

@[to_additive] lemma smul_left_cancel (g : α) {x y : β} (h : g • x = g • y) : x = y :=
mul_action.injective g h

@[simp, to_additive] lemma smul_left_cancel_iff (g : α) {x y : β} : g • x = g • y ↔ x = y :=
(mul_action.injective g).eq_iff

@[to_additive] lemma smul_eq_iff_eq_inv_smul (g : α) {x y : β} :
  g • x = y ↔ x = g⁻¹ • y :=
(mul_action.to_perm g).apply_eq_iff_eq_symm_apply

end group

/-- `monoid.to_mul_action` is faithful on nontrivial cancellative monoids with zero. -/
instance cancel_monoid_with_zero.to_has_faithful_smul [cancel_monoid_with_zero α] [nontrivial α] :
  has_faithful_smul α α :=
⟨λ x y h, mul_left_injective₀ one_ne_zero (h 1)⟩

section gwz
variables [group_with_zero α] [mul_action α β]

@[simp]
lemma inv_smul_smul₀ {c : α} (hc : c ≠ 0) (x : β) : c⁻¹ • c • x = x :=
inv_smul_smul (units.mk0 c hc) x

@[simp]
lemma smul_inv_smul₀ {c : α} (hc : c ≠ 0) (x : β) : c • c⁻¹ • x = x :=
smul_inv_smul (units.mk0 c hc) x

lemma inv_smul_eq_iff₀ {a : α} (ha : a ≠ 0) {x y : β} : a⁻¹ • x = y ↔ x = a • y :=
(mul_action.to_perm (units.mk0 a ha)).symm_apply_eq

lemma eq_inv_smul_iff₀ {a : α} (ha : a ≠ 0) {x y : β} : x = a⁻¹ • y ↔ a • x = y :=
(mul_action.to_perm (units.mk0 a ha)).eq_symm_apply

@[simp] lemma commute.smul_right_iff₀ [has_mul β] [smul_comm_class α β β] [is_scalar_tower α β β]
  {a b : β} {c : α} (hc : c ≠ 0) :
  commute a (c • b) ↔ commute a b :=
commute.smul_right_iff (units.mk0 c hc)

@[simp] lemma commute.smul_left_iff₀ [has_mul β] [smul_comm_class α β β] [is_scalar_tower α β β]
  {a b : β} {c : α} (hc : c ≠ 0) :
  commute (c • a) b ↔ commute a b :=
commute.smul_left_iff (units.mk0 c hc)

end gwz

end mul_action

section distrib_mul_action

section group
variables [group α] [add_monoid β] [distrib_mul_action α β]

variables (β)

/-- Each element of the group defines an additive monoid isomorphism.

This is a stronger version of `mul_action.to_perm`. -/
@[simps {simp_rhs := tt}]
def distrib_mul_action.to_add_equiv (x : α) : β ≃+ β :=
{ .. distrib_mul_action.to_add_monoid_hom β x,
  .. mul_action.to_perm_hom α β x }

variables (α β)

/-- Each element of the group defines an additive monoid isomorphism.

This is a stronger version of `mul_action.to_perm_hom`. -/
@[simps]
def distrib_mul_action.to_add_aut : α →* add_aut β :=
{ to_fun := distrib_mul_action.to_add_equiv β,
  map_one' := add_equiv.ext (one_smul _),
  map_mul' := λ a₁ a₂, add_equiv.ext (mul_smul _ _) }

variables {α β}

theorem smul_eq_zero_iff_eq (a : α) {x : β} : a • x = 0 ↔ x = 0 :=
⟨λ h, by rw [← inv_smul_smul a x, h, smul_zero], λ h, h.symm ▸ smul_zero _⟩

theorem smul_ne_zero_iff_ne (a : α) {x : β} : a • x ≠ 0 ↔ x ≠ 0 :=
not_congr $ smul_eq_zero_iff_eq a

end group

section gwz
variables [group_with_zero α] [add_monoid β] [distrib_mul_action α β]

theorem smul_eq_zero_iff_eq' {a : α} (ha : a ≠ 0) {x : β} : a • x = 0 ↔ x = 0 :=
smul_eq_zero_iff_eq (units.mk0 a ha)

theorem smul_ne_zero_iff_ne' {a : α} (ha : a ≠ 0) {x : β} : a • x ≠ 0 ↔ x ≠ 0 :=
smul_ne_zero_iff_ne (units.mk0 a ha)

end gwz

end distrib_mul_action

section mul_distrib_mul_action
variables [group α] [monoid β] [mul_distrib_mul_action α β]

variables (β)

/-- Each element of the group defines a multiplicative monoid isomorphism.

This is a stronger version of `mul_action.to_perm`. -/
@[simps {simp_rhs := tt}]
def mul_distrib_mul_action.to_mul_equiv (x : α) : β ≃* β :=
{ .. mul_distrib_mul_action.to_monoid_hom β x,
  .. mul_action.to_perm_hom α β x }

variables (α β)

/-- Each element of the group defines an multiplicative monoid isomorphism.

This is a stronger version of `mul_action.to_perm_hom`. -/
@[simps]
def mul_distrib_mul_action.to_mul_aut : α →* mul_aut β :=
{ to_fun := mul_distrib_mul_action.to_mul_equiv β,
  map_one' := mul_equiv.ext (one_smul _),
  map_mul' := λ a₁ a₂, mul_equiv.ext (mul_smul _ _) }

variables {α β}

end mul_distrib_mul_action

section arrow

/-- If `G` acts on `A`, then it acts also on `A → B`, by `(g • F) a = F (g⁻¹ • a)`. -/
@[to_additive arrow_add_action "If `G` acts on `A`, then it acts also on `A → B`, by
`(g +ᵥ F) a = F (g⁻¹ +ᵥ a)`", simps]
def arrow_action {G A B : Type*} [division_monoid G] [mul_action G A] : mul_action G (A → B) :=
{ smul := λ g F a, F (g⁻¹ • a),
  one_smul := by { intro, simp only [inv_one, one_smul] },
  mul_smul := by { intros, simp only [mul_smul, mul_inv_rev] } }

local attribute [instance] arrow_action

/-- When `B` is a monoid, `arrow_action` is additionally a `mul_distrib_mul_action`. -/
def arrow_mul_distrib_mul_action {G A B : Type*} [group G] [mul_action G A] [monoid B] :
  mul_distrib_mul_action G (A → B) :=
{ smul_one := λ g, rfl,
  smul_mul := λ g f₁ f₂, rfl }

local attribute [instance] arrow_mul_distrib_mul_action

/-- Given groups `G H` with `G` acting on `A`, `G` acts by
  multiplicative automorphisms on `A → H`. -/
@[simps] def mul_aut_arrow {G A H} [group G] [mul_action G A] [monoid H] : G →* mul_aut (A → H) :=
mul_distrib_mul_action.to_mul_aut _ _

end arrow

namespace is_unit

section mul_action
variables [monoid α] [mul_action α β]

@[to_additive] lemma smul_left_cancel {a : α} (ha : is_unit a) {x y : β} :
  a • x = a • y ↔ x = y :=
let ⟨u, hu⟩ := ha in hu ▸ smul_left_cancel_iff u

end mul_action

section distrib_mul_action
variables [monoid α] [add_monoid β] [distrib_mul_action α β]

@[simp] theorem smul_eq_zero {u : α} (hu : is_unit u) {x : β} :
  u • x = 0 ↔ x = 0 :=
exists.elim hu $ λ u hu, hu ▸ smul_eq_zero_iff_eq u

end distrib_mul_action

end is_unit

section smul

variables [group α] [monoid β]

@[simp] lemma is_unit_smul_iff [mul_action α β] [smul_comm_class α β β] [is_scalar_tower α β β]
  (g : α) (m : β) : is_unit (g • m) ↔ is_unit m :=
⟨λ h, inv_smul_smul g m ▸ h.smul g⁻¹, is_unit.smul g⟩

lemma is_unit.smul_sub_iff_sub_inv_smul
  [add_group β] [distrib_mul_action α β] [is_scalar_tower α β β] [smul_comm_class α β β]
  (r : α) (a : β) : is_unit (r • 1 - a) ↔ is_unit (1 - r⁻¹ • a) :=
by rw [←is_unit_smul_iff r (1 - r⁻¹ • a), smul_sub, smul_inv_smul]

end smul


/-
Copyright (c) 2021 Yakov Pechersky. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yakov Pechersky
-/
import data.fintype.basic
import data.finset.powerset

/-!

# Fintype instance for nodup lists

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

The subtype of `{l : list α // l.nodup}` over a `[fintype α]`
admits a `fintype` instance.

## Implementation details
To construct the `fintype` instance, a function lifting a `multiset α`
to the `finset (list α)` that can construct it is provided.
This function is applied to the `finset.powerset` of `finset.univ`.

In general, a `decidable_eq` instance is not necessary to define this function,
but a proof of `(list.permutations l).nodup` is required to avoid it,
which is a TODO.

-/

variables {α : Type*} [decidable_eq α]

open list

namespace multiset

/--
The `finset` of `l : list α` that, given `m : multiset α`, have the property `⟦l⟧ = m`.
-/
def lists : multiset α → finset (list α) :=
λ s, quotient.lift_on s (λ l, l.permutations.to_finset)
(λ l l' (h : l ~ l'),
  begin
    ext sl,
    simp only [mem_permutations, list.mem_to_finset],
    exact ⟨λ hs, hs.trans h, λ hs, hs.trans h.symm⟩
  end)

@[simp] lemma lists_coe (l : list α) :
  lists (l : multiset α) = l.permutations.to_finset := rfl

@[simp] lemma mem_lists_iff (s : multiset α) (l : list α) :
  l ∈ lists s ↔ s = ⟦l⟧ :=
begin
  induction s using quotient.induction_on,
  simpa using perm_comm
end

end multiset

instance fintype_nodup_list [fintype α] : fintype {l : list α // l.nodup} :=
fintype.subtype ((finset.univ : finset α).powerset.bUnion (λ s, s.val.lists)) (λ l,
  begin
    suffices : (∃ (a : finset α), a.val = ↑l) ↔ l.nodup,
    { simpa },
    split,
    { rintro ⟨s, hs⟩,
      simpa [←multiset.coe_nodup, ←hs] using s.nodup },
    { intro hl,
      refine ⟨⟨↑l, hl⟩, _⟩,
      simp }
  end)


inductive vec : Nat → Type where
  | nil : vec 0
  | cons : Int → vec n → vec n.succ

def vec_len : vec n → Nat
  | vec.nil => 0
  | x@(vec.cons h t) => vec_len t + 1

def vec_len' : {n : Nat} → vec n → Nat
  | _, vec.nil => 0
  | _, x@(vec.cons h t) => vec_len' t + 1

def tst1 : vec (n+1) → Int × vec (n+1) × vec n
  | x@(vec.cons h t) => (h, x, t)

def tst2 : vec n → Option (Int × vec n)
  | x@(vec.cons h t) => some (h, x)
  | _ => none

example (a : Int) (x : vec n) : tst2 (vec.cons a x) = some (a, vec.cons a x) :=
  rfl

def vec_len_non_as : vec n → Nat
  | vec.nil => 0
  | vec.cons h t => vec_len_non_as t + 1

def list_len : List Int → Nat
  | List.nil => 0
  | x@(List.cons h t) => list_len t + 1


import topology.metric_space.basic

section
variables {α : Type*} [partial_order α]
variables x y z : α

#check x ≤ y
#check (le_refl x : x ≤ x)
#check (le_trans : x ≤ y → y ≤ z → x ≤ z)

#check x < y
#check (lt_irrefl x : ¬ x < x)
#check (lt_trans : x < y → y < z → x < z)
#check (lt_of_le_of_lt : x ≤ y → y < z → x < z)
#check (lt_of_lt_of_le : x < y → y ≤ z → x < z)

example : x < y ↔ x ≤ y ∧ x ≠ y :=
lt_iff_le_and_ne

end

section
variables {α : Type*} [lattice α]
variables x y z : α

#check x ⊓ y -- inf ⊓
#check (inf_le_left : x ⊓ y ≤ x)
#check (inf_le_right : x ⊓ y ≤ y)
#check (le_inf : z ≤ x → z ≤ y → z ≤ x ⊓ y)

#check x ⊔ y --sup ⊔
#check (le_sup_left : x ≤ x ⊔ y)
#check (le_sup_right: y ≤ x ⊔ y)
#check (sup_le : x ≤ z → y ≤ z → x ⊔ y ≤ z)

example : x ⊓ y = y ⊓ x :=
begin
  have h : ∀ (a b : α), a ⊓ b ≤ b ⊓ a := by
  { intros,
    apply le_inf,
    apply inf_le_right,
    apply inf_le_left,},
  apply le_antisymm,
  repeat {apply h},
end

example : x ⊓ y ⊓ z = x ⊓ (y ⊓ z) :=
begin
  apply le_antisymm,
  { show x ⊓ y ⊓ z ≤ x ⊓ (y ⊓ z),
    apply le_inf,
    { show x ⊓ y ⊓ z ≤ x,
      have h' : x ⊓ y ⊓ z ≤ x ⊓ y := by apply inf_le_left,
      have : x ⊓ y ≤ x := by apply inf_le_left,
      apply le_trans h' this,},
    { show x ⊓ y ⊓ z ≤ y ⊓ z,
      apply le_inf,
      { show x ⊓ y ⊓ z ≤ y,
        have h' : x ⊓ y ⊓ z ≤ x ⊓ y := by apply inf_le_left,
        have : x ⊓ y ≤ y := by apply inf_le_right,
        apply le_trans h' this,},
      { show x ⊓ y ⊓ z ≤ z,
        apply inf_le_right,},},},
  { show x ⊓ (y ⊓ z) ≤ x ⊓ y ⊓ z,
    apply le_inf,
    { show x ⊓ (y ⊓ z) ≤ x ⊓ y,
      apply le_inf,
      { show x ⊓ (y ⊓ z) ≤ x,
        apply inf_le_left,},
      { show x ⊓ (y ⊓ z) ≤ y,
        have h' : x ⊓ (y ⊓ z) ≤ y ⊓ z := by apply inf_le_right,
        have : y ⊓ z ≤ y := by apply inf_le_left,
        apply le_trans h' this,}},
    { show x ⊓ (y ⊓ z) ≤ z,
      have h' : x ⊓ (y ⊓ z) ≤ y ⊓ z := by apply inf_le_right,
      have : y ⊓ z ≤ z := by apply inf_le_right,
      apply le_trans h' this,},},
end

example : x ⊔ y = y ⊔ x :=
begin
  apply le_antisymm,
  repeat {
    apply sup_le,
    apply le_sup_right,
    apply le_sup_left,
  }
end

example : x ⊔ y ⊔ z = x ⊔ (y ⊔ z) :=
begin
  apply le_antisymm,
  { apply sup_le,
    { apply sup_le,
      { apply le_sup_left,},
      { apply le_trans,
        show y ≤ y ⊔ z; apply le_sup_left,
        apply le_sup_right,},
      },
    { apply le_trans,
      show z ≤ y ⊔ z; apply le_sup_right,
      apply le_sup_right,},},
  { apply sup_le,
    { apply le_trans,
      show x ≤ x ⊔ y; apply le_sup_left,
      apply le_sup_left,},
    { apply sup_le,
      { apply le_trans,
        show y ≤ x ⊔ y; apply le_sup_right,
        apply le_sup_left,},
      { apply le_sup_right,},},},
end

theorem absorb1 : x ⊓ (x ⊔ y) = x :=
begin
  apply le_antisymm,
  { show x ⊓ (x ⊔ y) ≤ x,
    apply inf_le_left,
    },
  { show x ≤ x ⊓ (x ⊔ y),
    apply le_inf,
    apply le_refl,
    apply le_sup_left,},
end

theorem absorb2 : x ⊔ (x ⊓ y) = x :=
begin
  apply le_antisymm,
  { show x ⊔ (x ⊓ y) ≤ x,
    apply sup_le,
    apply le_refl,
    apply inf_le_left,},
  { show x ≤ x ⊔ (x ⊓ y),
    apply le_sup_left,},
end

end

section

variables {α : Type*} [distrib_lattice α]
variables x y z : α

#check (inf_sup_left : x ⊓ (y ⊔ z) = (x ⊓ y) ⊔ (x ⊓ z))
#check (inf_sup_right : (x ⊔ y) ⊓ z = (x ⊓ z) ⊔ (y ⊓ z))
#check (sup_inf_left : x ⊔ (y ⊓ z) = (x ⊔ y) ⊓ (x ⊔ z))
#check (sup_inf_right : (x ⊓ y) ⊔ z = (x ⊔ z) ⊓ (y ⊔ z))

end

section
variables {α : Type*} [lattice α]
variables a b c : α

example (h : ∀ x y z : α, x ⊓ (y ⊔ z) = (x ⊓ y) ⊔ (x ⊓ z)) :
  a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c) :=
begin
  have h' : (a ⊔ b) ⊓ (a ⊔ c) = a ⊔ ((a ⊔ b) ⊓ c) :=
    calc
      (a ⊔ b) ⊓ (a ⊔ c) = ((a ⊔ b) ⊓ a) ⊔ ((a ⊔ b) ⊓ c) : by apply h
      ... = a ⊔ ((a ⊔ b) ⊓ c) : by rw [inf_comm, inf_sup_self],
  have h'' : (a ⊔ b) ⊓ (a ⊔ c) = a ⊔ (c ⊓ a) ⊔ (c ⊓ b) :=
    calc
      (a ⊔ b) ⊓ (a ⊔ c) = a ⊔ ((a ⊔ b) ⊓ c) : by apply h'
      ... = a ⊔ ((c ⊓ a) ⊔ (c ⊓ b)) : by rw [inf_comm, h]
      ... = a ⊔ (c ⊓ a) ⊔ (c ⊓ b) : by rw [sup_assoc],
  rw h'',
  apply symm,
  calc
    a ⊔ (c ⊓ a) ⊔ (c ⊓ b) = a ⊔ (a ⊓ c) ⊔ (c ⊓ b) : by rw inf_comm
    ... = a ⊔ (c ⊓ b) : by rw sup_inf_self
    ... = a ⊔ (b ⊓ c) : by rw inf_comm,
end

example (h : ∀ x y z : α, x ⊔ (y ⊓ z) = (x ⊔ y) ⊓ (x ⊔ z)) :
  a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c) :=
begin
  apply symm,
  calc
    (a ⊓ b) ⊔ (a ⊓ c) = ((a ⊓ b) ⊔ a) ⊓ ((a ⊓ b) ⊔ c) : by rw h
    ... = (a ⊔ (a ⊓ b)) ⊓ ((a ⊓ b) ⊔ c) : by rw sup_comm
    ... = a ⊓ (c ⊔ (a ⊓ b)) : by rw [sup_inf_self, sup_comm]
    ... = a ⊓ (c ⊔ a) ⊓ (c ⊔ b) : by rw [h, inf_assoc]
    ... = a ⊓ (b ⊔ c) : by rw [sup_comm, inf_sup_self, sup_comm],
end

end

section

variables {R : Type*} [ordered_ring R]
variables a b c : R

#check (add_le_add_left : a ≤ b → ∀ c, c + a ≤ c + b)
#check (mul_pos : 0 < a → 0 < b → 0 < a * b)
#check (mul_nonneg : 0 ≤ a → 0 ≤ b → 0 ≤ a * b)

lemma aux1 : a ≤ b → 0 ≤ b - a :=
begin
  intro h,
  have : -a + a ≤ -a + b := add_le_add_left h (-a),
  have : a + -a ≤ b + -a := by rw [add_comm (-a), add_comm (-a)] at this; exact this,
  rw [add_neg_self] at this,
  rw tactic.ring.add_neg_eq_sub at this,
  exact this,
end

lemma aux2 : 0 ≤ b - a → a ≤ b :=
begin
  intro h,
  have : a + 0 ≤ a + (b - a) := add_le_add_left h a,
  have : a ≤ (a + b) + -a :=
    by rw [add_zero, ←tactic.ring.add_neg_eq_sub, ←add_assoc] at this; exact this,
  rw add_neg_cancel_comm at this,
  exact this,
end

example (h : a ≤ b) (h' : 0 ≤ c) : a * c ≤ b * c :=
begin
  have : 0 ≤ (b - a) * c := by
  { apply mul_nonneg,
    exact aux1 a b h,
    exact h',},
  have : 0 ≤ (b * c) - (a * c) := by rw [sub_mul] at this; exact this,
  exact aux2 (a*c) (b*c) this,
end

end

section

variables {X : Type*} [metric_space X]
variables x y z : X

#check (dist_self x : dist x x = 0)
#check (dist_comm x y : dist x y = dist y x)
#check (dist_triangle x y z : dist x z ≤ dist x y + dist y z)

example (x y : X) : 0 ≤ dist x y :=
begin
  have : dist x x ≤ dist x y + dist y x := by apply dist_triangle,
  have : 0 ≤ dist x y + dist x y := by rw [dist_self, dist_comm y x] at this; exact this,
  have : 0 ≤ 2 * dist x y := by rw [←two_mul] at this; exact this,
  exact nonneg_of_mul_nonneg_left this (by norm_num),
end

#check nonneg_of_mul_nonneg_left

end


/-
Copyright (c) 2018 . All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Thomas Browning
-/

import data.zmod.basic
import group_theory.index
import group_theory.group_action.conj_act
import group_theory.perm.cycle_type
import group_theory.quotient_group

/-!
# p-groups

This file contains a proof that if `G` is a `p`-group acting on a finite set `α`,
then the number of fixed points of the action is congruent mod `p` to the cardinality of `α`.
It also contains proofs of some corollaries of this lemma about existence of fixed points.
-/

open_locale big_operators

open fintype mul_action

variables (p : ℕ) (G : Type*) [group G]

/-- A p-group is a group in which every element has prime power order -/
def is_p_group : Prop := ∀ g : G, ∃ k : ℕ, g ^ (p ^ k) = 1

variables {p} {G}

namespace is_p_group

lemma iff_order_of [hp : fact p.prime] :
  is_p_group p G ↔ ∀ g : G, ∃ k : ℕ, order_of g = p ^ k :=
forall_congr (λ g, ⟨λ ⟨k, hk⟩, exists_imp_exists (by exact λ j, Exists.snd)
  ((nat.dvd_prime_pow hp.out).mp (order_of_dvd_of_pow_eq_one hk)),
  exists_imp_exists (λ k hk, by rw [←hk, pow_order_of_eq_one])⟩)

lemma of_card [fintype G] {n : ℕ} (hG : card G = p ^ n) : is_p_group p G :=
λ g, ⟨n, by rw [←hG, pow_card_eq_one]⟩

lemma of_bot : is_p_group p (⊥ : subgroup G) :=
of_card (subgroup.card_bot.trans (pow_zero p).symm)

lemma iff_card [fact p.prime] [fintype G] :
  is_p_group p G ↔ ∃ n : ℕ, card G = p ^ n :=
begin
  have hG : 0 < card G := card_pos_iff.mpr has_one.nonempty,
  refine ⟨λ h, _, λ ⟨n, hn⟩, of_card hn⟩,
  suffices : ∀ q ∈ nat.factors (card G), q = p,
  { use (card G).factors.length,
    rw [←list.prod_repeat, ←list.eq_repeat_of_mem this, nat.prod_factors hG] },
  intros q hq,
  obtain ⟨hq1, hq2⟩ := (nat.mem_factors hG.ne').mp hq,
  haveI : fact q.prime := ⟨hq1⟩,
  obtain ⟨g, hg⟩ := equiv.perm.exists_prime_order_of_dvd_card q hq2,
  obtain ⟨k, hk⟩ := (iff_order_of.mp h) g,
  exact (hq1.pow_eq_iff.mp (hg.symm.trans hk).symm).1.symm,
end

section G_is_p_group

variables (hG : is_p_group p G)

include hG

lemma of_injective {H : Type*} [group H] (ϕ : H →* G) (hϕ : function.injective ϕ) :
  is_p_group p H :=
begin
  simp_rw [is_p_group, ←hϕ.eq_iff, ϕ.map_pow, ϕ.map_one],
  exact λ h, hG (ϕ h),
end

lemma to_subgroup (H : subgroup G) : is_p_group p H :=
hG.of_injective H.subtype subtype.coe_injective

lemma of_surjective {H : Type*} [group H] (ϕ : G →* H) (hϕ : function.surjective ϕ) :
  is_p_group p H :=
begin
  refine λ h, exists.elim (hϕ h) (λ g hg, exists_imp_exists (λ k hk, _) (hG g)),
  rw [←hg, ←ϕ.map_pow, hk, ϕ.map_one],
end

lemma to_quotient (H : subgroup G) [H.normal] :
  is_p_group p (G ⧸ H) :=
hG.of_surjective (quotient_group.mk' H) quotient.surjective_quotient_mk'

lemma of_equiv {H : Type*} [group H] (ϕ : G ≃* H) : is_p_group p H :=
hG.of_surjective ϕ.to_monoid_hom ϕ.surjective

variables [hp : fact p.prime]

include hp

lemma index (H : subgroup G) [fintype (G ⧸ H)] :
  ∃ n : ℕ, H.index = p ^ n :=
begin
  obtain ⟨n, hn⟩ := iff_card.mp (hG.to_quotient H.normal_core),
  obtain ⟨k, hk1, hk2⟩ := (nat.dvd_prime_pow hp.out).mp ((congr_arg _
    (H.normal_core.index_eq_card.trans hn)).mp (subgroup.index_dvd_of_le H.normal_core_le)),
  exact ⟨k, hk2⟩,
end

variables {α : Type*} [mul_action G α]

lemma card_orbit (a : α) [fintype (orbit G a)] :
  ∃ n : ℕ, card (orbit G a) = p ^ n :=
begin
  let ϕ := orbit_equiv_quotient_stabilizer G a,
  haveI := fintype.of_equiv (orbit G a) ϕ,
  rw [card_congr ϕ, ←subgroup.index_eq_card],
  exact hG.index (stabilizer G a),
end

variables (α) [fintype α] [fintype (fixed_points G α)]

/-- If `G` is a `p`-group acting on a finite set `α`, then the number of fixed points
  of the action is congruent mod `p` to the cardinality of `α` -/
lemma card_modeq_card_fixed_points : card α ≡ card (fixed_points G α) [MOD p] :=
begin
  classical,
  calc card α = card (Σ y : quotient (orbit_rel G α), {x // quotient.mk' x = y}) :
    card_congr (equiv.sigma_preimage_equiv (@quotient.mk' _ (orbit_rel G α))).symm
  ... = ∑ a : quotient (orbit_rel G α), card {x // quotient.mk' x = a} : card_sigma _
  ... ≡ ∑ a : fixed_points G α, 1 [MOD p] : _
  ... = _ : by simp; refl,
  rw [←zmod.eq_iff_modeq_nat p, nat.cast_sum, nat.cast_sum],
  have key : ∀ x, card {y // (quotient.mk' y : quotient (orbit_rel G α)) = quotient.mk' x} =
    card (orbit G x) := λ x, by simp only [quotient.eq']; congr,
  refine eq.symm (finset.sum_bij_ne_zero (λ a _ _, quotient.mk' a.1) (λ _ _ _, finset.mem_univ _)
    (λ a₁ a₂ _ _ _ _ h, subtype.eq ((mem_fixed_points' α).mp a₂.2 a₁.1 (quotient.exact' h)))
      (λ b, quotient.induction_on' b (λ b _ hb, _)) (λ a ha _, by
      { rw [key, mem_fixed_points_iff_card_orbit_eq_one.mp a.2] })),
  obtain ⟨k, hk⟩ := hG.card_orbit b,
  have : k = 0 := nat.le_zero_iff.1 (nat.le_of_lt_succ (lt_of_not_ge (mt (pow_dvd_pow p)
    (by rwa [pow_one, ←hk, ←nat.modeq_zero_iff_dvd, ←zmod.eq_iff_modeq_nat, ←key])))),
  exact ⟨⟨b, mem_fixed_points_iff_card_orbit_eq_one.2 $ by rw [hk, this, pow_zero]⟩,
    finset.mem_univ _, (ne_of_eq_of_ne nat.cast_one one_ne_zero), rfl⟩,
end

/-- If a p-group acts on `α` and the cardinality of `α` is not a multiple
  of `p` then the action has a fixed point. -/
lemma nonempty_fixed_point_of_prime_not_dvd_card (hpα : ¬ p ∣ card α) :
  (fixed_points G α).nonempty :=
@set.nonempty_of_nonempty_subtype _ _ begin
rw [←card_pos_iff, pos_iff_ne_zero],
  contrapose! hpα,
  rw [←nat.modeq_zero_iff_dvd, ←hpα],
  exact hG.card_modeq_card_fixed_points α,
end

/-- If a p-group acts on `α` and the cardinality of `α` is a multiple
  of `p`, and the action has one fixed point, then it has another fixed point. -/
lemma exists_fixed_point_of_prime_dvd_card_of_fixed_point
  (hpα : p ∣ card α) {a : α} (ha : a ∈ fixed_points G α) :
  ∃ b, b ∈ fixed_points G α ∧ a ≠ b :=
have hpf : p ∣ card (fixed_points G α) :=
  nat.modeq_zero_iff_dvd.mp ((hG.card_modeq_card_fixed_points α).symm.trans hpα.modeq_zero_nat),
have hα : 1 < card (fixed_points G α) :=
  (fact.out p.prime).one_lt.trans_le (nat.le_of_dvd (card_pos_iff.2 ⟨⟨a, ha⟩⟩) hpf),
let ⟨⟨b, hb⟩, hba⟩ := exists_ne_of_one_lt_card hα ⟨a, ha⟩ in
⟨b, hb, λ hab, hba (by simp_rw [hab])⟩

lemma center_nontrivial [nontrivial G] [fintype G] : nontrivial (subgroup.center G) :=
begin
  classical,
  have := (hG.of_equiv conj_act.to_conj_act).exists_fixed_point_of_prime_dvd_card_of_fixed_point G,
  rw conj_act.fixed_points_eq_center at this,
  obtain ⟨g, hg⟩ := this _ (subgroup.center G).one_mem,
  { exact ⟨⟨1, ⟨g, hg.1⟩, mt subtype.ext_iff.mp hg.2⟩⟩ },
  { obtain ⟨n, hn⟩ := is_p_group.iff_card.mp hG,
    rw hn,
    apply dvd_pow_self,
    rintro rfl,
    exact (fintype.one_lt_card).ne' hn },
end

lemma bot_lt_center [nontrivial G] [fintype G] : ⊥ < subgroup.center G :=
begin
  haveI := center_nontrivial hG,
  classical,
  exact bot_lt_iff_ne_bot.mpr ((subgroup.center G).one_lt_card_iff_ne_bot.mp fintype.one_lt_card),
end

end G_is_p_group

lemma to_le {H K : subgroup G} (hK : is_p_group p K) (hHK : H ≤ K) : is_p_group p H :=
hK.of_injective (subgroup.inclusion hHK) (λ a b h, subtype.ext (show _, from subtype.ext_iff.mp h))

lemma to_inf_left {H K : subgroup G} (hH : is_p_group p H) : is_p_group p (H ⊓ K : subgroup G) :=
hH.to_le inf_le_left

lemma to_inf_right {H K : subgroup G} (hK : is_p_group p K) : is_p_group p (H ⊓ K : subgroup G) :=
hK.to_le inf_le_right

lemma map {H : subgroup G} (hH : is_p_group p H) {K : Type*} [group K]
  (ϕ : G →* K) : is_p_group p (H.map ϕ) :=
begin
  rw [←H.subtype_range, monoid_hom.map_range],
  exact hH.of_surjective (ϕ.restrict H).range_restrict (ϕ.restrict H).range_restrict_surjective,
end

lemma comap_of_ker_is_p_group {H : subgroup G} (hH : is_p_group p H) {K : Type*} [group K]
  (ϕ : K →* G) (hϕ : is_p_group p ϕ.ker) : is_p_group p (H.comap ϕ) :=
begin
  intro g,
  obtain ⟨j, hj⟩ := hH ⟨ϕ g.1, g.2⟩,
  rw [subtype.ext_iff, H.coe_pow, subtype.coe_mk, ←ϕ.map_pow] at hj,
  obtain ⟨k, hk⟩ := hϕ ⟨g.1 ^ p ^ j, hj⟩,
  rwa [subtype.ext_iff, ϕ.ker.coe_pow, subtype.coe_mk, ←pow_mul, ←pow_add] at hk,
  exact ⟨j + k, by rwa [subtype.ext_iff, (H.comap ϕ).coe_pow]⟩,
end

lemma ker_is_p_group_of_injective {K : Type*} [group K] {ϕ : K →* G} (hϕ : function.injective ϕ) :
  is_p_group p ϕ.ker :=
(congr_arg (λ Q : subgroup K, is_p_group p Q) (ϕ.ker_eq_bot_iff.mpr hϕ)).mpr is_p_group.of_bot

lemma comap_of_injective {H : subgroup G} (hH : is_p_group p H) {K : Type*} [group K]
  (ϕ : K →* G) (hϕ : function.injective ϕ) : is_p_group p (H.comap ϕ) :=
hH.comap_of_ker_is_p_group ϕ (ker_is_p_group_of_injective hϕ)

lemma comap_subtype {H : subgroup G} (hH : is_p_group p H) {K : subgroup G} :
  is_p_group p (H.comap K.subtype) :=
hH.comap_of_injective K.subtype subtype.coe_injective

lemma to_sup_of_normal_right {H K : subgroup G} (hH : is_p_group p H) (hK : is_p_group p K)
  [K.normal] : is_p_group p (H ⊔ K : subgroup G) :=
begin
  rw [←quotient_group.ker_mk K, ←subgroup.comap_map_eq],
  apply (hH.map (quotient_group.mk' K)).comap_of_ker_is_p_group,
  rwa quotient_group.ker_mk,
end

lemma to_sup_of_normal_left {H K : subgroup G} (hH : is_p_group p H) (hK : is_p_group p K)
  [H.normal] : is_p_group p (H ⊔ K : subgroup G) :=
(congr_arg (λ H : subgroup G, is_p_group p H) sup_comm).mp (to_sup_of_normal_right hK hH)

lemma to_sup_of_normal_right' {H K : subgroup G} (hH : is_p_group p H) (hK : is_p_group p K)
  (hHK : H ≤ K.normalizer) : is_p_group p (H ⊔ K : subgroup G) :=
let hHK' := to_sup_of_normal_right (hH.of_equiv (subgroup.comap_subtype_equiv_of_le hHK).symm)
  (hK.of_equiv (subgroup.comap_subtype_equiv_of_le subgroup.le_normalizer).symm) in
((congr_arg (λ H : subgroup K.normalizer, is_p_group p H)
  (subgroup.sup_subgroup_of_eq hHK subgroup.le_normalizer)).mp hHK').of_equiv
  (subgroup.comap_subtype_equiv_of_le (sup_le hHK subgroup.le_normalizer))

lemma to_sup_of_normal_left' {H K : subgroup G} (hH : is_p_group p H) (hK : is_p_group p K)
  (hHK : K ≤ H.normalizer) : is_p_group p (H ⊔ K : subgroup G) :=
(congr_arg (λ H : subgroup G, is_p_group p H) sup_comm).mp (to_sup_of_normal_right' hK hH hHK)

/-- finite p-groups with different p have coprime orders -/
lemma coprime_card_of_ne {G₂ : Type*} [group G₂]
  (p₁ p₂ : ℕ) [hp₁ : fact p₁.prime] [hp₂ : fact p₂.prime] (hne : p₁ ≠ p₂)
  (H₁ : subgroup G) (H₂ : subgroup G₂) [fintype H₁] [fintype H₂]
  (hH₁ : is_p_group p₁ H₁) (hH₂ : is_p_group p₂ H₂) :
  nat.coprime (fintype.card H₁) (fintype.card H₂) :=
begin
  obtain ⟨n₁, heq₁⟩ := iff_card.mp hH₁, rw heq₁, clear heq₁,
  obtain ⟨n₂, heq₂⟩ := iff_card.mp hH₂, rw heq₂, clear heq₂,
  exact nat.coprime_pow_primes _ _ (hp₁.elim) (hp₂.elim) hne,
end

/-- p-groups with different p are disjoint -/
lemma disjoint_of_ne (p₁ p₂ : ℕ) [hp₁ : fact p₁.prime] [hp₂ : fact p₂.prime] (hne : p₁ ≠ p₂)
  (H₁ H₂ : subgroup G) (hH₁ : is_p_group p₁ H₁) (hH₂ : is_p_group p₂ H₂) :
  disjoint H₁ H₂ :=
begin
  rintro x ⟨hx₁, hx₂⟩,
  rw subgroup.mem_bot,
  obtain ⟨n₁, hn₁⟩ := iff_order_of.mp hH₁ ⟨x, hx₁⟩,
  obtain ⟨n₂, hn₂⟩ := iff_order_of.mp hH₂ ⟨x, hx₂⟩,
  rw [← order_of_subgroup, subgroup.coe_mk] at hn₁ hn₂,
  have : p₁ ^ n₁ = p₂ ^ n₂, by rw [← hn₁, ← hn₂],
  have : n₁ = 0,
  { contrapose! hne with h,
    rw ← associated_iff_eq at this ⊢,
    exact associated.of_pow_associated_of_prime
      (nat.prime_iff.mp hp₁.elim) (nat.prime_iff.mp hp₂.elim) (ne.bot_lt h) this },
  simpa [this] using hn₁,
end

end is_p_group


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.bitvec.core
import Mathlib.data.fin
import Mathlib.tactic.norm_num
import Mathlib.tactic.monotonicity.default
import Mathlib.PostPort

namespace Mathlib

namespace bitvec

protected instance preorder (n : ℕ) : preorder (bitvec n) :=
  preorder.lift bitvec.to_nat

/-- convert `fin` to `bitvec` -/
def of_fin {n : ℕ} (i : fin (bit0 1 ^ n)) : bitvec n :=
  bitvec.of_nat n (subtype.val i)

theorem of_fin_val {n : ℕ} (i : fin (bit0 1 ^ n)) : bitvec.to_nat (of_fin i) = subtype.val i := sorry

/-- convert `bitvec` to `fin` -/
def to_fin {n : ℕ} (i : bitvec n) : fin (bit0 1 ^ n) :=
  fin.of_nat' (bitvec.to_nat i)

theorem add_lsb_eq_twice_add_one {x : ℕ} {b : Bool} : add_lsb x b = bit0 1 * x + cond b 1 0 := sorry

theorem to_nat_eq_foldr_reverse {n : ℕ} (v : bitvec n) : bitvec.to_nat v = list.foldr (flip add_lsb) 0 (list.reverse (vector.to_list v)) := sorry

theorem to_nat_lt {n : ℕ} (v : bitvec n) : bitvec.to_nat v < bit0 1 ^ n := sorry

theorem add_lsb_div_two {x : ℕ} {b : Bool} : add_lsb x b / bit0 1 = x := sorry

theorem to_bool_add_lsb_mod_two {x : ℕ} {b : Bool} : to_bool (add_lsb x b % bit0 1 = 1) = b := sorry

theorem of_nat_to_nat {n : ℕ} (v : bitvec n) : bitvec.of_nat n (bitvec.to_nat v) = v := sorry

theorem to_fin_val {n : ℕ} (v : bitvec n) : ↑(to_fin v) = bitvec.to_nat v := sorry

theorem to_fin_le_to_fin_of_le {n : ℕ} {v₀ : bitvec n} {v₁ : bitvec n} (h : v₀ ≤ v₁) : to_fin v₀ ≤ to_fin v₁ :=
  (fun (this : ↑(to_fin v₀) ≤ ↑(to_fin v₁)) => this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(to_fin v₀) ≤ ↑(to_fin v₁))) (to_fin_val v₀)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (bitvec.to_nat v₀ ≤ ↑(to_fin v₁))) (to_fin_val v₁))) h))

theorem of_fin_le_of_fin_of_le {n : ℕ} {i : fin (bit0 1 ^ n)} {j : fin (bit0 1 ^ n)} (h : i ≤ j) : of_fin i ≤ of_fin j := sorry

theorem to_fin_of_fin {n : ℕ} (i : fin (bit0 1 ^ n)) : to_fin (of_fin i) = i := sorry

theorem of_fin_to_fin {n : ℕ} (v : bitvec n) : of_fin (to_fin v) = v :=
  id
    (eq.mpr (id (Eq._oldrec (Eq.refl (bitvec.of_nat n ↑(to_fin v) = v)) (to_fin_val v)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (bitvec.of_nat n (bitvec.to_nat v) = v)) (of_nat_to_nat v))) (Eq.refl v)))