import tactic.norm_fin

example : (5 : fin 7) = fin.succ (fin.succ 8) := by norm_num
example : (12 : fin 7) = 5 := by norm_num
example : (11 : fin 7) = 4 := by norm_num
example : (12 : fin 6) = 0 := by norm_num
example : (11 : fin 6) = 5 := by norm_num
example : (1 : fin 1) = 0 := by norm_num
example : fin.succ (4 : fin 6) = 12 := by norm_num
example : fin.succ (1 : fin (1 + 2)) = 2 := by norm_num
example : fin.succ (1 : fin (nat.succ (1 + 1))) = 2 := by norm_num
example : (1 : fin (nat.succ (1 + 1))) = 1 := by norm_num
example : (1 : fin (nat.succ (1 + 2))) = 1 := by norm_num
example : (3 : fin (nat.succ (1 + 1 + 1))) = 3 := by norm_num
example : (2 : fin (nat.succ (2 + 1 + 1))) = 7 := by norm_num
example : (2 : fin (nat.succ (nat.succ (2 + 1 + 1)))) = 8 := by norm_num
example : fin.cast_succ (1 : fin (nat.succ (1 + 1))) = 1 := by norm_num
example : (1 : fin (nat.succ (1 + 1))) = 1 := by norm_num
example : fin.succ (3 : fin 6) = 11 := by norm_num
example : fin.cast_succ (4 : fin 6) = 4 := by norm_num
example : fin.cast_succ (fin.cast_succ (4 : fin 5)) = 4 := by norm_num
example : fin.cast_succ (4 : fin 6) = 11 := by norm_num
example : fin.cast_succ (3 : fin 6) = 10 := by norm_num
example : fin.cast_succ (fin.cast_succ (3 : fin 5)) = 10 := by norm_num
example : ¬ fin.cast_succ (fin.cast_succ (3 : fin 5)) ≠ 10 := by norm_num

example : equiv.swap (0 : fin 3) 1 (fin.succ 1) = 2 :=
begin
  success_if_fail {guard_target ((equiv.swap (0 : fin 3) 1) 2 = 2)},
  norm_fin,
  guard_target (equiv.swap (0 : fin 3) 1 2 = 2),
  exact equiv.swap_apply_of_ne_of_ne dec_trivial dec_trivial
end
example : equiv.swap (0 : fin (1 + 2)) (1 : fin (nat.succ (1 + 1))) (fin.succ 1) = 2 :=
begin
  success_if_fail {guard_target ((equiv.swap (0 : fin 3) 1) 2 = 2)},
  norm_fin,
  guard_target' (equiv.swap (0 : fin 3) 1 2 = 2),
  exact equiv.swap_apply_of_ne_of_ne dec_trivial dec_trivial
end
example : equiv.swap (0 : fin 3) 1 (fin.cast_succ 1) = 0 := by norm_fin

example : (5 : fin 7) < fin.succ (fin.succ 9) := by norm_num
example : (12 : fin 7) < 6 := by norm_num
example : (11 : fin 7) > 3 := by norm_num
example : (12 : fin 6) ≤ 0 := by norm_num
example : (11 : fin 6) ≥ 5 := by norm_num
example : fin.succ (4 : fin 6) < 13 := by norm_num
example : fin.succ (1 : fin (1 + 2)) < 3 := by norm_num
example : fin.succ (1 : fin (nat.succ (1 + 1))) < 3 := by norm_num
example : (1 : fin (nat.succ (1 + 1))) < 2 := by norm_num
example : (1 : fin (nat.succ (1 + 2))) < 7 := by norm_num
example : (3 : fin (nat.succ (1 + 1 + 1))) > 4 := by norm_num
example : (2 : fin (nat.succ (2 + 1 + 1))) < 8 := by norm_num
example : (2 : fin (nat.succ (nat.succ (2 + 1 + 1)))) < 9 := by norm_num
example : fin.cast_succ (1 : fin (nat.succ (1 + 1))) < 7 := by norm_num
example : (1 : fin (nat.succ (1 + 1))) < fin.succ 3 := by norm_num
example : fin.succ (3 : fin 6) < fin.cast_succ 11 := by norm_num
example : fin.cast_succ (4 : fin 6) < fin.succ 4 := by norm_num
example : fin.cast_succ (fin.cast_succ (4 : fin 5)) < fin.cast_succ (fin.succ 4) := by norm_num
example : fin.cast_succ (4 : fin 6) < fin.succ 11 := by norm_num
example : fin.cast_succ (3 : fin 6) < fin.cast_succ 10 := by norm_num
example : fin.cast_succ (fin.cast_succ (3 : fin 5)) < fin.succ (fin.cast_succ 9) := by norm_num

example : (5 : fin 7) ≠ fin.succ (fin.succ 9) := by norm_num
example : (12 : fin 7) ≠ 6 := by norm_num
example : (11 : fin 7) ≠ 3 := by norm_num
example : fin.succ (4 : fin 6) ≠ 13 := by norm_num
example : fin.succ (1 : fin (1 + 2)) ≠ 3 := by norm_num
example : fin.succ (1 : fin (nat.succ (1 + 1))) ≠ 3 := by norm_num
example : (1 : fin (nat.succ (1 + 1))) ≠ 2 := by norm_num
example : (1 : fin (nat.succ (1 + 2))) ≠ 7 := by norm_num
example : (3 : fin (nat.succ (1 + 1 + 1))) ≠ 4 := by norm_num
example : (2 : fin (nat.succ (2 + 1 + 1))) ≠ 8 := by norm_num
example : (2 : fin (nat.succ (nat.succ (2 + 1 + 1)))) ≠ 9 := by norm_num
example : fin.cast_succ (1 : fin (nat.succ (1 + 1))) ≠ 7 := by norm_num
example : (1 : fin (nat.succ (1 + 1))) ≠ fin.succ 3 := by norm_num
example : fin.succ (3 : fin 6) ≠ fin.cast_succ 11 := by norm_num
example : fin.cast_succ (4 : fin 6) ≠ fin.succ 4 := by norm_num
example : fin.cast_succ (fin.cast_succ (4 : fin 5)) ≠ fin.cast_succ (fin.succ 4) := by norm_num
example : fin.cast_succ (4 : fin 6) ≠ fin.succ 11 := by norm_num
example : fin.cast_succ (3 : fin 6) ≠ fin.cast_succ 10 := by norm_num
example : fin.cast_succ (fin.cast_succ (3 : fin 5)) ≠ fin.succ (fin.cast_succ 9) := by norm_num

example : (5 : fin 7) ≠ fin.succ (fin.succ 9) :=
begin
  intro H,
  norm_num at H,
end


-- auxiliary lemmas unrelated to verifier

import data.set

-- auxiliary lemmas for nat

lemma nonneg_of_nat {n: ℕ}: 0 ≤ n := nat.rec_on n
  (show 0 ≤ 0, by refl)
  (λn zero_lt_n, show 0 ≤ n + 1, from le_add_of_le_of_nonneg zero_lt_n zero_le_one)

lemma lt_of_add_one {n: ℕ}: n < n + 1 :=
  have n ≤ n, by refl,
  show n < n + 1, from lt_add_of_le_of_pos this zero_lt_one

lemma lt_of_add {n m: ℕ}: n < n + m + 1 ∧ m < n + m + 1 :=
  have n_nonneg: 0 ≤ n, from nonneg_of_nat,
  have m_nonneg: 0 ≤ m, from nonneg_of_nat,
  have n ≤ n, by refl,
  have n ≤ n + m, from le_add_of_le_of_nonneg this m_nonneg,
  have h₁: n < n + m + 1, from lt_add_of_le_of_pos this zero_lt_one,
  have m ≤ m, by refl,
  have m ≤ m + n, from le_add_of_le_of_nonneg this n_nonneg,
  have m ≤ n + m, by { rw[add_comm], assumption },
  have h₂: m < n + m + 1, from lt_add_of_le_of_pos this zero_lt_one,
  ⟨h₁, h₂⟩

lemma lt_of_x_s_y {x s y: ℕ}: s < x + (s + (y + 1)) :=
  begin
    rw[←add_assoc],
    rw[←add_comm s x],
    rw[add_assoc],
    apply lt_add_of_pos_right s,
    change 0 < x + (y + 1),
    rw[←add_assoc],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma nat.succ.inj.inv {n m: ℕ}: n = m → (nat.succ n = nat.succ m) :=
  assume : n = m,
  by simp [this]

lemma eq_add_right_of_eq {n m k: ℕ}: n = m → n + k = m + k :=
  begin
    assume h,
    induction k,
    simp,
    from h,

    change (n + (a + 1) = m + (a + 1)),
    rw[←add_assoc n a 1],
    rw[←add_assoc m a 1],
    change (nat.succ (n + a) = nat.succ (m + a)),
    apply nat.succ.inj.inv,
    from ih_1
  end

lemma eq_add_left_of_eq {n m k: ℕ}: n = m → k + n = k + m :=
  begin
    assume h,
    rw[←add_comm n k],
    rw[←add_comm m k],
    from eq_add_right_of_eq h
  end

-- auxiliary lemmas for option

lemma some.inj.inv {α: Type} {a b: α}: a = b → (some a = some b) :=
  assume : a = b,
  by simp [this]

lemma option.some_iff_not_none {α: Type} {a: option α}: option.is_some a ↔ ¬ option.is_none a :=
  begin
    cases a,
    split,
    intro h,
    contradiction,
    intro h2,
    unfold option.is_none at h2,
    have h3: ↑tt = false, from eq_false_intro h2,
    have h4: ↑tt = true, by simp,
    have h5: false = true, from eq.trans h3.symm h4,
    have h6: true, from trivial,
    have h7: false, from h5.symm ▸ h6,
    contradiction,
    split,
    intro h8,
    intro h9,
    contradiction,
    intro h10,
    unfold option.is_some,
    change tt = tt,
    refl
  end

lemma option.none_iff_not_some {α: Type} {a: option α}: option.is_none a ↔ ¬ option.is_some a :=
  begin
    cases a,
    split,
    intro h,
    contradiction,
    intro h2,
    unfold option.is_none,
    change tt = tt,
    refl,
    split,
    intro h3,
    intro h4,
    unfold option.is_none at h3,
    change ff = tt at h3,
    contradiction,
    intro h5,
    unfold option.is_some at h5,
    have h6: ↑tt = false, from eq_false_intro h5,
    have h7: ↑tt = true, by simp,
    have h8: false = true, from eq.trans h6.symm h7,
    have h9: true, from trivial,
    have : false, from h8.symm ▸ h9,
    contradiction
  end

lemma option.is_none.inv {α: Type} {a: option α}: (a = none) ↔ option.is_none a :=
  begin
    cases a,
    case option.some v {
      split,
      assume is_none_some,
      contradiction,
      assume is_none_some,
      contradiction,
    },
    case option.none {
      split,
      assume is_none_none,
      exact rfl,
      assume is_none_none,
      exact rfl
    }
  end

lemma option.is_none.ninv {α: Type} {a: option α}: (a ≠ none) ↔ ¬ option.is_none a :=
  begin
    split,
    intro h,
    cases a,
    contradiction,
    unfold option.is_none,
    intro h2,
    change ff = tt at h2,
    contradiction,
    intro h3,
    intro h4,
    rw[h4] at h3,
    unfold option.is_none at h3,
    have h5: ↑tt = false, from eq_false_intro h3,
    have h6: ↑tt = true, by simp,
    have h7: false = true, from eq.trans h5.symm h6,
    have h8: true, from trivial,
    have r9: false, from h7.symm ▸ h8,
    contradiction
  end

lemma option.is_some_iff_exists {α: Type} {a: option α}: option.is_some a ↔ (∃b, a = some b) :=
  begin
    split,
    cases a,
    assume c,
    cases c,
    intro h,
    existsi a,
    refl,
    intro h2,
    cases h2,
    rw[a_2],
    unfold option.is_some,
    change tt = tt,
    refl
  end

def option.is_none_prop {α: Type} (a: option α): Prop := option.is_none a

instance {α: Type} {a: option α} : decidable (option.is_none_prop a) :=
  let r := a in
  have h: r = a, from rfl,
  @option.rec_on α (λv, (r = v) → decidable (option.is_none_prop a)) r
  (
    assume : r = none,
    have a = none, from eq.trans h this,
    have option.is_none a, from option.is_none.inv.mp this,
    have option.is_none_prop a, from this,
    is_true this
  ) (
    assume v: α,
    assume : r = some v,
    have a = some v, from eq.trans h this,
    have ∃v, a = some v, from exists.intro v this,
    have option.is_some a, from option.is_some_iff_exists.mpr this,
    have ¬ option.is_none a, from option.some_iff_not_none.mp this,
    is_false this
  ) rfl

lemma eq_from_map_result_some {α: Type} {a: option α} {b: α} {f: α → α}: f <$> a = some b → ∃c: α, a=some c ∧ b=f c :=
  begin
    assume h1,
    unfold has_map.map at h1,
    cases a with c,

    unfold option.map at h1,
    unfold option.bind at h1,
    contradiction,

    unfold option.map at h1,
    unfold option.bind at h1,
    unfold function.comp at h1,
    have h2, from option.some.inj h1,
    existsi c,
    split,
    from rfl,
    from h2.symm
  end

-- auxiliary lemmas for sets

lemma set.two_elems_mem {α: Type} {a b c: α}:
  a ∈ ({b, c}: set α) → (a = b) ∨ (a = c) :=
  assume a_in_bc: a ∈ {b, c},
  have a_in_bc: a ∈ insert b (insert c (∅: set α)), by { simp at a_in_bc, simp[a_in_bc] },
  have a = b ∨ a ∈ insert c ∅, from set.eq_or_mem_of_mem_insert a_in_bc,
  or.elim this (
    assume : a = b,
    show (a = b) ∨ (a = c), from or.inl this
  ) (
    assume : a ∈ insert c ∅,
    have a = c ∨ a ∈ ∅, from set.eq_or_mem_of_mem_insert this,
    or.elim this (
      assume : a = c,
      show (a = b) ∨ (a = c), from or.inr this
    ) (
      assume : a ∈ ∅,
      show (a = b) ∨ (a = c), from absurd this (set.not_mem_empty a)
    )
  )

lemma set.two_elems_mem.inv {α: Type} {a b c: α}: (a = b) ∨ (a = c) → a ∈ ({b, c}: set α) :=
  assume : (a = b) ∨ (a = c),
  or.elim this (
    assume : a = b,
    show a ∈ ({b, c}: set α), { simp, left, from this }
  ) (
    assume : a = c,
    show a ∈ ({b, c}: set α), { simp, right, from this }
  )

lemma set.three_elems_mem {α: Type} {a b c d: α}:
  a ∈ ({b, c, d}: set α) → (a = b) ∨ (a = c) ∨ (a = d) :=
  assume a_in_bcd: a ∈ {b, c, d},
  have a_in_bcd: a ∈ insert b (insert c (insert d (∅: set α))),
  by { simp at a_in_bcd, simp[a_in_bcd] },
  have a = b ∨ a ∈ insert c (insert d (∅: set α)), from set.eq_or_mem_of_mem_insert a_in_bcd,
  or.elim this (
    assume : a = b,
    show (a = b) ∨ (a = c) ∨ (a = d), from or.inl this
  ) (
    assume : a ∈ insert c (insert d (∅: set α)),
    have a = c ∨ a ∈ insert d (∅: set α), from set.eq_or_mem_of_mem_insert this,
    or.elim this (
      assume : a = c,
      show (a = b) ∨ (a = c) ∨ (a = d), from or.inr (or.inl this)
    ) (
      assume : a ∈ insert d (∅: set α),
      have a = d ∨ a ∈ ∅, from set.eq_or_mem_of_mem_insert this,
      or.elim this (
        assume : a = d,
        show (a = b) ∨ (a = c) ∨ (a = d), from or.inr (or.inr this)
      ) (
        assume : a ∈ ∅,
        show (a = b) ∨ (a = c) ∨ (a = d), from absurd this (set.not_mem_empty a)
      )
    )
  )

lemma set.three_elems_mem₁ {α: Type} {a b c d: α}: (a = b) → a ∈ ({b, c, d}: set α) := by { intro ab, rw[ab], simp }
lemma set.three_elems_mem₂ {α: Type} {a b c d: α}: (a = c) → a ∈ ({b, c, d}: set α) := by { intro ac, rw[ac], simp }
lemma set.three_elems_mem₃ {α: Type} {a b c d: α}: (a = d) → a ∈ ({b, c, d}: set α) := by { intro ad, rw[ad], simp }

lemma set.forall_not_mem_of_eq_empty {α: Type} {s: set α}: s = ∅ → ∀ x, x ∉ s :=
  by simp[set.set_eq_def]

lemma set.two_elems_of_insert {α: Type} {a b: α}: set.insert a ∅ ∪ set.insert b ∅ = {a, b} :=
  set.eq_of_subset_of_subset (
    assume x: α,
    assume : x ∈ set.insert a ∅ ∪ set.insert b ∅,
    or.elim (set.mem_or_mem_of_mem_union this) (
      assume : x ∈ set.insert a ∅,
      have x ∈ {a}, from @eq.subst (set α) (λc, x ∈ c) (set.insert a ∅) {a} (set.singleton_def a).symm this,
      show x ∈ {a, b}, by { simp, left, simp at this, from this }
    ) (
      assume : x ∈ set.insert b ∅,
      have x ∈ {b}, from @eq.subst (set α) (λc, x ∈ c) (set.insert b ∅) {b} (set.singleton_def b).symm this,
      show x ∈ {a, b}, by { simp, right, simp at this, from this }
    )
  ) (
    assume x: α,
    assume : x ∈ {a, b},
    or.elim (set.two_elems_mem this) (
      assume : x = a,
      have x ∈ set.insert a ∅, from (set.mem_singleton_iff x a).mpr this,
      show x ∈ set.insert a ∅ ∪ set.insert b ∅, from set.mem_union_left (set.insert b ∅) this
    ) (
      assume : x = b,
      have x ∈ set.insert b ∅, from (set.mem_singleton_iff x b).mpr this,
      show x ∈ set.insert a ∅ ∪ set.insert b ∅, from set.mem_union_right (set.insert a ∅) this
    )
  )

lemma set.subset_of_eq {α: Type} {a b: set α}: (a = b) → (a ⊆ b) :=
  assume a_eq_b: a = b,
  assume x: α,
  assume : x ∈ a,
  show x ∈ b, from a_eq_b ▸ this

lemma set.not_mem_or_mem_of_not_mem_diff {α: Type} {a: α} {b c: set α}: a ∉ b \ c → (a ∉ b ∨ a ∈ c) :=
  begin
    assume h1,
    rw[set.diff_eq] at h1,
    rw[←set.compl_compl b] at h1,
    rw[←set.compl_union] at h1,
    rw[←set.mem_compl_eq] at h1,
    rw[set.compl_compl] at h1,
    have h2, from set.mem_or_mem_of_mem_union h1,
    rw[set.mem_compl_eq] at h2,
    from h2
  end

lemma set.diff_self {α: Type} {a: set α}: a - a = ∅ :=
  begin
    apply set.eq_of_subset_of_subset,

    assume x: α,
    assume h1: x ∈ a - a,
    have h2, from set.mem_of_mem_diff h1,
    have h3, from set.not_mem_of_mem_diff h1,
    contradiction,

    assume x: α,
    assume h1: x ∈ ∅,
    have h2: x ∉ ∅, from set.forall_not_mem_of_eq_empty rfl x,
    contradiction
  end

-- lemmas about if then else

lemma ite.if_true {a: Prop} {b: Type} {c d: b} [decidable a]: a → (ite a c d = c) :=
  begin
    assume ha,
    simp[ha]
  end

lemma ite.if_false {a: Prop} {b: Type} {c d: b} [decidable a]: ¬a → (ite a c d = d) :=
  begin
    assume ha,
    simp[ha]
  end


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

! This file was ported from Lean 3 source module algebra.order.kleene
! leanprover-community/mathlib commit 98e83c3d541c77cdb7da20d79611a780ff8e7d90
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Ring.Canonical
import Mathlib.Algebra.Ring.Pi
import Mathlib.Algebra.Ring.Prod
import Mathlib.Order.Hom.CompleteLattice
import Mathlib.Tactic.ScopedNS  -- Porting note: `scoped[]`

/-!
# Kleene Algebras

This file defines idempotent semirings and Kleene algebras, which are used extensively in the theory
of computation.

An idempotent semiring is a semiring whose addition is idempotent. An idempotent semiring is
naturally a semilattice by setting `a ≤ b` if `a + b = b`.

A Kleene algebra is an idempotent semiring equipped with an additional unary operator `∗`, the
Kleene star.

## Main declarations

* `IdemSemiring`: Idempotent semiring
* `IdemCommSemiring`: Idempotent commutative semiring
* `KleeneAlgebra`: Kleene algebra

## Notation

`a∗` is notation for `kstar a` in locale `Computability`.

## References

* [D. Kozen, *A completeness theorem for Kleene algebras and the algebra of regular events*]
  [kozen1994]
* https://planetmath.org/idempotentsemiring
* https://encyclopediaofmath.org/wiki/Idempotent_semi-ring
* https://planetmath.org/kleene_algebra

## TODO

Instances for `AddOpposite`, `MulOpposite`, `ULift`, `Subsemiring`, `Subring`, `Subalgebra`.

## Tags

kleene algebra, idempotent semiring
-/

open Function

universe u

variable {α β ι : Type _} {π : ι → Type _}

/-- An idempotent semiring is a semiring with the additional property that addition is idempotent.
-/
-- @[protect_proj] -- Porting note: Not yet implemented
class IdemSemiring (α : Type u) extends Semiring α, SemilatticeSup α where
  sup := (· + ·)
  add_eq_sup : ∀ a b : α, a + b = a ⊔ b := by
    intros
    rfl
  bot : α := 0
  bot_le : ∀ a, bot ≤ a
#align idem_semiring IdemSemiring

/-- An idempotent commutative semiring is a commutative semiring with the additional property that
addition is idempotent. -/
-- @[protect_proj] -- Porting note: Not yet implemented
class IdemCommSemiring (α : Type u) extends CommSemiring α, IdemSemiring α
#align idem_comm_semiring IdemCommSemiring

/-- Notation typeclass for the Kleene star `∗`. -/
-- @[protect_proj] -- Porting note: Not yet implemented
class KStar (α : Type _) where
  kstar : α → α
#align has_kstar KStar

-- mathport name: «expr ∗»
scoped[Computability] postfix:1024 "∗" => KStar.kstar
open Computability

/-- A Kleene Algebra is an idempotent semiring with an additional unary operator `kstar` (for Kleene
star) that satisfies the following properties:
* `1 + a * a∗ ≤ a∗`
* `1 + a∗ * a ≤ a∗`
* If `a * c + b ≤ c`, then `a∗ * b ≤ c`
* If `c * a + b ≤ c`, then `b * a∗ ≤ c`
-/
-- @[protect_proj] -- Porting note: Not yet implemented
class KleeneAlgebra (α : Type _) extends IdemSemiring α, KStar α where
  one_le_kstar : ∀ a : α, 1 ≤ a∗
  mul_kstar_le_kstar : ∀ a : α, a * a∗ ≤ a∗
  kstar_mul_le_kstar : ∀ a : α, a∗ * a ≤ a∗
  mul_kstar_le_self : ∀ a b : α, b * a ≤ b → b * a∗ ≤ b
  kstar_mul_le_self : ∀ a b : α, a * b ≤ b → a∗ * b ≤ b
#align kleene_algebra KleeneAlgebra

-- See note [lower instance priority]
instance (priority := 100) IdemSemiring.toOrderBot [IdemSemiring α] : OrderBot α :=
  { ‹IdemSemiring α› with }
#align idem_semiring.to_order_bot IdemSemiring.toOrderBot

-- See note [reducible non-instances]
/-- Construct an idempotent semiring from an idempotent addition. -/
@[reducible]
def IdemSemiring.ofSemiring [Semiring α] (h : ∀ a : α, a + a = a) : IdemSemiring α :=
  { ‹Semiring α› with
    le := fun a b ↦ a + b = b
    le_refl := h
    le_trans := fun a b c hab hbc ↦ by
      simp only
      rw [← hbc, ← add_assoc, hab]
    le_antisymm := fun a b hab hba ↦ by rwa [← hba, add_comm]
    sup := (· + ·)
    le_sup_left := fun a b ↦ by
      simp only
      rw [← add_assoc, h]
    le_sup_right := fun a b ↦ by
      simp only
      rw [add_comm, add_assoc, h]
    sup_le := fun a b c hab hbc ↦ by
      simp only
      rwa [add_assoc, hbc]
    bot := 0
    bot_le := zero_add }
#align idem_semiring.of_semiring IdemSemiring.ofSemiring

section IdemSemiring

variable [IdemSemiring α] {a b c : α}

theorem add_eq_sup (a b : α) : a + b = a ⊔ b :=
  IdemSemiring.add_eq_sup _ _
#align add_eq_sup add_eq_sup

-- Porting note: This simp theorem often leads to timeout when `α` has rich structure.
--               So, this theorem should be scoped.
scoped[Computability] attribute [simp] add_eq_sup

theorem add_idem (a : α) : a + a = a := by simp
#align add_idem add_idem

theorem nsmul_eq_self : ∀ {n : ℕ} (_ : n ≠ 0) (a : α), n • a = a
  | 0, h => (h rfl).elim
  | 1, _ => one_nsmul
  | n + 2, _ => fun a ↦ by rw [succ_nsmul, nsmul_eq_self n.succ_ne_zero, add_idem]
#align nsmul_eq_self nsmul_eq_self

theorem add_eq_left_iff_le : a + b = a ↔ b ≤ a := by simp
#align add_eq_left_iff_le add_eq_left_iff_le

theorem add_eq_right_iff_le : a + b = b ↔ a ≤ b := by simp
#align add_eq_right_iff_le add_eq_right_iff_le

alias add_eq_left_iff_le ↔ _ LE.le.add_eq_left
#align has_le.le.add_eq_left LE.le.add_eq_left

alias add_eq_right_iff_le ↔ _ LE.le.add_eq_right
#align has_le.le.add_eq_right LE.le.add_eq_right

theorem add_le_iff : a + b ≤ c ↔ a ≤ c ∧ b ≤ c := by simp
#align add_le_iff add_le_iff

theorem add_le (ha : a ≤ c) (hb : b ≤ c) : a + b ≤ c :=
  add_le_iff.2 ⟨ha, hb⟩
#align add_le add_le

-- See note [lower instance priority]
instance (priority := 100) IdemSemiring.toCanonicallyOrderedAddMonoid :
    CanonicallyOrderedAddMonoid α :=
  { ‹IdemSemiring α› with
    add_le_add_left := fun a b hbc c ↦ by
      simp_rw [add_eq_sup]
      exact sup_le_sup_left hbc _
    exists_add_of_le := fun h ↦ ⟨_, h.add_eq_right.symm⟩
    le_self_add := fun a b ↦ add_eq_right_iff_le.1 <| by rw [← add_assoc, add_idem] }
#align idem_semiring.to_canonically_ordered_add_monoid IdemSemiring.toCanonicallyOrderedAddMonoid

-- See note [lower instance priority]
instance (priority := 100) IdemSemiring.toCovariantClass_mul_le :
    CovariantClass α α (· * ·) (· ≤ ·) :=
  ⟨fun a b c hbc ↦ add_eq_left_iff_le.1 <| by rw [← mul_add, hbc.add_eq_left]⟩
#align idem_semiring.to_covariant_class_mul_le IdemSemiring.toCovariantClass_mul_le

-- See note [lower instance priority]
instance (priority := 100) IdemSemiring.toCovariantClass_swap_mul_le :
    CovariantClass α α (swap (· * ·)) (· ≤ ·) :=
  ⟨fun a b c hbc ↦ add_eq_left_iff_le.1 <| by rw [← add_mul, hbc.add_eq_left]⟩
#align idem_semiring.to_covariant_class_swap_mul_le IdemSemiring.toCovariantClass_swap_mul_le

end IdemSemiring

section KleeneAlgebra

variable [KleeneAlgebra α] {a b c : α}

@[simp]
theorem one_le_kstar : 1 ≤ a∗ :=
  KleeneAlgebra.one_le_kstar _
#align one_le_kstar one_le_kstar

theorem mul_kstar_le_kstar : a * a∗ ≤ a∗ :=
  KleeneAlgebra.mul_kstar_le_kstar _
#align mul_kstar_le_kstar mul_kstar_le_kstar

theorem kstar_mul_le_kstar : a∗ * a ≤ a∗ :=
  KleeneAlgebra.kstar_mul_le_kstar _
#align kstar_mul_le_kstar kstar_mul_le_kstar

theorem mul_kstar_le_self : b * a ≤ b → b * a∗ ≤ b :=
  KleeneAlgebra.mul_kstar_le_self _ _
#align mul_kstar_le_self mul_kstar_le_self

theorem kstar_mul_le_self : a * b ≤ b → a∗ * b ≤ b :=
  KleeneAlgebra.kstar_mul_le_self _ _
#align kstar_mul_le_self kstar_mul_le_self

theorem mul_kstar_le (hb : b ≤ c) (ha : c * a ≤ c) : b * a∗ ≤ c :=
  (mul_le_mul_right' hb _).trans <| mul_kstar_le_self ha
#align mul_kstar_le mul_kstar_le

theorem kstar_mul_le (hb : b ≤ c) (ha : a * c ≤ c) : a∗ * b ≤ c :=
  (mul_le_mul_left' hb _).trans <| kstar_mul_le_self ha
#align kstar_mul_le kstar_mul_le

theorem kstar_le_of_mul_le_left (hb : 1 ≤ b) : b * a ≤ b → a∗ ≤ b := by
  simpa using mul_kstar_le hb
#align kstar_le_of_mul_le_left kstar_le_of_mul_le_left

theorem kstar_le_of_mul_le_right (hb : 1 ≤ b) : a * b ≤ b → a∗ ≤ b := by
  simpa using kstar_mul_le hb
#align kstar_le_of_mul_le_right kstar_le_of_mul_le_right

@[simp]
theorem le_kstar : a ≤ a∗ :=
  le_trans (le_mul_of_one_le_left' one_le_kstar) kstar_mul_le_kstar
#align le_kstar le_kstar

@[mono]
theorem kstar_mono : Monotone (KStar.kstar : α → α) :=
  fun _ _ h ↦
    kstar_le_of_mul_le_left one_le_kstar <| kstar_mul_le (h.trans le_kstar) <| mul_kstar_le_kstar
#align kstar_mono kstar_mono

@[simp]
theorem kstar_eq_one : a∗ = 1 ↔ a ≤ 1 :=
  ⟨le_kstar.trans_eq,
    fun h ↦ one_le_kstar.antisymm' <| kstar_le_of_mul_le_left le_rfl <| by rwa [one_mul]⟩
#align kstar_eq_one kstar_eq_one

@[simp]
theorem kstar_zero : (0 : α)∗ = 1 :=
  kstar_eq_one.2 zero_le_one
#align kstar_zero kstar_zero

@[simp]
theorem kstar_one : (1 : α)∗ = 1 :=
  kstar_eq_one.2 le_rfl
#align kstar_one kstar_one

@[simp]
theorem kstar_mul_kstar (a : α) : a∗ * a∗ = a∗ :=
  (mul_kstar_le le_rfl <| kstar_mul_le_kstar).antisymm <| le_mul_of_one_le_left' one_le_kstar
#align kstar_mul_kstar kstar_mul_kstar

@[simp]
theorem kstar_eq_self : a∗ = a ↔ a * a = a ∧ 1 ≤ a :=
  ⟨fun h ↦ ⟨by rw [← h, kstar_mul_kstar], one_le_kstar.trans_eq h⟩,
    fun h ↦ (kstar_le_of_mul_le_left h.2 h.1.le).antisymm le_kstar⟩
#align kstar_eq_self kstar_eq_self

@[simp]
theorem kstar_idem (a : α) : a∗∗ = a∗ :=
  kstar_eq_self.2 ⟨kstar_mul_kstar _, one_le_kstar⟩
#align kstar_idem kstar_idem

@[simp]
theorem pow_le_kstar : ∀ {n : ℕ}, a ^ n ≤ a∗
  | 0 => (pow_zero _).trans_le one_le_kstar
  | n + 1 => by
    rw [pow_succ]
    exact (mul_le_mul_left' pow_le_kstar _).trans mul_kstar_le_kstar
#align pow_le_kstar pow_le_kstar

end KleeneAlgebra

namespace Prod

instance [IdemSemiring α] [IdemSemiring β] : IdemSemiring (α × β) :=
  { Prod.instSemiringProd, Prod.semilatticeSup _ _, Prod.orderBot _ _ with
    add_eq_sup := fun _ _ ↦ ext (add_eq_sup _ _) (add_eq_sup _ _) }

instance [IdemCommSemiring α] [IdemCommSemiring β] : IdemCommSemiring (α × β) :=
  { Prod.instCommSemiringProd, Prod.instIdemSemiringProd with }

variable [KleeneAlgebra α] [KleeneAlgebra β]

instance : KleeneAlgebra (α × β) :=
  { Prod.instIdemSemiringProd with
    kstar := fun a ↦ (a.1∗, a.2∗)
    one_le_kstar := fun _ ↦ ⟨one_le_kstar, one_le_kstar⟩
    mul_kstar_le_kstar := fun _ ↦ ⟨mul_kstar_le_kstar, mul_kstar_le_kstar⟩
    kstar_mul_le_kstar := fun _ ↦ ⟨kstar_mul_le_kstar, kstar_mul_le_kstar⟩
    mul_kstar_le_self := fun _ _ ↦ And.imp mul_kstar_le_self mul_kstar_le_self
    kstar_mul_le_self := fun _ _ ↦ And.imp kstar_mul_le_self kstar_mul_le_self }

theorem kstar_def (a : α × β) : a∗ = (a.1∗, a.2∗) :=
  rfl
#align prod.kstar_def Prod.kstar_def

@[simp]
theorem fst_kstar (a : α × β) : a∗.1 = a.1∗ :=
  rfl
#align prod.fst_kstar Prod.fst_kstar

@[simp]
theorem snd_kstar (a : α × β) : a∗.2 = a.2∗ :=
  rfl
#align prod.snd_kstar Prod.snd_kstar

end Prod

namespace Pi

instance [∀ i, IdemSemiring (π i)] : IdemSemiring (∀ i, π i) :=
  { Pi.semiring, Pi.semilatticeSup, Pi.orderBot with
    add_eq_sup := fun _ _ ↦ funext fun _ ↦ add_eq_sup _ _ }

instance [∀ i, IdemCommSemiring (π i)] : IdemCommSemiring (∀ i, π i) :=
  { Pi.commSemiring, Pi.instIdemSemiringForAll with }

variable [∀ i, KleeneAlgebra (π i)]

instance : KleeneAlgebra (∀ i, π i) :=
  { Pi.instIdemSemiringForAll with
    kstar := fun a i ↦ (a i)∗
    one_le_kstar := fun _ _ ↦ one_le_kstar
    mul_kstar_le_kstar := fun _ _ ↦ mul_kstar_le_kstar
    kstar_mul_le_kstar := fun _ _ ↦ kstar_mul_le_kstar
    mul_kstar_le_self := fun _ _ h _ ↦ mul_kstar_le_self <| h _
    kstar_mul_le_self := fun _ _ h _ ↦ kstar_mul_le_self <| h _ }

theorem kstar_def (a : ∀ i, π i) : a∗ = fun i ↦ (a i)∗ :=
  rfl
#align pi.kstar_def Pi.kstar_def

@[simp]
theorem kstar_apply (a : ∀ i, π i) (i : ι) : a∗ i = (a i)∗ :=
  rfl
#align pi.kstar_apply Pi.kstar_apply

end Pi

namespace Function.Injective

-- See note [reducible non-instances]
/-- Pullback an `IdemSemiring` instance along an injective function. -/
@[reducible]
protected def idemSemiring [IdemSemiring α] [Zero β] [One β] [Add β] [Mul β] [Pow β ℕ] [SMul ℕ β]
    [NatCast β] [Sup β] [Bot β] (f : β → α) (hf : Injective f) (zero : f 0 = 0) (one : f 1 = 1)
    (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
    (nsmul : ∀ (x) (n : ℕ), f (n • x) = n • f x) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n)
    (nat_cast : ∀ n : ℕ, f n = n) (sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (bot : f ⊥ = ⊥) :
    IdemSemiring β :=
  { hf.semiring f zero one add mul nsmul npow nat_cast, hf.semilatticeSup _ sup,
    ‹Bot β› with
    add_eq_sup := fun a b ↦ hf <| by erw [sup, add, add_eq_sup]
    bot := ⊥
    bot_le := fun a ↦ bot.trans_le <| @bot_le _ _ _ <| f a }
#align function.injective.idem_semiring Function.Injective.idemSemiring

-- See note [reducible non-instances]
/-- Pullback an `IdemCommSemiring` instance along an injective function. -/
@[reducible]
protected def idemCommSemiring [IdemCommSemiring α] [Zero β] [One β] [Add β] [Mul β] [Pow β ℕ]
    [SMul ℕ β] [NatCast β] [Sup β] [Bot β] (f : β → α) (hf : Injective f) (zero : f 0 = 0)
    (one : f 1 = 1) (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
    (nsmul : ∀ (x) (n : ℕ), f (n • x) = n • f x) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n)
    (nat_cast : ∀ n : ℕ, f n = n) (sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (bot : f ⊥ = ⊥) :
    IdemCommSemiring β :=
  { hf.commSemiring f zero one add mul nsmul npow nat_cast,
    hf.idemSemiring f zero one add mul nsmul npow nat_cast sup bot with }
#align function.injective.idem_comm_semiring Function.Injective.idemCommSemiring

-- See note [reducible non-instances]
/-- Pullback a `KleeneAlgebra` instance along an injective function. -/
@[reducible]
protected def kleeneAlgebra [KleeneAlgebra α] [Zero β] [One β] [Add β] [Mul β] [Pow β ℕ] [SMul ℕ β]
    [NatCast β] [Sup β] [Bot β] [KStar β] (f : β → α) (hf : Injective f) (zero : f 0 = 0)
    (one : f 1 = 1) (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
    (nsmul : ∀ (x) (n : ℕ), f (n • x) = n • f x) (npow : ∀ (x) (n : ℕ), f (x ^ n) = f x ^ n)
    (nat_cast : ∀ n : ℕ, f n = n) (sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b) (bot : f ⊥ = ⊥)
    (kstar : ∀ a, f a∗ = (f a)∗) : KleeneAlgebra β :=
  { hf.idemSemiring f zero one add mul nsmul npow nat_cast sup bot,
    ‹KStar β› with
    one_le_kstar := fun a ↦ one.trans_le <| by
      erw [kstar]
      exact one_le_kstar
    mul_kstar_le_kstar := fun a ↦ by
      change f _ ≤ _
      erw [mul, kstar]
      exact mul_kstar_le_kstar
    kstar_mul_le_kstar := fun a ↦ by
      change f _ ≤ _
      erw [mul, kstar]
      exact kstar_mul_le_kstar
    mul_kstar_le_self := fun a b (h : f _ ≤ _) ↦ by
      change f _ ≤ _
      erw [mul, kstar]
      erw [mul] at h
      exact mul_kstar_le_self h
    kstar_mul_le_self := fun a b (h : f _ ≤ _) ↦ by
      change f _ ≤ _
      erw [mul, kstar]
      erw [mul] at h
      exact kstar_mul_le_self h }
#align function.injective.kleene_algebra Function.Injective.kleeneAlgebra

end Function.Injective


/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under the MIT license described in the file LICENSE.
Authors: Mac Malone
-/

import Folktale
open Folktale

/-!
A crime is committed, and X and Y are accused.
They could be both guilty, both innocent, or only one guilty.

8 witnesses are brought in, who make the following statements in order:
* A: X is a knight
* B: Y is a knave
* C: A is a knave
* D: B is a knave
* E: C and D are knights
* F: A and B are not both lying
* G: E and F are the same type
* H: I am the same type as G; also, X and Y are not both guilty

Whodunit? That is, did X do it and/or did Y do it?

**Clarifications:**
* H's statement is a single proposition with an AND.

**Source:** *The Riddle of Scheherazade* by Raymond Smullyan
-/

-- # Setting

axiom X : Folk
axiom Y : Folk

axiom A : Folk
axiom B : Folk
axiom C : Folk
axiom D : Folk
axiom E : Folk
axiom F : Folk
axiom G : Folk
axiom H : Folk

constant guilty : Folk → Prop

-- # Statements

axiom A_knight_X :
  A.say <| knight X

axiom B_knave_Y :
  B.say <| knave Y

axiom C_knave_A :
  C.say <| knave A

axiom D_knave_B :
  D.say <| knave B

axiom E_knight_C_D :
  E.say <| knight C ∧ knight D

axiom F_not_knave_A_B :
  F.say <| ¬ (knave A ∧ knave B)

axiom G_same_E_F :
  G.say <| same2 E F

axiom H_G_X_Y :
  H.say <| same2 H G ∧ ¬ (guilty X ∧ guilty Y)

-- # Deductions

theorem not_same_E_F : ¬ (same2 E F) := by
  intro h;
  cases h with
  | inl knights =>
    let ⟨knight_E, knight_F⟩ := knights
    let ⟨knight_C, knight_D⟩ := knight_truth knight_E E_knight_C_D
    cases Classical.dm_and (knight_truth knight_F F_not_knave_A_B) with
    | inl not_knave_A =>
      let knave_A := knight_truth knight_C C_knave_A
      contradiction
    | inr not_knave_B =>
      let knave_B := knight_truth knight_D D_knave_B
      contradiction
  | inr knaves =>
    let ⟨knave_E, knave_F⟩ := knaves
    let ⟨knave_A, knave_B⟩ := Classical.dne <| knave_lie knave_F F_not_knave_A_B
    cases Classical.dm_and (knave_lie knave_E E_knight_C_D) with
    | inl not_knight_C =>
      let not_knave_A := knave_lie (not_knight_knave (not_knight_C)) C_knave_A
      contradiction
    | inr not_knight_D =>
      let not_knave_B := knave_lie (not_knight_knave (not_knight_D)) D_knave_B
      contradiction

theorem knave_G : knave G :=
  not_knight_knave fun knight_G =>
    not_same_E_F (knight_truth knight_G G_same_E_F)

theorem solution : guilty X ∧ guilty Y := by
  cases knight_or_knave H with
  | inl knight_H =>
    apply False.elim
    let ⟨same_H_G, _⟩ := knight_truth knight_H H_G_X_Y
    cases same_H_G with
    | inl both_knights =>
      let ⟨_, knight_G⟩ := both_knights
      exact knight_not_knave knight_G knave_G
    | inr both_knaves =>
      let ⟨knave_H, _⟩ := both_knaves
      exact knight_not_knave knight_H knave_H
  | inr knave_H =>
    cases Classical.dm_and <| knave_lie knave_H H_G_X_Y with
    | inl not_same_H_G =>
      exact False.elim <| not_same_H_G <| Or.inr <| And.intro knave_H knave_G
    | inr not_not_guilty_X_Y =>
      exact Classical.dne not_not_guilty_X_Y

-- # Side Note

/--
If one interprets H's line as two separate statements instead of a single one
joined with an AND, the puzzle is contradictory (i.e., proves false).

Essentially, since G is provably a knave, H's statement that they are both
the same type reduces to "We are both knaves", which is always contradictory.
-/
theorem bad_interpretation
(H_same_G : H.say <| same2 H G) : False := by
  cases knight_or_knave H with
  | inl knight_H =>
    cases knight_truth knight_H H_same_G with
    | inl both_knights =>
      let ⟨_, knight_G⟩ := both_knights
      exact knight_not_knave knight_G knave_G
    | inr both_knaves =>
      let ⟨knave_H, _⟩ := both_knaves
      exact knight_not_knave knight_H knave_H
  | inr knave_H =>
    let ⟨_, not_both_knaves⟩ := Classical.dm_or <| knave_lie knave_H H_same_G
    cases Classical.dm_and not_both_knaves with
    | inl not_knave_H =>
      exact  not_knave_H knave_H
    | inr not_knave_G =>
      exact not_knave_G knave_G


/-
Copyright (c) 2021 Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Junyan Xu

! This file was ported from Lean 3 source module topology.sheaves.functors
! leanprover-community/mathlib commit 85d6221d32c37e68f05b2e42cde6cee658dae5e9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.SheafCondition.PairwiseIntersections

/-!
# functors between categories of sheaves

Show that the pushforward of a sheaf is a sheaf, and define
the pushforward functor from the category of C-valued sheaves
on X to that of sheaves on Y, given a continuous map between
topological spaces X and Y.

TODO: pullback for presheaves and sheaves
-/

noncomputable section

universe w v u

open CategoryTheory

open CategoryTheory.Limits

open TopologicalSpace

variable {C : Type u} [Category.{v} C]

variable {X Y : TopCat.{w}} (f : X ⟶ Y)

variable ⦃ι : Type w⦄ {U : ι → Opens Y}

namespace TopCat

namespace Presheaf.SheafConditionPairwiseIntersections

theorem map_diagram : Pairwise.diagram U ⋙ Opens.map f = Pairwise.diagram ((Opens.map f).obj ∘ U) :=
  by
  apply functor.hext
  abstract obj_eq intro i; cases i <;> rfl
  intro i j g; apply Subsingleton.helim
  iterate 2 rw [map_diagram.obj_eq]
#align Top.presheaf.sheaf_condition_pairwise_intersections.map_diagram TopCat.Presheaf.SheafConditionPairwiseIntersections.map_diagram

theorem mapCocone :
    HEq ((Opens.map f).mapCocone (Pairwise.cocone U)) (Pairwise.cocone ((Opens.map f).obj ∘ U)) :=
  by
  unfold functor.map_cocone cocones.functoriality; dsimp; congr
  iterate 2 rw [map_diagram]; rw [opens.map_supr]
  apply Subsingleton.helim; rw [map_diagram, opens.map_supr]
  apply proof_irrel_heq
#align Top.presheaf.sheaf_condition_pairwise_intersections.map_cocone TopCat.Presheaf.SheafConditionPairwiseIntersections.mapCocone

theorem pushforward_sheaf_of_sheaf {F : Presheaf C X} (h : F.IsSheafPairwiseIntersections) :
    (f _* F).IsSheafPairwiseIntersections := fun ι U =>
  by
  convert h ((opens.map f).obj ∘ U) using 2
  rw [← map_diagram]; rfl
  change HEq (F.map_cone ((opens.map f).mapCocone _).op) _
  congr ; iterate 2 rw [map_diagram]; apply map_cocone
#align Top.presheaf.sheaf_condition_pairwise_intersections.pushforward_sheaf_of_sheaf TopCat.Presheaf.SheafConditionPairwiseIntersections.pushforward_sheaf_of_sheaf

end Presheaf.SheafConditionPairwiseIntersections

namespace Sheaf

open Presheaf

/-- The pushforward of a sheaf (by a continuous map) is a sheaf.
-/
theorem pushforward_sheaf_of_sheaf {F : X.Presheaf C} (h : F.IsSheaf) : (f _* F).IsSheaf := by
  rw [is_sheaf_iff_is_sheaf_pairwise_intersections] at h⊢ <;>
    exact sheaf_condition_pairwise_intersections.pushforward_sheaf_of_sheaf f h
#align Top.sheaf.pushforward_sheaf_of_sheaf TopCat.Sheaf.pushforward_sheaf_of_sheaf

/-- The pushforward functor.
-/
def pushforward (f : X ⟶ Y) : X.Sheaf C ⥤ Y.Sheaf C
    where
  obj ℱ := ⟨f _* ℱ.1, pushforward_sheaf_of_sheaf f ℱ.2⟩
  map _ _ g := ⟨pushforwardMap f g.1⟩
#align Top.sheaf.pushforward TopCat.Sheaf.pushforward

end Sheaf

end TopCat


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
A tactic for discharging linear integer & natural
number arithmetic goals using the Omega test.
-/

import tactic.omega.int.main
import tactic.omega.nat.main

namespace omega

open tactic

meta def select_domain (t s : tactic (option bool)) : tactic (option bool) :=
do a ← t, b ← s,
   match a, b with
   | a,         none      := return a
   | none,      b         := return b
   | (some tt), (some tt) := return (some tt)
   | (some ff), (some ff) := return (some ff)
   | _,         _         := failed
   end

meta def type_domain (x : expr) : tactic (option bool) :=
if x = `(int)
then return (some tt)
else if x = `(nat)
     then return (some ff)
     else failed

/-- Detects domain of a formula from its expr.
* Returns none, if domain can be either ℤ or ℕ
* Returns some tt, if domain is exclusively ℤ
* Returns some ff, if domain is exclusively ℕ
* Fails, if domain is neither ℤ nor ℕ -/
meta def form_domain : expr → tactic (option bool)
| `(¬ %%px)      := form_domain px
| `(%%px ∨ %%qx) := select_domain (form_domain px) (form_domain qx)
| `(%%px ∧ %%qx) := select_domain (form_domain px) (form_domain qx)
| `(%%px ↔ %%qx) := select_domain (form_domain px) (form_domain qx)
| `(%%(expr.pi _ _ px qx)) :=
  monad.cond
     (if expr.has_var px then return tt else is_prop px)
     (select_domain (form_domain px) (form_domain qx))
     (select_domain (type_domain px) (form_domain qx))
| `(@has_lt.lt %%dx %%h _ _) := type_domain dx
| `(@has_le.le %%dx %%h _ _) := type_domain dx
| `(@eq %%dx _ _)            := type_domain dx
| `(@ge %%dx %%h _ _)        := type_domain dx
| `(@gt %%dx %%h _ _)        := type_domain dx
| `(@ne %%dx _ _)            := type_domain dx
| `(true)                    := return none
| `(false)                   := return none
| x                          := failed

meta def goal_domain_aux (x : expr) : tactic bool :=
(omega.int.wff x >> return tt) <|> (omega.nat.wff x >> return ff)

/-- Use the current goal to determine.
    Return tt if the domain is ℤ, and return ff if it is ℕ -/
meta def goal_domain : tactic bool :=
do gx ← target,
   hxs ← local_context >>= monad.mapm infer_type,
   app_first goal_domain_aux (gx::hxs)

/-- Return tt if the domain is ℤ, and return ff if it is ℕ -/
meta def determine_domain (opt : list name) : tactic bool :=
if `int ∈ opt
then return tt
else if `nat ∈ opt
     then return ff
     else goal_domain

end omega

open lean.parser interactive omega

/-- Attempts to discharge goals in the quantifier-free fragment of
linear integer and natural number arithmetic using the Omega test.
Guesses the correct domain by looking at the goal and hypotheses,
and then reverts all relevant hypotheses and variables.
Use `omega manual` to disable automatic reverts, and `omega int` or
`omega nat` to specify the domain.
-/
meta def tactic.interactive.omega (opt : parse (many ident)) : tactic unit :=
do is_int ← determine_domain opt,
   let is_manual : bool := if `manual ∈ opt then tt else ff,
   if is_int
   then omega_int is_manual
   else omega_nat is_manual

add_hint_tactic "omega"

declare_trace omega

/--
`omega` attempts to discharge goals in the quantifier-free fragment of linear integer and natural
number arithmetic using the Omega test. In other words, the core procedure of `omega` works with
goals of the form
```lean
∀ x₁, ... ∀ xₖ, P
```
where `x₁, ... xₖ` are integer (resp. natural number) variables, and `P` is a quantifier-free
formula of linear integer (resp. natural number) arithmetic. For instance:
```lean
example : ∀ (x y : int), (x ≤ 5 ∧ y ≤ 3) → x + y ≤ 8 := by omega
```
By default, `omega` tries to guess the correct domain by looking at the goal and hypotheses, and
then reverts all relevant hypotheses and variables (e.g., all variables of type `nat` and `Prop`s
in linear natural number arithmetic, if the domain was determined to be `nat`) to universally close
the goal before calling the main procedure. Therefore, `omega` will often work even if the goal
is not in the above form:
```lean
example (x y : nat) (h : 2 * x + 1 = 2 * y) : false := by omega
```
But this behaviour is not always optimal, since it may revert irrelevant hypotheses or incorrectly
guess the domain. Use `omega manual` to disable automatic reverts, and `omega int` or `omega nat`
to specify the domain.
```lean
example (x y z w : int) (h1 : 3 * y ≥ x) (h2 : z > 19 * w) : 3 * x ≤ 9 * y :=
by {revert h1 x y, omega manual}

example (i : int) (n : nat) (h1 : i = 0) (h2 : n < n) : false := by omega nat

example (n : nat) (h1 : n < 34) (i : int) (h2 : i * 9 = -72) : i = -8 :=
by {revert h2 i, omega manual int}
```
`omega` handles `nat` subtraction by repeatedly rewriting goals of the form `P[t-s]` into
`P[x] ∧ (t = s + x ∨ (t ≤ s ∧ x = 0))`, where `x` is fresh. This means that each (distinct)
occurrence of subtraction will cause the goal size to double during DNF transformation.

`omega` implements the real shadow step of the Omega test, but not the dark and gray shadows.
Therefore, it should (in principle) succeed whenever the negation of the goal has no real solution,
but it may fail if a real solution exists, even if there is no integer/natural number solution.

You can enable `set_option trace.omega true` to see how `omega` interprets your goal.
-/
add_tactic_doc
{ name       := "omega",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.omega],
  tags       := ["finishing", "arithmetic", "decision procedure"] }


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

import Mathlib.Tactic.Basic
import Mathlib.Tactic.SwapVar

example {P Q : Prop} (q : P) (p : Q) : P ∧ Q := by
  swap_var p ↔ q
  exact ⟨p, q⟩

example {a b : Nat} (h : a = b) : a = b ∧ a = a := by
  swap_var a ↔ b
  guard_hyp h : b = a
  guard_target = b = a ∧ b = b
  exact ⟨h, Eq.refl b⟩

example {a b c d : Nat} (h : a = b ∧ c = d) : a = b ∧ c = d := by
  swap_var a ↔ b, b c
  guard_target = c = a ∧ b = d
  exact h


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module group_theory.submonoid.inverses
! leanprover-community/mathlib commit 59694bd07f0a39c5beccba34bd9f413a160782bf
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.Submonoid.Pointwise

/-!

# Submonoid of inverses

Given a submonoid `N` of a monoid `M`, we define the submonoid `N.leftInv` as the submonoid of
left inverses of `N`. When `M` is commutative, we may define `fromCommLeftInv : N.leftInv →* N`
since the inverses are unique. When `N ≤ IsUnit.Submonoid M`, this is precisely
the pointwise inverse of `N`, and we may define `leftInvEquiv : S.leftInv ≃* S`.

For the pointwise inverse of submonoids of groups, please refer to
`GroupTheory.Submonoid.Pointwise`.

## TODO

Define the submonoid of right inverses and two-sided inverses.
See the comments of #10679 for a possible implementation.

-/

variable {M : Type _}

namespace Submonoid

@[to_additive]
noncomputable instance [Monoid M] : Group (IsUnit.submonoid M) :=
  { inferInstanceAs (Monoid (IsUnit.submonoid M)) with
    inv := fun x ↦ ⟨x.prop.unit⁻¹.val, x.prop.unit⁻¹.isUnit⟩
    mul_left_inv := fun x ↦
      Subtype.ext ((Units.val_mul x.prop.unit⁻¹ _).trans x.prop.unit.inv_val) }

@[to_additive]
noncomputable instance [CommMonoid M] : CommGroup (IsUnit.submonoid M) :=
  { inferInstanceAs (Group (IsUnit.submonoid M)) with
    mul_comm := fun a b ↦ by convert mul_comm a b }

@[to_additive]
theorem IsUnit.Submonoid.coe_inv [Monoid M] (x : IsUnit.submonoid M) :
    ↑x⁻¹ = (↑x.prop.unit⁻¹ : M) :=
  rfl
#align submonoid.is_unit.submonoid.coe_inv Submonoid.IsUnit.Submonoid.coe_inv
#align add_submonoid.is_unit.submonoid.coe_neg AddSubmonoid.IsUnit.Submonoid.coe_neg

section Monoid

variable [Monoid M] (S : Submonoid M)

/-- `S.leftInv` is the submonoid containing all the left inverses of `S`. -/
@[to_additive
      "`S.leftNeg` is the additive submonoid containing all the left additive inverses of `S`."]
def leftInv : Submonoid M where
  carrier := { x : M | ∃ y : S, x * y = 1 }
  one_mem' := ⟨1, mul_one 1⟩
  mul_mem' := fun {a} _b ⟨a', ha⟩ ⟨b', hb⟩ ↦
    ⟨b' * a', by simp only [coe_mul, ← mul_assoc, mul_assoc a, hb, mul_one, ha]⟩
#align submonoid.left_inv Submonoid.leftInv
#align add_submonoid.left_neg AddSubmonoid.leftNeg

@[to_additive]
theorem leftInv_leftInv_le : S.leftInv.leftInv ≤ S := by
  rintro x ⟨⟨y, z, h₁⟩, h₂ : x * y = 1⟩
  convert z.prop
  rw [← mul_one x, ← h₁, ← mul_assoc, h₂, one_mul]
#align submonoid.left_inv_left_inv_le Submonoid.leftInv_leftInv_le
#align add_submonoid.left_neg_left_neg_le AddSubmonoid.leftNeg_leftNeg_le

@[to_additive]
theorem unit_mem_leftInv (x : Mˣ) (hx : (x : M) ∈ S) : ((x⁻¹ : _) : M) ∈ S.leftInv :=
  ⟨⟨x, hx⟩, x.inv_val⟩
#align submonoid.unit_mem_left_inv Submonoid.unit_mem_leftInv
#align add_submonoid.add_unit_mem_left_neg AddSubmonoid.addUnit_mem_leftNeg

@[to_additive]
theorem leftInv_leftInv_eq (hS : S ≤ IsUnit.submonoid M) : S.leftInv.leftInv = S := by
  refine' le_antisymm S.leftInv_leftInv_le _
  intro x hx
  have : x = ((hS hx).unit⁻¹⁻¹ : Mˣ) :=
    by
    rw [inv_inv (hS hx).unit]
    rfl
  rw [this]
  exact S.leftInv.unit_mem_leftInv _ (S.unit_mem_leftInv _ hx)
#align submonoid.left_inv_left_inv_eq Submonoid.leftInv_leftInv_eq
#align add_submonoid.left_neg_left_neg_eq AddSubmonoid.leftNeg_leftNeg_eq

/-- The function from `S.leftInv` to `S` sending an element to its right inverse in `S`.
This is a `MonoidHom` when `M` is commutative. -/
@[to_additive
      "The function from `S.leftAdd` to `S` sending an element to its right additive
inverse in `S`. This is an `AddMonoidHom` when `M` is commutative."]
noncomputable def fromLeftInv : S.leftInv → S := fun x ↦ x.prop.choose
#align submonoid.from_left_inv Submonoid.fromLeftInv
#align add_submonoid.from_left_neg AddSubmonoid.fromLeftNeg

@[to_additive (attr := simp)]
theorem mul_fromLeftInv (x : S.leftInv) : (x : M) * S.fromLeftInv x = 1 :=
  x.prop.choose_spec
#align submonoid.mul_from_left_inv Submonoid.mul_fromLeftInv
#align add_submonoid.add_from_left_neg AddSubmonoid.add_fromLeftNeg

@[to_additive (attr := simp)]

end Monoid

section CommMonoid

variable [CommMonoid M] (S : Submonoid M)

@[to_additive (attr := simp)]
theorem fromLeftInv_mul (x : S.leftInv) : (S.fromLeftInv x : M) * x = 1 := by
  rw [mul_comm, mul_fromLeftInv]
#align submonoid.from_left_inv_mul Submonoid.fromLeftInv_mul
#align add_submonoid.from_left_neg_add AddSubmonoid.fromLeftNeg_add

@[to_additive]
theorem leftInv_le_isUnit : S.leftInv ≤ IsUnit.submonoid M := fun x ⟨y, hx⟩ ↦
  ⟨⟨x, y, hx, mul_comm x y ▸ hx⟩, rfl⟩
#align submonoid.left_inv_le_is_unit Submonoid.leftInv_le_isUnit
#align add_submonoid.left_neg_le_is_add_unit AddSubmonoid.leftNeg_le_isAddUnit

@[to_additive]
theorem fromLeftInv_eq_iff (a : S.leftInv) (b : M) : (S.fromLeftInv a : M) = b ↔ (a : M) * b = 1 :=
  by rw [← IsUnit.mul_right_inj (leftInv_le_isUnit _ a.prop), S.mul_fromLeftInv, eq_comm]
#align submonoid.from_left_inv_eq_iff Submonoid.fromLeftInv_eq_iff
#align add_submonoid.from_left_neg_eq_iff AddSubmonoid.fromLeftNeg_eq_iff

/-- The `MonoidHom` from `S.leftInv` to `S` sending an element to its right inverse in `S`. -/
@[to_additive (attr := simps)
    "The `AddMonoidHom` from `S.leftNeg` to `S` sending an element to its
    right additive inverse in `S`."]
noncomputable def fromCommLeftInv : S.leftInv →* S where
  toFun := S.fromLeftInv
  map_one' := S.fromLeftInv_one
  map_mul' x y :=
    Subtype.ext <| by
      rw [fromLeftInv_eq_iff, mul_comm x, Submonoid.coe_mul, Submonoid.coe_mul, mul_assoc, ←
        mul_assoc (x : M), mul_fromLeftInv, one_mul, mul_fromLeftInv]
#align submonoid.from_comm_left_inv Submonoid.fromCommLeftInv
#align add_submonoid.from_comm_left_neg AddSubmonoid.fromCommLeftNeg

variable (hS : S ≤ IsUnit.submonoid M)

-- Porting note: commented out next line
 -- include hS

/-- The submonoid of pointwise inverse of `S` is `MulEquiv` to `S`. -/
@[to_additive (attr := simps apply) "The additive submonoid of pointwise additive inverse of `S` is
`AddEquiv` to `S`."]
noncomputable def leftInvEquiv : S.leftInv ≃* S :=
  { S.fromCommLeftInv with
    invFun := fun x ↦ by
      choose x' hx using hS x.prop
      exact ⟨x'.inv, x, hx ▸ x'.inv_val⟩
    left_inv := fun x ↦
      Subtype.eq <| by
        dsimp only; generalize_proofs h; rw [← h.choose.mul_left_inj]
        conv => rhs ; rw [h.choose_spec]
        exact h.choose.inv_val.trans (S.mul_fromLeftInv x).symm
    right_inv := fun x ↦ by
      dsimp only [fromCommLeftInv]
      ext
      rw [fromLeftInv_eq_iff]
      convert (hS x.prop).choose.inv_val
      exact (hS x.prop).choose_spec.symm }
#align submonoid.left_inv_equiv Submonoid.leftInvEquiv
#align add_submonoid.left_neg_equiv AddSubmonoid.leftNegEquiv

@[to_additive (attr := simp)]
theorem fromLeftInv_leftInvEquiv_symm (x : S) : S.fromLeftInv ((S.leftInvEquiv hS).symm x) = x :=
  (S.leftInvEquiv hS).right_inv x
#align submonoid.from_left_inv_left_inv_equiv_symm Submonoid.fromLeftInv_leftInvEquiv_symm
#align add_submonoid.from_left_neg_left_neg_equiv_symm AddSubmonoid.fromLeftNeg_leftNegEquiv_symm

@[to_additive (attr := simp)]
theorem leftInvEquiv_symm_fromLeftInv (x : S.leftInv) :
    (S.leftInvEquiv hS).symm (S.fromLeftInv x) = x :=
  (S.leftInvEquiv hS).left_inv x
#align submonoid.left_inv_equiv_symm_from_left_inv Submonoid.leftInvEquiv_symm_fromLeftInv
#align add_submonoid.left_neg_equiv_symm_from_left_neg AddSubmonoid.leftNegEquiv_symm_fromLeftNeg

@[to_additive]
theorem leftInvEquiv_mul (x : S.leftInv) : (S.leftInvEquiv hS x : M) * x = 1 := by
  simpa only [leftInvEquiv_apply, fromCommLeftInv] using fromLeftInv_mul S x
#align submonoid.left_inv_equiv_mul Submonoid.leftInvEquiv_mul
#align add_submonoid.left_neg_equiv_add AddSubmonoid.leftNegEquiv_add

@[to_additive]
theorem mul_leftInvEquiv (x : S.leftInv) : (x : M) * S.leftInvEquiv hS x = 1 := by
  simp only [leftInvEquiv_apply, fromCommLeftInv, mul_fromLeftInv]
#align submonoid.mul_left_inv_equiv Submonoid.mul_leftInvEquiv
#align add_submonoid.add_left_neg_equiv AddSubmonoid.add_leftNegEquiv

@[to_additive (attr := simp)]
theorem leftInvEquiv_symm_mul (x : S) : ((S.leftInvEquiv hS).symm x : M) * x = 1 := by
  convert S.mul_leftInvEquiv hS ((S.leftInvEquiv hS).symm x)
  simp
#align submonoid.left_inv_equiv_symm_mul Submonoid.leftInvEquiv_symm_mul
#align add_submonoid.left_neg_equiv_symm_add AddSubmonoid.leftNegEquiv_symm_add

@[to_additive (attr := simp)]
theorem mul_leftInvEquiv_symm (x : S) : (x : M) * (S.leftInvEquiv hS).symm x = 1 := by
  convert S.leftInvEquiv_mul hS ((S.leftInvEquiv hS).symm x)
  simp
#align submonoid.mul_left_inv_equiv_symm Submonoid.mul_leftInvEquiv_symm
#align add_submonoid.add_left_neg_equiv_symm AddSubmonoid.add_leftNegEquiv_symm

end CommMonoid

section Group

variable [Group M] (S : Submonoid M)

open Pointwise

@[to_additive]
theorem leftInv_eq_inv : S.leftInv = S⁻¹ :=
  Submonoid.ext fun _ ↦
    ⟨fun h ↦ Submonoid.mem_inv.mpr ((inv_eq_of_mul_eq_one_right h.choose_spec).symm ▸
      h.choose.prop),
      fun h ↦ ⟨⟨_, h⟩, mul_right_inv _⟩⟩
#align submonoid.left_inv_eq_inv Submonoid.leftInv_eq_inv
#align add_submonoid.left_neg_eq_neg AddSubmonoid.leftNeg_eq_neg

@[to_additive (attr := simp)]
theorem fromLeftInv_eq_inv (x : S.leftInv) : (S.fromLeftInv x : M) = (x : M)⁻¹ := by
  rw [← mul_right_inj (x : M), mul_right_inv, mul_fromLeftInv]
#align submonoid.from_left_inv_eq_inv Submonoid.fromLeftInv_eq_inv
#align add_submonoid.from_left_neg_eq_neg AddSubmonoid.fromLeftNeg_eq_neg

end Group

section CommGroup

variable [CommGroup M] (S : Submonoid M) (hS : S ≤ IsUnit.submonoid M)

@[to_additive (attr := simp)]
theorem leftInvEquiv_symm_eq_inv (x : S) : ((S.leftInvEquiv hS).symm x : M) = (x : M)⁻¹ := by
  rw [← mul_right_inj (x : M), mul_right_inv, mul_leftInvEquiv_symm]
#align submonoid.left_inv_equiv_symm_eq_inv Submonoid.leftInvEquiv_symm_eq_inv
#align add_submonoid.left_neg_equiv_symm_eq_neg AddSubmonoid.leftNegEquiv_symm_eq_neg

end CommGroup

end Submonoid


import free_group.extras
import dyck.basic
import dyck.positive_negative

universe u
variables {α : Type u} {L L₁ : list (α × bool)}

namespace free_group

def positive (L : list (α × bool)) :=
∃ L₁ : list (α × bool), L₁ ≠ [] ∧ mk L = mk L₁ ∧ (∀ (x : α × bool), x ∈ L₁ → x.2 = tt)

def negative (L : list (α × bool)) :=
∃ L₁ : list (α × bool), L₁ ≠ [] ∧ mk L = mk L₁ ∧ (∀ (x : α × bool), x ∈ L₁ → x.2 = ff)

lemma red.all_pos_iff {L L₁ : list (α × bool)} {H : ∀ x' : α × bool, x' ∈ L → x'.snd = tt} :
red L L₁ ↔ L = L₁ :=
begin
  split,
  { intro h,
    induction h with L₂ L₃ h ih,
    refl,
    subst_vars,
    rw ← red at *,
    simp at *,
    induction ih,
    induction ih_b,
    simp,
    specialize H ih_x ff (by simp),
    simp at *,
    contradiction,
    simp,
    specialize H ih_x ff (by simp),
    simp at *,
    contradiction },
  intro h,
  rw h,
end

lemma red.all_neg_iff {L L₁ : list (α × bool)} {H : ∀ x' : α × bool, x' ∈ L → x'.snd = ff} :
red L L₁ ↔ L = L₁ :=
begin
  split,
  { intro h,
    induction h with L₂ L₃ h ih,
    refl,
    subst_vars,
    rw ← red at *,
    simp at *,
    induction ih,
    induction ih_b,
    simp,
    specialize H ih_x tt (by simp),
    simp at *,
    contradiction,
    simp,
    specialize H ih_x tt (by simp),
    simp at *,
    contradiction },
  intro h,
  rw h,
end

lemma one_not_positive : mk L = 1 → ¬ positive L :=
begin
  rintro h ⟨L', hnil, hmk, hpos⟩,
  rw h at hmk,
  have := eq.symm hmk,
  rw mk_one_iff at this,
  rw red.all_pos_iff at this,
  contradiction,
  exact hpos,
end

lemma one_not_negative : mk L = 1 → ¬ negative L :=
begin
  rintro h ⟨L', hnil, hmk, hneg⟩,
  rw h at hmk,
  have := eq.symm hmk,
  rw mk_one_iff at this,
  rw red.all_neg_iff at this,
  contradiction,
  exact hneg,
end

lemma positive_append {L₁ L₂ : list (α × bool)} : positive L₁ → positive L₂ → positive (L₁ ++ L₂) :=
begin
  intros h h₁,
  rw positive at *,
  rcases h with ⟨L', hnil, hmk, hpos⟩,
  rcases h₁ with ⟨L₁', hnil', hmk', hpos'⟩,
  use (L' ++ L₁'),
  split,
  { assume h',
    simp only [ne.def, prod.forall, list.append_eq_nil] at *,
    cases h',
    contradiction },
  { split,
   { rw [← mul_mk, ← mul_mk, hmk, hmk']},
   { intros x hx,
     rw list.mem_append at *,
     induction hx,
     specialize hpos x hx,
     exact hpos,
     specialize hpos' x hx,
     exact hpos' } }
end

lemma negative_cons {x} : negative L → negative ((x, ff) :: L) :=
begin
  rintros ⟨L', hnil, hmk, hneg⟩,
  use (x, ff) :: L',
  split,
  simp,
  split,
  rw [← list.singleton_append, ← mul_mk, hmk, mul_mk, list.singleton_append],
  intros x hx,
  simp at hx,
  cases hx,
  rw hx,
  specialize hneg x hx,
  exact hneg
end

lemma negative_singleton_iff {x : α × bool} : negative [x] ↔ x.snd = ff :=
begin
  split,
  intro h,
  rcases h with ⟨L', hnil, hmk, hneg⟩,
  induction x with x b,
  induction b,
  refl,
  rw [← mul_left_inj (mk L')⁻¹, mul_inv_self,
      inv_mk, mul_mk, list.singleton_append,
      mk_one_iff, red.cons_nil_iff_singleton] at hmk,
  simp at *,
  have h₁ := red.sublist hmk,
  simp at *,
  specialize hneg x tt h₁,
  contradiction,
  intro h,
  induction x with x b,
  use ([(x, b)]),
  simp,
  intros a b' h₁ h₂,
  simp at *,
  rw h₂,
  exact h,
end

lemma positive_singleton_iff {x : α × bool} : positive [x] ↔ x.snd = tt :=
begin
  split,
  intro h,
  rcases h with ⟨L', hnil, hmk, hpos⟩,
  induction x with x b,
  induction b,
  rw [← mul_left_inj (mk L')⁻¹, mul_inv_self,
      inv_mk, mul_mk, list.singleton_append,
      mk_one_iff, red.cons_nil_iff_singleton] at hmk,
  simp at *,
  have h₁ := red.sublist hmk,
  simp at *,
  specialize hpos x ff h₁,
  contradiction,
  refl,
  intro h,
  induction x with x b,
  use ([(x, b)]),
  simp,
  intros a b' h₁ h₂,
  simp at *,
  rw h₂,
  exact h,
end

lemma positive_append_exists_suffix {L : list (α × bool)} {x} :
positive (L ++ [(x, ff)]) → ∃ e, list.is_suffix ((x, tt)::e) L ∧ mk e = 1 :=
begin
  rintros ⟨L', hnil, hmk, hpos⟩,
  rw ← mul_left_inj ((mk L')⁻¹) at hmk,
  rw mul_inv_self at hmk,
  simp at *,
  have := append_cons_one_exists_suffix_or_prefix_eq_one hmk,
  cases this,
  {
    exact this,
  },
  {
    rcases this with ⟨e, hl, hr⟩,
    generalize eq₁ : (list.map (λ (x : α × bool), (x.fst, !x.snd)) L').reverse = LL,
    rw eq₁ at *,
    have : ∀ x : α × bool, x ∈ LL → x.snd = ff, {
     rintros ⟨x, b⟩ hx,
     rw ← eq₁ at hx,
     cases b,
     refl,
     simp at hx,
     specialize hpos x ff hx,
     contradiction,
    },
    simp at *,
    specialize this x tt _,
    cases hl with t hl,
    rw ← hl,
    simp at *,
    simp at *,
    contradiction,
  }
end

lemma negative_exists_prefix {L : list (α × bool)} : free_group.negative L → ∃ e (x : α), list.is_prefix (e ++ [(x, ff)]) L ∧ free_group.mk e = 1 :=
begin
  rintros ⟨L', hnil, hmk, hneg⟩,
  rw [← mul_right_inj (free_group.mk L')⁻¹, inv_mul_self,
        free_group.inv_mk, free_group.mul_mk] at hmk,
  cases L',
  contradiction,
  induction L'_hd with a b,
  cases b,
  {
    simp at hmk,
    have h₁ := free_group.append_cons_one_exists_suffix_or_prefix_eq_one hmk,
    cases h₁,
    {
      generalize eq₁ : (list.map (λ (x : α × bool), (x.fst, !x.snd)) L'_tl).reverse = LL,
      have h₂ : ∀ x : α × bool, x ∈ LL → x.snd = tt, {
        intros x hx,
        rw ← eq₁ at hx,
        induction x with x b,
        cases b,
        simp at hx,
        specialize hneg (x, tt) _,
        simp,
        exact hx,
        contradiction,
        refl,
      },
      rcases h₁ with ⟨e, ⟨t, ht⟩, he⟩,
      rw eq₁ at ht,
      simp at ht,
      specialize h₂ (a, ff) _,
      rw ← ht,
      simp,
      contradiction,
    },
    {
      rcases h₁ with ⟨e, h₂, h₃⟩,
      use [e, a],
      simp at h₂,
      exact ⟨h₂, h₃⟩,
    },
  },
  {
    specialize hneg (a, tt) (by simp),
    contradiction,
  }
end

lemma all_neg_iff_dyck_neg {L L₁ : list (α × bool)}
(H : ∀ x' : α × bool, x' ∈ L → x'.snd = ff) (H' : ∀ x' : α × bool, x' ∈ L₁ → x'.snd = ff) :
mk L = mk L₁ ↔ dyck.mk L = dyck.mk L₁ :=
begin
  split,
  {
    intro h,
    rw red.exact at h,
    rcases h with ⟨c, hl, hr⟩,
    rw red.all_neg_iff at *,
    subst_vars,
    exact H',
    exact H,
  },
  exact dyck.mk_free_group,
end

lemma all_pos_iff_dyck_all_pos {L L₁ : list (α × bool)}
(H : ∀ x' : α × bool, x' ∈ L → x'.snd = tt) (H' : ∀ x' : α × bool, x' ∈ L₁ → x'.snd = tt) :
mk L = mk L₁ ↔ dyck.mk L = dyck.mk L₁ :=
begin
  split,
  {
    intro h,
    rw red.exact at h,
    rcases h with ⟨c, hl, hr⟩,
    rw red.all_pos_iff at *,
    subst_vars,
    exact H',
    exact H,
  },
  exact dyck.mk_free_group,
end

lemma all_pos_append_eq_all_pos_exists_pos {L L₁ : list (α × bool)} {x}
(H : ∀ x' : α × bool, x' ∈ L → x'.snd = tt) (H' : ∀ x' : α × bool, x' ∈ L₁ → x'.snd = tt) :
free_group.mk (L ++ [(x, ff)]) = free_group.mk L₁ → ∃ L₂, L = L₂ ++ [(x, tt)] ∧ (∀ x' : α × bool, x' ∈ L₂ → x'.snd = tt) :=
begin
  intro h,
  {
    rw [← mul_left_inj ((free_group.mk L₁)⁻¹), mul_inv_self] at h,
    simp at *,
    have h₁ := append_cons_one_exists_suffix_or_prefix_eq_one h,
    induction h₁,
    { rcases h₁ with ⟨e, ⟨t, ht⟩, he⟩,
      have h₂ : e = [], {
        cases e,
        refl,
        induction e_hd with a b,
        induction b,
        {
          have h₃ : (a, ff) ∈ L, {
            rw ← ht,
            simp,
          },
          specialize H a ff h₃,
          simp at *,
          exact H,
        },
        {
          have h₃ := cons_one_exists_prefix_eq_one he,
          rcases h₃ with ⟨e', ⟨t', ht'⟩, he'⟩,
          simp at *,
          rw ← ht' at ht,
          have h₄ : (a, ff) ∈ L, {
            rw ← ht,
            simp,
          },
          specialize H a ff h₄,
          simp at *,
          exact H,
        },
      },
      use t,
      split,
      subst_vars,
      simp at *,
      intros a b hab,
      specialize H a b _,
      rw ← ht,
      simp,
      left,
      exact hab,
      exact H },
    {
      rcases h₁ with ⟨e, ⟨t, ht⟩, he⟩,
      simp at *,
      generalize eq₁ : ((list.map (λ (x : α × bool), (x.fst, !x.snd)) L₁).reverse = LL),
      rw eq₁ at *,
      have h₂ : ∀ x' : α × bool, x' ∈ LL → x'.snd = ff, {
        intros x hx,
        rw ← eq₁ at *,
        simp at *,
        cases hx with a h₃,
        induction h₃,
        {
          cases h₃ with hl hr,
          specialize H' a ff hl,
          simp at *,
          contradiction,
        },
        {
          induction x with x b,
          cases h₃ with hl hr,
          simp at *,
          exact hr.2.symm,
        },
      },
      specialize h₂ (x, tt) _,
      {rw ← ht; simp,},
      simp at *,
      contradiction,
    }
  },
end

lemma all_positive_append_eq_one_iff {L : list (α × bool)} {x} {H : ∀ x' : α × bool, x' ∈ L → x'.snd = tt} :
mk (L ++ [(x, ff)]) = 1 ↔ L = [(x, tt)] :=
begin
  split,
  {
    intro h,
    have h₁ := append_singleton_one_exists_suffix_eq_one h,
    rcases h₁ with ⟨e, h₂, h₃⟩,
    have : e = [], {
      cases e,
      refl,
      induction e_hd with a b,
      induction b,
      have h₄ : (a, ff) ∈ L, {
        rw list.is_suffix at *,
        cases h₂ with t h₂,
        simp at *,
        rw ← h₂,
        simp,
      },
      specialize H (a, ff) h₄,
      simp at *,
      exact H,
      rw mk_one_iff at *,
      rw red.cons_nil_iff_singleton at *,
      simp at *,
      have := red.sublist h₃,
      simp at *,
      have h₄ : (a, ff) ∈ L, {
        rw list.is_suffix at *,
        cases h₂ with t h₂,
        rw ← h₂,
        simp,
        right,
        exact this,
      },
      specialize H a ff h₄,
      simp at *,
      exact H,
    },
    subst_vars,
    simp at *,
    rw list.is_suffix at *,
    cases h₂ with t ht,
    have : t = [], {
      cases t,
      refl,
      induction t_hd with a b,
      induction b,
      have h₄ : (a, ff) ∈ L, {
        rw ← ht,
        simp,
      },
      specialize H a ff h₄,
      simp at *,
      exact H,
      subst_vars,
      have : (a, tt) :: t_tl ++ [(x, tt)] ++ [(x, ff)] =
             (a, tt) :: t_tl ++ [(x, tt), (x, !tt)] := by simp,
      rw this at *,
      clear this,
      rw ← mul_mk at h,
      rw mk_bnot at h,
      rw mul_one at h,
      rw mk_one_iff at h,
      rw red.cons_nil_iff_singleton at h,
      have := red.sublist h,
      simp at *,
      specialize H a ff _,
      right,
      left,
      exact this,
      simp at *,
      exact H,
    },
    rw this at *,
    simp at *,
    exact ht.symm,
  },
  {
    intro h,
    rw h,
    simp,
    rw ← bool.bnot_true,
    exact mk_bnot,
  }
end

end free_group


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

! This file was ported from Lean 3 source module init.wf
! leanprover-community/mathlib commit 4a03bdeb31b3688c31d02d7ff8e0ff2e5d6174db
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Data.Nat.Basic
import Leanbin.Init.Data.Prod

universe u v

#print Acc /-
/-- A value `x : α` is accessible from `r` when every value that's lesser under `r` is also
accessible. Note that any value that's minimal under `r` is vacuously accessible.

Equivalently, `acc r x` when there is no infinite chain of elements starting at `x` that are related
under `r`.

This is used to state the definition of well-foundedness (see `well_founded`). -/
inductive Acc {α : Sort u} (r : α → α → Prop) : α → Prop
  | intro (x : α) (h : ∀ y, r y x → Acc y) : Acc x
#align acc Acc
-/

namespace Acc

variable {α : Sort u} {r : α → α → Prop}

#print Acc.inv /-
theorem inv {x y : α} (h₁ : Acc r x) (h₂ : r y x) : Acc r y :=
  Acc.recOn h₁ (fun x₁ ac₁ ih h₂ => ac₁ y h₂) h₂
#align acc.inv Acc.inv
-/

end Acc

#print WellFounded /-
/-- A relation `r : α → α → Prop` is well-founded when `∀ x, (∀ y, r y x → P y → P x) → P x` for all
predicates `P`. Equivalently, `acc r x` for all `x`.

Once you know that a relation is well_founded, you can use it to define fixpoint functions on `α`.-/
structure WellFounded {α : Sort u} (r : α → α → Prop) : Prop where intro ::
  apply : ∀ a, Acc r a
#align well_founded WellFounded
-/

/- warning: has_well_founded -> WellFoundedRelation is a dubious translation:
lean 3 declaration is
  Sort.{u1} -> Type.{u1}
but is expected to have type
  Sort.{u1} -> Sort.{max 1 u1}
Case conversion may be inaccurate. Consider using '#align has_well_founded WellFoundedRelationₓ'. -/
class WellFoundedRelation (α : Sort u) : Type u where
  R : α → α → Prop
  wf : WellFounded r
#align has_well_founded WellFoundedRelation

namespace WellFounded

section

parameter {α : Sort u}{r : α → α → Prop}

-- mathport name: «expr ≺ »
local infixl:50 "≺" => r

parameter (hwf : WellFounded r)

#print WellFounded.recursion /-
def recursion {C : α → Sort v} (a : α) (h : ∀ x, (∀ y, y≺x → C y) → C x) : C a :=
  Acc.recOn (apply hwf a) fun x₁ ac₁ ih => h x₁ ih
#align well_founded.recursion WellFounded.recursion
-/

#print WellFounded.induction /-
theorem induction {C : α → Prop} (a : α) (h : ∀ x, (∀ y, y≺x → C y) → C x) : C a :=
  recursion a h
#align well_founded.induction WellFounded.induction
-/

variable {C : α → Sort v}

variable (F : ∀ x, (∀ y, y≺x → C y) → C x)

#print WellFounded.fixF /-
def fixF (x : α) (a : Acc r x) : C x :=
  Acc.recOn a fun x₁ ac₁ ih => F x₁ ih
#align well_founded.fix_F WellFounded.fixF
-/

theorem fixF_eq (x : α) (acx : Acc r x) :
    fix_F F x acx = F x fun (y : α) (p : y≺x) => fix_F F y (Acc.inv acx p) :=
  Acc.drec (fun x r ih => rfl) acx
#align well_founded.fix_F_eq WellFounded.fixF_eq

end

variable {α : Sort u} {C : α → Sort v} {r : α → α → Prop}

#print WellFounded.fix /-
/-- Well-founded fixpoint -/
def fix (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) : C x :=
  fixF F x (apply hwf x)
#align well_founded.fix WellFounded.fix
-/

#print WellFounded.fix_eq /-
/-- Well-founded fixpoint satisfies fixpoint equation -/
theorem fix_eq (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) :
    fix hwf F x = F x fun y h => fix hwf F y :=
  fixF_eq F x (apply hwf x)
#align well_founded.fix_eq WellFounded.fix_eq
-/

end WellFounded

open WellFounded

/-- Empty relation is well-founded -/
theorem empty_wf {α : Sort u} : WellFounded (@EmptyRelation α) :=
  WellFounded.intro fun a : α => Acc.intro a fun (b : α) (lt : False) => False.ndrec _ lt
#align empty_wf empty_wf

/-! Subrelation of a well-founded relation is well-founded -/

namespace Subrelation

section

parameter {α : Sort u}{r Q : α → α → Prop}

parameter (h₁ : Subrelation Q r)

parameter (h₂ : WellFounded r)

theorem accessible {a : α} (ac : Acc r a) : Acc Q a :=
  Acc.recOn ac fun x ax ih => Acc.intro x fun (y : α) (lt : Q y x) => ih y (h₁ lt)
#align subrelation.accessible Subrelation.accessibleₓ

#print Subrelation.wf /-
theorem wf : WellFounded Q :=
  ⟨fun a => accessible (apply h₂ a)⟩
#align subrelation.wf Subrelation.wf
-/

end

end Subrelation

-- The inverse image of a well-founded relation is well-founded
namespace InvImage

section

parameter {α : Sort u}{β : Sort v}{r : β → β → Prop}

parameter (f : α → β)

parameter (h : WellFounded r)

private def acc_aux {b : β} (ac : Acc r b) : ∀ x : α, f x = b → Acc (InvImage r f) x :=
  Acc.recOn ac fun x acx ih z e =>
    Acc.intro z fun y lt => Eq.recOn e (fun acx ih => ih (f y) lt y rfl) acx ih
#align inv_image.acc_aux inv_image.acc_aux

theorem accessible {a : α} (ac : Acc r (f a)) : Acc (InvImage r f) a :=
  acc_aux ac a rfl
#align inv_image.accessible InvImage.accessibleₓ

#print InvImage.wf /-
theorem wf : WellFounded (InvImage r f) :=
  ⟨fun a => accessible (apply h (f a))⟩
#align inv_image.wf InvImage.wf
-/

end

end InvImage

/- warning: nat.lt_wf -> Nat.lt_wfRel is a dubious translation:
lean 3 declaration is
  WellFounded.{1} Nat Nat.lt
but is expected to have type
  WellFoundedRelation.{1} Nat
Case conversion may be inaccurate. Consider using '#align nat.lt_wf Nat.lt_wfRelₓ'. -/
/-- less-than is well-founded -/
theorem Nat.lt_wfRel : WellFounded Nat.lt :=
  ⟨Nat.rec (Acc.intro 0 fun n h => absurd h (Nat.not_lt_zero n)) fun n ih =>
      Acc.intro (Nat.succ n) fun m h =>
        Or.elim (Nat.eq_or_lt_of_le (Nat.le_of_succ_le_succ h)) (fun e => Eq.substr e ih)
          (Acc.inv ih)⟩
#align nat.lt_wf Nat.lt_wfRel

#print Measure /-
def Measure {α : Sort u} : (α → ℕ) → α → α → Prop :=
  InvImage (· < ·)
#align measure Measure
-/

theorem measure_wf {α : Sort u} (f : α → ℕ) : WellFounded (Measure f) :=
  InvImage.wf f Nat.lt_wfRel
#align measure_wf measure_wf

def SizeofMeasure (α : Sort u) [SizeOf α] : α → α → Prop :=
  Measure SizeOf.sizeOf
#align sizeof_measure SizeofMeasure

theorem sizeofMeasure_wf (α : Sort u) [SizeOf α] : WellFounded (SizeofMeasure α) :=
  measure_wf SizeOf.sizeOf
#align sizeof_measure_wf sizeofMeasure_wf

instance hasWellFoundedOfHasSizeof (α : Sort u) [SizeOf α] : WellFoundedRelation α
    where
  R := SizeofMeasure α
  wf := sizeofMeasure_wf α
#align has_well_founded_of_has_sizeof hasWellFoundedOfHasSizeof

namespace Prod

open WellFounded

section

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

variable (ra : α → α → Prop)

variable (rb : β → β → Prop)

#print Prod.Lex /-
-- Lexicographical order based on ra and rb
inductive Lex : α × β → α × β → Prop
  | left {a₁} (b₁) {a₂} (b₂) (h : ra a₁ a₂) : Lex (a₁, b₁) (a₂, b₂)
  | right (a) {b₁ b₂} (h : rb b₁ b₂) : Lex (a, b₁) (a, b₂)
#align prod.lex Prod.Lex
-/

#print Prod.RProd /-
-- relational product based on ra and rb
inductive RProd : α × β → α × β → Prop
  | intro {a₁ b₁ a₂ b₂} (h₁ : ra a₁ a₂) (h₂ : rb b₁ b₂) : rprod (a₁, b₁) (a₂, b₂)
#align prod.rprod Prod.RProd
-/

end

section

parameter {α : Type u}{β : Type v}

parameter {ra : α → α → Prop}{rb : β → β → Prop}

-- mathport name: «expr ≺ »
local infixl:50 "≺" => Lex ra rb

theorem lex_accessible {a} (aca : Acc ra a) (acb : ∀ b, Acc rb b) : ∀ b, Acc (Lex ra rb) (a, b) :=
  Acc.recOn aca fun xa aca iha b =>
    Acc.recOn (acb b) fun xb acb ihb =>
      Acc.intro (xa, xb) fun p lt =>
        have aux : xa = xa → xb = xb → Acc (Lex ra rb) p :=
          @Prod.Lex.rec_on α β ra rb (fun p₁ p₂ => fst p₂ = xa → snd p₂ = xb → Acc (Lex ra rb) p₁) p
            (xa, xb) lt
            (fun a₁ b₁ a₂ b₂ h (eq₂ : a₂ = xa) (eq₃ : b₂ = xb) => iha a₁ (Eq.recOn eq₂ h) b₁)
            fun a b₁ b₂ h (eq₂ : a = xa) (eq₃ : b₂ = xb) =>
            Eq.recOn eq₂.symm (ihb b₁ (Eq.recOn eq₃ h))
        aux rfl rfl
#align prod.lex_accessible Prod.lex_accessible

#print WellFounded.prod_lex /-
-- The lexicographical order of well founded relations is well-founded
theorem prod_lex (ha : WellFounded ra) (hb : WellFounded rb) : WellFounded (Lex ra rb) :=
  ⟨fun p => casesOn p fun a b => lex_accessible (apply ha a) (WellFounded.apply hb) b⟩
#align prod.lex_wf WellFounded.prod_lex
-/

-- relational product is a subrelation of the lex
theorem rProd_sub_lex : ∀ a b, RProd ra rb a b → Lex ra rb a b := fun a b h =>
  Prod.RProd.rec_on h fun a₁ b₁ a₂ b₂ h₁ h₂ => Lex.left b₁ b₂ h₁
#align prod.rprod_sub_lex Prod.rProd_sub_lex

-- The relational product of well founded relations is well-founded
theorem rProd_wf (ha : WellFounded ra) (hb : WellFounded rb) : WellFounded (RProd ra rb) :=
  Subrelation.wf rprod_sub_lex (lex_wf ha hb)
#align prod.rprod_wf Prod.rProd_wf

end

instance hasWellFounded {α : Type u} {β : Type v} [s₁ : WellFoundedRelation α]
    [s₂ : WellFoundedRelation β] : WellFoundedRelation (α × β)
    where
  R := Lex s₁.R s₂.R
  wf := prod_lex s₁.wf s₂.wf
#align prod.has_well_founded Prod.hasWellFounded

end Prod


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import order.basic
import logic.function.iterate
import data.nat.basic

/-!
# Inequalities on iterates

In this file we prove some inequalities comparing `f^[n] x` and `g^[n] x` where `f` and `g` are
two self-maps that commute with each other.

Current selection of inequalities is motivated by formalization of the rotation number of
a circle homeomorphism.
-/
variables {α : Type*}

namespace monotone

variables [preorder α] {f : α → α} {x y : ℕ → α}

lemma seq_le_seq (hf : monotone f) (n : ℕ) (h₀ : x 0 ≤ y 0)
  (hx : ∀ k < n, x (k + 1) ≤ f (x k)) (hy : ∀ k < n, f (y k) ≤ y (k + 1)) :
  x n ≤ y n :=
begin
  induction n with n ihn,
  { exact h₀ },
  { refine (hx _ n.lt_succ_self).trans ((hf $ ihn _ _).trans (hy _ n.lt_succ_self)),
    exact λ k hk, hx _ (hk.trans n.lt_succ_self),
    exact λ k hk, hy _ (hk.trans n.lt_succ_self) }
end

lemma seq_pos_lt_seq_of_lt_of_le (hf : monotone f) {n : ℕ} (hn : 0 < n) (h₀ : x 0 ≤ y 0)
  (hx : ∀ k < n, x (k + 1) < f (x k)) (hy : ∀ k < n, f (y k) ≤ y (k + 1)) :
  x n < y n :=
begin
  induction n with n ihn, { exact hn.false.elim },
  suffices : x n ≤ y n,
    from (hx n n.lt_succ_self).trans_le ((hf this).trans $ hy n n.lt_succ_self),
  cases n, { exact h₀ },
  refine (ihn n.zero_lt_succ (λ k hk, hx _ _) (λ k hk, hy _ _)).le;
    exact hk.trans n.succ.lt_succ_self
end

lemma seq_pos_lt_seq_of_le_of_lt (hf : monotone f) {n : ℕ} (hn : 0 < n) (h₀ : x 0 ≤ y 0)
  (hx : ∀ k < n, x (k + 1) ≤ f (x k)) (hy : ∀ k < n, f (y k) < y (k + 1)) :
  x n < y n :=
hf.order_dual.seq_pos_lt_seq_of_lt_of_le hn h₀ hy hx

lemma seq_lt_seq_of_lt_of_le (hf : monotone f) (n : ℕ) (h₀ : x 0 < y 0)
  (hx : ∀ k < n, x (k + 1) < f (x k)) (hy : ∀ k < n, f (y k) ≤ y (k + 1)) :
  x n < y n :=
by { cases n, exacts [h₀, hf.seq_pos_lt_seq_of_lt_of_le n.zero_lt_succ h₀.le hx hy] }

lemma seq_lt_seq_of_le_of_lt (hf : monotone f) (n : ℕ) (h₀ : x 0 < y 0)
  (hx : ∀ k < n, x (k + 1) ≤ f (x k)) (hy : ∀ k < n, f (y k) < y (k + 1)) :
  x n < y n :=
hf.order_dual.seq_lt_seq_of_lt_of_le n h₀ hy hx

end monotone

namespace function

namespace commute

section preorder

variables [preorder α] {f g : α → α}

lemma iterate_le_of_map_le (h : commute f g) (hf : monotone f)  (hg : monotone g)
  {x} (hx : f x ≤ g x) (n : ℕ) :
  f^[n] x ≤ (g^[n]) x :=
by refine hf.seq_le_seq n _ (λ k hk, _) (λ k hk, _);
  simp [iterate_succ' f, h.iterate_right _ _, hg.iterate _ hx]

lemma iterate_pos_lt_of_map_lt (h : commute f g) (hf : monotone f) (hg : strict_mono g)
  {x} (hx : f x < g x) {n} (hn : 0 < n) :
  f^[n] x < (g^[n]) x :=
by refine hf.seq_pos_lt_seq_of_le_of_lt hn _ (λ k hk, _) (λ k hk, _);
  simp [iterate_succ' f, h.iterate_right _ _, hg.iterate _ hx]

lemma iterate_pos_lt_of_map_lt' (h : commute f g) (hf : strict_mono f) (hg : monotone g)
  {x} (hx : f x < g x) {n} (hn : 0 < n) :
  f^[n] x < (g^[n]) x :=
@iterate_pos_lt_of_map_lt (order_dual α) _ g f h.symm hg.order_dual hf.order_dual x hx n hn

end preorder

variables [linear_order α] {f g : α → α}

lemma iterate_pos_lt_iff_map_lt (h : commute f g) (hf : monotone f)
  (hg : strict_mono g) {x n} (hn : 0 < n) :
  f^[n] x < (g^[n]) x ↔ f x < g x :=
begin
  rcases lt_trichotomy (f x) (g x) with H|H|H,
  { simp only [*, iterate_pos_lt_of_map_lt] },
  { simp only [*, h.iterate_eq_of_map_eq, lt_irrefl] },
  { simp only [lt_asymm H, lt_asymm (h.symm.iterate_pos_lt_of_map_lt' hg hf H hn)] }
end

lemma iterate_pos_lt_iff_map_lt' (h : commute f g) (hf : strict_mono f)
  (hg : monotone g) {x n} (hn : 0 < n) :
  f^[n] x < (g^[n]) x ↔ f x < g x :=
@iterate_pos_lt_iff_map_lt (order_dual α) _ _ _ h.symm hg.order_dual hf.order_dual x n hn

lemma iterate_pos_le_iff_map_le (h : commute f g) (hf : monotone f)
  (hg : strict_mono g) {x n} (hn : 0 < n) :
  f^[n] x ≤ (g^[n]) x ↔ f x ≤ g x :=
by simpa only [not_lt] using not_congr (h.symm.iterate_pos_lt_iff_map_lt' hg hf hn)

lemma iterate_pos_le_iff_map_le' (h : commute f g) (hf : strict_mono f)
  (hg : monotone g) {x n} (hn : 0 < n) :
  f^[n] x ≤ (g^[n]) x ↔ f x ≤ g x :=
by simpa only [not_lt] using not_congr (h.symm.iterate_pos_lt_iff_map_lt hg hf hn)

lemma iterate_pos_eq_iff_map_eq (h : commute f g) (hf : monotone f)
  (hg : strict_mono g) {x n} (hn : 0 < n) :
  f^[n] x = (g^[n]) x ↔ f x = g x :=
by simp only [le_antisymm_iff, h.iterate_pos_le_iff_map_le hf hg hn,
  h.symm.iterate_pos_le_iff_map_le' hg hf hn]

end commute

end function

namespace monotone

variables [preorder α] {f g : α → α}

open function

/-- If `f ≤ g` and `f` is monotone, then `f^[n] ≤ g^[n]`. -/

/-- If `f ≤ g` and `f` is monotone, then `f^[n] ≤ g^[n]`. -/
lemma iterate_ge_of_ge (hg : monotone g) (h : f ≤ g) (n : ℕ) :
  f^[n] ≤ (g^[n]) :=
hg.order_dual.iterate_le_of_le h n

end monotone


/-
Copyright (c) 2021 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import linear_algebra.basis
import linear_algebra.multilinear.basic

/-!
# Multilinear maps in relation to bases.

This file proves lemmas about the action of multilinear maps on basis vectors.

## TODO

 * Refactor the proofs in terms of bases of tensor products, once there is an equivalent of
   `basis.tensor_product` for `pi_tensor_product`.

-/

open multilinear_map

variables {R : Type*} {ι : Type*} {n : ℕ} {M : fin n → Type*} {M₂ : Type*} {M₃ : Type*}
variables [comm_semiring R] [add_comm_monoid M₂] [add_comm_monoid M₃] [∀i, add_comm_monoid (M i)]
variables [∀i, module R (M i)] [module R M₂] [module R M₃]

/-- Two multilinear maps indexed by `fin n` are equal if they are equal when all arguments are
basis vectors. -/
lemma basis.ext_multilinear_fin {f g : multilinear_map R M M₂} {ι₁ : fin n → Type*}
  (e : Π i, basis (ι₁ i) R (M i)) (h : ∀ (v : Π i, ι₁ i), f (λ i, e i (v i)) = g (λ i, e i (v i))) :
  f = g :=
begin
  unfreezingI { induction n with m hm },
  { ext x,
    convert h fin_zero_elim },
  { apply function.left_inverse.injective uncurry_curry_left,
    refine basis.ext (e 0) _,
    intro i,
    apply hm (fin.tail e),
    intro j,
    convert h (fin.cons i j),
    iterate 2
    { rw curry_left_apply,
      congr' 1 with x,
      refine fin.cases rfl (λ x, _) x,
      dsimp [fin.tail],
      rw [fin.cons_succ, fin.cons_succ], } }
end

/-- Two multilinear maps indexed by a `fintype` are equal if they are equal when all arguments
are basis vectors. Unlike `basis.ext_multilinear_fin`, this only uses a single basis; a
dependently-typed version would still be true, but the proof would need a dependently-typed
version of `dom_dom_congr`. -/
lemma basis.ext_multilinear [finite ι] {f g : multilinear_map R (λ i : ι, M₂) M₃}
  {ι₁ : Type*} (e : basis ι₁ R M₂) (h : ∀ v : ι → ι₁, f (λ i, e (v i)) = g (λ i, e (v i))) :
  f = g :=
by { casesI nonempty_fintype ι, exact (dom_dom_congr_eq_iff (fintype.equiv_fin ι) f g).mp
    (basis.ext_multilinear_fin (λ i, e) $ λ i, h (i ∘ _)) }


import data.nat.basic

example (a : ℕ ): a + 0 = a:=
begin
induction a with k hk,
rw zero_add,
rw add_zero,
end


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import data.equiv.nat
import order.rel_iso
import order.directed

/-!
# Encodable types

This file defines encodable (constructively countable) types as a typeclass.
This is used to provide explicit encode/decode functions from and to `ℕ`, with the information that
those functions are inverses of each other.
The difference with `denumerable` is that finite types are encodable. For infinite types,
`encodable` and `denumerable` agree.

## Main declarations

* `encodable α`: States that there exists an explicit encoding function `encode : α → ℕ` with a
  partial inverse `decode : ℕ → option α`.
* `decode₂`: Version of `decode` that is equal to `none` outside of the range of `encode`. Useful as
  we do not require this in the definition of `decode`.
* `ulower α`: Any encodable type has an equivalent type living in the lowest universe, namely a
  subtype of `ℕ`. `ulower α` finds it.

## Implementation notes

The point of asking for an explicit partial inverse `decode : ℕ → option α` to `encode : α → ℕ` is
to make the range of `encode` decidable even when the finiteness of `α` is not.
-/

open option list nat function

/-- Constructively countable type. Made from an explicit injection `encode : α → ℕ` and a partial
inverse `decode : ℕ → option α`. Note that finite types *are* countable. See `denumerable` if you
wish to enforce infiniteness. -/
class encodable (α : Type*) :=
(encode : α → ℕ)
(decode [] : ℕ → option α)
(encodek : ∀ a, decode (encode a) = some a)

attribute [simp] encodable.encodek

namespace encodable
variables {α : Type*} {β : Type*}
universe u

theorem encode_injective [encodable α] : function.injective (@encode α _)
| x y e := option.some.inj $ by rw [← encodek, e, encodek]

@[simp] lemma encode_inj [encodable α] {a b : α} : encode a = encode b ↔ a = b :=
encode_injective.eq_iff

lemma surjective_decode_iget (α : Type*) [encodable α] [inhabited α] :
  surjective (λ n, (encodable.decode α n).iget) :=
λ x, ⟨encodable.encode x, by simp_rw [encodable.encodek]⟩

/-- An encodable type has decidable equality. Not set as an instance because this is usually not the
best way to infer decidability. -/
def decidable_eq_of_encodable (α) [encodable α] : decidable_eq α
| a b := decidable_of_iff _ encode_inj

/-- If `α` is encodable and there is an injection `f : β → α`, then `β` is encodable as well. -/
def of_left_injection [encodable α]
  (f : β → α) (finv : α → option β) (linv : ∀ b, finv (f b) = some b) : encodable β :=
⟨λ b, encode (f b),
 λ n, (decode α n).bind finv,
 λ b, by simp [encodable.encodek, linv]⟩

/-- If `α` is encodable and `f : β → α` is invertible, then `β` is encodable as well. -/
def of_left_inverse [encodable α]
  (f : β → α) (finv : α → β) (linv : ∀ b, finv (f b) = b) : encodable β :=
of_left_injection f (some ∘ finv) (λ b, congr_arg some (linv b))

/-- Encodability is preserved by equivalence. -/
def of_equiv (α) [encodable α] (e : β ≃ α) : encodable β :=
of_left_inverse e e.symm e.left_inv

@[simp] theorem encode_of_equiv {α β} [encodable α] (e : β ≃ α) (b : β) :
  @encode _ (of_equiv _ e) b = encode (e b) := rfl

@[simp] theorem decode_of_equiv {α β} [encodable α] (e : β ≃ α) (n : ℕ) :
  @decode _ (of_equiv _ e) n = (decode α n).map e.symm := rfl

instance nat : encodable ℕ :=
⟨id, some, λ a, rfl⟩

@[simp] theorem encode_nat (n : ℕ) : encode n = n := rfl
@[simp] theorem decode_nat (n : ℕ) : decode ℕ n = some n := rfl

instance empty : encodable empty :=
⟨λ a, a.rec _, λ n, none, λ a, a.rec _⟩

instance unit : encodable punit :=
⟨λ_, 0, λ n, nat.cases_on n (some punit.star) (λ _, none), λ _, by simp⟩

@[simp] theorem encode_star : encode punit.star = 0 := rfl

@[simp] theorem decode_unit_zero : decode punit 0 = some punit.star := rfl
@[simp] theorem decode_unit_succ (n) : decode punit (succ n) = none := rfl

/-- If `α` is encodable, then so is `option α`. -/
instance option {α : Type*} [h : encodable α] : encodable (option α) :=
⟨λ o, option.cases_on o nat.zero (λ a, succ (encode a)),
 λ n, nat.cases_on n (some none) (λ m, (decode α m).map some),
 λ o, by cases o; dsimp; simp [encodek, nat.succ_ne_zero]⟩

@[simp] theorem encode_none [encodable α] : encode (@none α) = 0 := rfl
@[simp] theorem encode_some [encodable α] (a : α) :
  encode (some a) = succ (encode a) := rfl

@[simp] theorem decode_option_zero [encodable α] : decode (option α) 0 = some none := rfl
@[simp] theorem decode_option_succ [encodable α] (n) :
  decode (option α) (succ n) = (decode α n).map some := rfl

/-- Failsafe variant of `decode`. `decode₂ α n` returns the preimage of `n` under `encode` if it
exists, and returns `none` if it doesn't. This requirement could be imposed directly on `decode` but
is not to help make the definition easier to use. -/
def decode₂ (α) [encodable α] (n : ℕ) : option α :=
(decode α n).bind (option.guard (λ a, encode a = n))

theorem mem_decode₂' [encodable α] {n : ℕ} {a : α} :
  a ∈ decode₂ α n ↔ a ∈ decode α n ∧ encode a = n :=
by simp [decode₂]; exact
⟨λ ⟨_, h₁, rfl, h₂⟩, ⟨h₁, h₂⟩, λ ⟨h₁, h₂⟩, ⟨_, h₁, rfl, h₂⟩⟩

theorem mem_decode₂ [encodable α] {n : ℕ} {a : α} :
  a ∈ decode₂ α n ↔ encode a = n :=
mem_decode₂'.trans (and_iff_right_of_imp $ λ e, e ▸ encodek _)

theorem decode₂_eq_some [encodable α] {n : ℕ} {a : α} :
  decode₂ α n = some a ↔ encode a = n :=
mem_decode₂

@[simp] lemma decode₂_encode [encodable α] (a : α) :
  decode₂ α (encode a) = some a :=
by { ext, simp [mem_decode₂, eq_comm] }

theorem decode₂_ne_none_iff [encodable α] {n : ℕ} :
  decode₂ α n ≠ none ↔ n ∈ set.range (encode : α → ℕ) :=
by simp_rw [set.range, set.mem_set_of_eq, ne.def, option.eq_none_iff_forall_not_mem,
  encodable.mem_decode₂, not_forall, not_not]

theorem decode₂_is_partial_inv [encodable α] : is_partial_inv encode (decode₂ α) :=
λ a n, mem_decode₂

theorem decode₂_inj [encodable α] {n : ℕ} {a₁ a₂ : α}
  (h₁ : a₁ ∈ decode₂ α n) (h₂ : a₂ ∈ decode₂ α n) : a₁ = a₂ :=
encode_injective $ (mem_decode₂.1 h₁).trans (mem_decode₂.1 h₂).symm

theorem encodek₂ [encodable α] (a : α) : decode₂ α (encode a) = some a :=
mem_decode₂.2 rfl

/-- The encoding function has decidable range. -/
def decidable_range_encode (α : Type*) [encodable α] : decidable_pred (∈ set.range (@encode α _)) :=
λ x, decidable_of_iff (option.is_some (decode₂ α x))
  ⟨λ h, ⟨option.get h, by rw [← decode₂_is_partial_inv (option.get h), option.some_get]⟩,
  λ ⟨n, hn⟩, by rw [← hn, encodek₂]; exact rfl⟩

/-- An encodable type is equivalent to the range of its encoding function. -/
def equiv_range_encode (α : Type*) [encodable α] : α ≃ set.range (@encode α _) :=
{ to_fun := λ a : α, ⟨encode a, set.mem_range_self _⟩,
  inv_fun := λ n, option.get (show is_some (decode₂ α n.1),
    by cases n.2 with x hx; rw [← hx, encodek₂]; exact rfl),
  left_inv := λ a, by dsimp;
    rw [← option.some_inj, option.some_get, encodek₂],
  right_inv := λ ⟨n, x, hx⟩, begin
    apply subtype.eq,
    dsimp,
    conv {to_rhs, rw ← hx},
    rw [encode_injective.eq_iff, ← option.some_inj, option.some_get, ← hx, encodek₂],
  end }

/-- A type with unique element is encodable. This is not an instance to avoid diamonds. -/
def _root_.unique.encodable [unique α] : encodable α :=
⟨λ _, 0, λ _, some default, unique.forall_iff.2 rfl⟩

section sum
variables [encodable α] [encodable β]

/-- Explicit encoding function for the sum of two encodable types. -/
def encode_sum : α ⊕ β → ℕ
| (sum.inl a) := bit0 $ encode a
| (sum.inr b) := bit1 $ encode b

/-- Explicit decoding function for the sum of two encodable types. -/
def decode_sum (n : ℕ) : option (α ⊕ β) :=
match bodd_div2 n with
| (ff, m) := (decode α m).map sum.inl
| (tt, m) := (decode β m).map sum.inr
end

/-- If `α` and `β` are encodable, then so is their sum. -/
instance sum : encodable (α ⊕ β) :=
⟨encode_sum, decode_sum, λ s,
  by cases s; simp [encode_sum, decode_sum, encodek]; refl⟩

@[simp] theorem encode_inl (a : α) :
  @encode (α ⊕ β) _ (sum.inl a) = bit0 (encode a) := rfl
@[simp] theorem encode_inr (b : β) :
  @encode (α ⊕ β) _ (sum.inr b) = bit1 (encode b) := rfl
@[simp] theorem decode_sum_val (n : ℕ) :
  decode (α ⊕ β) n = decode_sum n := rfl

end sum

instance bool : encodable bool :=
of_equiv (unit ⊕ unit) equiv.bool_equiv_punit_sum_punit

@[simp] theorem encode_tt : encode tt = 1 := rfl
@[simp] theorem encode_ff : encode ff = 0 := rfl

@[simp] theorem decode_zero : decode bool 0 = some ff := rfl
@[simp] theorem decode_one : decode bool 1 = some tt := rfl

theorem decode_ge_two (n) (h : 2 ≤ n) : decode bool n = none :=
begin
  suffices : decode_sum n = none,
  { change (decode_sum n).map _ = none, rw this, refl },
  have : 1 ≤ div2 n,
  { rw [div2_val, nat.le_div_iff_mul_le],
    exacts [h, dec_trivial] },
  cases exists_eq_succ_of_ne_zero (ne_of_gt this) with m e,
  simp [decode_sum]; cases bodd n; simp [decode_sum]; rw e; refl
end

noncomputable instance «Prop» : encodable Prop :=
of_equiv bool equiv.Prop_equiv_bool

section sigma
variables {γ : α → Type*} [encodable α] [∀ a, encodable (γ a)]

/-- Explicit encoding function for `sigma γ` -/
def encode_sigma : sigma γ → ℕ
| ⟨a, b⟩ := mkpair (encode a) (encode b)

/-- Explicit decoding function for `sigma γ` -/
def decode_sigma (n : ℕ) : option (sigma γ) :=
let (n₁, n₂) := unpair n in
(decode α n₁).bind $ λ a, (decode (γ a) n₂).map $ sigma.mk a

instance sigma : encodable (sigma γ) :=
⟨encode_sigma, decode_sigma, λ ⟨a, b⟩,
  by simp [encode_sigma, decode_sigma, unpair_mkpair, encodek]⟩

@[simp] theorem decode_sigma_val (n : ℕ) : decode (sigma γ) n =
  (decode α n.unpair.1).bind (λ a, (decode (γ a) n.unpair.2).map $ sigma.mk a) :=
show decode_sigma._match_1 _ = _, by cases n.unpair; refl

@[simp] theorem encode_sigma_val (a b) : @encode (sigma γ) _ ⟨a, b⟩ =
  mkpair (encode a) (encode b) := rfl

end sigma

section prod
variables [encodable α] [encodable β]

/-- If `α` and `β` are encodable, then so is their product. -/
instance prod : encodable (α × β) :=
of_equiv _ (equiv.sigma_equiv_prod α β).symm

@[simp] theorem decode_prod_val (n : ℕ) : decode (α × β) n =
  (decode α n.unpair.1).bind (λ a, (decode β n.unpair.2).map $ prod.mk a) :=
show (decode (sigma (λ _, β)) n).map (equiv.sigma_equiv_prod α β) = _,
by simp; cases decode α n.unpair.1; simp;
   cases decode β n.unpair.2; refl

@[simp] theorem encode_prod_val (a b) : @encode (α × β) _ (a, b) =
  mkpair (encode a) (encode b) := rfl

end prod

section subtype
open subtype decidable
variables {P : α → Prop} [encA : encodable α] [decP : decidable_pred P]
include encA

/-- Explicit encoding function for a decidable subtype of an encodable type -/
def encode_subtype : {a : α // P a} → ℕ
| ⟨v, h⟩ := encode v

include decP

/-- Explicit decoding function for a decidable subtype of an encodable type -/
def decode_subtype (v : ℕ) : option {a : α // P a} :=
(decode α v).bind $ λ a,
if h : P a then some ⟨a, h⟩ else none

/-- A decidable subtype of an encodable type is encodable. -/
instance subtype : encodable {a : α // P a} :=
⟨encode_subtype, decode_subtype,
 λ ⟨v, h⟩, by simp [encode_subtype, decode_subtype, encodek, h]⟩

lemma subtype.encode_eq (a : subtype P) : encode a = encode a.val :=
by cases a; refl

end subtype

instance fin (n) : encodable (fin n) :=
of_equiv _ (equiv.fin_equiv_subtype _)

instance int : encodable ℤ :=
of_equiv _ equiv.int_equiv_nat

instance pnat : encodable ℕ+ :=
of_equiv _ equiv.pnat_equiv_nat

/-- The lift of an encodable type is encodable. -/
instance ulift [encodable α] : encodable (ulift α) :=
of_equiv _ equiv.ulift

/-- The lift of an encodable type is encodable. -/
instance plift [encodable α] : encodable (plift α) :=
of_equiv _ equiv.plift

/-- If `β` is encodable and there is an injection `f : α → β`, then `α` is encodable as well. -/
noncomputable def of_inj [encodable β] (f : α → β) (hf : injective f) : encodable α :=
of_left_injection f (partial_inv f) (λ x, (partial_inv_of_injective hf _ _).2 rfl)

end encodable

section ulower
local attribute [instance, priority 100] encodable.decidable_range_encode

/-- `ulower α : Type` is an equivalent type in the lowest universe, given `encodable α`. -/
@[derive decidable_eq, derive encodable]
def ulower (α : Type*) [encodable α] : Type :=
set.range (encodable.encode : α → ℕ)

end ulower

namespace ulower
variables (α : Type*) [encodable α]

/-- The equivalence between the encodable type `α` and `ulower α : Type`. -/
def equiv : α ≃ ulower α :=
encodable.equiv_range_encode α

variables {α}

/-- Lowers an `a : α` into `ulower α`. -/
def down (a : α) : ulower α := equiv α a

instance [inhabited α] : inhabited (ulower α) := ⟨down default⟩

/-- Lifts an `a : ulower α` into `α`. -/
def up (a : ulower α) : α := (equiv α).symm a

@[simp] lemma down_up {a : ulower α} : down a.up = a := equiv.right_inv _ _
@[simp] lemma up_down {a : α} : (down a).up = a := equiv.left_inv _ _

@[simp] lemma up_eq_up {a b : ulower α} : a.up = b.up ↔ a = b :=
equiv.apply_eq_iff_eq _

@[simp] lemma down_eq_down {a b : α} : down a = down b ↔ a = b :=
equiv.apply_eq_iff_eq _

@[ext] protected lemma ext {a b : ulower α} : a.up = b.up → a = b :=
up_eq_up.1

end ulower

/-
Choice function for encodable types and decidable predicates.
We provide the following API

choose      {α : Type*} {p : α → Prop} [c : encodable α] [d : decidable_pred p] : (∃ x, p x) → α :=
choose_spec {α : Type*} {p : α → Prop} [c : encodable α] [d : decidable_pred p] (ex : ∃ x, p x) :
  p (choose ex) :=
-/

namespace encodable
section find_a
variables {α : Type*} (p : α → Prop) [encodable α] [decidable_pred p]

private def good : option α → Prop
| (some a) := p a
| none     := false

private def decidable_good : decidable_pred (good p)
| n := by cases n; unfold good; apply_instance
local attribute [instance] decidable_good

open encodable
variable {p}

/-- Constructive choice function for a decidable subtype of an encodable type. -/
def choose_x (h : ∃ x, p x) : {a : α // p a} :=
have ∃ n, good p (decode α n), from
let ⟨w, pw⟩ := h in ⟨encode w, by simp [good, encodek, pw]⟩,
match _, nat.find_spec this : ∀ o, good p o → {a // p a} with
| some a, h := ⟨a, h⟩
end

/-- Constructive choice function for a decidable predicate over an encodable type. -/
def choose (h : ∃ x, p x) : α := (choose_x h).1

lemma choose_spec (h : ∃ x, p x) : p (choose h) := (choose_x h).2

end find_a

theorem axiom_of_choice {α : Type*} {β : α → Type*} {R : Π x, β x → Prop}
  [Π a, encodable (β a)] [∀ x y, decidable (R x y)]
  (H : ∀ x, ∃ y, R x y) : ∃ f : Π a, β a, ∀ x, R x (f x) :=
⟨λ x, choose (H x), λ x, choose_spec (H x)⟩

theorem skolem {α : Type*} {β : α → Type*} {P : Π x, β x → Prop}
  [c : Π a, encodable (β a)] [d : ∀ x y, decidable (P x y)] :
  (∀ x, ∃ y, P x y) ↔ ∃ f : Π a, β a, (∀ x, P x (f x)) :=
⟨axiom_of_choice, λ ⟨f, H⟩ x, ⟨_, H x⟩⟩

/-
There is a total ordering on the elements of an encodable type, induced by the map to ℕ.
-/

/-- The `encode` function, viewed as an embedding. -/
def encode' (α) [encodable α] : α ↪ ℕ :=
⟨encodable.encode, encodable.encode_injective⟩

instance {α} [encodable α] : is_trans _ (encode' α ⁻¹'o (≤)) :=
(rel_embedding.preimage _ _).is_trans
instance {α} [encodable α] : is_antisymm _ (encodable.encode' α ⁻¹'o (≤)) :=
(rel_embedding.preimage _ _).is_antisymm
instance {α} [encodable α] : is_total _ (encodable.encode' α ⁻¹'o (≤)) :=
(rel_embedding.preimage _ _).is_total

end encodable

namespace directed

open encodable

variables {α : Type*} {β : Type*} [encodable α] [inhabited α]

/-- Given a `directed r` function `f : α → β` defined on an encodable inhabited type,
construct a noncomputable sequence such that `r (f (x n)) (f (x (n + 1)))`
and `r (f a) (f (x (encode a + 1))`. -/
protected noncomputable def sequence {r : β → β → Prop} (f : α → β) (hf : directed r f) : ℕ → α
| 0       := default
| (n + 1) :=
  let p := sequence n in
  match decode α n with
  | none     := classical.some (hf p p)
  | (some a) := classical.some (hf p a)
  end

lemma sequence_mono_nat {r : β → β → Prop} {f : α → β} (hf : directed r f) (n : ℕ) :
  r (f (hf.sequence f n)) (f (hf.sequence f (n+1))) :=
begin
  dsimp [directed.sequence],
  generalize eq : hf.sequence f n = p,
  cases h : decode α n with a,
  { exact (classical.some_spec (hf p p)).1 },
  { exact (classical.some_spec (hf p a)).1 }
end

lemma rel_sequence {r : β → β → Prop} {f : α → β} (hf : directed r f) (a : α) :
  r (f a) (f (hf.sequence f (encode a + 1))) :=
begin
  simp only [directed.sequence, encodek],
  exact (classical.some_spec (hf _ a)).2
end

variables [preorder β] {f : α → β} (hf : directed (≤) f)

lemma sequence_mono : monotone (f ∘ (hf.sequence f)) :=
monotone_nat_of_le_succ $ hf.sequence_mono_nat

lemma le_sequence (a : α) : f a ≤ f (hf.sequence f (encode a + 1)) :=
hf.rel_sequence a

end directed

section quotient
open encodable quotient
variables {α : Type*} {s : setoid α} [@decidable_rel α (≈)] [encodable α]

/-- Representative of an equivalence class. This is a computable version of `quot.out` for a setoid
on an encodable type. -/
def quotient.rep (q : quotient s) : α :=
choose (exists_rep q)

theorem quotient.rep_spec (q : quotient s) : ⟦q.rep⟧ = q :=
choose_spec (exists_rep q)

/-- The quotient of an encodable space by a decidable equivalence relation is encodable. -/
def encodable_quotient : encodable (quotient s) :=
⟨λ q, encode q.rep,
 λ n, quotient.mk <$> decode α n,
 by rintros ⟨l⟩; rw encodek; exact congr_arg some ⟦l⟧.rep_spec⟩

end quotient


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.clifford_algebra.conjugation

/-!
# Star structure on `clifford_algebra`

This file defines the "clifford conjugation", equal to `reverse (involute x)`, and assigns it the
`star` notation.

This choice is somewhat non-canonical; a star structure is also possible under `reverse` alone.
However, defining it gives us access to constructions like `unitary`.

Most results about `star` can be obtained by unfolding it via `clifford_algebra.star_def`.

## Main definitions

* `clifford_algebra.star_ring`

-/

variables {R : Type*} [comm_ring R]
variables {M : Type*} [add_comm_group M] [module R M]
variables {Q : quadratic_form R M}

namespace clifford_algebra

instance : star_ring (clifford_algebra Q) :=
{ star := λ x, reverse (involute x),
  star_involutive := λ x,
    by simp only [reverse_involute_commute.eq, reverse_reverse, involute_involute],
  star_mul := λ x y, by simp only [map_mul, reverse.map_mul],
  star_add := λ x y, by simp only [map_add] }

lemma star_def (x : clifford_algebra Q) : star x = reverse (involute x) := rfl
lemma star_def' (x : clifford_algebra Q) : star x = involute (reverse x) := reverse_involute _

@[simp] lemma star_ι (m : M) : star (ι Q m) = -ι Q m :=
by rw [star_def, involute_ι, map_neg, reverse_ι]

/-- Note that this not match the `star_smul` implied by `star_module`; it certainly could if we
also conjugated all the scalars, but there appears to be nothing in the literature that advocates
doing this. -/
@[simp] lemma star_smul (r : R) (x : clifford_algebra Q) :
  star (r • x) = r • star x :=
by rw [star_def, star_def, map_smul, map_smul]

@[simp] lemma star_algebra_map (r : R) :
  star (algebra_map R (clifford_algebra Q) r) = algebra_map R (clifford_algebra Q) r :=
by rw [star_def, involute.commutes, reverse.commutes]

end clifford_algebra