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

! This file was ported from Lean 3 source module group_theory.group_action.group
! leanprover-community/mathlib commit ba2245edf0c8bb155f1569fd9b9492a9b384cde6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Hom.Aut
import Mathlib.GroupTheory.GroupAction.Units

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

This file contains lemmas about `SMul` on `GroupWithZero`, and `Group`.
-/

universe u v w

variable {α : Type u} {β : Type v} {γ : Type w}

section MulAction

/-- `Monoid.toMulAction` is faithful on cancellative monoids. -/
@[to_additive " `AddMonoid.toAddAction` is faithful on additive cancellative monoids. "]
instance RightCancelMonoid.faithfulSMul [RightCancelMonoid α] : FaithfulSMul α α :=
  ⟨fun h => mul_right_cancel (h 1)⟩
#align right_cancel_monoid.to_has_faithful_smul RightCancelMonoid.faithfulSMul
#align add_right_cancel_monoid.to_has_faithful_vadd AddRightCancelMonoid.faithfulVAdd

section Group

variable [Group α] [MulAction α β]

@[to_additive (attr := simp)]
theorem inv_smul_smul (c : α) (x : β) : c⁻¹ • c • x = x := by rw [smul_smul, mul_left_inv, one_smul]
#align inv_smul_smul inv_smul_smul
#align neg_vadd_vadd neg_vadd_vadd

@[to_additive (attr := simp)]
theorem smul_inv_smul (c : α) (x : β) : c • c⁻¹ • x = x := by
  rw [smul_smul, mul_right_inv, one_smul]
#align smul_inv_smul smul_inv_smul
#align vadd_neg_vadd vadd_neg_vadd

/-- Given an action of a group `α` on `β`, each `g : α` defines a permutation of `β`. -/
@[to_additive (attr := simps)]
def MulAction.toPerm (a : α) : Equiv.Perm β :=
  ⟨fun x => a • x, fun x => a⁻¹ • x, inv_smul_smul a, smul_inv_smul a⟩
#align mul_action.to_perm MulAction.toPerm
#align add_action.to_perm AddAction.toPerm
#align add_action.to_perm_apply AddAction.toPerm_apply
#align mul_action.to_perm_apply MulAction.toPerm_apply
#align add_action.to_perm_symm_apply AddAction.toPerm_symm_apply
#align mul_action.to_perm_symm_apply MulAction.toPerm_symm_apply

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

/-- `MulAction.toPerm` is injective on faithful actions. -/
@[to_additive "`AddAction.toPerm` is injective on faithful actions."]
theorem MulAction.toPerm_injective [FaithfulSMul α β] :
    Function.Injective (MulAction.toPerm : α → Equiv.Perm β) :=
  (show Function.Injective (Equiv.toFun ∘ MulAction.toPerm) from smul_left_injective').of_comp
#align mul_action.to_perm_injective MulAction.toPerm_injective
#align add_action.to_perm_injective AddAction.toPerm_injective

variable (α) (β)

/-- Given an action of a group `α` on a set `β`, each `g : α` defines a permutation of `β`. -/
@[simps]
def MulAction.toPermHom : α →* Equiv.Perm β where
  toFun := MulAction.toPerm
  map_one' := Equiv.ext <| one_smul α
  map_mul' u₁ u₂ := Equiv.ext <| mul_smul (u₁ : α) u₂
#align mul_action.to_perm_hom MulAction.toPermHom
#align mul_action.to_perm_hom_apply MulAction.toPermHom_apply

/-- Given an action of a additive group `α` on a set `β`, each `g : α` defines a permutation of
`β`. -/
@[simps!]
def AddAction.toPermHom (α : Type _) [AddGroup α] [AddAction α β] :
    α →+ Additive (Equiv.Perm β) :=
  MonoidHom.toAdditive'' <| MulAction.toPermHom (Multiplicative α) β
#align add_action.to_perm_hom AddAction.toPermHom

/-- The tautological action by `Equiv.Perm α` on `α`.

This generalizes `Function.End.applyMulAction`.-/
instance Equiv.Perm.applyMulAction (α : Type _) : MulAction (Equiv.Perm α) α where
  smul f a := f a
  one_smul _ := rfl
  mul_smul _ _ _ := rfl
#align equiv.perm.apply_mul_action Equiv.Perm.applyMulAction

@[simp]
protected theorem Equiv.Perm.smul_def {α : Type _} (f : Equiv.Perm α) (a : α) : f • a = f a :=
  rfl
#align equiv.perm.smul_def Equiv.Perm.smul_def

/-- `Equiv.Perm.applyMulAction` is faithful. -/
instance Equiv.Perm.applyFaithfulSMul (α : Type _) : FaithfulSMul (Equiv.Perm α) α :=
  ⟨Equiv.ext⟩
#align equiv.perm.apply_has_faithful_smul Equiv.Perm.applyFaithfulSMul

variable {α} {β}

@[to_additive]
theorem inv_smul_eq_iff {a : α} {x y : β} : a⁻¹ • x = y ↔ x = a • y :=
  (MulAction.toPerm a).symm_apply_eq
#align inv_smul_eq_iff inv_smul_eq_iff
#align neg_vadd_eq_iff neg_vadd_eq_iff

@[to_additive]
theorem eq_inv_smul_iff {a : α} {x y : β} : x = a⁻¹ • y ↔ a • x = y :=
  (MulAction.toPerm a).eq_symm_apply
#align eq_inv_smul_iff eq_inv_smul_iff
#align eq_neg_vadd_iff eq_neg_vadd_iff

theorem smul_inv [Group β] [SMulCommClass α β β] [IsScalarTower α β β] (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]
#align smul_inv smul_inv

theorem smul_zpow [Group β] [SMulCommClass α β β] [IsScalarTower α β β] (c : α) (x : β) (p : ℤ) :
    (c • x) ^ p = c ^ p • x ^ p := by
  cases p <;>
  simp [smul_pow, smul_inv]
#align smul_zpow smul_zpow

@[simp]
theorem Commute.smul_right_iff [Mul β] [SMulCommClass α β β] [IsScalarTower α β β] {a b : β}
    (r : α) : Commute a (r • b) ↔ Commute a b :=
  ⟨fun h => inv_smul_smul r b ▸ h.smul_right r⁻¹, fun h => h.smul_right r⟩
#align commute.smul_right_iff Commute.smul_right_iff

@[simp]
theorem Commute.smul_left_iff [Mul β] [SMulCommClass α β β] [IsScalarTower α β β] {a b : β}
    (r : α) : Commute (r • a) b ↔ Commute a b := by
  rw [Commute.symm_iff, Commute.smul_right_iff, Commute.symm_iff]
#align commute.smul_left_iff Commute.smul_left_iff

@[to_additive]
protected theorem MulAction.bijective (g : α) : Function.Bijective ((· • ·) g : β → β) :=
  (MulAction.toPerm g).bijective
#align mul_action.bijective MulAction.bijective
#align add_action.bijective AddAction.bijective

@[to_additive]
protected theorem MulAction.injective (g : α) : Function.Injective ((· • ·) g : β → β) :=
  (MulAction.bijective g).injective
#align mul_action.injective MulAction.injective
#align add_action.injective AddAction.injective

@[to_additive]
protected theorem MulAction.surjective (g : α) : Function.Surjective ((· • ·) g : β → β) :=
  (MulAction.bijective g).surjective
#align mul_action.surjective MulAction.surjective
#align add_action.surjective AddAction.surjective

@[to_additive]
theorem smul_left_cancel (g : α) {x y : β} (h : g • x = g • y) : x = y :=
  MulAction.injective g h
#align smul_left_cancel smul_left_cancel
#align vadd_left_cancel vadd_left_cancel

@[to_additive (attr := simp)]
theorem smul_left_cancel_iff (g : α) {x y : β} : g • x = g • y ↔ x = y :=
  (MulAction.injective g).eq_iff
#align smul_left_cancel_iff smul_left_cancel_iff
#align vadd_left_cancel_iff vadd_left_cancel_iff

@[to_additive]
theorem smul_eq_iff_eq_inv_smul (g : α) {x y : β} : g • x = y ↔ x = g⁻¹ • y :=
  (MulAction.toPerm g).apply_eq_iff_eq_symm_apply
#align smul_eq_iff_eq_inv_smul smul_eq_iff_eq_inv_smul
#align vadd_eq_iff_eq_neg_vadd vadd_eq_iff_eq_neg_vadd

end Group

/-- `Monoid.toMulAction` is faithful on nontrivial cancellative monoids with zero. -/
instance CancelMonoidWithZero.faithfulSMul [CancelMonoidWithZero α] [Nontrivial α] :
    FaithfulSMul α α :=
  ⟨fun h => mul_left_injective₀ one_ne_zero (h 1)⟩
#align cancel_monoid_with_zero.to_has_faithful_smul CancelMonoidWithZero.faithfulSMul

section Gwz

variable [GroupWithZero α] [MulAction α β] {a : α}

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

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

theorem inv_smul_eq_iff₀ {a : α} (ha : a ≠ 0) {x y : β} : a⁻¹ • x = y ↔ x = a • y :=
  ⟨fun h => by rw [← h, smul_inv_smul₀ ha], fun h => by rw [h, inv_smul_smul₀ ha]⟩
#align inv_smul_eq_iff₀ inv_smul_eq_iff₀

theorem eq_inv_smul_iff₀ {a : α} (ha : a ≠ 0) {x y : β} : x = a⁻¹ • y ↔ a • x = y :=
  (MulAction.toPerm (Units.mk0 a ha)).eq_symm_apply
#align eq_inv_smul_iff₀ eq_inv_smul_iff₀

@[simp]
theorem Commute.smul_right_iff₀ [Mul β] [SMulCommClass α β β] [IsScalarTower α β β] {a b : β}
    {c : α} (hc : c ≠ 0) : Commute a (c • b) ↔ Commute a b :=
  Commute.smul_right_iff (Units.mk0 c hc)
#align commute.smul_right_iff₀ Commute.smul_right_iff₀

@[simp]
theorem Commute.smul_left_iff₀ [Mul β] [SMulCommClass α β β] [IsScalarTower α β β] {a b : β} {c : α}
    (hc : c ≠ 0) : Commute (c • a) b ↔ Commute a b :=
  Commute.smul_left_iff (Units.mk0 c hc)
#align commute.smul_left_iff₀ Commute.smul_left_iff₀

protected theorem MulAction.bijective₀ (ha : a ≠ 0) : Function.Bijective ((· • ·) a : β → β) :=
  MulAction.bijective <| Units.mk0 a ha
#align mul_action.bijective₀ MulAction.bijective₀

protected theorem MulAction.injective₀ (ha : a ≠ 0) : Function.Injective ((· • ·) a : β → β) :=
  (MulAction.bijective₀ ha).injective
#align mul_action.injective₀ MulAction.injective₀

protected theorem MulAction.surjective₀ (ha : a ≠ 0) : Function.Surjective ((· • ·) a : β → β) :=
  (MulAction.bijective₀ ha).surjective
#align mul_action.surjective₀ MulAction.surjective₀

end Gwz

end MulAction

section DistribMulAction

section Group

variable [Group α] [AddMonoid β] [DistribMulAction α β]

variable (β)

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

This is a stronger version of `MulAction.toPerm`. -/
@[simps (config := { simpRhs := true })]
def DistribMulAction.toAddEquiv (x : α) : β ≃+ β :=
  { DistribMulAction.toAddMonoidHom β x, MulAction.toPermHom α β x with }
#align distrib_mul_action.to_add_equiv DistribMulAction.toAddEquiv
#align distrib_mul_action.to_add_equiv_apply DistribMulAction.toAddEquiv_apply
#align distrib_mul_action.to_add_equiv_symm_apply DistribMulAction.toAddEquiv_symm_apply

variable (α)

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

This is a stronger version of `MulAction.toPermHom`. -/
@[simps]
def DistribMulAction.toAddAut : α →* AddAut β where
  toFun := DistribMulAction.toAddEquiv β
  map_one' := AddEquiv.ext (one_smul _)
  map_mul' _ _ := AddEquiv.ext (mul_smul _ _)
#align distrib_mul_action.to_add_aut DistribMulAction.toAddAut
#align distrib_mul_action.to_add_aut_apply DistribMulAction.toAddAut_apply

variable {α β}

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

theorem smul_ne_zero_iff_ne (a : α) {x : β} : a • x ≠ 0 ↔ x ≠ 0 :=
  not_congr <| smul_eq_zero_iff_eq a
#align smul_ne_zero_iff_ne smul_ne_zero_iff_ne

end Group

section Gwz

variable [GroupWithZero α] [AddMonoid β] [DistribMulAction α β]

theorem smul_eq_zero_iff_eq' {a : α} (ha : a ≠ 0) {x : β} : a • x = 0 ↔ x = 0 :=
  show Units.mk0 a ha • x = 0 ↔ x = 0 from smul_eq_zero_iff_eq _
#align smul_eq_zero_iff_eq' smul_eq_zero_iff_eq'

theorem smul_ne_zero_iff_ne' {a : α} (ha : a ≠ 0) {x : β} : a • x ≠ 0 ↔ x ≠ 0 :=
  show Units.mk0 a ha • x ≠ 0 ↔ x ≠ 0 from smul_ne_zero_iff_ne _
#align smul_ne_zero_iff_ne' smul_ne_zero_iff_ne'

end Gwz

end DistribMulAction

section MulDistribMulAction

variable [Group α] [Monoid β] [MulDistribMulAction α β]

variable (β)

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

This is a stronger version of `MulAction.toPerm`. -/
@[simps (config := { simpRhs := true })]
def MulDistribMulAction.toMulEquiv (x : α) : β ≃* β :=
  { MulDistribMulAction.toMonoidHom β x, MulAction.toPermHom α β x with }
#align mul_distrib_mul_action.to_mul_equiv MulDistribMulAction.toMulEquiv
#align mul_distrib_mul_action.to_mul_equiv_symm_apply MulDistribMulAction.toMulEquiv_symm_apply
#align mul_distrib_mul_action.to_mul_equiv_apply MulDistribMulAction.toMulEquiv_apply

variable (α)

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

This is a stronger version of `MulAction.toPermHom`. -/
@[simps]
def MulDistribMulAction.toMulAut : α →* MulAut β where
  toFun := MulDistribMulAction.toMulEquiv β
  map_one' := MulEquiv.ext (one_smul _)
  map_mul' _ _ := MulEquiv.ext (mul_smul _ _)
#align mul_distrib_mul_action.to_mul_aut MulDistribMulAction.toMulAut
#align mul_distrib_mul_action.to_mul_aut_apply MulDistribMulAction.toMulAut_apply

variable {α β}

end MulDistribMulAction

section Arrow

/-- If `G` acts on `A`, then it acts also on `A → B`, by `(g • F) a = F (g⁻¹ • a)`. -/
@[to_additive (attr := simps) arrowAddAction
      "If `G` acts on `A`, then it acts also on `A → B`, by `(g +ᵥ F) a = F (g⁻¹ +ᵥ a)`"]
def arrowAction {G A B : Type _} [DivisionMonoid G] [MulAction G A] : MulAction G (A → B) where
  smul g F a := F (g⁻¹ • a)
  one_smul := by
    intro f
    show (fun x => f ((1 : G)⁻¹ • x)) = f
    simp only [inv_one, one_smul]
  mul_smul := by
    intros x y f
    show (fun a => f ((x*y)⁻¹ • a)) = (fun a => f (y⁻¹ • x⁻¹ • a))
    simp only [mul_smul, mul_inv_rev]
#align arrow_action arrowAction
#align arrow_add_action arrowAddAction

attribute [local instance] arrowAction

/-- When `B` is a monoid, `ArrowAction` is additionally a `MulDistribMulAction`. -/
def arrowMulDistribMulAction {G A B : Type _} [Group G] [MulAction G A] [Monoid B] :
    MulDistribMulAction G (A → B) where
  smul_one _ := rfl
  smul_mul _ _ _ := rfl
#align arrow_mul_distrib_mul_action arrowMulDistribMulAction

attribute [local instance] arrowMulDistribMulAction

/-- Given groups `G H` with `G` acting on `A`, `G` acts by
  multiplicative automorphisms on `A → H`. -/
@[simps!]
def mulAutArrow {G A H} [Group G] [MulAction G A] [Monoid H] : G →* MulAut (A → H) :=
  MulDistribMulAction.toMulAut _ _
#align mul_aut_arrow mulAutArrow
#align mul_aut_arrow_apply_apply mulAutArrow_apply_apply
#align mul_aut_arrow_apply_symm_apply mulAutArrow_apply_symm_apply

end Arrow

namespace IsUnit

section MulAction

variable [Monoid α] [MulAction α β]

@[to_additive]
theorem smul_left_cancel {a : α} (ha : IsUnit a) {x y : β} : a • x = a • y ↔ x = y :=
  let ⟨u, hu⟩ := ha
  hu ▸ smul_left_cancel_iff u
#align is_unit.smul_left_cancel IsUnit.smul_left_cancel
#align is_add_unit.vadd_left_cancel IsAddUnit.vadd_left_cancel

end MulAction

section DistribMulAction

variable [Monoid α] [AddMonoid β] [DistribMulAction α β]

@[simp]
theorem smul_eq_zero {u : α} (hu : IsUnit u) {x : β} : u • x = 0 ↔ x = 0 :=
  (Exists.elim hu) fun u hu => hu ▸ show u • x = 0 ↔ x = 0 from smul_eq_zero_iff_eq u
#align is_unit.smul_eq_zero IsUnit.smul_eq_zero

end DistribMulAction

end IsUnit

section SMul

variable [Group α] [Monoid β]

@[simp]
theorem isUnit_smul_iff [MulAction α β] [SMulCommClass α β β] [IsScalarTower α β β] (g : α)
    (m : β) : IsUnit (g • m) ↔ IsUnit m :=
  ⟨fun h => inv_smul_smul g m ▸ h.smul g⁻¹, IsUnit.smul g⟩
#align is_unit_smul_iff isUnit_smul_iff

theorem IsUnit.smul_sub_iff_sub_inv_smul [AddGroup β] [DistribMulAction α β] [IsScalarTower α β β]
    [SMulCommClass α β β] (r : α) (a : β) : IsUnit (r • (1 : β) - a) ↔ IsUnit (1 - r⁻¹ • a) := by
  rw [← isUnit_smul_iff r (1 - r⁻¹ • a), smul_sub, smul_inv_smul]
#align is_unit.smul_sub_iff_sub_inv_smul IsUnit.smul_sub_iff_sub_inv_smul

end SMul


import Mathlib.Init.Data.Option.Instances
import Mathlib.Init.Data.List.Lemmas
import Mathlib.Logic.Basic
import Mathlib.Logic.Function.Basic
import Mathlib.Data.Nat.Basic
import Mathlib.Data.Option.Basic
import Mathlib.Data.List.Defs
import Lean

open Function

namespace List

theorem concat_eq_append : ∀ (l : List α) a, concat l a = l ++ [a]
| [], a => (append_nil _).symm
| x::xs, a => by simp only [concat, cons_append, concat_eq_append xs]

theorem get_cons_drop : ∀ (l : List α) i,
  List.get l i :: List.drop (i + 1) l = List.drop i l
| _::_, ⟨0, h⟩ => rfl
| _::_, ⟨i+1, h⟩ => get_cons_drop _ ⟨i, _⟩

theorem drop_eq_nil_of_le : ∀ {l : List α} {k : Nat} (h : l.length ≤ k), l.drop k = []
| [], k, _ => by cases k <;> rfl
| a::l, 0, h => by cases h
| a::l, k+1, h => by have h0 : length (a :: l) = length l + 1 := rfl
                     have h1 : length l ≤ k := by rw [h0] at h
                                                   exact Nat.le_of_succ_le_succ h
                     exact drop_eq_nil_of_le (l := l) h1

theorem join_nil : join ([] : List (List α)) = [] := rfl

theorem join_cons : join (a :: l : List (List α)) = a ++ join l := rfl

/-!
# Basic properties of Lists
-/

-- instance : is_left_id (List α) has_append.append [] :=
-- ⟨ nil_append ⟩

-- instance : is_right_id (List α) has_append.append [] :=
-- ⟨ append_nil ⟩

-- instance : is_associative (List α) has_append.append :=
-- ⟨ append_assoc ⟩

theorem cons_ne_nil (a : α) (l : List α) : a::l ≠ [] := by intro h; cases h

theorem cons_ne_self (a : α) (l : List α) : a::l ≠ l :=
  mt (congr_arg length) (Nat.succ_ne_self _)

theorem head_eq_of_cons_eq {h₁ h₂ : α} {t₁ t₂ : List α} :
      (h₁::t₁) = (h₂::t₂) → h₁ = h₂ :=
fun Peq => List.noConfusion Peq fun Pheq Pteq => Pheq

theorem tail_eq_of_cons_eq {h₁ h₂ : α} {t₁ t₂ : List α} :
      (h₁::t₁) = (h₂::t₂) → t₁ = t₂ :=
fun Peq => List.noConfusion Peq (fun Pheq Pteq => Pteq)

-- @[simp] theorem cons_injective {a : α} : injective (cons a) :=
-- assume l₁ l₂, assume Pe, tail_eq_of_cons_eq Pe

-- theorem cons_inj (a : α) {l l' : List α} : a::l = a::l' ↔ l = l' :=
-- cons_injective.eq_iff

theorem exists_cons_of_ne_nil {l : List α} (h : l ≠ nil) : ∃ b L, l = b :: L := by
  induction l with
    | nil          => contradiction
    | cons c l' ih => exact ⟨c, l', rfl⟩

/-! ### mem -/

theorem mem_singleton_self (a : α) : a ∈ [a] := mem_cons_self _ _

theorem eq_of_mem_singleton {a b : α} (h : a ∈ [b]) : a = b :=
  (eq_or_mem_of_mem_cons h).elim
    (fun heq : a = b => heq)
    (fun hin : a ∈ [] => absurd hin (not_mem_nil a))

@[simp 1100] theorem mem_singleton {a b : α} : a ∈ [b] ↔ a = b :=
⟨eq_of_mem_singleton, by simp⟩

theorem mem_of_mem_cons_of_mem {a b : α} {l : List α} : a ∈ b::l → b ∈ l → a ∈ l :=
  fun ainbl binl =>
    (eq_or_mem_of_mem_cons ainbl).elim
      (fun heq : a = b => heq ▸ binl)
      (fun hin : a ∈ l => hin)

theorem eq_or_ne_mem_of_mem {a b : α} {l : List α} (h' : a ∈ b :: l) : a = b ∨ (a ≠ b ∧ a ∈ l) :=
  open Classical in if h : a = b then Or.inl h else Or.inr ⟨h, (mem_cons.1 h').resolve_left h⟩

theorem not_mem_append {a : α} {s t : List α} (h₁ : a ∉ s) (h₂ : a ∉ t) : a ∉ s ++ t :=
mt mem_append.1 $ (not_or _ _).mpr ⟨h₁, h₂⟩

theorem ne_nil_of_mem {a : α} {l : List α} (h : a ∈ l) : l ≠ [] := by intro e; rw [e] at h; cases h

theorem mem_constructor {a : α} {l : List α} (h : a ∈ l) : ∃ s t : List α, l = s ++ a :: t := by
  induction l with
  | nil => cases h --exact ⟨[], l, rfl⟩
  | cons b l ih =>
      cases h with
      | head => exact ⟨[], l, rfl⟩
      | tail _ hmem =>
        match ih hmem with
        | ⟨s, t, h'⟩ =>
          refine ⟨b::s, t, ?_⟩
          rw [h', cons_append]

theorem mem_of_ne_of_mem {a y : α} {l : List α} (h₁ : a ≠ y) (h₂ : a ∈ y :: l) : a ∈ l :=
Or.elim (eq_or_mem_of_mem_cons h₂) (fun e => absurd e h₁) (fun r => r)

theorem ne_of_not_mem_cons {a b : α} {l : List α} : (a ∉ b::l) → a ≠ b :=
fun nin aeqb => absurd (aeqb ▸ Mem.head ..) nin

theorem not_mem_of_not_mem_cons {a b : α} {l : List α} : (a ∉ b::l) → a ∉ l :=
fun nin nainl => absurd (Mem.tail _ nainl) nin

theorem not_mem_cons_of_ne_of_not_mem {a y : α} {l : List α} : a ≠ y → (a ∉ l) → (a ∉ y::l) :=
fun p1 p2 => fun Pain => absurd (eq_or_mem_of_mem_cons Pain) ((not_or _ _).mpr ⟨p1, p2⟩)

theorem ne_and_not_mem_of_not_mem_cons {a y : α} {l : List α} : (a ∉ y::l) → a ≠ y ∧ a ∉ l :=
fun p => And.intro (ne_of_not_mem_cons p) (not_mem_of_not_mem_cons p)

theorem mem_map_of_mem (f : α → β) {a : α} {l : List α} (h : a ∈ l) : f a ∈ map f l := by
  induction l with
  | nil => cases h
  | cons b l' ih =>
    cases h with constructor
    | tail _ h' => exact ih h'

theorem exists_of_mem_map {f : α → β} {b : β} {l : List α} (h : b ∈ List.map f l) :
    ∃ a, a ∈ l ∧ f a = b := by
  induction l with
  | nil => cases h
  | cons c l' ih =>
    cases eq_or_mem_of_mem_cons h with
    | inl h => exact ⟨c, mem_cons_self _ _, h.symm⟩
    | inr h =>
      match ih h with
      | ⟨a, ha₁, ha₂⟩ => exact ⟨a, mem_cons_of_mem _ ha₁, ha₂⟩

theorem mem_map {f : α → β} {b} : ∀ {l : List α}, b ∈ l.map f ↔ ∃ a, a ∈ l ∧ b = f a
| [] => by simp
| b :: l => by
  rw [map_cons, mem_cons, mem_map];
  exact ⟨fun | Or.inl h => ⟨_, Mem.head .., h⟩
             | Or.inr ⟨l, h₁, h₂⟩ => ⟨l, Mem.tail _ h₁, h₂⟩,
         fun | ⟨_, Mem.head .., h⟩ => Or.inl h
             | ⟨l, Mem.tail _ h₁, h₂⟩ => Or.inr ⟨l, h₁, h₂⟩⟩

theorem mem_map_of_injective {f : α → β} (H : injective f) {a : α} {l : List α} :
  f a ∈ map f l ↔ a ∈ l :=
⟨fun m => let ⟨a', m', e⟩ := exists_of_mem_map m
          H e ▸ m', mem_map_of_mem _⟩

lemma forall_mem_map_iff {f : α → β} {l : List α} {P : β → Prop} :
  (∀ i ∈ l.map f, P i) ↔ ∀ j ∈ l, P (f j) := by
  constructor
  { intros H j hj; exact H (f j) (mem_map_of_mem f hj) }
    intros H i hi
    match mem_map.1 hi with
    | ⟨j, hj, ji⟩ => rw [ji]; exact H j hj

@[simp] lemma map_eq_nil {f : α → β} {l : List α} : List.map f l = [] ↔ l = [] := by
  constructor
  { cases l with
    | nil => intro _; rfl
    | cons b l => intro h; exact List.noConfusion h }
  { intro h; rw [h]; rfl }

theorem mem_join {a} : ∀ {L : List (List α)}, a ∈ L.join ↔ ∃ l, l ∈ L ∧ a ∈ l
| [] => by simp
| b :: l => by
  simp only [join, mem_append, mem_join]
  exact ⟨fun | Or.inl h => ⟨_, Mem.head .., h⟩
             | Or.inr ⟨l, h₁, h₂⟩ => ⟨l, Mem.tail _ h₁, h₂⟩,
         fun | ⟨_, Mem.head .., h⟩ => Or.inl h
             | ⟨l, Mem.tail _ h₁, h₂⟩ => Or.inr ⟨l, h₁, h₂⟩⟩

theorem exists_of_mem_join {a : α} {L : List (List α)} : a ∈ join L → ∃ l, l ∈ L ∧ a ∈ l :=
mem_join.1

theorem mem_join_of_mem {a : α} {L : List (List α)} {l} (lL : l ∈ L) (al : a ∈ l) : a ∈ join L :=
mem_join.2 ⟨l, lL, al⟩

theorem mem_bind {f : α → List β} {b} {l : List α} : b ∈ l.bind f ↔ ∃ a, a ∈ l ∧ b ∈ f a := by
  simp [List.bind, mem_map, mem_join]
  exact ⟨fun ⟨_, ⟨a, h₁, rfl⟩, h₂⟩ => ⟨a, h₁, h₂⟩, fun ⟨a, h₁, h₂⟩ => ⟨_, ⟨a, h₁, rfl⟩, h₂⟩⟩

theorem exists_of_mem_bind {b : β} {l : List α} {f : α → List β} :
  b ∈ List.bind l f → ∃ a, a ∈ l ∧ b ∈ f a :=
mem_bind.1

theorem mem_bind_of_mem {b : β} {l : List α} {f : α → List β} {a} (al : a ∈ l) (h : b ∈ f a) :
  b ∈ List.bind l f :=
mem_bind.2 ⟨a, al, h⟩

lemma bind_map {g : α → List β} {f : β → γ} :
  ∀(l : List α), List.map f (l.bind g) = l.bind (fun a => (g a).map f)
| [] => rfl
| a::l => by simp only [cons_bind, map_append, bind_map l]

/-! ### length -/

-- @[simp] lemma length_tail (l : list α) : length (tail l) = length l - 1 :=
-- by cases l; refl

-- -- TODO(Leo): cleanup proof after arith dec proc
-- @[simp] lemma length_drop : ∀ (i : ℕ) (l : list α), length (drop i l) = length l - i
-- | 0 l         := rfl
-- | (succ i) [] := eq.symm (nat.zero_sub (succ i))
-- | (succ i) (x::l) := calc
--   length (drop (succ i) (x::l))
--           = length l - i             : length_drop i l
--       ... = succ (length l) - succ i : (nat.succ_sub_succ_eq_sub (length l) i).symm

theorem length_eq_zero {l : List α} : length l = 0 ↔ l = [] :=
⟨eq_nil_of_length_eq_zero, fun h => by rw [h]; rfl⟩

@[simp 1100] lemma length_singleton (a : α) : length [a] = 1 := rfl

theorem length_pos_of_mem {a : α} : ∀ {l : List α}, a ∈ l → 0 < length l
| nil,  h => by cases h
| b::l, _ => by rw [length_cons]; exact Nat.zero_lt_succ _

theorem exists_mem_of_length_pos : ∀ {l : List α}, 0 < length l → ∃ a, a ∈ l
| nil,    h => by cases h
| b::l, _   => ⟨b, mem_cons_self _ _⟩

theorem length_pos_iff_exists_mem {l : List α} : 0 < length l ↔ ∃ a, a ∈ l :=
⟨exists_mem_of_length_pos, fun  ⟨a, h⟩ => length_pos_of_mem h⟩

theorem ne_nil_of_length_pos {l : List α} : 0 < length l → l ≠ [] :=
fun h1 h2 => Nat.lt_irrefl 0 ((length_eq_zero.2 h2).subst h1)

theorem length_pos_of_ne_nil {l : List α} : l ≠ [] → 0 < length l :=
fun h => Nat.pos_iff_ne_zero.2 $ fun h0 => h $ length_eq_zero.1 h0

theorem length_pos_iff_ne_nil {l : List α} : 0 < length l ↔ l ≠ [] :=
⟨ne_nil_of_length_pos, length_pos_of_ne_nil⟩

lemma exists_mem_of_ne_nil (l : List α) (h : l ≠ []) : ∃ x, x ∈ l :=
exists_mem_of_length_pos (length_pos_of_ne_nil h)

theorem length_eq_one {l : List α} : length l = 1 ↔ ∃ a, l = [a] := by
  constructor
  · intro h
    match l with
    | nil => contradiction
    | [a] => exact ⟨_, rfl⟩
    | a::b::l => simp at h
  · intro ⟨a, leq⟩; rw [leq]; simp

lemma exists_of_length_succ {n} :
  ∀ l : List α, l.length = n + 1 → ∃ h t, l = h :: t
| [], H => absurd H.symm $ Nat.succ_ne_zero n
| (h :: t), H => ⟨h, t, rfl⟩

-- @[simp] lemma length_injective_iff : injective (List.length : List α → ℕ) ↔ subsingleton α :=
-- begin
--   constructor,
--   { intro h, refine ⟨fun  x y, _⟩, suffices : [x] = [y], { simpa using this }, apply h, refl },
--   { intros hα l1 l2 hl, induction l1 generalizing l2; cases l2,
--     { refl }, { cases hl }, { cases hl },
--     congr, exactI subsingleton.elim _ _, apply l1_ih, simpa using hl }
-- end

-- @[simp] lemma length_injective [subsingleton α] : injective (length : List α → ℕ) :=
-- length_injective_iff.mpr $ by apply_instance

/-! ### set-theoretic notation of Lists -/

lemma empty_eq : (∅ : List α) = [] := by rfl
--lemma singleton_eq (x : α) : ({x} : List α) = [x] := rfl
--lemma insert_neg [DecidableEq α] {x : α} {l : List α} (h : x ∉ l) :
--  has_insert.insert x l = x :: l :=
--if_neg h
--lemma insert_pos [DecidableEq α] {x : α} {l : List α} (h : x ∈ l) :
--  has_insert.insert x l = l :=
--if_pos h
-- lemma doubleton_eq [DecidableEq α] {x y : α} (h : x ≠ y) : ({x, y} : List α) = [x, y] := by
--   rw [insert_neg, singleton_eq]; rwa [singleton_eq, mem_singleton]

/-! ### bounded quantifiers over Lists -/

theorem forall_mem_nil (p : α → Prop) : ∀ x∈ @nil α, p x := fun x h => by cases h

theorem forall_mem_cons : ∀ {p : α → Prop} {a : α} {l : List α},
  (∀ x ∈ a :: l, p x) ↔ p a ∧ ∀ x ∈ l, p x :=
ball_cons _ _ _

theorem forall_mem_of_forall_mem_cons {p : α → Prop} {a : α} {l : List α}
    (h : ∀ x, x ∈ a :: l → p x) :
  ∀ x, x ∈ l → p x :=
(forall_mem_cons.1 h).2

theorem forall_mem_singleton {p : α → Prop} {a : α} : (∀ x ∈ [a], p x) ↔ p a := by
  simp only [mem_singleton, forall_eq]; rfl

theorem forall_mem_append {p : α → Prop} {l₁ l₂ : List α} :
  (∀ x ∈ l₁ ++ l₂, p x) ↔ (∀ x ∈ l₁, p x) ∧ (∀ x ∈ l₂, p x) :=
by simp only [mem_append, or_imp_distrib, forall_and_distrib]; rfl

theorem not_exists_mem_nil (p : α → Prop) : ¬ ∃ x ∈ @nil α, p x
  | ⟨_, ⟨h, _⟩⟩ => by cases h

theorem exists_mem_cons_of {p : α → Prop} {a : α} (l : List α) (h : p a) :
  ∃ x ∈ a :: l, p x :=
⟨a, (mem_cons_self _ _), h⟩

theorem exists_mem_cons_of_exists {p : α → Prop} {a : α} {l : List α} :
    (∃ x ∈ l, p x) → ∃ x ∈ a :: l, p x
| ⟨x, h, px⟩ => ⟨x, Mem.tail _ h, px⟩

theorem or_exists_of_exists_mem_cons {p : α → Prop} {a : α} {l : List α} :
    (∃ x ∈ a :: l, p x) → p a ∨ ∃ x ∈ l, p x
| ⟨x, xal, px⟩ => by
  cases xal with
  | head => exact Or.inl px
  | tail _ h => exact Or.inr ⟨x, h, px⟩

theorem exists_mem_cons_iff (p : α → Prop) (a : α) (l : List α) :
  (∃ x ∈ a :: l, p x) ↔ p a ∨ ∃ x ∈ l, p x :=
Iff.intro or_exists_of_exists_mem_cons
  (fun h => Or.elim h (exists_mem_cons_of l) exists_mem_cons_of_exists)

/-! ### List subset -/

theorem subset_def {l₁ l₂ : List α} : l₁ ⊆ l₂ ↔ ∀ {a : α}, a ∈ l₁ → a ∈ l₂ := Iff.rfl

theorem subset_append_of_subset_left (l l₁ l₂ : List α) : l ⊆ l₁ → l ⊆ l₁++l₂ :=
fun s => subset.trans s $ subset_append_left _ _

theorem subset_append_of_subset_right (l l₁ l₂ : List α) : l ⊆ l₂ → l ⊆ l₁++l₂ :=
fun s => subset.trans s $ subset_append_right _ _

@[simp] theorem cons_subset {a : α} {l m : List α} :
    a::l ⊆ m ↔ a ∈ m ∧ l ⊆ m := by
  simp only [subset_def, mem_cons, or_imp_distrib, forall_and_distrib, forall_eq]; rfl

theorem cons_subset_of_subset_of_mem {a : α} {l m : List α}
  (ainm : a ∈ m) (lsubm : l ⊆ m) : a::l ⊆ m :=
cons_subset.2 ⟨ainm, lsubm⟩

theorem append_subset_of_subset_of_subset {l₁ l₂ l : List α} (l₁subl : l₁ ⊆ l) (l₂subl : l₂ ⊆ l) :
  l₁ ++ l₂ ⊆ l :=
fun {a} h => (mem_append.1 h).elim (@l₁subl _) (@l₂subl _)

@[simp] theorem append_subset_iff {l₁ l₂ l : List α} :
    l₁ ++ l₂ ⊆ l ↔ l₁ ⊆ l ∧ l₂ ⊆ l := by
  constructor
  { intro h; simp only [subset_def] at *
    constructor
    { intros; apply h; apply mem_append_left; assumption }
    { intros; apply h; apply mem_append_right; assumption } }
  { intro h; match h with | ⟨h1, h2⟩ => apply append_subset_of_subset_of_subset h1 h2 }

theorem eq_nil_of_subset_nil : ∀ {l : List α}, l ⊆ [] → l = []
| [],     s => rfl
| (a::l), s => nomatch s $ mem_cons_self a l

theorem eq_nil_iff_forall_not_mem {l : List α} : l = [] ↔ ∀ a, a ∉ l :=
  have : l = [] ↔ l ⊆ [] := ⟨fun e => e ▸ subset.refl _, eq_nil_of_subset_nil⟩
  by simp [subset_def] at this; exact this

theorem map_subset {l₁ l₂ : List α} (f : α → β) (H : l₁ ⊆ l₂) : map f l₁ ⊆ map f l₂ :=
fun {x} => by simp only [mem_map, not_and, exists_imp_distrib, and_imp]
              exact fun a h e => ⟨a, H h, e⟩

-- theorem map_subset_iff {l₁ l₂ : List α} (f : α → β) (h : injective f) :
--   map f l₁ ⊆ map f l₂ ↔ l₁ ⊆ l₂ :=
-- begin
--   refine ⟨_, map_subset f⟩, intros h2 x hx,
--   rcases mem_map.1 (h2 (mem_map_of_mem f hx)) with ⟨x', hx', hxx'⟩,
--   cases h hxx', exact hx'
-- end

@[simp] theorem mem_reverseAux (x : α) : ∀ as bs, x ∈ reverseAux as bs ↔ x ∈ as ∨ x ∈ bs
  | [], bs => by simp [reverseAux]
  | a :: as, bs => by simp [reverseAux, mem_reverseAux]; rw [←or_assoc, @or_comm (x = a)]

@[simp] theorem mem_reverse (x : α) (as : List α) : x ∈ reverse as ↔ x ∈ as := by simp [reverse]

-- TODO: better automation needed
theorem mem_filterAux (x : α) (p : α → Bool) :
    ∀ as bs, x ∈ filterAux p as bs ↔ (x ∈ as ∧ p x) ∨ x ∈ bs
  | [], bs => by simp [filterAux]
  | (a :: as), bs => by
    simp [filterAux]
    cases pa : p a with
    | true =>
      simp [mem_filterAux x p as (a :: bs)]
      constructor
      · intro
        | Or.inl h'' => exact Or.inl ⟨Or.inr h''.1, h''.2⟩
        | Or.inr (Or.inl h₃) => exact Or.inl ⟨Or.inl h₃, h₃ ▸ pa⟩
        | Or.inr (Or.inr h₃) => exact Or.inr h₃
      · intro
        | Or.inl ⟨Or.inl h₃, _⟩ => exact Or.inr (Or.inl h₃)
        | Or.inl ⟨Or.inr h₃, h''⟩ => exact Or.inl ⟨h₃, h''⟩
        | Or.inr h'' => exact Or.inr (Or.inr h'')
    | false =>
      simp [mem_filterAux x p as bs]
      constructor
      · intro
        | Or.inl h'' => exact Or.inl ⟨Or.inr h''.1, h''.2⟩
        | Or.inr h'' => exact Or.inr h''
      · intro
        | Or.inl ⟨Or.inl h₃, h''⟩ => rw [← h₃, h''] at pa; contradiction
        | Or.inl ⟨Or.inr h₃, h''⟩ => exact Or.inl ⟨h₃, h''⟩
        | Or.inr h'' => exact Or.inr h''

theorem mem_filter (as : List α) (p : α → Bool) (x : α) :
    x ∈ filter p as ↔ x ∈ as ∧ p x = true := by simp [filter, mem_filterAux]

/-! ### append -/

lemma append_eq_has_append {L₁ L₂ : List α} : List.append L₁ L₂ = L₁ ++ L₂ := rfl

@[simp 1100] lemma singleton_append {x : α} {l : List α} : [x] ++ l = x :: l := rfl

@[simp] lemma append_eq_nil {p q : List α} : (p ++ q) = [] ↔ p = [] ∧ q = [] := by
  cases p <;> simp

theorem append_ne_nil_of_ne_nil_left (s t : List α) : s ≠ [] → s ++ t ≠ [] := by simp_all

theorem append_ne_nil_of_ne_nil_right (s t : List α) : t ≠ [] → s ++ t ≠ [] := by simp_all

@[simp] lemma nil_eq_append_iff {a b : List α} : [] = a ++ b ↔ a = [] ∧ b = [] :=
by rw [eq_comm, append_eq_nil]

lemma append_ne_nil_of_left_ne_nil (a b : List α) (h0 : a ≠ []) : a ++ b ≠ [] := by simp [*]

lemma append_eq_cons_iff {a b c : List α} {x : α} :
  a ++ b = x :: c ↔ (a = [] ∧ b = x :: c) ∨ (∃a', a = x :: a' ∧ c = a' ++ b) := by
  cases a with simp | cons a as => ?_
  exact ⟨fun h => ⟨as, by simp [h]⟩, fun ⟨a', ⟨aeq, aseq⟩, h⟩ => ⟨aeq, by rw [aseq, h]⟩⟩

lemma cons_eq_append_iff {a b c : List α} {x : α} :
    (x :: c : List α) = a ++ b ↔ (a = [] ∧ b = x :: c) ∨ (∃a', a = x :: a' ∧ c = a' ++ b) := by
  rw [eq_comm, append_eq_cons_iff]

-- theorem append_eq_append_iff {a b c d : List α} :
--   a ++ b = c ++ d ↔ (∃ a', c = a ++ a' ∧ b = a' ++ d) ∨ ∃ c', a = c ++ c' ∧ d = c' ++ b := by
--   induction a generalizing c with
--   | nil =>
--     rw [nil_append]; constructor
--     · rintro rfl; left; exact ⟨_, rfl, rfl⟩
--     · rintro (⟨a', rfl, rfl⟩ | ⟨a', H, rfl⟩); {rfl}; rw [←append_assoc, ←H]; rfl
--   | cons a as ih =>
--     cases c
--     · simp only [cons_append, nil_append, false_and, exists_false, false_or, exists_eq_left']
--       exact eq_comm
--     · simp only [cons_append, @eq_comm _ a, ih, and_assoc, and_or_distrib_left,
--         exists_and_distrib_left]

-- @[simp] theorem split_at_eq_take_drop : ∀ (n : ℕ) (l : List α), split_at n l = (take n l, drop n l)
-- | 0, a => rfl
-- | n+1, [] => rfl
-- | n+1, x :: xs => by simp only [split_at, split_at_eq_take_drop n xs, take, drop]

@[simp] theorem take_append_drop : ∀ (n : ℕ) (l : List α), take n l ++ drop n l = l
| 0, a => rfl
| n+1, [] => rfl
| n+1, x :: xs => congr_arg (cons x) $ take_append_drop n xs

-- TODO(Leo): cleanup proof after arith dec proc
theorem append_inj :
  ∀ {s₁ s₂ t₁ t₂ : List α}, s₁ ++ t₁ = s₂ ++ t₂ → length s₁ = length s₂ → s₁ = s₂ ∧ t₁ = t₂
| [], [], t₁, t₂, h, hl => ⟨rfl, h⟩
| a :: s₁, [], t₁, t₂, h, hl => List.noConfusion $ eq_nil_of_length_eq_zero hl
| [], b :: s₂, t₁, t₂, h, hl => List.noConfusion $ eq_nil_of_length_eq_zero hl.symm
| a :: s₁, b :: s₂, t₁, t₂, h, hl => List.noConfusion h fun ab hap =>
  let ⟨e1, e2⟩ := @append_inj _ s₁ s₂ t₁ t₂ hap (Nat.succ.inj hl)
  by rw [ab, e1, e2] <;> exact ⟨rfl, rfl⟩

theorem append_inj_right {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
  (hl : length s₁ = length s₂) : t₁ = t₂ :=
(append_inj h hl).right

theorem append_inj_left {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
  (hl : length s₁ = length s₂) : s₁ = s₂ :=
(append_inj h hl).left

theorem append_inj' {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : length t₁ = length t₂) :
  s₁ = s₂ ∧ t₁ = t₂ :=
append_inj h $ @Nat.add_right_cancel _ (length t₁) _ $
let hap := congr_arg length h; by simp only [length_append] at hap; rwa [← hl] at hap

theorem append_inj_right' {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
  (hl : length t₁ = length t₂) : t₁ = t₂ :=
(append_inj' h hl).right

theorem append_inj_left' {s₁ s₂ t₁ t₂ : List α} (h : s₁ ++ t₁ = s₂ ++ t₂)
  (hl : length t₁ = length t₂) : s₁ = s₂ :=
(append_inj' h hl).left

theorem append_left_cancel {s t₁ t₂ : List α} (h : s ++ t₁ = s ++ t₂) : t₁ = t₂ :=
append_inj_right h rfl

theorem append_right_cancel {s₁ s₂ t : List α} (h : s₁ ++ t = s₂ ++ t) : s₁ = s₂ :=
append_inj_left' h rfl

theorem append_right_injective (s : List α) : injective fun t => s ++ t :=
fun _ _ => append_left_cancel

theorem append_right_inj {t₁ t₂ : List α} (s) : s ++ t₁ = s ++ t₂ ↔ t₁ = t₂ :=
(@append_right_injective _ s).eq_iff

theorem append_left_injective (t : List α) : injective fun s => s ++ t :=
fun _ _ => append_right_cancel

theorem append_left_inj {s₁ s₂ : List α} (t) : s₁ ++ t = s₂ ++ t ↔ s₁ = s₂ :=
(append_left_injective t).eq_iff

theorem map_eq_append_split {f : α → β} {l : List α} {s₁ s₂ : List β}
  (h : map f l = s₁ ++ s₂) : ∃ l₁ l₂, l = l₁ ++ l₂ ∧ map f l₁ = s₁ ∧ map f l₂ = s₂ := by
  have := h
  rw [← take_append_drop (length s₁) l] at this ⊢
  rw [map_append] at this
  refine' ⟨_, _, rfl, append_inj this _⟩
  rw [length_map, length_take, min_eq_left]
  rw [←length_map l f, h, length_append]
  apply Nat.le_add_right

/-! ### repeat -/

theorem repeat'_succ (a : α) n : repeat' a (n+1) = a :: repeat' a n := rfl

theorem mem_repeat' {a b : α} : ∀ {n}, b ∈ repeat' a n ↔ n ≠ 0 ∧ b = a
| 0 => by simp
| n+1 => by simp [mem_repeat']

theorem eq_of_mem_repeat' {a b : α} {n} (h : b ∈ repeat' a n) : b = a :=
  (mem_repeat'.1 h).2

/-! ### getLast -/

theorem getLast_cons {a : α} {l : List α} : ∀ (h₁ : a :: l ≠ nil) (h₂ : l ≠ nil),
  getLast (a :: l) h₁ = getLast l h₂ := by
  induction l <;> intros; {contradiction}; rfl

@[simp] theorem getLast_append {a : α} : ∀ (l : List α) (h : l ++ [a] ≠ []), getLast (l ++ [a]) h = a
| [], _ => rfl
| a::t, h => by
  show getLast (_ :: (_ ++ _)) _ = _
  rw [getLast_cons _ fun H => cons_ne_nil _ _ (append_eq_nil.1 H).2, getLast_append t]

theorem getLast_concat {a : α} (l : List α) : (h : concat l a ≠ []) → getLast (concat l a) h = a := by
  rw [concat_eq_append]; apply getLast_append

/-! ### nth element -/

theorem get_of_mem : ∀ {a} {l : List α}, a ∈ l → ∃ n, get l n = a
| a, _ :: l, Mem.head .. => ⟨⟨0, Nat.succ_pos _⟩, rfl⟩
| a, b :: l, Mem.tail _ m =>
  let ⟨⟨n, h⟩, e⟩ := get_of_mem m
  ⟨⟨n+1, Nat.succ_lt_succ h⟩, e⟩

theorem get?_eq_get : ∀ {l : List α} {n} h, l.get? n = some (get l ⟨n, h⟩)
| a :: l, 0, h => rfl
| a :: l, n+1, h => @get?_eq_get _ l n _

theorem get?_len_le : ∀ {l : List α} {n}, length l ≤ n → l.get? n = none
| [], n, h => rfl
| a :: l, n+1, h => @get?_len_le _ l n $ Nat.le_of_succ_le_succ h

theorem get?_eq_some {l : List α} {n a} : l.get? n = some a ↔ ∃ h, get l ⟨n, h⟩ = a :=
  ⟨fun e =>
      have h : n < length l := lt_of_not_ge fun hn => by
        rw [get?_len_le hn] at e; contradiction
      ⟨h, by rw [get?_eq_get h] at e; injection e with e; exact e⟩,
    fun ⟨h, e⟩ => e ▸ get?_eq_get _⟩

@[simp] theorem get?_eq_none_iff {l : List α} {n} : l.get? n = none ↔ length l ≤ n := by
  constructor
  · intro h
    by_contra h'
    have h₂ : ∃ h , l.get ⟨n, h⟩ = l.get ⟨n, lt_of_not_ge h'⟩ := ⟨lt_of_not_ge h', rfl⟩
    rw [← get?_eq_some, h] at h₂
    cases h₂
  · exact get?_len_le

theorem get?_of_mem {a} {l : List α} (h : a ∈ l) : ∃ n, l.get? n = some a :=
  let ⟨⟨n, h⟩, e⟩ := get_of_mem h
  ⟨n,
    by
      rw [get?_eq_get, e]⟩

theorem get_mem : ∀ (l : List α) n h, get l ⟨n, h⟩ ∈ l
| a :: l, 0, h => mem_cons_self _ _
| a :: l, n+1, h => mem_cons_of_mem _ (get_mem l _ _)

theorem get?_mem {l : List α} {n a} (e : l.get? n = some a) : a ∈ l :=
  let ⟨h, e⟩ := get?_eq_some.1 e
  e ▸ get_mem _ _ _

theorem mem_iff_get {a} {l : List α} : a ∈ l ↔ ∃ n, get l n = a :=
  ⟨get_of_mem, fun ⟨_, e⟩ => e ▸ get_mem _ _ _⟩

theorem Fin.exists_iff (p : Fin n → Prop) : (∃ i, p i) ↔ ∃ i h, p ⟨i, h⟩ :=
  ⟨fun ⟨i, h⟩ => ⟨i.1, i.2, h⟩, fun ⟨i, hi, h⟩ => ⟨⟨i, hi⟩, h⟩⟩

theorem mem_iff_get? {a} {l : List α} : a ∈ l ↔ ∃ n, l.get? n = some a := by
  simp [get?_eq_some, Fin.exists_iff, mem_iff_get]

theorem get?_zero (l : List α) : l.get? 0 = l.head? := by cases l <;> rfl

theorem get?_injective {α : Type u} {xs : List α} {i j : ℕ}
  (h₀ : i < xs.length)
  (h₁ : Nodup xs)
  (h₂ : xs.get? i = xs.get? j) : i = j := by
  induction xs generalizing i j with
  | nil => cases h₀
  | cons x xs ih =>
    match i, j with
    | 0, 0 => rfl
    | i+1, j+1 => simp; cases h₁ with
      | cons ha h₁ => exact ih (Nat.lt_of_succ_lt_succ h₀) h₁ h₂
    | i+1, 0 => ?_ | 0, j+1 => ?_
    all_goals
      simp at h₂
      cases h₁; rename_i h' h
      have := h x ?_ rfl; cases this
      rw [mem_iff_get?]
    exact ⟨_, h₂⟩; exact ⟨_ , h₂.symm⟩

@[simp] theorem get?_map (f : α → β) : ∀ l n, (map f l).get? n = (l.get? n).map f
| [], n => rfl
| a :: l, 0 => rfl
| a :: l, n+1 => get?_map f l n

@[simp]
theorem get_map (f : α → β) {l n} : get (map f l) n = f (get l ⟨n, length_map l f ▸ n.2⟩) :=
  Option.some.inj $ by
    rw [←get?_eq_get, get?_map, get?_eq_get]; rfl

/-- If one has `get L i hi` in a formula and `h : L = L'`, one can not `rw h` in the formula as
`hi` gives `i < L.length` and not `i < L'.length`. The lemma `get_of_eq` can be used to make
such a rewrite, with `rw (get_of_eq h)`. -/
theorem get_of_eq {L L' : List α} (h : L = L') (i : Fin  L.length) :
  get L i = get L' ⟨i, h ▸ i.2⟩ := by cases h; rfl

@[simp] theorem get_singleton (a : α) (n : Fin 1) : get [a] n = a := by
  have hn0 : n.1 = 0 := Nat.le_zero_iff.1 (Nat.le_of_lt_succ n.2)
  cases n
  subst hn0; rfl

theorem get_zero [Inhabited α] {L : List α} (h : 0 < L.length) : L.get ⟨0, h⟩ = L.head? := by
  cases L; {cases h}; simp

theorem get_append : ∀ {l₁ l₂ : List α} (n : ℕ) (h : n < l₁.length),
    (l₁ ++ l₂).get ⟨n, id (length_append .. ▸ Nat.lt_add_right _ _ _ h)⟩ = l₁.get ⟨n, h⟩
| a :: l, _, 0, h => rfl
| a :: l, _, n+1, h => by
  simp only [get, cons_append] <;> exact get_append _ _

theorem get?_append_right : ∀ {l₁ l₂ : List α} {n : ℕ} (hn : l₁.length ≤ n),
  (l₁ ++ l₂).get? n = l₂.get? (n - l₁.length)
| [], _, n, h₁ => rfl
| a :: l, _, n+1, h₁ => by
  rw [cons_append]; simp
  rw [Nat.add_sub_add_right, get?_append_right (Nat.lt_succ_iff.mp h₁)]

theorem get_append_right_aux {l₁ l₂ : List α} {n : ℕ}
  (h₁ : l₁.length ≤ n) (h₂ : n < (l₁ ++ l₂).length) : n - l₁.length < l₂.length := by
  rw [length_append] at h₂
  exact Nat.sub_lt_left_of_lt_add h₁ h₂

theorem get_append_right' {l₁ l₂ : List α} {n : ℕ} (h₁ : l₁.length ≤ n) (h₂) :
    (l₁ ++ l₂).get ⟨n, h₂⟩ = l₂.get ⟨n - l₁.length, id <| get_append_right_aux h₁ h₂⟩ :=
Option.some.inj $ by rw [← get?_eq_get, ← get?_eq_get, get?_append_right h₁]

@[simp] theorem get_repeat' (a : α) {n : ℕ} (m : Fin _) : (List.repeat' a n).get m = a :=
  eq_of_mem_repeat' (get_mem _ _ _)

theorem get?_append {l₁ l₂ : List α} {n : ℕ} (hn : n < l₁.length) :
  (l₁ ++ l₂).get? n = l₁.get? n := by
  have hn' : n < (l₁ ++ l₂).length := Nat.lt_of_lt_of_le hn $ by
    rw [length_append] <;> exact Nat.le_add_right _ _
  rw [get?_eq_get hn, get?_eq_get hn', get_append]

theorem getLast_eq_get : ∀ (l : List α) (h : l ≠ []),
  getLast l h = l.get ⟨l.length - 1, id <| Nat.sub_lt (length_pos_of_ne_nil h) Nat.one_pos⟩
| [a], h => by
  rw [getLast_singleton, get_singleton]
| a :: b :: l, h => by rw [getLast_cons, getLast_eq_get (b :: l)]; {rfl}; exact cons_ne_nil b l

@[simp] theorem get?_concat_length : ∀ (l : List α) a : α, (l ++ [a]).get? l.length = some a
| [], a => rfl
| b :: l, a => by rw [cons_append, length_cons]; simp only [get?, get?_concat_length]

theorem get_cons_length (x : α) (xs : List α) (n : ℕ) (h : n = xs.length) :
  (x :: xs).get ⟨n, by simp [h]⟩ = (x :: xs).getLast (cons_ne_nil x xs) := by
  rw [getLast_eq_get]; cases h; rfl

@[ext] theorem ext : ∀ {l₁ l₂ : List α}, (∀ n, l₁.get? n = l₂.get? n) → l₁ = l₂
| [], [], h => rfl
| a :: l₁, [], h => nomatch h 0
| [], a' :: l₂, h => nomatch h 0
| a :: l₁, a' :: l₂, h => by
  have h0 : some a = some a' := h 0
  injection h0 with aa; simp only [aa, ext fun n => h (n+1)]

theorem ext_get {l₁ l₂ : List α} (hl : length l₁ = length l₂)
  (h : ∀ n h₁ h₂, get l₁ ⟨n, h₁⟩ = get l₂ ⟨n, h₂⟩) : l₁ = l₂ :=
  ext fun n =>
    if h₁ : n < length l₁ then by
      rw [get?_eq_get, get?_eq_get, h n h₁ (by rwa [←hl])]
    else by
      have h₁ := le_of_not_gt h₁
      rw [get?_len_le h₁, get?_len_le]; rwa [← hl]

theorem modifyNthTail_id : ∀ n (l : List α), l.modifyNthTail id n = l
| 0, l => rfl
| n+1, [] => rfl
| n+1, a :: l => congr_arg (List.cons a) (modifyNthTail_id n l)

theorem removeNth_eq_nth_tail : ∀ n (l : List α), removeNth l n = modifyNthTail tail n l
| 0, l => by cases l <;> rfl
| n+1, [] => rfl
| n+1, a :: l => congr_arg (cons _) (removeNth_eq_nth_tail _ _)

theorem set_eq_modifyNth (a : α) : ∀ n (l : List α), set l n a = modifyNth (fun _ => a) n l
| 0, l => by cases l <;> rfl
| n+1, [] => rfl
| n+1, b :: l => congr_arg (cons _) (set_eq_modifyNth _ _ _)

theorem modifyNth_eq_set (f : α → α) :
  ∀ n (l : List α), l.modifyNth f n = ((fun a => l.set n (f a)) <$> l.get? n).getD l
| 0, l => by cases l <;> rfl
| n+1, [] => rfl
| n+1, b :: l =>
  (congr_arg (cons b) (modifyNth_eq_set f n l)).trans $ by
    cases l.get? n <;> rfl

theorem get?_modifyNth (f : α → α) :
  ∀ n (l : List α) m, (modifyNth f n l).get? m = (fun a => if n = m then f a else a) <$> l.get? m
| n, l, 0 => by cases l <;> cases n <;> rfl
| n, [], m+1 => by cases n <;> rfl
| 0, a :: l, m+1 => by cases l.get? m <;> rfl
| n+1, a :: l, m+1 =>
  (get?_modifyNth f n l m).trans $ by
    cases l.get? m <;> by_cases h : n = m <;>
      simp only [h, if_pos, if_true, if_false, Option.map, mt Nat.succ.inj, not_false_iff]

theorem modifyNthTail_length (f : List α → List α) (H : ∀ l, length (f l) = length l) :
  ∀ n l, length (modifyNthTail f n l) = length l
| 0, l => H _
| n+1, [] => rfl
| n+1, a :: l => congr_arg (·+1) (modifyNthTail_length _ H _ _)

@[simp] theorem modify_get?_length (f : α → α) : ∀ n l, length (modifyNth f n l) = length l :=
  modifyNthTail_length _ fun l => by cases l <;> rfl

@[simp] theorem get?_modifyNth_eq (f : α → α) (n) (l : List α) :
  (modifyNth f n l).get? n = f <$> l.get? n := by
  simp only [get?_modifyNth, if_pos]

@[simp] theorem get?_modifyNth_ne (f : α → α) {m n} (l : List α) (h : m ≠ n) :
  (modifyNth f m l).get? n = l.get? n := by
  simp only [get?_modifyNth, if_neg h, id_map']

theorem get?_set_eq (a : α) (n) (l : List α) : (set l n a).get? n = (fun _ => a) <$> l.get? n := by
  simp only [set_eq_modifyNth, get?_modifyNth_eq]

theorem get?_set_of_lt (a : α) {n} {l : List α} (h : n < length l) :
  (set l n a).get? n = some a := by rw [get?_set_eq, get?_eq_get h]; rfl

theorem get?_set_ne (a : α) {m n} (l : List α) (h : m ≠ n) : (set l m a).get? n = l.get? n := by
  simp only [set_eq_modifyNth, get?_modifyNth_ne _ _ h]

@[simp] theorem set_nil (n : ℕ) (a : α) : [].set n a = [] := rfl

@[simp] theorem set_succ (x : α) (xs : List α) (n : ℕ) (a : α) :
  (x :: xs).set n.succ a = x :: xs.set n a := rfl

theorem set_comm (a b : α) : ∀ {n m : ℕ} (l : List α) (h : n ≠ m),
  (l.set n a).set m b = (l.set m b).set n a
| _, _, [], _ => by simp
| n+1, 0, x :: t, h => by simp [set]
| 0, m+1, x :: t, h => by simp [set]
| n+1, m+1, x :: t, h => by
  simp only [set, true_and, eq_self_iff_true]
  conv => lhs; rhs; tactic' =>
    exact set_comm a b t fun h' => h $ Nat.succ_inj'.mpr h'

@[simp] theorem get_set_eq (l : List α) (i : ℕ) (a : α) (h : i < (l.set i a).length) :
    (l.set i a).get ⟨i, h⟩ = a := by
  rw [← Option.some_inj, ← get?_eq_get, get?_set_eq, get?_eq_get] <;> simp_all

@[simp] theorem get_set_ne {l : List α} {i j : ℕ} (h : i ≠ j) (a : α)
  (hj : j < (l.set i a).length) :
    (l.set i a).get ⟨j, hj⟩ = l.get ⟨j, by simp at hj; exact hj⟩ := by
  rw [← Option.some_inj, ← List.get?_eq_get, List.get?_set_ne _ _ h, List.get?_eq_get]

theorem mem_or_eq_of_mem_set : ∀ {l : List α} {n : ℕ} {a b : α} h : a ∈ l.set n b, a ∈ l ∨ a = b
| c :: l, 0, a, b, h => ((mem_cons ..).1 h).elim Or.inr (Or.inl ∘ mem_cons_of_mem _)
| c :: l, n+1, a, b, h =>
  ((mem_cons ..).1 h).elim (fun h => h ▸ Or.inl (mem_cons_self ..))
    fun h => (mem_or_eq_of_mem_set h).elim (Or.inl ∘ mem_cons_of_mem _) Or.inr

/-! ### insert -/
section insert
variable [DecidableEq α]

@[simp] theorem insert_of_mem {a : α} {l : List α} (h : a ∈ l) : insert a l = l := by
  simp only [insert, if_pos h]

@[simp] theorem insert_of_not_mem {a : α} {l : List α} (h : a ∉ l) : insert a l = a :: l := by
  simp only [insert, if_neg h]

@[simp] theorem mem_insert_iff {a b : α} {l : List α} : a ∈ insert b l ↔ a = b ∨ a ∈ l := by
  by_cases h : b ∈ l
  · rw [insert_of_mem h]
    constructor; {apply Or.inr}
    intro
    | Or.inl h' => rw [h']; exact h
    | Or.inr h' => exact h'
  · rw [insert_of_not_mem h, mem_cons]

@[simp 1100] theorem mem_insert_self (a : α) (l : List α) : a ∈ insert a l :=
mem_insert_iff.2 (Or.inl rfl)

theorem mem_insert_of_mem {a b : α} {l : List α} (h : a ∈ l) : a ∈ insert b l :=
mem_insert_iff.2 (Or.inr h)

theorem eq_or_mem_of_mem_insert {a b : α} {l : List α} (h : a ∈ insert b l) : a = b ∨ a ∈ l :=
mem_insert_iff.1 h

@[simp] theorem length_insert_of_mem {a : α} {l : List α} (h : a ∈ l) :
  length (insert a l) = length l := by
  rw [insert_of_mem h]

@[simp] theorem length_insert_of_not_mem {a : α} {l : List α} (h : a ∉ l) :
  length (insert a l) = length l + 1 := by
  rw [insert_of_not_mem h]; rfl

end insert

/-! ### erasep -/

section erasep

variable {p : α → Prop} [DecidablePred p]

@[simp] theorem erasep_nil : [].erasep p = [] := rfl

theorem erasep_cons (a : α) (l : List α) :
  (a :: l).erasep p = if p a then l else a :: l.erasep p := rfl

@[simp] theorem erasep_cons_of_pos {a : α} {l : List α} (h : p a) : (a :: l).erasep p = l := by
  simp [erasep_cons, h]

@[simp] theorem erasep_cons_of_neg {a : α} {l : List α} (h : ¬ p a) :
  (a::l).erasep p = a :: l.erasep p := by
  simp [erasep_cons, h]

theorem erasep_of_forall_not {l : List α}
  (h : ∀ a, a ∈ l → ¬ p a) : l.erasep p = l := by
  induction l with
  | nil => rfl
  | cons _ _ ih => simp [h _ (Mem.head ..), ih (forall_mem_of_forall_mem_cons h)]

theorem exists_of_erasep {l : List α} {a} (al : a ∈ l) (pa : p a) :
    ∃ a l₁ l₂, (∀ b ∈ l₁, ¬ p b) ∧ p a ∧ l = l₁ ++ a :: l₂ ∧ l.erasep p = l₁ ++ l₂ := by
  induction l with
  | nil => cases al
  | cons b l ih =>
    by_cases pb : p b
    · exact ⟨b, [], l, forall_mem_nil _, pb, by simp [pb]⟩
    · cases al with
      | head => cases pb pa
      | tail _ al =>
        let ⟨c, l₁, l₂, h₁, h₂, h₃, h₄⟩ := ih al
        exact ⟨c, b::l₁, l₂, forall_mem_cons.2 ⟨pb, h₁⟩,
          h₂, by rw [h₃, cons_append], by simp [pb, h₄]⟩

theorem exists_or_eq_self_of_erasep (p : α → Prop) [DecidablePred p] (l : List α) :
    l.erasep p = l ∨
      ∃ a l₁ l₂, (∀ b ∈ l₁, ¬ p b) ∧ p a ∧ l = l₁ ++ a :: l₂ ∧ l.erasep p = l₁ ++ l₂ := by
  by_cases h : ∃ a ∈ l, p a
  · let ⟨a, ha, pa⟩ := h
    exact Or.inr (exists_of_erasep ha pa)
  · simp at h
    exact Or.inl (erasep_of_forall_not h)

@[simp] theorem length_erasep_of_mem {l : List α} {a} (al : a ∈ l) (pa : p a) :
   length (l.erasep p) = Nat.pred (length l) := by
  let ⟨_, l₁, l₂, _, _, e₁, e₂⟩ := exists_of_erasep al pa
  rw [e₂]; simp [length_append, e₁]; rfl

theorem erasep_append_left {a : α} (pa : p a) :
  ∀ {l₁ : List α} (l₂), a ∈ l₁ → (l₁++l₂).erasep p = l₁.erasep p ++ l₂
| (x::xs), l₂, h => by
  by_cases h' : p x <;> simp [h']
  rw [erasep_append_left pa l₂ (mem_of_ne_of_mem (mt _ h') h)]
  intro | rfl => exact pa

theorem erasep_append_right :
  ∀ {l₁ : List α} (l₂), (∀ b ∈ l₁, ¬ p b) → erasep p (l₁++l₂) = l₁ ++ l₂.erasep p
| [],      l₂, h => rfl
| (x::xs), l₂, h => by
  simp [(forall_mem_cons.1 h).1, erasep_append_right _ (forall_mem_cons.1 h).2]

-- theorem erasep_sublist (l : List α) : l.erasep p <+ l :=
-- by rcases exists_or_eq_self_of_erasep p l with h | ⟨c, l₁, l₂, h₁, h₂, h₃, h₄⟩;
--    [rw h, {rw [h₄, h₃], simp}]

theorem erasep_subset (l : List α) : l.erasep p ⊆ l := fun a => by
  match exists_or_eq_self_of_erasep p l with
  | Or.inl h => rw [h]; apply subset.refl
  | Or.inr ⟨c, l₁, l₂, h₁, h₂, h₃, h₄⟩ =>
    rw [h₄, h₃, mem_append, mem_append]
    intro
    | Or.inl h => exact Or.inl h
    | Or.inr h => exact Or.inr $ mem_cons_of_mem _ h
-- the proof was:
-- (erasep_sublist l).subset

-- theorem sublist.erasep {l₁ l₂ : List α} (s : l₁ <+ l₂) : l₁.erasep p <+ l₂.erasep p :=
-- begin
--   induction s,
--   case List.sublist.slnil { refl },
--   case List.sublist.cons : l₁ l₂ a s IH {
--     by_cases h : p a; simp [h],
--     exacts [IH.trans (erasep_sublist _), IH.cons _ _ _] },
--   case List.sublist.cons2 : l₁ l₂ a s IH {
--     by_cases h : p a; simp [h],
--     exacts [s, IH.cons2 _ _ _] }
-- end

theorem mem_of_mem_erasep {a : α} {l : List α} : a ∈ l.erasep p → a ∈ l :=
@erasep_subset _ _ _ _ _

@[simp] theorem mem_erasep_of_neg {a : α} {l : List α} (pa : ¬ p a) : a ∈ l.erasep p ↔ a ∈ l := by
  refine ⟨mem_of_mem_erasep, fun al => ?_⟩
  apply Or.elim (exists_or_eq_self_of_erasep p l)
  · intro h; rw [h]; assumption
  intro ⟨c, l₁, l₂, h₁, h₂, h₃, h₄⟩
  rw [h₄]
  rw [h₃] at al
  have : a ≠ c := fun h => by rw [h] at pa; exact pa.elim h₂
  simp [this] at al
  simp [al]

theorem erasep_map (f : β → α) :
  ∀ (l : List β), (map f l).erasep p = map f (l.erasep (p ∘ f))
| []     => rfl
| (b::l) => by
  by_cases h : p (f b)
  · simp [h, erasep_map f l, @erasep_cons_of_pos β (p ∘ f) _ b l h]
  · simp [h, erasep_map f l, @erasep_cons_of_neg β (p ∘ f) _ b l h]

-- @[simp] theorem extractp_eq_find_erasep :
--   ∀ l : List α, extractp p l = (find p l, erasep p l)
-- | []     => rfl
-- | (a::l) => by by_cases pa : p a; simp [extractp, pa, extractp_eq_find_erasep l]

end erasep

/-! ### erase -/

section erase
variable [DecidableEq α]

@[simp] theorem erase_nil (a : α) : [].erase a = [] := rfl

theorem erase_cons (a b : α) (l : List α) :
    (b :: l).erase a = if b = a then l else b :: l.erase a := by
  by_cases h : a = b
  · simp only [if_pos h.symm, List.erase, EqIffBeqTrue.mp h.symm]
  · simp only [if_neg (Ne.symm h), List.erase, NeqIffBeqFalse.mp (Ne.symm h)]

@[simp] theorem erase_cons_head (a : α) (l : List α) : (a :: l).erase a = l := by
  simp [erase_cons]

@[simp] theorem erase_cons_tail {a b : α} (l : List α) (h : b ≠ a) :
  (b::l).erase a = b :: l.erase a :=
by simp only [erase_cons, if_neg h]

theorem erase_eq_erasep (a : α) (l : List α) : l.erase a = l.erasep (Eq a) := by
  induction l with
  | nil => rfl
  | cons b l ih =>
    by_cases h : a = b
    · simp [h]
    · simp [h, Ne.symm h, ih]

theorem erase_of_not_mem {a : α} {l : List α} (h : a ∉ l) : l.erase a = l := by
  induction l with
  | nil => rfl
  | cons b l ih =>
    rw [mem_cons, not_or] at h
    rw [erase_cons, if_neg (Ne.symm h.1), ih h.2]

-- TODO: ∉ should have higher priority
theorem exists_erase_eq {a : α} {l : List α} (h : a ∈ l) :
    ∃ l₁ l₂, (a ∉ l₁) ∧ l = l₁ ++ a :: l₂ ∧ l.erase a = l₁ ++ l₂ :=
  match exists_of_erasep h rfl with
  | ⟨_, l₁, l₂, h₁, rfl, h₂, h₃⟩ => by
    rw [erase_eq_erasep]; exact ⟨l₁, l₂, fun h => h₁ _ h rfl, h₂, h₃⟩

@[simp] theorem length_erase_of_mem {a : α} {l : List α} (h : a ∈ l) :
  length (l.erase a) = Nat.pred (length l) := by
  rw [erase_eq_erasep]; exact length_erasep_of_mem h rfl

theorem erase_append_left {a : α} {l₁ : List α} (l₂) (h : a ∈ l₁) :
  (l₁++l₂).erase a = l₁.erase a ++ l₂ := by
  simp [erase_eq_erasep]; exact erasep_append_left (by rfl) l₂ h

theorem erase_append_right {a : α} {l₁ : List α} (l₂ : List α) (h : a ∉ l₁) :
    (l₁++l₂).erase a = (l₁ ++ l₂.erase a) := by
  rw [erase_eq_erasep, erase_eq_erasep, erasep_append_right]
  intros b h' h''; rw [h''] at h; exact h h'

-- theorem erase_sublist (a : α) (l : List α) : l.erase a <+ l :=
-- by rw erase_eq_erasep; apply erasep_sublist

theorem erase_subset (a : α) (l : List α) : l.erase a ⊆ l := by
  rw [erase_eq_erasep]; apply erasep_subset
--(erase_sublist a l).subset

-- theorem sublist.erase (a : α) {l₁ l₂ : List α} (h : l₁ <+ l₂) : l₁.erase a <+ l₂.erase a :=
-- by simp [erase_eq_erasep]; exact sublist.erasep h

theorem mem_of_mem_erase {a b : α} {l : List α} : a ∈ l.erase b → a ∈ l :=
  @erase_subset _ _ _ _ _

@[simp] theorem mem_erase_of_ne {a b : α} {l : List α} (ab : a ≠ b) : a ∈ l.erase b ↔ a ∈ l := by
  rw [erase_eq_erasep]; exact mem_erasep_of_neg ab.symm

-- theorem erase_comm (a b : α) (l : List α) : (l.erase a).erase b = (l.erase b).erase a :=
-- if ab : a = b then by rw ab else
-- if ha : a ∈ l then
-- if hb : b ∈ l then match l, l.erase a, exists_erase_eq ha, hb with
-- | ._, ._, ⟨l₁, l₂, ha', rfl, rfl⟩, hb :=
--   if h₁ : b ∈ l₁ then
--     by rw [erase_append_left _ h₁, erase_append_left _ h₁,
--            erase_append_right _ (mt mem_of_mem_erase ha'), erase_cons_head]
--   else
--     by rw [erase_append_right _ h₁, erase_append_right _ h₁, erase_append_right _ ha',
--            erase_cons_tail _ ab, erase_cons_head]
-- end
-- else by simp only [erase_of_not_mem hb, erase_of_not_mem (mt mem_of_mem_erase hb)]
-- else by simp only [erase_of_not_mem ha, erase_of_not_mem (mt mem_of_mem_erase ha)]

-- theorem map_erase [DecidableEq β] {f : α → β} (finj : injective f) {a : α}
--   (l : List α) : map f (l.erase a) = (map f l).erase (f a) :=
-- by rw [erase_eq_erasep, erase_eq_erasep, erasep_map]; congr;
--    ext b; simp [finj.eq_iff]

-- theorem map_foldl_erase [DecidableEq β] {f : α → β} (finj : injective f) {l₁ l₂ : List α} :
--   map f (foldl List.erase l₁ l₂) = foldl (fun  l a, l.erase (f a)) (map f l₁) l₂ :=
-- by induction l₂ generalizing l₁; [refl,
-- simp only [foldl_cons, map_erase finj, *]]

-- @[simp] theorem count_erase_self (a : α) :
--   ∀ (s : List α), count a (List.erase s a) = pred (count a s)
-- | [] => by simp
-- | (h :: t) :=
-- begin
--   rw erase_cons,
--   by_cases p : h = a,
--   { rw [if_pos p, count_cons', if_pos p.symm], simp },
--   { rw [if_neg p, count_cons', count_cons', if_neg (fun  x : a = h, p x.symm), count_erase_self],
--     simp, }
-- end

-- @[simp] theorem count_erase_of_ne {a b : α} (ab : a ≠ b) :
--   ∀ (s : List α), count a (List.erase s b) = count a s
-- | [] := by simp
-- | (x :: xs) :=
-- begin
--   rw erase_cons,
--   split_ifs with h,
--   { rw [count_cons', h, if_neg ab], simp },
--   { rw [count_cons', count_cons', count_erase_of_ne] }
-- end

end erase

-- /-! ### disjoint -/

section disjoint

variable {α : Type _} {l l₁ l₂ : List α} {p : α → Prop} {a : α}

lemma disjoint_symm (d : disjoint l₁ l₂) : disjoint l₂ l₁ := λ _ i₂ i₁ => d i₁ i₂

lemma disjoint_comm : disjoint l₁ l₂ ↔ disjoint l₂ l₁ := ⟨disjoint_symm, disjoint_symm⟩

lemma disjoint_left : disjoint l₁ l₂ ↔ ∀ ⦃a⦄, a ∈ l₁ → a ∉ l₂ := by simp [disjoint]

lemma disjoint_right : disjoint l₁ l₂ ↔ ∀ ⦃a⦄, a ∈ l₂ → a ∉ l₁ := disjoint_comm

lemma disjoint_iff_ne : disjoint l₁ l₂ ↔ ∀ a ∈ l₁, ∀ b ∈ l₂, a ≠ b :=
  ⟨fun h a al1 b bl2 ab => h al1 (ab ▸ bl2), fun h a al1 al2 => h _ al1 _ al2 rfl⟩

lemma disjoint_of_subset_left (ss : l₁ ⊆ l) (d : disjoint l l₂) : disjoint l₁ l₂ :=
λ x m => d (ss m)

lemma disjoint_of_subset_right (ss : l₂ ⊆ l) (d : disjoint l₁ l) : disjoint l₁ l₂ :=
λ x m m₁ => d m (ss m₁)

lemma disjoint_of_disjoint_cons_left {l₁ l₂} : disjoint (a :: l₁) l₂ → disjoint l₁ l₂ :=
disjoint_of_subset_left (List.subset_cons _ _)

lemma disjoint_of_disjoint_cons_right {l₁ l₂} : disjoint l₁ (a :: l₂) → disjoint l₁ l₂ :=
disjoint_of_subset_right (List.subset_cons _ _)

@[simp] lemma disjoint_nil_left (l : List α) : disjoint [] l := λ a => (not_mem_nil a).elim

@[simp] lemma disjoint_nil_right (l : List α) : disjoint l [] := by
  rw [disjoint_comm]; exact disjoint_nil_left _

-- TODO: this lemma is marked with simp and priority 1100 in mathlib3
lemma singleton_disjoint : disjoint [a] l ↔ a ∉ l := by
simp [disjoint]

-- TODO: this lemma is marked with priority 1100 in mathlib3
@[simp] lemma disjoint_singleton : disjoint l [a] ↔ a ∉ l := by
rw [disjoint_comm, singleton_disjoint]

@[simp] lemma disjoint_append_left : disjoint (l₁ ++ l₂) l ↔ disjoint l₁ l ∧ disjoint l₂ l :=
by simp [disjoint, or_imp_distrib, forall_and_distrib]

-- @[simp] lemma disjoint_append_right : disjoint l (l₁ ++ l₂) ↔ disjoint l l₁ ∧ disjoint l l₂ :=
-- disjoint_comm.trans $ by simp [disjoint_comm, disjoint_append_left]

@[simp] lemma disjoint_cons_left : disjoint (a::l₁) l₂ ↔ (a ∉ l₂) ∧ disjoint l₁ l₂ :=
(@disjoint_append_left _ l₂ [a] l₁).trans $ by simp [singleton_disjoint]

-- @[simp] lemma disjoint_cons_right : disjoint l₁ (a :: l₂) ↔ (a ∉ l₁) ∧ disjoint l₁ l₂ :=
-- disjoint_comm.trans $ by simp [disjoint_comm, disjoint_cons_left]

lemma disjoint_of_disjoint_append_left_left (d : disjoint (l₁ ++ l₂) l) : disjoint l₁ l :=
(disjoint_append_left.1 d).1

lemma disjoint_of_disjoint_append_left_right (d : disjoint (l₁ ++ l₂) l) : disjoint l₂ l :=
(disjoint_append_left.1 d).2

-- lemma disjoint_of_disjoint_append_right_left (d : disjoint l (l₁ ++ l₂)) : disjoint l l₁ :=
-- (disjoint_append_right.1 d).1

-- lemma disjoint_of_disjoint_append_right_right (d : disjoint l (l₁ ++ l₂)) : disjoint l l₂ :=
-- (disjoint_append_right.1 d).2

-- lemma disjoint_take_drop {m n : ℕ} (hl : l.nodup) (h : m ≤ n) : disjoint (l.take m) (l.drop n) :=
-- begin
--   induction l generalizing m n,
--   case list.nil : m n
--   { simp },
--   case list.cons : x xs xs_ih m n
--   { cases m; cases n; simp only [disjoint_cons_left, mem_cons_iff, disjoint_cons_right, drop,
--                                  true_or, eq_self_iff_true, not_true, false_and,
--                                  disjoint_nil_left, take],
--     { cases h },
--     cases hl with _ _ h₀ h₁, split,
--     { intro h, exact h₀ _ (mem_of_mem_drop h) rfl, },
--     solve_by_elim [le_of_succ_le_succ] { max_depth := 4 } },
-- end

end disjoint

-- /-! ### union -/

section union

variable [DecidableEq α]

@[simp] theorem nil_union (l : List α) : nil.union l = l := by simp [List.union, foldr]

@[simp] theorem cons_union (a : α) (l₁ l₂ : List α) :
  (a :: l₁).union l₂ = insert a (l₁.union l₂) := by simp [List.union, foldr]

@[simp] theorem mem_union_iff [DecidableEq α] {x : α} {l₁ l₂ : List α} :
    x ∈ l₁.union l₂ ↔ x ∈ l₁ ∨ x ∈ l₂ := by
  induction l₁ with
  | nil => simp
  | cons a l' ih => simp [ih, or_assoc]

end union

-- /-! ### inter -/

@[simp] theorem mem_inter_iff [DecidableEq α] {x : α} {l₁ l₂ : List α} :
    x ∈ l₁.inter l₂ ↔ x ∈ l₁ ∧ x ∈ l₂ := by
  cases l₁ <;> simp [List.inter, mem_filter]

/--
List.prod satisfies a specification of cartesian product on lists.
-/
theorem product_spec (xs : List α) (ys : List β) (x : α) (y : β) :
  (x, y) ∈ product xs ys <-> (x ∈ xs ∧ y ∈ ys) := by
  constructor
  · simp only [List.product, and_imp, exists_prop, List.mem_map, Prod.mk.injEq,
      exists_eq_right_right', List.mem_bind]
    exact And.intro
  · simp only [product, mem_bind, mem_map, Prod.mk.injEq, exists_eq_right_right', exists_prop]
    exact id

section Pairwise

variable {R : α → α → Prop}

@[simp]
theorem Pairwise_cons {a : α} {l : List α} :
  Pairwise R (a::l) ↔ (∀ a', a' ∈ l -> R a a') ∧ Pairwise R l :=
  ⟨fun | Pairwise.cons h1 h2 => ⟨h1, h2⟩, And.elim Pairwise.cons⟩

instance decidablePairwise [DecidableRel R] (l : List α) : Decidable (Pairwise R l) :=
  match h: l with
  | [] => isTrue Pairwise.nil
  | hd :: tl =>
    match decidablePairwise tl with
    | isTrue ht =>
      match decidableBAll (R hd) tl with
      | isFalse hf => isFalse fun hf' =>
        have hAnd : (∀ a', a' ∈ tl -> R hd a') ∧ Pairwise R tl := Pairwise_cons.mp hf'
        hf hAnd.left
      | isTrue ht' =>  isTrue $ Pairwise_cons.mpr (And.intro ht' ht)
    | isFalse hf => isFalse fun
      | Pairwise.cons h ih => hf ih

end Pairwise

instance nodupDecidable [DecidableEq α] : ∀ l : List α, Decidable (Nodup l) :=
List.decidablePairwise

/-- pad `l : List α` with repeated occurrences of `a : α` until it's of length `n`.
  If `l` is initially larger than `n`, just return `l`. -/
def leftpad (n : ℕ) (a : α) (l : List α) : List α :=
repeat' a (n - length l) ++ l

/-- The length of the List returned by `List.leftpad n a l` is equal
  to the larger of `n` and `l.length` -/
theorem leftpad_length (n : ℕ) (a : α) (l : List α) : (leftpad n a l).length = max n l.length :=
by simp only [leftpad, length_append, length_repeat', Nat.sub_add_eq_max]

theorem leftpad_prefix [DecidableEq α] (n : ℕ) (a : α) (l : List α) : isPrefix (repeat' a (n - length l)) (leftpad n a l) :=
by
  simp only [isPrefix, leftpad]
  exact Exists.intro l rfl

theorem leftpad_suffix [DecidableEq α] (n : ℕ) (a : α) (l : List α) : isSuffix l (leftpad n a l) :=
by
  simp only [isSuffix, leftpad]
  exact Exists.intro (repeat' a (n - length l)) rfl

end List


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

namespace Cpdt
namespace Chapter2

inductive Ty where
  | nat : Ty
  | bool : Ty

inductive TBinop : Ty → Ty → Ty → Type where
  | plus : TBinop .nat .nat .nat
  | times : TBinop .nat .nat .nat
  | eq (t : Ty) : TBinop t t .bool
  | lt : TBinop .nat .nat .bool

inductive TExp : Ty → Type where
  | nConst : Nat → TExp .nat
  | bConst : Bool → TExp .bool
  | binop : TBinop t1 t2 r → TExp t1 → TExp t2 → TExp r

namespace Ty

@[reducible]
def denote : Ty → Type
  | nat => Nat
  | bool => Bool

end Ty

namespace TBinop

def denote : TBinop t1 t2 r → (t1.denote → t2.denote → r.denote)
  | plus => Nat.add
  | times => Nat.mul
  | eq .nat => (· == ·)
  | eq .bool => (· == ·)
  | lt => (· < ·)

end TBinop

namespace TExp

def denote : TExp t → t.denote
  | nConst n => n
  | bConst b => b
  | binop op arg1 arg2 => op.denote (denote arg1) (denote arg2)

@[simp] theorem denote_nConst : denote (nConst n) = n := by rfl
@[simp] theorem denote_bConst : denote (bConst b) = b := by rfl
@[simp] theorem denote_binop : denote (binop op arg1 arg2) = op.denote (denote arg1) (denote arg2) := by rfl

end TExp

abbrev TStack := List Ty

inductive TInstr : TStack → TStack → Type where
  | inConst (n : Nat) : TInstr s (.nat :: s)
  | ibConst (b : Bool) : TInstr s (.bool :: s)
  | iBinop (op : TBinop arg1 arg2 r) : TInstr (arg1 :: arg2 :: s) (r :: s)

inductive TProg : TStack → TStack → Type where
  | nil : TProg s s
  | cons : TInstr s1 s2 → TProg s2 s3 → TProg s1 s3

namespace TStack

@[reducible]
def VStack : TStack → Type
  | [] => Unit
  | t :: ts => t.denote × VStack ts

end TStack

namespace TInstr

open TStack

def denote : TInstr ts ts' → VStack ts → VStack ts'
  | inConst n, s => (n, s)
  | ibConst b, s => (b, s)
  | iBinop op, (arg1, (arg2, s')) => (op.denote arg1 arg2, s')

@[simp] theorem denote_inConst : denote (inConst n) s = (n, s) := by rfl
@[simp] theorem denote_ibConst : denote (ibConst b) s = (b, s) := by rfl
@[simp] theorem denote_iBinop : denote (iBinop op) (arg1, (arg2, s')) = (op.denote arg1 arg2, s') := by rfl

end TInstr

namespace TProg

open TStack

def denote : TProg ts ts' → VStack ts → VStack ts'
  | nil, s => s
  | cons i p, s => (denote p) (i.denote s)

def concat : TProg ts1 ts2 → TProg ts2 ts3 → TProg ts1 ts3
  | nil, ps => ps
  | cons i ps, rs => cons i (concat ps rs)

@[simp] theorem denote_nil : denote nil s = s := by rfl
@[simp] theorem denote_cons : denote (cons i p) s = (denote p) (i.denote s) := by rfl
@[simp] theorem concat_nil : concat nil ps = ps := by rfl
@[simp] theorem concat_cons : concat (cons i ps) rs = cons i (concat ps rs) := by rfl

end TProg

namespace TExp

open TInstr TProg TStack

def compile : (e : TExp t) → (ts : TStack) → TProg ts (t :: ts)
  | nConst n, _ => cons (inConst n) nil
  | bConst b, _ => cons (ibConst b) nil
  | binop op arg1 arg2, _ =>
      let arg2Out := compile arg2 _
      let arg1Out := compile arg1 _
      let opOut := cons (iBinop op) nil
      concat arg2Out (concat arg1Out opOut)

@[simp] theorem compile_nConst : compile (nConst n) ts = cons (inConst n) nil := by rfl
@[simp] theorem compile_bConst : compile (bConst b) ts = cons (ibConst b) nil := by rfl
@[simp] theorem compile_binop :
  compile (@binop _ _ r op arg1 arg2) ts
  = concat (compile arg2 ts) (concat (compile arg1 (r :: ts)) (cons (iBinop op) nil)) := by rfl

theorem concat_correct : ∀ (p1 : TProg ts1 ts2) (p2 : TProg ts2 ts3) (s : VStack ts1), TProg.denote (concat p1 p2) s = TProg.denote p2 (TProg.denote p1 s) := by
  intro p1
  induction p1 <;> simp_all

theorem compile_correct_helper : ∀ (e : TExp t) (ts : TStack) (s : VStack ts), TProg.denote (compile e ts) s = (TExp.denote e, s) := by
  intro e
  induction e <;> simp_all[compile, concat_correct]

theorem compile_correct : ∀ (e : TExp t), TProg.denote (compile e []) () = (TExp.denote e, ()) := by
  simp [compile_correct_helper]

end TExp

end Chapter2
end Cpdt


open nat

inductive Expr
| zero : Expr
| one  : Expr
| add  : Expr → Expr → Expr

namespace Expr

inductive direct_subterm : Expr → Expr → Prop
| add_1 : ∀ e₁ e₂ : Expr, direct_subterm _ (add _ _)
| add_2 : ∀ e₁ e₂ : Expr, direct_subterm _ (add _ _)

theorem direct_subterm_wf : well_founded direct_subterm :=
begin
  constructor,
  intro e,
  induction e,
  all_goals { constructor },
  all_goals { sorry }
end

def subterm := tc direct_subterm

#check @tc -- tc : Π {α : Sort u_1}, (α → α → Prop) → α → α → Prop

theorem subterm_wf : well_founded subterm := tc.wf direct_subterm_wf

local infix `+` := Expr.add

set_option pp.notation false

def ev : Expr → nat
| zero := 0
| one := 1
| ((a : Expr) + b) := has_add.add (ev a) (ev b)

def foo : Expr := add zero (add one one)

example : ev foo = 2 := rfl

end Expr


open expr tactic classical

section logical_equivalences
local attribute [instance] prop_decidable
variables {a b : Prop}
theorem not_not_iff (a : Prop) : ¬¬a ↔ a :=
iff.intro classical.by_contradiction not_not_intro
theorem implies_iff_not_or (a b : Prop) : (a → b) ↔ (¬ a ∨ b) :=
iff.intro
(λ h, if ha : a then or.inr (h ha) else or.inl ha)
(λ h, or.elim h (λ hna ha, absurd ha hna) (λ hb ha, hb))
theorem not_and_of_not_or_not (h : ¬ a ∨ ¬ b) : ¬ (a ∧ b) :=
assume ⟨ha, hb⟩, or.elim h (assume hna, hna ha) (assume hnb, hnb hb)
theorem not_or_not_of_not_and (h : ¬ (a ∧ b)) : ¬ a ∨ ¬ b :=
if ha : a then
or.inr (show ¬ b, from assume hb, h ⟨ha, hb⟩)
else
or.inl ha
theorem not_and_iff (a b : Prop) : ¬ (a ∧ b) ↔ ¬a ∨ ¬b :=
iff.intro not_or_not_of_not_and not_and_of_not_or_not
theorem not_or_of_not_and_not (h : ¬ a ∧ ¬ b) : ¬ (a ∨ b) :=
assume h1, or.elim h1 (assume ha, h^.left ha) (assume hb, h^.right hb)
theorem not_and_not_of_not_or (h : ¬ (a ∨ b)) : ¬ a ∧ ¬ b :=
and.intro (assume ha, h (or.inl ha)) (assume hb, h (or.inr hb))

theorem not_or_iff (a b : Prop) : ¬ (a ∨ b) ↔ ¬ a ∧ ¬ b :=
iff.intro not_and_not_of_not_or not_or_of_not_and_not
end logical_equivalences

meta def normalize_hyp (lemmas : simp_lemmas) (hyp : expr) : tactic unit :=
do try (simp_hyp lemmas [] hyp)

meta def normalize_hyps : tactic unit :=
do hyps ← local_context,
lemmas ← list.mmap mk_const [``iff_iff_implies_and_implies,
``implies_iff_not_or, ``not_and_iff, ``not_or_iff, ``not_not_iff,
``not_true_iff, ``not_false_iff],
lemmas2 ← simp_lemmas.append simp_lemmas.mk lemmas,
hyps.mmap' (normalize_hyp lemmas2)

meta def add_fact (prf : expr) : tactic unit :=
do nh ← get_unused_name `h none,
p ← infer_type prf,
assertv nh p prf,
return ()

meta def is_conj (e : expr) : tactic bool :=
do t ← infer_type e,
return (is_app_of t `and)

meta def add_conjuncts : expr → tactic unit | e :=
do e1 ← mk_app `and.left [e],
monad.cond (is_conj e1) (add_conjuncts e1) (add_fact e1),
e2 ← mk_app `and.right [e],
monad.cond (is_conj e2) (add_conjuncts e2) (add_fact e2)

meta def split_conjs_at (h : expr) : tactic unit :=
do monad.cond (is_conj h)
(add_conjuncts h >> clear h)
skip

meta def split_conjs : tactic unit :=
do l ← local_context,
l.mmap' split_conjs_at

meta def deny_conclusion : tactic unit :=
do refine ```(classical.by_contradiction _),
nh ← get_unused_name `h none,
intro nh,
return ()

meta def find_disj : tactic (option expr) :=
do l ← local_context,
(first $ l.map
(λ h, do t ← infer_type h,
cond (is_app_of t `or)
(return (option.some h)) failed)) <|>
return none

meta def prop_prover_aux : ℕ → tactic unit
| 0 := fail "prop prover max depth reached"
| (nat.succ n) :=
do split_conjs,
contradiction <|>
do (option.some h) ← find_disj |
fail "prop_prover failed: unprovable goal",
cases h,
prop_prover_aux n,
prop_prover_aux n

meta def prop_prover : tactic unit :=
do deny_conclusion,
normalize_hyps,
prop_prover_aux 30

section
variables a b c d : Prop
example (h1 : a ∧ b) (h2 : b ∧ ¬ c) : a ∨ c :=
by prop_prover
example (h1 : a ∧ b) (h2 : b ∧ ¬ c) : a ∧ ¬ c :=
by prop_prover
-- not valid
-- example (h1 : a ∧ b) (h2 : b ∧ ¬ c) : a ∧ c :=
-- by prop_prover
example : ((a → b) → a) → a :=
by prop_prover
example : (a → b) ∧ (b → c) → a → c :=
by prop_prover
example (α : Type) (x y z w : α) :
x = y ∧ (x = y → z = w) → z = w :=
by prop_prover
example : ¬ (a ↔ ¬ a) :=
by prop_prover
end


import tactic

@[derive decidable_eq] def free_cat : Type := ℕ

namespace free_cat

@[derive decidable_eq] inductive hom : free_cat → free_cat → Type
| id : Π (A : free_cat), hom A A
| cons : Π {A B C : free_cat}, ℕ → hom B C → hom A C

def comp : Π {A B C : free_cat} (f : hom A B) (g : hom B C), hom A C
| _ _ _ (hom.id _) g := g
| _ _ _ (hom.cons n f) g := hom.cons n (comp f g)

@[simp] lemma id_comp {A B : free_cat} (f : hom A B) : comp (hom.id A) f = f := rfl

@[simp] lemma comp_id {A B : free_cat} (f : hom A B) : comp f (hom.id B) = f :=
by { induction f; simp [*, comp] }

lemma comp_assoc {A B C D : free_cat} (f : hom A B) (g : hom B C) (h : hom C D) :
  comp f (comp g h) = comp (comp f g) h :=
by induction f; simp [comp, *]

end free_cat


/-
  Presheaf (of types).
  https://stacks.math.columbia.edu/tag/006D
-/

import topology.basic
import topology.opens
import order.bounds

universes u v

-- Definition of a presheaf.

open topological_space lattice

structure presheaf (α : Type u) [semilattice_inf α] :=
(F     : α → Type v)
(res   : ∀ (U V) (HVU : V ≤ U), F U → F V)
(Hid   : ∀ (U), res U U (le_refl U) = id)
(Hcomp : ∀ (U V W) (HWV : W ≤ V) (HVU : V ≤ U),
  res U W (le_trans HWV HVU) = res V W HWV ∘ res U V HVU)

namespace presheaf

variables {α : Type u} [semilattice_inf α]

instance : has_coe_to_fun (presheaf α) :=
{ F := λ _, α → Type v,
  coe := presheaf.F }

-- Simplification lemmas for Hid and Hcomp.

@[simp] lemma Hcomp' (F : presheaf α) :
∀ (U V W) (HWV : W ≤ V) (HVU : V ≤ U) (s : F U),
  (F.res U W (le_trans HWV HVU)) s =
  (F.res V W HWV) ((F.res U V HVU) s) :=
λ U V W HWV HVU s, by rw F.Hcomp U V W HWV HVU

@[simp] lemma Hid' (F : presheaf α) :
∀ (U) (s : F U),
  (F.res U U (le_refl U)) s = s :=
λ U s, by rw F.Hid U; simp

def total (F : presheaf α) : Type (max u v) := Σ U, F.F U

instance (F : presheaf α) (U : α) : has_coe_t (F U) F.total :=
⟨sigma.mk _⟩

@[elab_as_eliminator]
theorem total.cases_on (F : presheaf α) {C : F.total → Sort*}
  (x) (H : ∀ U (x : F U), C x) : C x :=
by cases x; apply H

def res' (F : presheaf α) (V : α) : F.total → F.total
| ⟨U, x⟩ := F.res U (U ⊓ V) inf_le_left x

theorem res'_def (F : presheaf α) {U V} (x : F U) :
  F.res' V x = F.res U (U ⊓ V) inf_le_left x := rfl

theorem res'_val (F : presheaf α) {U V} (x : F U) (h : V ≤ U) :
  F.res' V x = F.res U V h x :=
have ∀ W (H : W ≤ U), W = V →
  (F.res U W H x : F.total) = F.res U V h x :=
  by rintro _ _ rfl; refl,
this _ _ (inf_of_le_right h)

theorem res'_eq_inf (F : presheaf α) {U V} (x : F U) :
  F.res' V x = F.res' (U ⊓ V) x :=
by rw [res'_def, ← res'_val _ _ inf_le_left]

theorem res'_eq_left (F : presheaf α) {U V W} (x : F U) (H : U ⊓ V = U ⊓ W) :
  F.res' V x = F.res' W x :=
by rw [res'_eq_inf, H, ← res'_eq_inf]

@[simp] theorem res'_id {F : presheaf α} {U} (x : F U) : F.res' U x = x :=
by rw [res'_val _ _ (le_refl U), F.Hid]; refl

@[simp] theorem res'_comp {F : presheaf α} {U V} (x : F.total) :
  F.res' U (F.res' V x) = F.res' (U ⊓ V) x :=
total.cases_on F x $ λ W x,
by rw [res'_def, res'_def, ← F.Hcomp', ← res'_val, res'_eq_left];
   simp [inf_left_comm, inf_comm]

-- Morphism of presheaves.

-- Kenny wants morphisms on the subsheaves
structure morphism (F G : presheaf α) :=
(map      : ∀ (U), F U → G U)
(commutes : ∀ (U V) (HVU : V ≤ U),
  (G.res U V HVU) ∘ (map U) = (map V) ∘ (F.res U V HVU))

infix ` ⟶ `:80 := morphism

section morphism

def comp {F G H : presheaf α} (fg : F ⟶ G) (gh : G ⟶ H) : F ⟶ H :=
{ map := λ U, gh.map U ∘ fg.map U,
  commutes := λ U V HVU,
    begin
      rw [←function.comp.assoc, gh.commutes U V HVU], symmetry,
      rw [function.comp.assoc, ←fg.commutes U V HVU]
    end }

infix ` ⊚ `:80 := comp

def id (F : presheaf α) : F ⟶ F :=
{ map := λ U, id,
  commutes := λ U V HVU, by simp, }

structure iso (F G : presheaf α) :=
(mor : F ⟶ G)
(inv : G ⟶ F)
(mor_inv_id : mor ⊚ inv = id F)
(inv_mor_id : inv ⊚ mor = id G)

infix ` ≅ `:80 := iso

end morphism

section sheaf_condition

-- Sheaf condition.

def locality (F : presheaf α) :=
∀ {{U S}}, is_lub S U → ∀ {{s t : F U}},
  (∀ V ∈ S, F.res' V s = F.res' V t) → s = t

def gluing (F : presheaf α) :=
∀ {{U : α}} {{S}}, is_lub S U → ∀ (s : Π V : S, F V),
  (∀ V W : S, res' F (V ⊓ W) (s V) = res' F (V ⊓ W) (s W)) →
  ∃ x : F U, ∀ V:S, F.res' V x = s V

def is_sheaf (F : presheaf α) :=
locality F ∧ gluing F

end sheaf_condition

end presheaf

structure semilattice_inf_hom
  (α β : Type*) [semilattice_inf α] [semilattice_inf β] :=
(to_fun : α → β)
(mono : monotone to_fun)
(map_inf' : ∀ a b, to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

namespace semilattice_inf_hom

infixr ` →⊓ `:25 := semilattice_inf_hom

instance {α β : Type*} [semilattice_inf α] [semilattice_inf β] :
  has_coe_to_fun (α →⊓ β) := ⟨_, to_fun⟩

@[simp] theorem map_inf {α β : Type*} [semilattice_inf α] [semilattice_inf β]
  (f : α →⊓ β) (a b : α) : f (a ⊓ b) = f a ⊓ f b := map_inf' _ _ _

def id {α : Type*} [semilattice_inf α] : α →⊓ α :=
⟨id, monotone_id, λ _ _, rfl⟩

def comp {α β γ : Type*} [semilattice_inf α] [semilattice_inf β] [semilattice_inf γ]
  (g : β →⊓ γ) (f : α →⊓ β) : α →⊓ γ :=
⟨g ∘ f, monotone.comp g.mono f.mono, λ a b, by simp⟩

end semilattice_inf_hom

structure semilattice_inf_lub_emb
  (α β : Type*) [semilattice_inf α] [semilattice_inf β] extends α →⊓ β :=
(inj : function.injective to_fun)
(map_lub : ∀ {{S a}}, is_lub S a → is_lub (to_fun '' S) (to_fun a))

namespace semilattice_inf_lub_emb

infixr ` ↪⊓⨆ `:25 := semilattice_inf_lub_emb

instance {α β : Type*} [semilattice_inf α] [semilattice_inf β] :
  has_coe (α ↪⊓⨆ β) (α →⊓ β) := ⟨to_semilattice_inf_hom⟩

@[simp] theorem map_inf {α β : Type*} [semilattice_inf α] [semilattice_inf β]
  (f : α ↪⊓⨆ β) (a b : α) : f (a ⊓ b) = f a ⊓ f b := f.map_inf' _ _

def id {α : Type*} [semilattice_inf α] : α ↪⊓⨆ α :=
⟨semilattice_inf_hom.id, function.injective_id,
  λ S a h, by simp [semilattice_inf_hom.id, h]⟩

def comp {α β γ : Type*} [semilattice_inf α] [semilattice_inf β] [semilattice_inf γ]
  (g : β ↪⊓⨆ γ) (f : α ↪⊓⨆ β) : α ↪⊓⨆ γ :=
⟨(g : β →⊓ γ).comp f, function.injective_comp g.inj f.inj,
  λ S a h, by have := g.map_lub (f.map_lub h); rwa [set.image_image] at this⟩

end semilattice_inf_lub_emb

namespace presheaf

variables {α : Type*} {β : Type*} [semilattice_inf α] [semilattice_inf β]

def comap (f : α →⊓ β) (F : presheaf β) : presheaf α :=
{ F := λ a, F (f a),
  res := λ a b h, F.res _ _ (f.mono h),
  Hid := λ a, F.Hid _,
  Hcomp := λ a b c bc ab, F.Hcomp _ _ _ _ _ }

theorem comap_res (f : α →⊓ β) (F : presheaf β) (a b h) :
  (F.comap f).res a b h = F.res _ _ (f.mono h) := rfl

instance (f : α →⊓ β) (F : presheaf β) : has_coe (F.comap f).total F.total :=
⟨λ x, ⟨_, x.2⟩⟩

theorem comap_coe_inj (f : α →⊓ β) (F : presheaf β) (h : function.injective f) :
  function.injective (coe : (F.comap f).total → F.total)
| ⟨a, x⟩ ⟨b, y⟩ e := by cases h (congr_arg sigma.fst e:_); cases e; refl

@[simp] theorem coe_total_coe
  (f : α →⊓ β) (F : presheaf β) (U : α) (x : (F.comap f) U) :
  ((x : (F.comap f).total) : F.total) = @coe (F (f U)) _ _ x := rfl

theorem comap_res' (f : α →⊓ β) (F : presheaf β) (U : α) (x : (F.comap f).total) :
  ↑((F.comap f).res' U x) = F.res' (f U) x :=
total.cases_on (F.comap f) x $ λ W x,
by rw [res'_def, coe_total_coe, coe_total_coe, comap_res, ← res'_val, f.map_inf,
       ← res'_eq_inf]

end presheaf

structure sheaf (α : Type u) [semilattice_inf α] extends presheaf α :=
(locality : to_presheaf.locality)
(gluing   : to_presheaf.gluing)

structure sheaf_of_rings (α : Type u) [semilattice_inf α] extends sheaf α :=
[ring' : ∀ U, ring (F U)]
[ring_hom : ∀ U V h, is_ring_hom (res U V h)]

namespace sheaf

variables {α : Type*} {β : Type*} [semilattice_inf α] [semilattice_inf β]

def total (F : sheaf α) := F.to_presheaf.total

def res' (F : sheaf α) : α → F.total → F.total := F.to_presheaf.res'

instance : has_coe_to_fun (sheaf α) :=
{ F := λ _, α → Type v,
  coe := λ F, F.to_presheaf }

instance (F : sheaf α) (U : α) : has_coe_t (F U) F.total :=
⟨sigma.mk _⟩

def comap (f : α ↪⊓⨆ β) (F : sheaf β) : sheaf α :=
{ locality := λ a S lub (s t : F (f a)) H, F.locality (f.map_lub lub) begin
    rintro _ ⟨b, hb, rfl⟩,
    let G := F.to_presheaf.comap (f : α →⊓ β),
    have : G.res' b (@coe (G a) _ _ s) =
           G.res' b (@coe (G a) _ _ t) := H b hb,
    have H1 := F.to_presheaf.comap_res' (f : α →⊓ β) b _,
    rw [this, F.to_presheaf.comap_res' (f : α →⊓ β) b] at H1,
    simp at H1, exact H1.symm
  end,
  gluing := λ a S lub (g : ∀ U : S, F (f U)), begin
    let G := F.to_presheaf.comap (f : α →⊓ β),
    change ∀_: ∀ V W : S, G.res' (V ⊓ W) (@coe (G V) _ _ (g V)) =
                          G.res' (V ⊓ W) (@coe (G W) _ _ (g W)),
      ∃ U : F (f a), ∀ V : S, G.res' V (@coe (G a) _ _ U) = @coe (G V) _ _ (g V),
    choose k hk using show ∀ V : f '' S, ∃ U : S, (V:β) = f U,
    by rintro ⟨_, U, hU, rfl⟩; exact ⟨⟨U, hU⟩, rfl⟩,
    let g' : ∀ V : f '' S, F (V:β) := λ V, by rw hk V; exact g (k V),
    have g'eq : ∀ U (hU : U ∈ S), (g' ⟨f U, U, hU, rfl⟩ : F.total) = g ⟨U, hU⟩,
    { intros,
      suffices : ∀ U' (h' : U' = k ⟨f U, _⟩),
        (by rw h'; exact g (k ⟨f U, U, hU, rfl⟩) : F (f U')) = g U',
      { congr, exact this ⟨U, hU⟩ (subtype.eq (f.inj (hk ⟨f U, _⟩))) },
      rintro _ rfl, refl },
    intro h,
    cases F.gluing (f.map_lub lub) g' _ with z hz,
    { use z, rintro ⟨U, hU⟩,
      apply presheaf.comap_coe_inj _ _ f.inj,
      rw [presheaf.comap_res'],
      exact (hz ⟨_, U, hU, rfl⟩).trans (g'eq _ _) },
    { rintro ⟨_, V, hV, rfl⟩ ⟨_, W, hW, rfl⟩,
      have := congr_arg coe (h ⟨V, hV⟩ ⟨W, hW⟩),
      rw [presheaf.comap_res', presheaf.comap_res'] at this,
      simp at this, rwa [← g'eq, ← g'eq] at this }
  end,
  ..F.to_presheaf.comap f.to_semilattice_inf_hom }

end sheaf


import data.set.basic
import data.fintype.basic
import automata.nfa

open set

namespace epsnfa

structure epsNFA (S : Type) (Q : Type) [fintype Q] [decidable_eq Q] :=
    (start : Q) -- starting state
    (term : Q) -- terminal state (only one!)
    (next : Q → S → set Q) -- transitions
    (eps : Q → set Q) -- eps-transitions

variables {S Q : Type} [fintype S] [fintype Q] [decidable_eq Q] {enfa : epsNFA S Q}

inductive go (enfa : epsNFA S Q) : Q → list S → Q → Prop
| finish {q} :
    go q [] q
| step {hd tl q n f} (h : n ∈ enfa.next q hd) :
    go n tl f →
    go q (hd::tl) f
| eps {tl q n f} (h : n ∈ enfa.eps q):
    go n tl f → go q tl f

@[simp] def epsnfa_accepts_word (enfa : epsNFA S Q) (w : list S) := go enfa enfa.start w enfa.term

def eps_reach (enfa : epsNFA S Q) (q : Q) (r : Q) := go enfa q [] r

@[simp] def lang_of_epsnfa (enfa : epsNFA S Q) := {w | epsnfa_accepts_word enfa w}

@[simp] def mem_of_epsnfa_iff {w} : w ∈ lang_of_epsnfa enfa ↔ go enfa enfa.start w enfa.term := by refl

def epsnfa_lang (lang : set (list S)) : Prop :=
    ∃ {Q : Type} [fintype Q] [decidable_eq Q], by exactI ∃ (enfa : epsNFA S Q), lang_of_epsnfa enfa = lang

lemma epsnfa_go_trans {a b c : Q} {left right : list S}:
    go enfa a left b → go enfa b right c → go enfa a (left ++ right) c :=
begin
    rintro hab hfc,
    induction hab with q  head tail q n f h prev ih  tail q n f h prev ih,
    { exact hfc },
    { apply go.step h (ih hfc) },
    { apply go.eps h (ih hfc) },
end

lemma epsnfa_go_exists_cons {a d : Q}
    {head : S} {tail concat : list S} (clr : list.cons head tail = concat):
    go enfa a concat d → (∃ {b c : Q}, eps_reach enfa a b ∧ c ∈ enfa.next b head ∧ go enfa c tail d) :=
begin
    intros go_ac,
    induction go_ac with q  head tail q n f h prev ih  tail q n f h prev ih, {
        contradiction,
    }, {
        rw list.cons.inj_eq at clr,
        rcases clr with ⟨rfl, rfl⟩,
        use [q, n, go.finish, h, prev],
    }, {
        rcases ih clr with ⟨b, c, eps_ab, next_bc, tail_cd⟩,
        use [b, c, go.eps h eps_ab, next_bc, tail_cd],
    }
end

lemma epsnfa_go_exists_trans {a c : Q}
    {left right concat : list S} (clr : left ++ right = concat):
    go enfa a concat c → (∃ {b : Q}, go enfa a left b ∧ go enfa b right c) :=
begin
    intros go_ac,
    induction left with head tail ih generalizing a concat, {
        subst clr,
        use [a, go.finish, go_ac],
    }, {
        subst clr,
        rcases epsnfa_go_exists_cons rfl go_ac with ⟨b, c', eps_ab, next_bc', tail_cd⟩,
        specialize @ih c' (tail ++ right) rfl,
        rcases ih tail_cd with ⟨real_b, go_real_b_tail, go_real_b_right⟩,

        use [real_b],
        use [epsnfa_go_trans eps_ab (go.step next_bc' go_real_b_tail)],
        use [go_real_b_right],
    }
end

section epsnfa_to_nfa

def epsnfa_to_nfa (enfa : epsNFA S Q) : nfa.NFA S Q := {
    start := enfa.start,
    term := {x | eps_reach enfa x enfa.term},
    next := λ q c, {y | ∃ x, eps_reach enfa q x ∧ y ∈ enfa.next x c}
}

lemma epsnfa_to_nfa_accepts_iff_accepts
    (en : epsNFA S Q) {n : nfa.NFA S Q} (w : list S) (st : Q)
    : n = epsnfa_to_nfa en → (go en st w en.term ↔ ∃ t : Q, nfa.go n st w t ∧ t ∈ n.term) :=
begin
    rintro rfl,
    split, {
        rintro en_go,
        induction w with head tail hyp generalizing st, {
            use [st, nfa.go.finish],
            dsimp [epsnfa_to_nfa],
            use en_go,
        }, {
            replace en_go := epsnfa_go_exists_cons rfl en_go,
            rcases en_go with ⟨b, c, eps_stb, next_bc, tail_cent⟩,
            specialize hyp c tail_cent,
            rcases hyp with ⟨t, t_go, t_term⟩,
            use t,
            split, {
                refine nfa.go.step _ t_go,
                dsimp [epsnfa_to_nfa],
                use [b, eps_stb, next_bc],
            },
            exact t_term,
        }
    }, {
        rintro ⟨n_t, n_go, n_term⟩,
        dsimp [epsnfa_to_nfa] at n_term,
        induction w with head tail hyp generalizing st, {
            cases n_go,
            use n_term,
        }, {
            rcases n_go with (_ | ⟨_, _, _, _, _, h_nxt, h_go⟩),
            specialize hyp n_go_n h_go,
            simp [epsnfa_to_nfa] at h_nxt,
            rcases h_nxt with ⟨x, x_go, x_nxt⟩,
            exact epsnfa_go_trans x_go (go.step x_nxt hyp),
        }
    }
end

theorem epsnfa_to_nfa_eq {L : set (list S)} : epsnfa_lang L → nfa.nfa_lang L :=
begin
    rintro ⟨Q, fQ, dQ, enf, rfl⟩,
    letI := fQ,
    existsi [Q, _, _, epsnfa_to_nfa enf],
    ext x,
    exact epsnfa_to_nfa_accepts_iff_accepts enf x enf.start rfl,
end

theorem epsnfa_to_dfa_eq {L : set (list S)} : epsnfa_lang L → DFA.dfa_lang L :=
    nfa.nfa_to_dfa_eq ∘ epsnfa_to_nfa_eq

end epsnfa_to_nfa

section nfa_to_epsnfa

open option

variables (n : nfa.NFA S Q) [decidable_pred n.term]

def nfa_to_epsnfa : epsNFA S (option Q) := {
    start := some n.start,
    term := none,
    next := λ q c, option.cases_on q ∅ (λ q', some '' n.next q' c),
    eps := λ q, option.cases_on q ∅ (λ q', if q' ∈ n.term then {none} else ∅),
}

lemma nfa_to_epsnfa_go_from_finish {en : epsNFA S (option Q)} {w : list S} {fi : option Q}
    : en = nfa_to_epsnfa n → (go en none w fi) → w = [] :=
begin
    rintro rfl (⟨⟩ | ⟨_, _, _, _, _, nxt⟩ | ⟨_, _, _, _, nxt⟩),
    { refl, },
    { simpa only using nxt },
    { simpa only [nfa_to_epsnfa, mem_empty_eq] using nxt, },
end

lemma nfa_to_epsnfa_accepts_iff_accepts
    {en : epsNFA S (option Q)} (w : list S) (st : Q)
    : en = nfa_to_epsnfa n → (go en (some st) w none ↔ ∃ t : Q, nfa.go n st w t ∧ t ∈ n.term) :=
begin
    rintro rfl,
    split, {
        intro go_enfa,
        generalize hst : some st = ust,
        generalize hfi : (none : option Q) = ufi,
        rw [hst, hfi] at go_enfa,
        induction go_enfa generalizing st, {
            subst hfi,
            injection hst,
        }, {
            substs hst hfi,
            cases go_enfa_n, {
                simpa [nfa_to_epsnfa] using go_enfa_h,
            }, {
                specialize go_enfa_ih rfl go_enfa_n rfl,
                rcases go_enfa_ih with ⟨t, t_go, t_term⟩,
                simp [nfa_to_epsnfa] at go_enfa_h,
                use [t, nfa.go.step go_enfa_h t_go, t_term],
            }
        }, {
            substs hst hfi,
            simp only [forall_prop_of_true] at go_enfa_ih,
            cases go_enfa_n, {
                simp [nfa_to_epsnfa] at go_enfa_h,
                split_ifs at go_enfa_h, {
                    suffices tail_nil : go_enfa_tl = [],
                    subst tail_nil,
                    use [st, nfa.go.finish, h],
                    refine nfa_to_epsnfa_go_from_finish n rfl _,
                    exact none,
                    assumption,
                }, {
                    simpa [nfa_to_epsnfa, h] using go_enfa_h,
                }
            }, {
                simp [nfa_to_epsnfa] at go_enfa_h,
                split_ifs at go_enfa_h,
                all_goals {simpa only [mem_empty_eq] using go_enfa_h},
            },
        }
    }, {
        rintro ⟨t, t_go, t_term⟩,
        induction t_go, {
            refine go.eps _ go.finish,
            simp only [nfa_to_epsnfa, dite_eq_ite],
            simp only [t_term, if_true, mem_singleton],
        }, {
            refine go.step _ (t_go_ih t_term),
            simpa [nfa_to_epsnfa],
        },
    }
end

theorem nfa_to_epsnfa_eq {L : set (list S)} : nfa.nfa_lang L → epsnfa_lang L :=
begin
    rintro ⟨Q, fQ, dQ, nfa, rfl⟩,
    letI := dQ,
    have tmp : decidable_pred nfa.term := by sorry,
    letI := tmp,
    refine ⟨option Q, _, _, nfa_to_epsnfa nfa, _⟩,
    ext x,
    exact nfa_to_epsnfa_accepts_iff_accepts nfa x nfa.start rfl,
end

theorem dfa_to_epsnfa_eq {L : set (list S)} : DFA.dfa_lang L → epsnfa_lang L :=
    nfa_to_epsnfa_eq ∘ nfa.dfa_to_nfa_eq

end nfa_to_epsnfa

end epsnfa