import category.basic
import heap.basic
import data.finmap
import tactic.omega
import tactic.linarith

namespace memory

variables value : Type

variables {value}

def maplet (x : ptr) (v : value) : heap value :=
finmap.singleton x v

def heap.mk (l : list (ptr × value)) : heap value :=
(l.map $ λ x : ptr × value, (⟨x.1,x.2⟩ : sigma $ λ _, value)).to_finmap

@[simp]
lemma heap.mk_nil : heap.mk [] = (∅ : heap value) := rfl

@[simp]
lemma heap.mk_cons (p v) (l : list (ptr × value)) : heap.mk ((p,v) :: l) = maplet p v ∪ heap.mk l := rfl

@[simp]
lemma mem_heap.mk (p) (l : list (ptr × value)) : p ∈ heap.mk l ↔ ∃ v, (p,v) ∈ l :=
iff.trans
  (finmap.mem_list_to_finmap _ _)
  (exists_congr $ λ v,
    by simp [list.mem_map]; split;
       [ { rintro ⟨a,b,h,⟨⟩,⟨⟩⟩, exact h },
         { intro h, refine ⟨_,_,h,rfl,rfl⟩ }])

def erase_all (p : ptr) (n : ℕ) (m : heap value) : heap value :=
(list.range n).foldl (λ m i, finmap.erase (p + i) m) m

@[simp] lemma erase_all_zero (p : ptr) (m : heap value) : erase_all p 0 m = m := rfl

lemma erase_all_succ (p : ptr) (n : ℕ) (m : heap value) : erase_all p n.succ m = finmap.erase (p+n) (erase_all p n m) :=
by simp [erase_all, list.foldl_eq_foldr' _ m (list.range _),list.range_concat]

lemma erase_all_one_add (p : ptr) (n : ℕ) (m : heap value) : erase_all p (1+n) m = finmap.erase (p+n) (erase_all p n m) :=
by rw nat.add_comm; apply erase_all_succ p _ m

lemma erase_all_succ' (p : ptr) (n : ℕ) (m : heap value) : erase_all p n.succ m = finmap.erase p (erase_all (p+1) n m) :=
by { simp only [erase_all,list.range_succ_eq_map],
     rw [list.foldl_eq_of_comm',list.foldl_map],
     congr, simp only [add_zero, nat.add_comm, add_left_comm],
     simp only [finmap.erase_erase, forall_3_true_iff, eq_self_iff_true] }

lemma erase_all_one_add' (p : ptr) (n : ℕ) (m : heap value) : erase_all p (1+n) m = finmap.erase p (erase_all (p+1) n m) :=
by rw nat.add_comm; apply erase_all_succ' p _ m

open list nat

lemma mem_erase_all (p p' : ptr) (m : heap value) : Π {n}, p ∈ erase_all p' n m ↔ ¬ p ∈ range' p' n ∧ p ∈ m
| 0 := by simp [erase_all_zero]
| (succ n) := by { simp only [erase_all_succ, mem_cons_iff, add_comm, mem_range', finmap.mem_erase, ne.def, add_left_comm, mem_erase_all, not_and_distrib],
                   repeat { rw ← and_assoc }, apply and_congr _ (iff.refl _),
                   clear mem_erase_all, dsimp [ptr] at p p', omega nat }

open finmap

@[simp]
lemma mem_maplet (p q : ptr) (v : value) : p ∈ maplet q v ↔ p = q :=
by simp only [maplet, not_mem_empty, finmap.mem_singleton, iff_self, or_false]

lemma disjoint_maplet (p) (v : value) (frame : heap value) : disjoint (maplet p v) frame ↔ ¬ p ∈ frame :=
begin
  split,
  { simp [disjoint.symm_iff], intros h h',
    specialize h _ h', simp only [maplet,finmap.mem_singleton] at h, exact h rfl },
  { intros h p' h', simp only [maplet,finmap.not_mem_empty,finmap.mem_singleton] at h',
    subst h', exact h }
end

lemma maplet_add (p : ptr) (v : value) (h : heap value) (hp : p ∉ h) :
  some (maplet p v) ⊗ some h = some (h.insert p v) :=
by rw ← union_eq_add_of_disjoint; [refl, { rw disjoint_maplet; exact hp }]

@[simp]
lemma heap.mem_mk (p : ptr) (vs : list (ptr × value)) : p ∈ heap.mk vs ↔ p ∈ vs.map prod.fst :=
by { simp only [heap.mk,mem_list_to_finmap,_root_.and_comm (_ ∈ vs),_root_.and_assoc,  list.mem_map,
                iff_self, exists_eq_left, exists_and_distrib_left, heq_iff_eq, list.map, prod.exists] }

instance : has_le (heap value) :=
{ le := λ x y, ∀ a b, x.lookup a = some b → y.lookup a = some b }

instance : preorder (heap value) :=
{ le_refl := λ h a b H, H,
  le_trans := λ h₀ h₁ h₂ H H' p _ HH, H' _ _ (H _ _ HH),
  .. memory.has_le
  }

lemma le_of_add_eq_some {h₀ h₁ : heap value} (h' : heap value) (H : some h₁ = some h₀ ⊗ some h') : h₀ ≤ h₁ :=
λ p v HH,
have HH' : _, from eq_union_of_eq_add H,
by rw [HH',lookup_union_left,HH]; apply mem_of_lookup_eq_some HH

lemma erase_all_union_mk_self (p : ptr) (vs : list value) (h : heap value) (H : heap.mk (vs.enum_from p) ≤ h) :
  erase_all p (length vs) h ∪ heap.mk (vs.enum_from p) = h :=
begin
  induction vs generalizing p; simp [length,enum_from,erase_all_one_add',union_assoc],
  rw [← union_assoc,maplet,erase_union_singleton,vs_ih],
  { transitivity'; [skip, exact H], dsimp [enum_from],
    intros p' v Hp, rw [lookup_union_right,Hp],
    simp [maplet], intro Hp', subst p',
    replace Hp := mem_of_lookup_eq_some Hp,
    simp at Hp, change ℕ at p, clear_except Hp,
    replace Hp := Hp.1, omega nat, },
  clear vs_ih, replace H : h.lookup p = some vs_hd,
  { apply H, simp [enum_from,maplet,lookup_singleton_eq] },
  generalize hq : p + 1 = q,
  have : p < q,
  { rw ← hq, apply lt_add_one },
  clear hq, induction vs_tl with v vs,
  { simp [H] },
  { simp [length,erase_all_one_add], rw [lookup_erase_ne,vs_tl_ih],
    apply ne_of_lt, linarith }
end

lemma mem_of_mem_of_le {h₀ h₁ : heap value} (H : h₀ ≤ h₁) : ∀ x ∈ h₀, x ∈ h₁ :=
by intros p; rw [mem_iff,mem_iff]; apply exists_imp_exists; exact H p

lemma insert_maplet  (p) (v v' : value) : finmap.insert p v (maplet p v') = maplet p v :=
finmap.insert_singleton_eq

lemma disjoint_mono {ha hb ha' hb' : heap value} (H₀ : ha' ≤ ha) (H₁ : hb' ≤ hb) :
  disjoint ha hb → disjoint ha' hb' :=
begin
  intros H₂ x H₃ H₄,
  replace H₃ := mem_of_mem_of_le H₀ _ H₃,
  replace H₄ := mem_of_mem_of_le H₁ _ H₄,
  exact H₂ _ H₃ H₄,
end

lemma add_inj {h₀ h₁ : option (heap value)} (hh : option (heap value)) (hh₀ hh₁ : heap value)
  (H₀ : some hh₀ = h₀ ⊗ hh) (H₁ : some hh₁ = h₁ ⊗ hh) (H₂ : h₀ ⊗ hh = h₁ ⊗ hh) :
  h₀ = h₁ :=
begin
  cases h₀; [skip, cases h₁], cases H₀, cases H₁, cases hh, cases H₀,
  rw [← union_eq_add_of_disjoint (disjoint_of_add _ H₀),← union_eq_add_of_disjoint (disjoint_of_add _ H₁),option.some_inj,finmap.union_cancel] at H₂, rw H₂,
  all_goals { apply disjoint_of_add, assumption },
end

end memory

namespace separation
open memory

structure tptr (val : Type) (α : Type*) :=
(get : ptr)

variables {val : Type} {α : Type*} {β : Type*}
include val
local notation `tptr` := tptr val

instance : decidable_linear_order (tptr α) :=
decidable_linear_order.lift tptr.get (λ ⟨_,_,x⟩ ⟨_,_,y⟩, congr_arg _) (by apply_instance)

def tptr.recast (β) (p : tptr α) : tptr β :=
{ get := p.get }

def tptr.add (p : tptr α) (n : ℕ) : tptr α :=
{ get := p.get + n }

infixl ` +. `:65 := tptr.add

@[simp, separation_logic]
lemma offset_zero (p : tptr α) : p +. 0 = p := by cases p; refl

@[simp, separation_logic]
lemma offset_offset (p : tptr α) (n m : ℕ) : p +. n +. m = p +. (n + m) :=
congr_arg _ (nat.add_assoc _ _ _)

lemma gt_offset_of_gt {α} (p : tptr α) {n : ℕ} (h : n > 0) : p +. n > p :=
by cases p; dsimp [(+.)]; apply lt_add_of_pos_right _ h

lemma le_offset (p : tptr α) {n : ℕ} : p ≤ p +. n :=
by cases p; dsimp [(+.)]; apply nat.le_add_right

lemma offset_ne (p : tptr α) {n : ℕ} (h : n > 0) : p +. n ≠ p :=
ne_of_gt (gt_offset_of_gt _ h)

@[simp, separation_logic]
lemma recast_offset (p : tptr α) (n : ℕ) : (p +. n).recast β = (p.recast β +. n) := rfl

lemma recast_le_iff_le_recast (p : tptr α) (q : tptr β) :
  p.recast β ≤ q ↔ p ≤ q.recast α :=
by cases p; cases q; refl

@[simp]
lemma tptr.mk_offset (p : ptr) (n : ℕ) : tptr.mk val α p +. n = tptr.mk val α (p + n) := rfl

open list

lemma some_mk_enum_from_cons (p : ptr) (x : val) (xs : list val) :
  some (heap.mk (enum_from p (x :: xs))) = some (maplet p x) ⊗ some (heap.mk $ xs.enum_from $ p + 1) :=
begin
  rw ← union_eq_add_of_disjoint,
  { simp [enum_from] },
  intro p', simp, intros h h', subst p',
  cases nat.not_succ_le_self _ h'
end

end separation


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.ring.basic
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u_1 u v

namespace Mathlib

/-- Add an extra element `1` to a type -/
def with_one (α : Type u_1) := Option α

namespace with_one

protected instance Mathlib.with_zero.monad : Monad with_zero := option.monad

protected instance has_one {α : Type u} : HasOne (with_one α) := { one := none }

protected instance Mathlib.with_zero.inhabited {α : Type u} : Inhabited (with_zero α) :=
  { default := 0 }

protected instance Mathlib.with_zero.nontrivial {α : Type u} [Nonempty α] :
    nontrivial (with_zero α) :=
  option.nontrivial

protected instance Mathlib.with_zero.has_coe_t {α : Type u} : has_coe_t α (with_zero α) :=
  has_coe_t.mk some

theorem Mathlib.with_zero.some_eq_coe {α : Type u} {a : α} : some a = ↑a := rfl

@[simp] theorem coe_ne_one {α : Type u} {a : α} : ↑a ≠ 1 := option.some_ne_none a

@[simp] theorem one_ne_coe {α : Type u} {a : α} : 1 ≠ ↑a := ne.symm coe_ne_one

theorem Mathlib.with_zero.ne_zero_iff_exists {α : Type u} {x : with_zero α} :
    x ≠ 0 ↔ ∃ (a : α), ↑a = x :=
  option.ne_none_iff_exists

-- `to_additive` fails to generate some meta info around eqn lemmas, so `lift` doesn't work

-- unless we explicitly define this instance

protected instance can_lift {α : Type u} : can_lift (with_one α) α :=
  can_lift.mk coe (fun (a : with_one α) => a ≠ 1) sorry

@[simp] theorem Mathlib.with_zero.coe_inj {α : Type u} {a : α} {b : α} : ↑a = ↑b ↔ a = b :=
  option.some_inj

protected theorem Mathlib.with_zero.cases_on {α : Type u} {P : with_zero α → Prop}
    (x : with_zero α) : P 0 → (∀ (a : α), P ↑a) → P x :=
  option.cases_on

protected instance Mathlib.with_zero.has_add {α : Type u} [Add α] : Add (with_zero α) :=
  { add := option.lift_or_get Add.add }

protected instance monoid {α : Type u} [semigroup α] : monoid (with_one α) :=
  monoid.mk Mul.mul sorry 1 sorry sorry

protected instance Mathlib.with_zero.add_comm_monoid {α : Type u} [add_comm_semigroup α] :
    add_comm_monoid (with_zero α) :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

/-- `coe` as a bundled morphism -/
def coe_mul_hom {α : Type u} [Mul α] : mul_hom α (with_one α) := mul_hom.mk coe sorry

/-- Lift a semigroup homomorphism `f` to a bundled monoid homorphism. -/
def Mathlib.with_zero.lift {α : Type u} [add_semigroup α] {β : Type v} [add_monoid β] :
    add_hom α β ≃ (with_zero α →+ β) :=
  equiv.mk
    (fun (f : add_hom α β) =>
      add_monoid_hom.mk (fun (x : with_zero α) => option.cases_on x 0 ⇑f) sorry sorry)
    (fun (F : with_zero α →+ β) => add_hom.comp (add_monoid_hom.to_add_hom F) with_zero.coe_add_hom)
    sorry sorry

@[simp] theorem Mathlib.with_zero.lift_coe {α : Type u} [add_semigroup α] {β : Type v}
    [add_monoid β] (f : add_hom α β) (x : α) : coe_fn (coe_fn with_zero.lift f) ↑x = coe_fn f x :=
  rfl

@[simp] theorem lift_one {α : Type u} [semigroup α] {β : Type v} [monoid β] (f : mul_hom α β) :
    coe_fn (coe_fn lift f) 1 = 1 :=
  rfl

theorem Mathlib.with_zero.lift_unique {α : Type u} [add_semigroup α] {β : Type v} [add_monoid β]
    (f : with_zero α →+ β) :
    f = coe_fn with_zero.lift (add_hom.comp (add_monoid_hom.to_add_hom f) with_zero.coe_add_hom) :=
  Eq.symm (equiv.apply_symm_apply with_zero.lift f)

/-- Given a multiplicative map from `α → β` returns a monoid homomorphism
  from `with_one α` to `with_one β` -/
def Mathlib.with_zero.map {α : Type u} {β : Type v} [add_semigroup α] [add_semigroup β]
    (f : add_hom α β) : with_zero α →+ with_zero β :=
  coe_fn with_zero.lift (add_hom.comp with_zero.coe_add_hom f)

@[simp] theorem Mathlib.with_zero.coe_add {α : Type u} [Add α] (a : α) (b : α) :
    ↑(a + b) = ↑a + ↑b :=
  rfl

end with_one

namespace with_zero

-- `to_additive` fails to generate some meta info around eqn lemmas, so `lift` doesn't work

-- unless we explicitly define this instance

protected instance can_lift {α : Type u} : can_lift (with_zero α) α :=
  can_lift.mk coe (fun (a : with_zero α) => a ≠ 0) sorry

protected instance has_one {α : Type u} [one : HasOne α] : HasOne (with_zero α) := { one := ↑1 }

@[simp] theorem coe_one {α : Type u} [HasOne α] : ↑1 = 1 := rfl

protected instance mul_zero_class {α : Type u} [Mul α] : mul_zero_class (with_zero α) :=
  mul_zero_class.mk
    (fun (o₁ o₂ : with_zero α) =>
      option.bind o₁ fun (a : α) => option.map (fun (b : α) => a * b) o₂)
    0 sorry sorry

@[simp] theorem coe_mul {α : Type u} [Mul α] {a : α} {b : α} : ↑(a * b) = ↑a * ↑b := rfl

@[simp] theorem zero_mul {α : Type u} [Mul α] (a : with_zero α) : 0 * a = 0 := rfl

@[simp] theorem mul_zero {α : Type u} [Mul α] (a : with_zero α) : a * 0 = 0 :=
  option.cases_on a (Eq.refl (none * 0)) fun (a : α) => Eq.refl (some a * 0)

protected instance semigroup {α : Type u} [semigroup α] : semigroup (with_zero α) :=
  semigroup.mk mul_zero_class.mul sorry

protected instance comm_semigroup {α : Type u} [comm_semigroup α] : comm_semigroup (with_zero α) :=
  comm_semigroup.mk semigroup.mul sorry sorry

protected instance monoid_with_zero {α : Type u} [monoid α] : monoid_with_zero (with_zero α) :=
  monoid_with_zero.mk mul_zero_class.mul sorry 1 sorry sorry mul_zero_class.zero sorry sorry

protected instance comm_monoid_with_zero {α : Type u} [comm_monoid α] :
    comm_monoid_with_zero (with_zero α) :=
  comm_monoid_with_zero.mk monoid_with_zero.mul sorry monoid_with_zero.one sorry sorry sorry
    monoid_with_zero.zero sorry sorry

/-- Given an inverse operation on `α` there is an inverse operation
  on `with_zero α` sending `0` to `0`-/
def inv {α : Type u} [has_inv α] (x : with_zero α) : with_zero α :=
  do
    let a ← x
    return (a⁻¹)

protected instance has_inv {α : Type u} [has_inv α] : has_inv (with_zero α) := has_inv.mk inv

@[simp] theorem coe_inv {α : Type u} [has_inv α] (a : α) : ↑(a⁻¹) = (↑a⁻¹) := rfl

@[simp] theorem inv_zero {α : Type u} [has_inv α] : 0⁻¹ = 0 := rfl

@[simp] theorem inv_one {α : Type u} [group α] : 1⁻¹ = 1 := sorry

/-- if `G` is a group then `with_zero G` is a group with zero. -/
protected instance group_with_zero {α : Type u} [group α] : group_with_zero (with_zero α) :=
  group_with_zero.mk monoid_with_zero.mul sorry monoid_with_zero.one sorry sorry
    monoid_with_zero.zero sorry sorry has_inv.inv
    (div_inv_monoid.div._default monoid_with_zero.mul sorry monoid_with_zero.one sorry sorry
      has_inv.inv)
    sorry sorry sorry

theorem div_coe {α : Type u} [group α] (a : α) (b : α) : ↑a / ↑b = ↑(a * (b⁻¹)) := rfl

protected instance comm_group_with_zero {α : Type u} [comm_group α] :
    comm_group_with_zero (with_zero α) :=
  comm_group_with_zero.mk group_with_zero.mul sorry group_with_zero.one sorry sorry sorry
    group_with_zero.zero sorry sorry group_with_zero.inv group_with_zero.div sorry sorry sorry

protected instance semiring {α : Type u} [semiring α] : semiring (with_zero α) :=
  semiring.mk add_comm_monoid.add sorry add_comm_monoid.zero sorry sorry sorry mul_zero_class.mul
    sorry monoid_with_zero.one sorry sorry sorry sorry sorry sorry

end Mathlib


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.multilinear.basic
import linear_algebra.tensor_product

/-!
# Constructions relating multilinear maps and tensor products.
-/

namespace multilinear_map

section dom_coprod

open_locale tensor_product

variables {R ι₁ ι₂ ι₃ ι₄ : Type*}
variables [comm_semiring R]
variables {N₁ : Type*} [add_comm_monoid N₁] [module R N₁]
variables {N₂ : Type*} [add_comm_monoid N₂] [module R N₂]
variables {N : Type*} [add_comm_monoid N] [module R N]

/-- Given two multilinear maps `(ι₁ → N) → N₁` and `(ι₂ → N) → N₂`, this produces the map
`(ι₁ ⊕ ι₂ → N) → N₁ ⊗ N₂` by taking the coproduct of the domain and the tensor product
of the codomain.

This can be thought of as combining `equiv.sum_arrow_equiv_prod_arrow.symm` with
`tensor_product.map`, noting that the two operations can't be separated as the intermediate result
is not a `multilinear_map`.

While this can be generalized to work for dependent `Π i : ι₁, N'₁ i` instead of `ι₁ → N`, doing so
introduces `sum.elim N'₁ N'₂` types in the result which are difficult to work with and not defeq
to the simple case defined here. See [this zulip thread](
https://leanprover.zulipchat.com/#narrow/stream/217875-Is-there.20code.20for.20X.3F/topic/Instances.20on.20.60sum.2Eelim.20A.20B.20i.60/near/218484619).
-/
@[simps apply]
def dom_coprod
  (a : multilinear_map R (λ _ : ι₁, N) N₁) (b : multilinear_map R (λ _ : ι₂, N) N₂) :
  multilinear_map R (λ _ : ι₁ ⊕ ι₂, N) (N₁ ⊗[R] N₂) :=
{ to_fun := λ v, a (λ i, v (sum.inl i)) ⊗ₜ b (λ i, v (sum.inr i)),
  map_add' := λ _ v i p q, by
  { resetI,
    letI := (@sum.inl_injective ι₁ ι₂).decidable_eq,
    letI := (@sum.inr_injective ι₁ ι₂).decidable_eq,
    cases i; simp [tensor_product.add_tmul, tensor_product.tmul_add] },
  map_smul' := λ _ v i c p, by
  { resetI,
    letI := (@sum.inl_injective ι₁ ι₂).decidable_eq,
    letI := (@sum.inr_injective ι₁ ι₂).decidable_eq,
    cases i; simp [tensor_product.smul_tmul', tensor_product.tmul_smul] } }

/-- A more bundled version of `multilinear_map.dom_coprod` that maps
`((ι₁ → N) → N₁) ⊗ ((ι₂ → N) → N₂)` to `(ι₁ ⊕ ι₂ → N) → N₁ ⊗ N₂`. -/
def dom_coprod' :
  multilinear_map R (λ _ : ι₁, N) N₁ ⊗[R] multilinear_map R (λ _ : ι₂, N) N₂ →ₗ[R]
  multilinear_map R (λ _ : ι₁ ⊕ ι₂, N) (N₁ ⊗[R] N₂) :=
tensor_product.lift $ linear_map.mk₂ R (dom_coprod)
  (λ m₁ m₂ n, by { ext, simp only [dom_coprod_apply, tensor_product.add_tmul, add_apply] })
  (λ c m n,   by { ext, simp only [dom_coprod_apply, tensor_product.smul_tmul', smul_apply] })
  (λ m n₁ n₂, by { ext, simp only [dom_coprod_apply, tensor_product.tmul_add, add_apply] })
  (λ c m n,   by { ext, simp only [dom_coprod_apply, tensor_product.tmul_smul, smul_apply] })

@[simp]
lemma dom_coprod'_apply
  (a : multilinear_map R (λ _ : ι₁, N) N₁) (b : multilinear_map R (λ _ : ι₂, N) N₂) :
  dom_coprod' (a ⊗ₜ[R] b) = dom_coprod a b := rfl

/-- When passed an `equiv.sum_congr`, `multilinear_map.dom_dom_congr` distributes over
`multilinear_map.dom_coprod`. -/
lemma dom_coprod_dom_dom_congr_sum_congr
  (a : multilinear_map R (λ _ : ι₁, N) N₁) (b : multilinear_map R (λ _ : ι₂, N) N₂)
  (σa : ι₁ ≃ ι₃) (σb : ι₂ ≃ ι₄) :
    (a.dom_coprod b).dom_dom_congr (σa.sum_congr σb) =
      (a.dom_dom_congr σa).dom_coprod (b.dom_dom_congr σb) := rfl

end dom_coprod

end multilinear_map


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

! This file was ported from Lean 3 source module data.list.permutation
! leanprover-community/mathlib commit be24ec5de6701447e5df5ca75400ffee19d65659
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.List.Join

/-!
# Permutations of a list

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

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

## Order of the permutations

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

### `list.permutations`

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

### `list.permutations'`

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

## TODO

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

open Nat

variable {α β : Type _}

namespace List

/- warning: list.permutations_aux2_fst -> List.permutationsAux2_fst is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (t : α) (ts : List.{u1} α) (r : List.{u2} β) (ys : List.{u1} α) (f : (List.{u1} α) -> β), Eq.{succ u1} (List.{u1} α) (Prod.fst.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r ys f)) (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) ys ts)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (t : α) (ts : List.{u2} α) (r : List.{u1} β) (ys : List.{u2} α) (f : (List.{u2} α) -> β), Eq.{succ u2} (List.{u2} α) (Prod.fst.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts r ys f)) (HAppend.hAppend.{u2, u2, u2} (List.{u2} α) (List.{u2} α) (List.{u2} α) (instHAppend.{u2} (List.{u2} α) (List.instAppendList.{u2} α)) ys ts)
Case conversion may be inaccurate. Consider using '#align list.permutations_aux2_fst List.permutationsAux2_fstₓ'. -/
theorem permutationsAux2_fst (t : α) (ts : List α) (r : List β) :
    ∀ (ys : List α) (f : List α → β), (permutationsAux2 t ts r ys f).1 = ys ++ ts
  | [], f => rfl
  | y :: ys, f =>
    match (motive :=
      ∀ o : List α × List β, o.1 = ys ++ ts → (permutationsAux2._match1 t y f o).1 = y :: ys ++ ts)
      _, permutations_aux2_fst ys _ with
    | ⟨_, zs⟩, rfl => rfl
#align list.permutations_aux2_fst List.permutationsAux2_fst

/- warning: list.permutations_aux2_snd_nil -> List.permutationsAux2_snd_nil is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (t : α) (ts : List.{u1} α) (r : List.{u2} β) (f : (List.{u1} α) -> β), Eq.{succ u2} (List.{u2} β) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r (List.nil.{u1} α) f)) r
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (t : α) (ts : List.{u2} α) (r : List.{u1} β) (f : (List.{u2} α) -> β), Eq.{succ u1} (List.{u1} β) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts r (List.nil.{u2} α) f)) r
Case conversion may be inaccurate. Consider using '#align list.permutations_aux2_snd_nil List.permutationsAux2_snd_nilₓ'. -/
@[simp]
theorem permutationsAux2_snd_nil (t : α) (ts : List α) (r : List β) (f : List α → β) :
    (permutationsAux2 t ts r [] f).2 = r :=
  rfl
#align list.permutations_aux2_snd_nil List.permutationsAux2_snd_nil

/- warning: list.permutations_aux2_snd_cons -> List.permutationsAux2_snd_cons is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (t : α) (ts : List.{u1} α) (r : List.{u2} β) (y : α) (ys : List.{u1} α) (f : (List.{u1} α) -> β), Eq.{succ u2} (List.{u2} β) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r (List.cons.{u1} α y ys) f)) (List.cons.{u2} β (f (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) (List.cons.{u1} α t (List.cons.{u1} α y ys)) ts)) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r ys (fun (x : List.{u1} α) => f (List.cons.{u1} α y x)))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (t : α) (ts : List.{u2} α) (r : List.{u1} β) (y : α) (ys : List.{u2} α) (f : (List.{u2} α) -> β), Eq.{succ u1} (List.{u1} β) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts r (List.cons.{u2} α y ys) f)) (List.cons.{u1} β (f (HAppend.hAppend.{u2, u2, u2} (List.{u2} α) (List.{u2} α) (List.{u2} α) (instHAppend.{u2} (List.{u2} α) (List.instAppendList.{u2} α)) (List.cons.{u2} α t (List.cons.{u2} α y ys)) ts)) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts r ys (fun (x : List.{u2} α) => f (List.cons.{u2} α y x)))))
Case conversion may be inaccurate. Consider using '#align list.permutations_aux2_snd_cons List.permutationsAux2_snd_consₓ'. -/
@[simp]
theorem permutationsAux2_snd_cons (t : α) (ts : List α) (r : List β) (y : α) (ys : List α)
    (f : List α → β) :
    (permutationsAux2 t ts r (y :: ys) f).2 =
      f (t :: y :: ys ++ ts) :: (permutationsAux2 t ts r ys fun x : List α => f (y :: x)).2 :=
  match (motive :=
    ∀ o : List α × List β,
      o.1 = ys ++ ts → (permutationsAux2._match1 t y f o).2 = f (t :: y :: ys ++ ts) :: o.2)
    _, permutationsAux2_fst t ts r _ _ with
  | ⟨_, zs⟩, rfl => rfl
#align list.permutations_aux2_snd_cons List.permutationsAux2_snd_cons

/- warning: list.permutations_aux2_append -> List.permutationsAux2_append is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (t : α) (ts : List.{u1} α) (r : List.{u2} β) (ys : List.{u1} α) (f : (List.{u1} α) -> β), Eq.{succ u2} (List.{u2} β) (Append.append.{u2} (List.{u2} β) (List.hasAppend.{u2} β) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts (List.nil.{u2} β) ys f)) r) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r ys f))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (t : α) (ts : List.{u2} α) (r : List.{u1} β) (ys : List.{u2} α) (f : (List.{u2} α) -> β), Eq.{succ u1} (List.{u1} β) (HAppend.hAppend.{u1, u1, u1} (List.{u1} β) (List.{u1} β) (List.{u1} β) (instHAppend.{u1} (List.{u1} β) (List.instAppendList.{u1} β)) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts (List.nil.{u1} β) ys f)) r) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts r ys f))
Case conversion may be inaccurate. Consider using '#align list.permutations_aux2_append List.permutationsAux2_appendₓ'. -/
/-- The `r` argument to `permutations_aux2` is the same as appending. -/
theorem permutationsAux2_append (t : α) (ts : List α) (r : List β) (ys : List α) (f : List α → β) :
    (permutationsAux2 t ts nil ys f).2 ++ r = (permutationsAux2 t ts r ys f).2 := by
  induction ys generalizing f <;> simp [*]
#align list.permutations_aux2_append List.permutationsAux2_append

/- warning: list.permutations_aux2_comp_append -> List.permutationsAux2_comp_append is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {t : α} {ts : List.{u1} α} {ys : List.{u1} α} {r : List.{u2} β} (f : (List.{u1} α) -> β), Eq.{succ u2} (List.{u2} β) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t (List.nil.{u1} α) r ys (fun (x : List.{u1} α) => f (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) x ts)))) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r ys f))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {t : α} {ts : List.{u2} α} {ys : List.{u2} α} {r : List.{u1} β} (f : (List.{u2} α) -> β), Eq.{succ u1} (List.{u1} β) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t (List.nil.{u2} α) r ys (fun (x : List.{u2} α) => f (HAppend.hAppend.{u2, u2, u2} (List.{u2} α) (List.{u2} α) (List.{u2} α) (instHAppend.{u2} (List.{u2} α) (List.instAppendList.{u2} α)) x ts)))) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts r ys f))
Case conversion may be inaccurate. Consider using '#align list.permutations_aux2_comp_append List.permutationsAux2_comp_appendₓ'. -/
/-- The `ts` argument to `permutations_aux2` can be folded into the `f` argument. -/
theorem permutationsAux2_comp_append {t : α} {ts ys : List α} {r : List β} (f : List α → β) :
    (permutationsAux2 t [] r ys fun x => f (x ++ ts)).2 = (permutationsAux2 t ts r ys f).2 :=
  by
  induction ys generalizing f
  · simp
  · simp [ys_ih fun xs => f (ys_hd :: xs)]
#align list.permutations_aux2_comp_append List.permutationsAux2_comp_append

/- warning: list.map_permutations_aux2' -> List.map_permutationsAux2' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {α' : Type.{u3}} {β' : Type.{u4}} (g : α -> α') (g' : β -> β') (t : α) (ts : List.{u1} α) (ys : List.{u1} α) (r : List.{u2} β) (f : (List.{u1} α) -> β) (f' : (List.{u3} α') -> β'), (forall (a : List.{u1} α), Eq.{succ u4} β' (g' (f a)) (f' (List.map.{u1, u3} α α' g a))) -> (Eq.{succ u4} (List.{u4} β') (List.map.{u2, u4} β β' g' (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r ys f))) (Prod.snd.{u3, u4} (List.{u3} α') (List.{u4} β') (List.permutationsAux2.{u3, u4} α' β' (g t) (List.map.{u1, u3} α α' g ts) (List.map.{u2, u4} β β' g' r) (List.map.{u1, u3} α α' g ys) f')))
but is expected to have type
  forall {α : Type.{u4}} {β : Type.{u3}} {α' : Type.{u2}} {β' : Type.{u1}} (g : α -> α') (g' : β -> β') (t : α) (ts : List.{u4} α) (ys : List.{u4} α) (r : List.{u3} β) (f : (List.{u4} α) -> β) (f' : (List.{u2} α') -> β'), (forall (a : List.{u4} α), Eq.{succ u1} β' (g' (f a)) (f' (List.map.{u4, u2} α α' g a))) -> (Eq.{succ u1} (List.{u1} β') (List.map.{u3, u1} β β' g' (Prod.snd.{u4, u3} (List.{u4} α) (List.{u3} β) (List.permutationsAux2.{u4, u3} α β t ts r ys f))) (Prod.snd.{u2, u1} (List.{u2} α') (List.{u1} β') (List.permutationsAux2.{u2, u1} α' β' (g t) (List.map.{u4, u2} α α' g ts) (List.map.{u3, u1} β β' g' r) (List.map.{u4, u2} α α' g ys) f')))
Case conversion may be inaccurate. Consider using '#align list.map_permutations_aux2' List.map_permutationsAux2'ₓ'. -/
theorem map_permutationsAux2' {α β α' β'} (g : α → α') (g' : β → β') (t : α) (ts ys : List α)
    (r : List β) (f : List α → β) (f' : List α' → β') (H : ∀ a, g' (f a) = f' (map g a)) :
    map g' (permutationsAux2 t ts r ys f).2 =
      (permutationsAux2 (g t) (map g ts) (map g' r) (map g ys) f').2 :=
  by
  induction ys generalizing f f' <;> simp [*]
  apply ys_ih; simp [H]
#align list.map_permutations_aux2' List.map_permutationsAux2'

/- warning: list.map_permutations_aux2 -> List.map_permutationsAux2 is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (t : α) (ts : List.{u1} α) (ys : List.{u1} α) (f : (List.{u1} α) -> β), Eq.{succ u2} (List.{u2} β) (List.map.{u1, u2} (List.{u1} α) β f (Prod.snd.{u1, u1} (List.{u1} α) (List.{u1} (List.{u1} α)) (List.permutationsAux2.{u1, u1} α (List.{u1} α) t ts (List.nil.{u1} (List.{u1} α)) ys (id.{succ u1} (List.{u1} α))))) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts (List.nil.{u2} β) ys f))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (t : α) (ts : List.{u2} α) (ys : List.{u2} α) (f : (List.{u2} α) -> β), Eq.{succ u1} (List.{u1} β) (List.map.{u2, u1} (List.{u2} α) β f (Prod.snd.{u2, u2} (List.{u2} α) (List.{u2} (List.{u2} α)) (List.permutationsAux2.{u2, u2} α (List.{u2} α) t ts (List.nil.{u2} (List.{u2} α)) ys (id.{succ u2} (List.{u2} α))))) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts (List.nil.{u1} β) ys f))
Case conversion may be inaccurate. Consider using '#align list.map_permutations_aux2 List.map_permutationsAux2ₓ'. -/
/-- The `f` argument to `permutations_aux2` when `r = []` can be eliminated. -/
theorem map_permutationsAux2 (t : α) (ts : List α) (ys : List α) (f : List α → β) :
    (permutationsAux2 t ts [] ys id).2.map f = (permutationsAux2 t ts [] ys f).2 :=
  by
  rw [map_permutations_aux2' id, map_id, map_id]; rfl
  simp
#align list.map_permutations_aux2 List.map_permutationsAux2

/- warning: list.permutations_aux2_snd_eq -> List.permutationsAux2_snd_eq is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (t : α) (ts : List.{u1} α) (r : List.{u2} β) (ys : List.{u1} α) (f : (List.{u1} α) -> β), Eq.{succ u2} (List.{u2} β) (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts r ys f)) (Append.append.{u2} (List.{u2} β) (List.hasAppend.{u2} β) (List.map.{u1, u2} (List.{u1} α) β (fun (x : List.{u1} α) => f (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) x ts)) (Prod.snd.{u1, u1} (List.{u1} α) (List.{u1} (List.{u1} α)) (List.permutationsAux2.{u1, u1} α (List.{u1} α) t (List.nil.{u1} α) (List.nil.{u1} (List.{u1} α)) ys (id.{succ u1} (List.{u1} α))))) r)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (t : α) (ts : List.{u2} α) (r : List.{u1} β) (ys : List.{u2} α) (f : (List.{u2} α) -> β), Eq.{succ u1} (List.{u1} β) (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts r ys f)) (HAppend.hAppend.{u1, u1, u1} (List.{u1} β) (List.{u1} β) (List.{u1} β) (instHAppend.{u1} (List.{u1} β) (List.instAppendList.{u1} β)) (List.map.{u2, u1} (List.{u2} α) β (fun (x : List.{u2} α) => f (HAppend.hAppend.{u2, u2, u2} (List.{u2} α) (List.{u2} α) (List.{u2} α) (instHAppend.{u2} (List.{u2} α) (List.instAppendList.{u2} α)) x ts)) (Prod.snd.{u2, u2} (List.{u2} α) (List.{u2} (List.{u2} α)) (List.permutationsAux2.{u2, u2} α (List.{u2} α) t (List.nil.{u2} α) (List.nil.{u2} (List.{u2} α)) ys (id.{succ u2} (List.{u2} α))))) r)
Case conversion may be inaccurate. Consider using '#align list.permutations_aux2_snd_eq List.permutationsAux2_snd_eqₓ'. -/
/-- An expository lemma to show how all of `ts`, `r`, and `f` can be eliminated from
`permutations_aux2`.

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

/- warning: list.map_map_permutations_aux2 -> List.map_map_permutationsAux2 is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {α' : Type.{u2}} (g : α -> α') (t : α) (ts : List.{u1} α) (ys : List.{u1} α), Eq.{succ u2} (List.{u2} (List.{u2} α')) (List.map.{u1, u2} (List.{u1} α) (List.{u2} α') (List.map.{u1, u2} α α' g) (Prod.snd.{u1, u1} (List.{u1} α) (List.{u1} (List.{u1} α)) (List.permutationsAux2.{u1, u1} α (List.{u1} α) t ts (List.nil.{u1} (List.{u1} α)) ys (id.{succ u1} (List.{u1} α))))) (Prod.snd.{u2, u2} (List.{u2} α') (List.{u2} (List.{u2} α')) (List.permutationsAux2.{u2, u2} α' (List.{u2} α') (g t) (List.map.{u1, u2} α α' g ts) (List.nil.{u2} (List.{u2} α')) (List.map.{u1, u2} α α' g ys) (id.{succ u2} (List.{u2} α'))))
but is expected to have type
  forall {α : Type.{u2}} {α' : Type.{u1}} (g : α -> α') (t : α) (ts : List.{u2} α) (ys : List.{u2} α), Eq.{succ u1} (List.{u1} (List.{u1} α')) (List.map.{u2, u1} (List.{u2} α) (List.{u1} α') (List.map.{u2, u1} α α' g) (Prod.snd.{u2, u2} (List.{u2} α) (List.{u2} (List.{u2} α)) (List.permutationsAux2.{u2, u2} α (List.{u2} α) t ts (List.nil.{u2} (List.{u2} α)) ys (id.{succ u2} (List.{u2} α))))) (Prod.snd.{u1, u1} (List.{u1} α') (List.{u1} (List.{u1} α')) (List.permutationsAux2.{u1, u1} α' (List.{u1} α') (g t) (List.map.{u2, u1} α α' g ts) (List.nil.{u1} (List.{u1} α')) (List.map.{u2, u1} α α' g ys) (id.{succ u1} (List.{u1} α'))))
Case conversion may be inaccurate. Consider using '#align list.map_map_permutations_aux2 List.map_map_permutationsAux2ₓ'. -/
theorem map_map_permutationsAux2 {α α'} (g : α → α') (t : α) (ts ys : List α) :
    map (map g) (permutationsAux2 t ts [] ys id).2 =
      (permutationsAux2 (g t) (map g ts) [] (map g ys) id).2 :=
  map_permutationsAux2' _ _ _ _ _ _ _ _ fun _ => rfl
#align list.map_map_permutations_aux2 List.map_map_permutationsAux2

/- warning: list.map_map_permutations'_aux -> List.map_map_permutations'Aux is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β) (t : α) (ts : List.{u1} α), Eq.{succ u2} (List.{u2} (List.{u2} β)) (List.map.{u1, u2} (List.{u1} α) (List.{u2} β) (List.map.{u1, u2} α β f) (List.permutations'Aux.{u1} α t ts)) (List.permutations'Aux.{u2} β (f t) (List.map.{u1, u2} α β f ts))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (f : α -> β) (t : α) (ts : List.{u2} α), Eq.{succ u1} (List.{u1} (List.{u1} β)) (List.map.{u2, u1} (List.{u2} α) (List.{u1} β) (List.map.{u2, u1} α β f) (List.permutations'Aux.{u2} α t ts)) (List.permutations'Aux.{u1} β (f t) (List.map.{u2, u1} α β f ts))
Case conversion may be inaccurate. Consider using '#align list.map_map_permutations'_aux List.map_map_permutations'Auxₓ'. -/
theorem map_map_permutations'Aux (f : α → β) (t : α) (ts : List α) :
    map (map f) (permutations'Aux t ts) = permutations'Aux (f t) (map f ts) := by
  induction' ts with a ts ih <;> [rfl,
    · simp [← ih]
      rfl]
#align list.map_map_permutations'_aux List.map_map_permutations'Aux

#print List.permutations'Aux_eq_permutationsAux2 /-
theorem permutations'Aux_eq_permutationsAux2 (t : α) (ts : List α) :
    permutations'Aux t ts = (permutationsAux2 t [] [ts ++ [t]] ts id).2 :=
  by
  induction' ts with a ts ih; · rfl
  simp [permutations'_aux, permutations_aux2_snd_cons, ih]
  simp (config := { singlePass := true }) only [← permutations_aux2_append]
  simp [map_permutations_aux2]
#align list.permutations'_aux_eq_permutations_aux2 List.permutations'Aux_eq_permutationsAux2
-/

#print List.mem_permutationsAux2 /-
theorem mem_permutationsAux2 {t : α} {ts : List α} {ys : List α} {l l' : List α} :
    l' ∈ (permutationsAux2 t ts [] ys (append l)).2 ↔
      ∃ l₁ l₂, l₂ ≠ [] ∧ ys = l₁ ++ l₂ ∧ l' = l ++ l₁ ++ t :: l₂ ++ ts :=
  by
  induction' ys with y ys ih generalizing l
  · simp (config := { contextual := true })
  rw [permutations_aux2_snd_cons,
    show (fun x : List α => l ++ y :: x) = append (l ++ [y]) by funext <;> simp, mem_cons_iff, ih]
  constructor
  · rintro (rfl | ⟨l₁, l₂, l0, rfl, rfl⟩)
    · exact ⟨[], y :: ys, by simp⟩
    · exact ⟨y :: l₁, l₂, l0, by simp⟩
  · rintro ⟨_ | ⟨y', l₁⟩, l₂, l0, ye, rfl⟩
    · simp [ye]
    · simp only [cons_append] at ye
      rcases ye with ⟨rfl, rfl⟩
      exact Or.inr ⟨l₁, l₂, l0, by simp⟩
#align list.mem_permutations_aux2 List.mem_permutationsAux2
-/

#print List.mem_permutationsAux2' /-
theorem mem_permutationsAux2' {t : α} {ts : List α} {ys : List α} {l : List α} :
    l ∈ (permutationsAux2 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 <;> rfl] <;> apply mem_permutations_aux2
#align list.mem_permutations_aux2' List.mem_permutationsAux2'
-/

/- warning: list.length_permutations_aux2 -> List.length_permutationsAux2 is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (t : α) (ts : List.{u1} α) (ys : List.{u1} α) (f : (List.{u1} α) -> β), Eq.{1} Nat (List.length.{u2} β (Prod.snd.{u1, u2} (List.{u1} α) (List.{u2} β) (List.permutationsAux2.{u1, u2} α β t ts (List.nil.{u2} β) ys f))) (List.length.{u1} α ys)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (t : α) (ts : List.{u2} α) (ys : List.{u2} α) (f : (List.{u2} α) -> β), Eq.{1} Nat (List.length.{u1} β (Prod.snd.{u2, u1} (List.{u2} α) (List.{u1} β) (List.permutationsAux2.{u2, u1} α β t ts (List.nil.{u1} β) ys f))) (List.length.{u2} α ys)
Case conversion may be inaccurate. Consider using '#align list.length_permutations_aux2 List.length_permutationsAux2ₓ'. -/
theorem length_permutationsAux2 (t : α) (ts : List α) (ys : List α) (f : List α → β) :
    length (permutationsAux2 t ts [] ys f).2 = length ys := by
  induction ys generalizing f <;> simp [*]
#align list.length_permutations_aux2 List.length_permutationsAux2

#print List.foldr_permutationsAux2 /-
theorem foldr_permutationsAux2 (t : α) (ts : List α) (r L : List (List α)) :
    foldr (fun y r => (permutationsAux2 t ts r y id).2) r L =
      (L.bind fun y => (permutationsAux2 t ts [] y id).2) ++ r :=
  by
  induction' L with l L ih <;> [rfl,
    · simp [ih]
      rw [← permutations_aux2_append]]
#align list.foldr_permutations_aux2 List.foldr_permutationsAux2
-/

#print List.mem_foldr_permutationsAux2 /-
theorem mem_foldr_permutationsAux2 {t : α} {ts : List α} {r L : List (List α)} {l' : List α} :
    l' ∈ foldr (fun y r => (permutationsAux2 t ts r y id).2) r L ↔
      l' ∈ r ∨ ∃ l₁ l₂, l₁ ++ l₂ ∈ L ∧ l₂ ≠ [] ∧ l' = l₁ ++ t :: l₂ ++ ts :=
  by
  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) :=
    ⟨fun ⟨a, aL, l₁, l₂, l0, e, h⟩ => ⟨l₁, l₂, l0, e ▸ aL, h⟩, fun ⟨l₁, l₂, l0, aL, h⟩ =>
      ⟨_, aL, l₁, l₂, l0, rfl, h⟩⟩
  rw [foldr_permutations_aux2] <;>
    simp [mem_permutations_aux2', this, or_comm, or_left_comm, or_assoc, and_comm, and_left_comm,
      and_assoc]
#align list.mem_foldr_permutations_aux2 List.mem_foldr_permutationsAux2
-/

#print List.length_foldr_permutationsAux2 /-
theorem length_foldr_permutationsAux2 (t : α) (ts : List α) (r L : List (List α)) :
    length (foldr (fun y r => (permutationsAux2 t ts r y id).2) r L) =
      sum (map length L) + length r :=
  by simp [foldr_permutations_aux2, (· ∘ ·), length_permutations_aux2]
#align list.length_foldr_permutations_aux2 List.length_foldr_permutationsAux2
-/

#print List.length_foldr_permutationsAux2' /-
theorem length_foldr_permutationsAux2' (t : α) (ts : List α) (r L : List (List α)) (n)
    (H : ∀ l ∈ L, length l = n) :
    length (foldr (fun y r => (permutationsAux2 t ts r y id).2) r L) = n * length L + length r :=
  by
  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 fun 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]
#align list.length_foldr_permutations_aux2' List.length_foldr_permutationsAux2'
-/

#print List.permutationsAux_nil /-
@[simp]
theorem permutationsAux_nil (is : List α) : permutationsAux [] is = [] := by
  rw [permutations_aux, permutations_aux.rec]
#align list.permutations_aux_nil List.permutationsAux_nil
-/

#print List.permutationsAux_cons /-
@[simp]
theorem permutationsAux_cons (t : α) (ts is : List α) :
    permutationsAux (t :: ts) is =
      foldr (fun y r => (permutationsAux2 t ts r y id).2) (permutationsAux ts (t :: is))
        (permutations is) :=
  by rw [permutations_aux, permutations_aux.rec] <;> rfl
#align list.permutations_aux_cons List.permutationsAux_cons
-/

#print List.permutations_nil /-
@[simp]
theorem permutations_nil : permutations ([] : List α) = [[]] := by
  rw [permutations, permutations_aux_nil]
#align list.permutations_nil List.permutations_nil
-/

/- warning: list.map_permutations_aux -> List.map_permutationsAux is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β) (ts : List.{u1} α) (is : List.{u1} α), Eq.{succ u2} (List.{u2} (List.{u2} β)) (List.map.{u1, u2} (List.{u1} α) (List.{u2} β) (List.map.{u1, u2} α β f) (List.permutationsAux.{u1} α ts is)) (List.permutationsAux.{u2} β (List.map.{u1, u2} α β f ts) (List.map.{u1, u2} α β f is))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (f : α -> β) (ts : List.{u2} α) (is : List.{u2} α), Eq.{succ u1} (List.{u1} (List.{u1} β)) (List.map.{u2, u1} (List.{u2} α) (List.{u1} β) (List.map.{u2, u1} α β f) (List.permutationsAux.{u2} α ts is)) (List.permutationsAux.{u1} β (List.map.{u2, u1} α β f ts) (List.map.{u2, u1} α β f is))
Case conversion may be inaccurate. Consider using '#align list.map_permutations_aux List.map_permutationsAuxₓ'. -/
theorem map_permutationsAux (f : α → β) :
    ∀ ts is : List α, map (map f) (permutationsAux ts is) = permutationsAux (map f ts) (map f is) :=
  by
  refine' permutations_aux.rec (by simp) _
  introv IH1 IH2; rw [map] at IH2
  simp only [foldr_permutations_aux2, map_append, map, map_map_permutations_aux2, permutations,
    bind_map, IH1, append_assoc, permutations_aux_cons, cons_bind, ← IH2, map_bind]
#align list.map_permutations_aux List.map_permutationsAux

/- warning: list.map_permutations -> List.map_permutations is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β) (ts : List.{u1} α), Eq.{succ u2} (List.{u2} (List.{u2} β)) (List.map.{u1, u2} (List.{u1} α) (List.{u2} β) (List.map.{u1, u2} α β f) (List.permutations.{u1} α ts)) (List.permutations.{u2} β (List.map.{u1, u2} α β f ts))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (f : α -> β) (ts : List.{u2} α), Eq.{succ u1} (List.{u1} (List.{u1} β)) (List.map.{u2, u1} (List.{u2} α) (List.{u1} β) (List.map.{u2, u1} α β f) (List.permutations.{u2} α ts)) (List.permutations.{u1} β (List.map.{u2, u1} α β f ts))
Case conversion may be inaccurate. Consider using '#align list.map_permutations List.map_permutationsₓ'. -/
theorem map_permutations (f : α → β) (ts : List α) :
    map (map f) (permutations ts) = permutations (map f ts) := by
  rw [permutations, permutations, map, map_permutations_aux, map]
#align list.map_permutations List.map_permutations

/- warning: list.map_permutations' -> List.map_permutations' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β) (ts : List.{u1} α), Eq.{succ u2} (List.{u2} (List.{u2} β)) (List.map.{u1, u2} (List.{u1} α) (List.{u2} β) (List.map.{u1, u2} α β f) (List.permutations'.{u1} α ts)) (List.permutations'.{u2} β (List.map.{u1, u2} α β f ts))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (f : α -> β) (ts : List.{u2} α), Eq.{succ u1} (List.{u1} (List.{u1} β)) (List.map.{u2, u1} (List.{u2} α) (List.{u1} β) (List.map.{u2, u1} α β f) (List.permutations'.{u2} α ts)) (List.permutations'.{u1} β (List.map.{u2, u1} α β f ts))
Case conversion may be inaccurate. Consider using '#align list.map_permutations' List.map_permutations'ₓ'. -/
theorem map_permutations' (f : α → β) (ts : List α) :
    map (map f) (permutations' ts) = permutations' (map f ts) := by
  induction' ts with t ts ih <;> [rfl, simp [← ih, map_bind, ← map_map_permutations'_aux, bind_map]]
#align list.map_permutations' List.map_permutations'

#print List.permutationsAux_append /-
theorem permutationsAux_append (is is' ts : List α) :
    permutationsAux (is ++ ts) is' =
      (permutationsAux is is').map (· ++ ts) ++ permutationsAux ts (is.reverse ++ is') :=
  by
  induction' is with t is ih generalizing is'; · simp
  simp [foldr_permutations_aux2, ih, bind_map]
  congr 2; funext ys; rw [map_permutations_aux2]
  simp (config := { singlePass := true }) only [← permutations_aux2_comp_append]
  simp only [id, append_assoc]
#align list.permutations_aux_append List.permutationsAux_append
-/

#print List.permutations_append /-
theorem permutations_append (is ts : List α) :
    permutations (is ++ ts) = (permutations is).map (· ++ ts) ++ permutationsAux ts is.reverse := by
  simp [permutations, permutations_aux_append]
#align list.permutations_append List.permutations_append
-/

end List


import Structure.Generic.Axioms.Universes
import Structure.Generic.Axioms.AbstractFunctors

import mathlib4_experiments.Data.Equiv.Basic

set_option autoBoundImplicitLocal false
--set_option pp.universes true

class HasEmptyType (U : Universe) [h : HasExternalFunctors U U] where
(Empty                  : U)
(emptyIsEmpty           : ⌈Empty⌉ → False)
(emptyElimIsFun (α : U) : h.IsFun (λ e : Empty => @False.elim ⌈α⌉ (emptyIsEmpty e)))

namespace HasEmptyType

  variable {U : Universe}

  def emptyElimFun' [HasExternalFunctors U U] [h : HasEmptyType U] (α : U) : h.Empty ⟶' α :=
  BundledFunctor.mkFun (h.emptyElimIsFun α)
  def emptyElimFun  [HasInternalFunctors U]   [h : HasEmptyType U] (α : U) : h.Empty ⟶  α :=
  HasInternalFunctors.fromBundled (emptyElimFun' α)

  def Not [HasInternalFunctors U] [h : HasEmptyType U] (α : U) := α ⟶ h.Empty

end HasEmptyType

-- TODO: Can we prove `α ⟶ Not α ⟶ β`?

class HasClassicalLogic (U : Universe) [HasInternalFunctors U] [h : HasEmptyType U] where
(byContradiction (α : U) : HasEmptyType.Not (HasEmptyType.Not α) ⟶ α)

class HasUnitType (U : Universe) [h : HasExternalFunctors U U] where
(Unit                   : U)
(unit                   : Unit)
(unitIntroIsFun (α : U) : h.IsFun (λ a : α => unit))

namespace HasUnitType

  variable {U : Universe}

  def unitIntroFun' [HasExternalFunctors U U] [h : HasUnitType U] (α : U) : α ⟶' h.Unit :=
  BundledFunctor.mkFun (h.unitIntroIsFun α)
  def unitIntroFun  [HasInternalFunctors U]   [h : HasUnitType U] (α : U) : α ⟶  h.Unit :=
  HasInternalFunctors.fromBundled (unitIntroFun' α)

  @[simp] theorem unitIntroFun.eff [HasInternalFunctors U] [h : HasUnitType U] (α : U) (a : α) :
    (unitIntroFun α) a = h.unit :=
  by apply HasInternalFunctors.fromBundled.eff

end HasUnitType


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.algebra.tower

/-!

# The `restrict_scalars` type alias

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

See the documentation attached to the `restrict_scalars` definition for advice on how and when to
use this type alias. As described there, it is often a better choice to use the `is_scalar_tower`
typeclass instead.

## Main definitions

* `restrict_scalars R S M`: the `S`-module `M` viewed as an `R` module when `S` is an `R`-algebra.
  Note that by default we do *not* have a `module S (restrict_scalars R S M)` instance
  for the original action.
  This is available as a def `restrict_scalars.module_orig` if really needed.
* `restrict_scalars.add_equiv : restrict_scalars R S M ≃+ M`: the additive equivalence
  between the restricted and original space (in fact, they are definitionally equal,
  but sometimes it is helpful to avoid using this fact, to keep instances from leaking).
* `restrict_scalars.ring_equiv : restrict_scalars R S A ≃+* A`: the ring equivalence
   between the restricted and original space when the module is an algebra.

## See also

There are many similarly-named definitions elsewhere which do not refer to this type alias. These
refer to restricting the scalar type in a bundled type, such as from `A →ₗ[R] B` to `A →ₗ[S] B`:

* `linear_map.restrict_scalars`
* `linear_equiv.restrict_scalars`
* `alg_hom.restrict_scalars`
* `alg_equiv.restrict_scalars`
* `submodule.restrict_scalars`
* `subalgebra.restrict_scalars`
-/

variables (R S M A : Type*)

/-- If we put an `R`-algebra structure on a semiring `S`, we get a natural equivalence from the
category of `S`-modules to the category of representations of the algebra `S` (over `R`). The type
synonym `restrict_scalars` is essentially this equivalence.

Warning: use this type synonym judiciously! Consider an example where we want to construct an
`R`-linear map from `M` to `S`, given:
```lean
variables (R S M : Type*)
variables [comm_semiring R] [semiring S] [algebra R S] [add_comm_monoid M] [module S M]
```
With the assumptions above we can't directly state our map as we have no `module R M` structure, but
`restrict_scalars` permits it to be written as:
```lean
-- an `R`-module structure on `M` is provided by `restrict_scalars` which is compatible
example : restrict_scalars R S M →ₗ[R] S := sorry
```
However, it is usually better just to add this extra structure as an argument:
```lean
-- an `R`-module structure on `M` and proof of its compatibility is provided by the user
example [module R M] [is_scalar_tower R S M] : M →ₗ[R] S := sorry
```
The advantage of the second approach is that it defers the duty of providing the missing typeclasses
`[module R M] [is_scalar_tower R S M]`. If some concrete `M` naturally carries these (as is often
the case) then we have avoided `restrict_scalars` entirely. If not, we can pass
`restrict_scalars R S M` later on instead of `M`.

Note that this means we almost always want to state definitions and lemmas in the language of
`is_scalar_tower` rather than `restrict_scalars`.

An example of when one might want to use `restrict_scalars` would be if one has a vector space
over a field of characteristic zero and wishes to make use of the `ℚ`-algebra structure. -/
@[nolint unused_arguments]
def restrict_scalars (R S M : Type*) : Type* := M

instance [I : inhabited M] : inhabited (restrict_scalars R S M) := I

instance [I : add_comm_monoid M] : add_comm_monoid (restrict_scalars R S M) := I

instance [I : add_comm_group M] : add_comm_group (restrict_scalars R S M) := I

section module

section
variables [semiring S] [add_comm_monoid M]

/-- We temporarily install an action of the original ring on `restrict_sclars R S M`. -/
def restrict_scalars.module_orig [I : module S M] :
  module S (restrict_scalars R S M) := I

variables [comm_semiring R] [algebra R S]
section
local attribute [instance] restrict_scalars.module_orig

/--
When `M` is a module over a ring `S`, and `S` is an algebra over `R`, then `M` inherits a
module structure over `R`.

The preferred way of setting this up is `[module R M] [module S M] [is_scalar_tower R S M]`.
-/
instance [module S M] : module R (restrict_scalars R S M) :=
module.comp_hom M (algebra_map R S)

/--
This instance is only relevant when `restrict_scalars.module_orig` is available as an instance.
-/
instance [module S M] : is_scalar_tower R S (restrict_scalars R S M) :=
⟨λ r S M, by { rw [algebra.smul_def, mul_smul], refl }⟩

end

/--
When `M` is a right-module over a ring `S`, and `S` is an algebra over `R`, then `M` inherits a
right-module structure over `R`.
The preferred way of setting this up is
`[module Rᵐᵒᵖ M] [module Sᵐᵒᵖ M] [is_scalar_tower Rᵐᵒᵖ Sᵐᵒᵖ M]`.
-/
instance restrict_scalars.op_module [module Sᵐᵒᵖ M] : module Rᵐᵒᵖ (restrict_scalars R S M) :=
begin
  letI : module Sᵐᵒᵖ (restrict_scalars R S M) := ‹module Sᵐᵒᵖ M›,
  exact module.comp_hom M (algebra_map R S).op
end

instance restrict_scalars.is_central_scalar [module S M] [module Sᵐᵒᵖ M] [is_central_scalar S M] :
  is_central_scalar R (restrict_scalars R S M) :=
{ op_smul_eq_smul := λ r x, (op_smul_eq_smul (algebra_map R S r) (_ : M) : _)}

/--
The `R`-algebra homomorphism from the original coefficient algebra `S` to endomorphisms
of `restrict_scalars R S M`.
-/
def restrict_scalars.lsmul [module S M] : S →ₐ[R] module.End R (restrict_scalars R S M) :=
begin
  -- We use `restrict_scalars.module_orig` in the implementation,
  -- but not in the type.
  letI : module S (restrict_scalars R S M) := restrict_scalars.module_orig R S M,
  exact algebra.lsmul R (restrict_scalars R S M),
end

end

variables [add_comm_monoid M]

/-- `restrict_scalars.add_equiv` is the additive equivalence with the original module. -/
def restrict_scalars.add_equiv : restrict_scalars R S M ≃+ M :=
add_equiv.refl M

variables [comm_semiring R] [semiring S] [algebra R S] [module S M]

@[simp] lemma restrict_scalars.add_equiv_map_smul (c : R) (x : restrict_scalars R S M) :
  restrict_scalars.add_equiv R S M (c • x)
  = (algebra_map R S c) • restrict_scalars.add_equiv R S M x :=
rfl

lemma restrict_scalars.smul_def (c : R) (x : restrict_scalars R S M) :
  c • x = (restrict_scalars.add_equiv R S M).symm
    (algebra_map R S c • restrict_scalars.add_equiv R S M x) :=
rfl

lemma restrict_scalars.add_equiv_symm_map_algebra_map_smul (r : R) (x : M) :
  (restrict_scalars.add_equiv R S M).symm (algebra_map R S r • x)
  = r • (restrict_scalars.add_equiv R S M).symm x :=
rfl

lemma restrict_scalars.add_equiv_symm_map_smul_smul (r : R) (s : S) (x : M) :
  (restrict_scalars.add_equiv R S M).symm ((r • s) • x)
  = r • (restrict_scalars.add_equiv R S M ).symm (s • x) :=
by { rw [algebra.smul_def, mul_smul], refl, }

lemma restrict_scalars.lsmul_apply_apply (s : S) (x : restrict_scalars R S M) :
  restrict_scalars.lsmul R S M s x =
    (restrict_scalars.add_equiv R S M).symm (s • (restrict_scalars.add_equiv R S M x)) :=
rfl

end module

section algebra

instance [I : semiring A] : semiring (restrict_scalars R S A) := I
instance [I : ring A] : ring (restrict_scalars R S A) := I
instance [I : comm_semiring A] : comm_semiring (restrict_scalars R S A) := I
instance [I : comm_ring A] : comm_ring (restrict_scalars R S A) := I

variables [semiring A]

/-- Tautological ring isomorphism `restrict_scalars R S A ≃+* A`. -/
def restrict_scalars.ring_equiv : restrict_scalars R S A ≃+* A := ring_equiv.refl _

variables [comm_semiring S] [algebra S A] [comm_semiring R] [algebra R S]

@[simp] lemma restrict_scalars.ring_equiv_map_smul (r : R) (x : restrict_scalars R S A) :
  restrict_scalars.ring_equiv R S A (r • x)
  = (algebra_map R S r) • restrict_scalars.ring_equiv R S A x :=
rfl

/-- `R ⟶ S` induces `S-Alg ⥤ R-Alg` -/
instance : algebra R (restrict_scalars R S A) :=
{ smul := (•),
  commutes' := λ r x, algebra.commutes _ _,
  smul_def' := λ _ _, algebra.smul_def _ _,
  .. (algebra_map S A).comp (algebra_map R S) }

@[simp] lemma restrict_scalars.ring_equiv_algebra_map (r : R) :
  restrict_scalars.ring_equiv R S A (algebra_map R (restrict_scalars R S A) r) =
    algebra_map S A (algebra_map R S r) :=
rfl

end algebra


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/

import control.uliftable
import system.random
import system.random.basic

/-!
# `gen` Monad

This monad is used to formulate randomized computations with a parameter
to specify the desired size of the result.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `gen` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/

universes u v

namespace slim_check

/-- Monad to generate random examples to test properties with.
It has a `nat` parameter so that the caller can decide on the
size of the examples. -/
@[reducible, derive [monad, is_lawful_monad]]
def gen (α : Type u) := reader_t (ulift ℕ) rand α

variable (α : Type u)

local infix ` .. `:41 := set.Icc

/-- Execute a `gen` inside the `io` monad using `i` as the example
size and with a fresh random number generator. -/
def io.run_gen {α} (x : gen α) (i : ℕ) : io α :=
io.run_rand (x.run ⟨i⟩)

namespace gen

section rand

/-- Lift `random.random` to the `gen` monad. -/
def choose_any [random α] : gen α :=
⟨ λ _, rand.random α ⟩

variables {α} [preorder α]

/-- Lift `random.random_r` to the `gen` monad. -/
def choose [bounded_random α] (x y : α) (p : x ≤ y) : gen (x .. y) :=
⟨ λ _, rand.random_r x y p ⟩

end rand

open nat (hiding choose)

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat (x y : ℕ) (p : x ≤ y) : gen (x .. y) :=
choose x y p

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat' (x y : ℕ) (p : x < y) : gen (set.Ico x y) :=
have ∀ i, x < i → i ≤ y → i.pred < y,
  from λ i h₀ h₁,
     show i.pred.succ ≤ y,
     by rwa succ_pred_eq_of_pos; apply lt_of_le_of_lt (nat.zero_le _) h₀,
subtype.map pred (λ i (h : x+1 ≤ i ∧ i ≤ y), ⟨le_pred_of_lt h.1, this _ h.1 h.2⟩) <$> choose (x+1) y p

open nat

instance : uliftable gen.{u} gen.{v} :=
reader_t.uliftable' (equiv.ulift.trans equiv.ulift.symm)

instance : has_orelse gen.{u} :=
⟨ λ α x y, do
  b ← uliftable.up $ choose_any bool,
  if b.down then x else y ⟩

variable {α}

/-- Get access to the size parameter of the `gen` monad. For
reasons of universe polymorphism, it is specified in
continuation passing style. -/
def sized (cmd : ℕ → gen α) : gen α :=
⟨ λ ⟨sz⟩, reader_t.run (cmd sz) ⟨sz⟩ ⟩

/-- Apply a function to the size parameter. -/
def resize (f : ℕ → ℕ) (cmd : gen α) : gen α :=
⟨ λ ⟨sz⟩, reader_t.run cmd ⟨f sz⟩ ⟩

/-- Create `n` examples using `cmd`. -/
def vector_of : ∀ (n : ℕ) (cmd : gen α), gen (vector α n)
| 0 _ := return vector.nil
| (succ n) cmd := vector.cons <$> cmd <*> vector_of n cmd

/-- Create a list of examples using `cmd`. The size is controlled
by the size parameter of `gen`. -/
def list_of (cmd : gen α) : gen (list α) :=
sized $ λ sz, do
do ⟨ n ⟩ ← uliftable.up $ choose_nat 0 (sz + 1) dec_trivial,
   v ← vector_of n.val cmd,
   return v.to_list

open ulift

/-- Given a list of example generators, choose one to create an example. -/
def one_of (xs : list (gen α)) (pos : 0 < xs.length) : gen α := do
⟨⟨n, h, h'⟩⟩ ← uliftable.up $ choose_nat' 0 xs.length pos,
list.nth_le xs n h'

/-- Given a list of example generators, choose one to create an example. -/
def elements (xs : list α) (pos : 0 < xs.length) : gen α := do
⟨⟨n,h₀,h₁⟩⟩ ← uliftable.up $ choose_nat' 0 xs.length pos,
pure $ list.nth_le xs n h₁

/--
`freq_aux xs i _` takes a weighted list of generator and a number meant to select one of the generators.

If we consider `freq_aux [(1, gena), (3, genb), (5, genc)] 4 _`, we choose a generator by splitting
the interval 1-9 into 1-1, 2-4, 5-9 so that the width of each interval corresponds to one of the
number in the list of generators. Then, we check which interval 4 falls into: it selects `genb`.
-/
def freq_aux : Π (xs : list (ℕ+ × gen α)) i, i < (xs.map (subtype.val ∘ prod.fst)).sum → gen α
| [] i h := false.elim (not_lt_zero _ h)
| ((i, x) :: xs) j h :=
  if h' : j < i then x
  else freq_aux xs (j - i)
    (by rw nat.sub_lt_right_iff_lt_add; [simpa [list.sum_cons, add_comm] using h, exact le_of_not_gt h'])

/--
`freq [(1, gena), (3, genb), (5, genc)] _` will choose one of `gena`, `genb`, `genc` with
probabiities proportional to the number accompanying them. In this example, the sum of
those numbers is 9, `gena` will be chosen with probability ~1/9, `genb` with ~3/9 (i.e. 1/3)
and `genc` with probability 5/9.
-/
def freq (xs : list (ℕ+ × gen α)) (pos : 0 < xs.length) : gen α :=
let s := (xs.map (subtype.val ∘ prod.fst)).sum in
have ha : 1 ≤ s, from
  (le_trans pos $
    list.length_map (subtype.val ∘ prod.fst) xs ▸
      (list.length_le_sum_of_one_le _ (λ i, by { simp, intros, assumption }))),
have 0 ≤ s - 1, from nat.le_sub_right_of_add_le ha,
uliftable.adapt_up gen.{0} gen.{u} (choose_nat 0 (s-1) this) $ λ i,
freq_aux xs i.1 (by rcases i with ⟨i,h₀,h₁⟩; rwa nat.le_sub_right_iff_add_le at h₁; exact ha)

/-- Generate a random permutation of a given list. -/
def permutation_of {α : Type u} : Π xs : list α, gen (subtype $ list.perm xs)
| [] := pure ⟨[], list.perm.nil ⟩
| (x :: xs) := do
⟨xs',h⟩ ← permutation_of xs,
⟨⟨n,_,h'⟩⟩ ← uliftable.up $ choose_nat 0 xs'.length dec_trivial,
pure ⟨list.insert_nth n x xs',
  list.perm.trans (list.perm.cons _ h)
    (list.perm_insert_nth _ _ h').symm ⟩

end gen

end slim_check